From Hammer Require Import Hammer.

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

Definition total_map (A:Type) := nat -> A.

Definition t_empty {A:Type} (v : A) : total_map A :=
(fun _ => v).

Definition t_update {A:Type} (m : total_map A)
(x : nat) (v : A) :=
fun x' => if beq_nat x x' then v else m x'.

Definition examplemap :=
t_update (t_update (t_empty false) 1 false) 3 true.

Example update_example1 : examplemap 0 = false.
Proof. hammer_hook "Maps" "Maps.update_example1". reflexivity. Qed.

Example update_example2 : examplemap 1 = false.
Proof. hammer_hook "Maps" "Maps.update_example2". reflexivity. Qed.

Example update_example3 : examplemap 2 = false.
Proof. hammer_hook "Maps" "Maps.update_example3". reflexivity. Qed.

Example update_example4 : examplemap 3 = true.
Proof. hammer_hook "Maps" "Maps.update_example4". reflexivity. Qed.

Lemma t_apply_empty:  forall A x v, @t_empty A v x = v.
Proof. hammer_hook "Maps" "Maps.t_apply_empty".
Admitted.

Lemma t_update_eq : forall A (m: total_map A) x v,
(t_update m x v) x = v.
Proof. hammer_hook "Maps" "Maps.t_update_eq".
Admitted.

Theorem t_update_neq : forall (X:Type) v x1 x2
(m : total_map X),
x1 <> x2 ->
(t_update m x1 v) x2 = m x2.
Proof. hammer_hook "Maps" "Maps.t_update_neq".
Admitted.

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
t_update (t_update m x v1) x v2
= t_update m x v2.
Proof. hammer_hook "Maps" "Maps.t_update_shadow".
Admitted.

Lemma beq_idP : forall x y, reflect (x = y) (beq_nat x y).
Proof. hammer_hook "Maps" "Maps.beq_idP".
Admitted.

Theorem t_update_same : forall X x (m : total_map X),
t_update m x (m x) = m.
Proof. hammer_hook "Maps" "Maps.t_update_same".
Admitted.

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
(m : total_map X),
x2 <> x1 ->
(t_update (t_update m x2 v2) x1 v1)
= (t_update (t_update m x1 v1) x2 v2).
Proof. hammer_hook "Maps" "Maps.t_update_permute".
Admitted.

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
t_empty None.

Definition update {A:Type} (m : partial_map A)
(x : nat) (v : A) :=
t_update m x (Some v).

Lemma apply_empty : forall A x, @empty A x = None.
Proof. hammer_hook "Maps" "Maps.apply_empty".
intros. unfold empty. rewrite t_apply_empty.
reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
(update m x v) x = Some v.
Proof. hammer_hook "Maps" "Maps.update_eq".
intros. unfold update. rewrite t_update_eq.
reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
(m : partial_map X),
x2 <> x1 ->
(update m x2 v) x1 = m x1.
Proof. hammer_hook "Maps" "Maps.update_neq".
intros X v x1 x2 m H.
unfold update. rewrite t_update_neq. reflexivity.
apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
update (update m x v1) x v2 = update m x v2.
Proof. hammer_hook "Maps" "Maps.update_shadow".
intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
m x = Some v ->
update m x v = m.
Proof. hammer_hook "Maps" "Maps.update_same".
intros X v x m H. unfold update. rewrite <- H.
apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
(m : partial_map X),
x2 <> x1 ->
(update (update m x2 v2) x1 v1)
= (update (update m x1 v1) x2 v2).
Proof. hammer_hook "Maps" "Maps.update_permute".
intros X v1 v2 x1 x2 m. unfold update.
apply t_update_permute.
Qed.


Require Import Ascii String Omega OrderedTypeEx.

(**** String_as_OT borrowed from Fiat *)

Lemma nat_compare_eq_refl : forall x, Nat.compare x x = Eq.
  intros; apply Nat.compare_eq_iff; trivial.
Qed.

Hint Rewrite <- nat_compare_lt : nat_comp_hints.
Hint Rewrite <- nat_compare_gt : nat_comp_hints.
Hint Rewrite    Nat.compare_eq_iff : nat_comp_hints.
Hint Rewrite <- Nat.compare_eq_iff : nat_comp_hints.
Hint Rewrite    nat_compare_eq_refl : nat_comp_hints.

Ltac autorewrite_nat_compare :=
  autorewrite with nat_comp_hints in *.

Lemma nat_compare_consistent :
  forall n0 n1,
    { Nat.compare n0 n1 = Lt /\ Nat.compare n1 n0 = Gt }
    + { Nat.compare n0 n1 = Eq /\ Nat.compare n1 n0 = Eq }
    + { Nat.compare n0 n1 = Gt /\ Nat.compare n1 n0 = Lt }.
Proof.
  intros n0 n1;
  destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ];
  [ constructor 1; constructor 1  | constructor 1; constructor 2 | constructor 2 ];
  split;
  autorewrite_nat_compare;
  intuition.
Defined.

Module String_as_OT <: UsualOrderedType.
  Definition t := string.

  Fixpoint string_compare str1 str2 :=
    match str1, str2 with
      | EmptyString, EmptyString => Eq
      | EmptyString, _           => Lt
      | _, EmptyString           => Gt
      | String char1 tail1, String char2 tail2 =>
        match Nat.compare (nat_of_ascii char1) (nat_of_ascii char2) with
          | Eq => string_compare tail1 tail2
          | Lt => Lt
          | Gt => Gt
        end
    end.

  Lemma string_compare_eq_refl : forall x, string_compare x x = Eq.
    intro x;
    induction x;
      simpl; trivial;
      autorewrite_nat_compare.
      trivial.
  Qed.

  Ltac comparisons_minicrush :=
    autorewrite_nat_compare;
    match goal with
      | [ |- context [Nat.compare ?a ?b] ] =>
        let H := fresh in
        first [
            assert (Nat.compare a b = Eq) as H by (autorewrite_nat_compare; omega) |
            assert (Nat.compare a b = Lt) as H by (autorewrite_nat_compare; omega) |
            assert (Nat.compare a b = Gt) as H by (autorewrite_nat_compare; omega)
        ]; rewrite H; intuition
    end.

  Ltac destruct_comparisons :=
    repeat match goal with
             | [ H: match ?pred ?a ?b with
                      | Lt => _ | Gt => _ | Eq => _ end = _
                 |- _] =>
               let H := fresh in
               destruct (pred a b) eqn:H;
                 try discriminate
           end.

  Ltac exfalso_from_equalities :=
    match goal with
      | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => assert (b = c) by congruence; discriminate
    end.

  Definition eq := @eq string.

  Hint Resolve string_compare_eq_refl.

  Lemma eq_Eq : forall x y, x = y -> string_compare x y = Eq.
  Proof.
    intros; subst; auto.
  Qed.

  Lemma nat_of_ascii_injective :
    forall a b, nat_of_ascii a = nat_of_ascii b <-> a = b.
  Proof.
    intros a b; split; intro H;
    [ apply (f_equal ascii_of_nat) in H;
      repeat rewrite ascii_nat_embedding in H
    | apply (f_equal nat_of_ascii) in H ]; trivial.
  Qed.

  Lemma Eq_eq : forall x y, string_compare x y = Eq -> x = y.
  Proof.
    induction x;
      destruct y;
      simpl;
      first [ discriminate
            | intros;
              f_equal;
              destruct_comparisons;
              autorewrite_nat_compare;
              rewrite nat_of_ascii_injective in *
            | idtac ];
      intuition.
  Qed.

  Lemma Eq_eq_iff : forall x y, x = y <-> string_compare x y = Eq.
  Proof.
    intros; split; eauto using eq_Eq, Eq_eq.
  Qed.

  Definition eq_refl := @eq_refl string.

  Definition eq_sym := @eq_sym string.

  Definition eq_trans := @eq_trans string.

  Definition lt x y :=
    string_compare x y = Lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros x y z;
    generalize x z;
    clear x z;

    induction y;
    destruct x;
    destruct z;
      intros;
      unfold lt in *;
      simpl in *;
      first [ discriminate
            | destruct_comparisons; comparisons_minicrush
            | trivial ]; intuition.
  Qed.

  Lemma lt_not_eq : forall x y, lt x y -> ~ eq x y.
  Proof.
    unfold lt, not in *;
    intros;
    rewrite Eq_eq_iff in *;
    exfalso_from_equalities.
  Qed.

  Lemma Lt_Gt : forall x y, string_compare x y = Gt <-> string_compare y x = Lt.
  Proof.
    intros x;
    induction x as [ | x0 x' Hind ];
      intros y;
      destruct y as [ | y0 y' ];

      simpl;
      split;
      first [ discriminate | trivial ];

      destruct (nat_compare_consistent
                  (nat_of_ascii x0)
                  (nat_of_ascii y0))
          as [ [ (H1, H2) | (H1, H2) ] | (H1, H2) ];
        rewrite H1, H2;
        try rewrite Hind;
        auto.
  Qed.

  Definition compare x y : OrderedType.Compare lt eq x y.
  Proof.
    destruct (string_compare x y) eqn:comp;
      unfold lt;
      [ constructor 2; apply Eq_eq
      | constructor 1
      | constructor 3; apply Lt_Gt];
      trivial.
  Defined.

  Definition eq_dec : forall (x y: string), { x = y } + { x <> y }.
  Proof.
    exact string_dec.
  Defined.

End String_as_OT.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  CFGV 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 General Public License
  along with CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)
Require Export AssociationList.
(** printing #  $\times$ #×# *)
(** printing &  $\times$ #×# *)

(** CatchFileBetweenTagsVarTypeStart *)
Record VarType := {
  typ : Type;  eqdec : Deq typ;
  fresh : forall (avoid : list typ) (sugg : list typ),typ;
  freshCorrect: forall (avoid : list typ)
    (sugg : list typ), !(LIn (fresh avoid sugg) avoid)
}.
(** CatchFileBetweenTagsVarTypeEnd *)

(* This predicate denotes that a type
    is suitable to serve
    as a collection of variable names.
    The equality should be decidable
    and it should be always possible
    to pick a fresh name.

    The definition of [fresh] should
    not use any opaque definitions/lemmas.

    What about efficiency?
    Can we replace the list with a binary
    (search) tree?
    we will need an ordering then too.
 *)

Fixpoint FreshDistinctRenamings
  (VT : VarType)
  (lv :list (typ VT ))
  (lvAvoid :list (typ VT ))
  {struct lv}
  : (AssocList (typ VT ) (typ VT )) :=
match  lv with
  | [] => []
  | vh :: vtl =>
    let newvar :=  ((fresh VT) lvAvoid [vh]) in
    (vh,newvar) :: (FreshDistinctRenamings
               VT vtl (newvar :: lvAvoid))
end.

Lemma FreshDistRenSpec: forall
  (VT : VarType)
  (lv :list (typ VT ))
  (lvAvoid :list (typ VT )),
  let sw := (FreshDistinctRenamings VT lv  lvAvoid) in
  no_repeats (ALRange sw)
  # disjoint (ALRange sw) lvAvoid
  # ALDom sw = lv.
Proof.
  induction lv as [| h tl Hind]; intros;
  [dands; cpx|].
  allsimpl. destruct VT; allsimpl.
  exrepnd.
  allsimpl.
  specialize (Hind ((fresh0 lvAvoid [h]):: lvAvoid)).
  repnd; allsimpl.
  dands; try econstructor; eauto; try congruence.
  - apply disjoint_sym in Hind1.
    apply Hind1; cpx.
  - repeat (disjoint_reasoning).
Defined.

(* might not compute.
    saves time in proofs.
    destruction of it gives the properties too *)
Lemma FreshDistRenWSpec: forall
  (VT : VarType)
  (lv :list (typ VT ))
  (lvAvoid :list (typ VT )),
  {lvn : list (typ VT ) $
  no_repeats lvn # disjoint lvn lvAvoid
  # length lvn= length lv}.
Proof.
  intros.
  eexists (ALRange (FreshDistinctRenamings VT lv  lvAvoid)).
  pose proof (FreshDistRenSpec VT lv lvAvoid) as XX.
  allsimpl. exrepnd.
  apply (f_equal (@length _ )) in XX.
  allunfold ALDom.
  allunfold ALRange.
  autorewrite with fast.
  autorewrite with fast in XX.
  dands; cpx.
Defined.

Fixpoint FreshDistinctVars
  (T :VarType)
  (lv :list (typ T))
  (lvAvoid :list (typ T))
  {struct lv}
  : (list (typ T)) :=
match  lv with
  | [] => []
  | vh :: vtl =>
    let newvar :=  ((fresh T) lvAvoid [vh]) in
    newvar :: (FreshDistinctVars
               T vtl (newvar :: lvAvoid))
end.

Lemma FreshDistVarsSpec: forall
  {T : VarType}
  (lv :list (typ T))
  (lvAvoid :list (typ T)),
  let lvn := (FreshDistinctVars T lv  lvAvoid) in
  no_repeats lvn # disjoint lvn lvAvoid # length lvn= length lv.
Proof.
  induction lv as [| h tl Hind]; intros; subst lvn;
  [dands; cpx|].
  allsimpl. destruct T. allsimpl.
  exrepnd.
  allsimpl.
  specialize (Hind ((fresh0 lvAvoid [h]):: lvAvoid)).
  repnd; allsimpl.
  dands; try econstructor; eauto; try congruence.
  - apply disjoint_sym in Hind1.
    apply Hind1; cpx.
  - repeat (disjoint_reasoning).
Defined.

Require Export variables.

Definition nvarVarType: VarType.
Proof.
  eapply Build_VarType with
    (typ:=NVar)
    (fresh:= (fun (la ls : list NVar) =>  fresh_var la))
                  ; eauto with Deq.
  intros.
  apply fresh_var_not_in.
Defined.

(** Transparent versions of the one in the standard
    library *)
Hint Resolve nvarVarType : VarType.

  Lemma map_length : forall {A B} (f: A->B) (l : list A),
    length (map f l) = length l.
  Proof.
    induction l; simpl; auto.
  Defined.
  Lemma seq_length : forall len start, length (seq start len) = len.
  Proof.
    induction len; simpl; auto.
  Defined.

Hint Rewrite  seq_length : fast.

Require Import String.
Require Import Ascii.

Lemma nat2string :forall (n: nat) , string.
Proof.
  intros.
  induction n.
  - exact "1".
  - exact (IHn++"1").
Defined.

Definition shead  (ls: list string) : string :=
match ls with
| [] => ""
| h::tl => h
end.

Fixpoint lmax (l : list nat) :=
match l with
| [] => 0
| h::tl => max h (lmax tl)
end .
Lemma lmaxSpec : forall (l : list nat),
  lforall (fun n=> n <= lmax l) l.
Proof.
  intros. apply lForallSame.
  induction l; cpx.
  allsimpl. dands; cpx.
  - apply Max.le_max_l.
  - apply lForallSame.
    apply lForallSame in IHl.
    eapply implies_lforall; eauto.
    introv H Hlt; allsimpl; cpx.
    apply NPeano.Nat.max_le_compat_l with (p:= a) in Hlt.
    pose proof (Max.le_max_r a a0).
    omega.
Qed.

Lemma lmaxSpecLen : forall (l : list string),
  lforall (fun a=> length a <= lmax (map length l)) l.
Proof.
  introv Hin.
  assert (LIn (length a) (map length l)) as Hl by
  (apply in_map_iff; eexists; eauto).
  simpl. apply lmaxSpec.
  trivial.
Qed.

Lemma lengthAppendStr :
  forall (l1 l2 : string) , length (l1++l2) = length l1 + length l2.
Proof.
  induction l1; trivial.
  intros. simpl. auto.
Qed.

Fixpoint freshStringAux (maxLen: nat)
  (avoid : list string)
  (sugg : list string) :=
match maxLen with
| 0 => shead (sugg)
| S n => let rs := freshStringAux n avoid sugg
         in match (memberb string_dec rs avoid) with
            | true => rs ++ "1"
            | false => rs
            end
end.

Definition freshString
  (avoid : list string)
  (sugg : list string) :=
  freshStringAux (S (lmax (map length avoid)
          - length (shead sugg))) avoid sugg.

Lemma freshStringAuxSpec:
  forall sugg (avoid : list string) lm,
  !LIn (freshStringAux lm  avoid sugg) avoid
  [+] (length (freshStringAux lm avoid sugg)
      = (length (shead sugg) + lm)%nat).
Proof.
  unfold freshString.
  induction lm; cpx.
  intros. allsimpl. rewrite memberb_din.
  cases_ifd Hd; cpx.
  dorn IHlm; cpx.
  right.
  rewrite lengthAppendStr.
  simpl. omega.
Qed.

Lemma freshStringSpec:
  forall (avoid : list string) sugg,
  !LIn (freshString  avoid sugg) avoid.
Proof.
  unfold freshString.
  intros.
  pose proof (freshStringAuxSpec sugg avoid
              (S (lmax (map length avoid) - length (shead sugg))))
              as Hfs.
  dorn Hfs; cpx.
  fold (freshString avoid sugg).
  fold (freshString avoid sugg) in Hfs.
  assert (length (shead sugg) +
      S (lmax (map length avoid) - length (shead sugg))
  > (lmax (map length avoid))) as XX by omega.
  rewrite <- Hfs in XX.
  introv Hc.
  apply lmaxSpecLen in Hc.
  omega.
Qed.

Lemma StringVar : VarType.
Proof.
  eapply Build_VarType with
      (typ:=string)
      (fresh:=freshString).
  - exact string_dec.
  - exact freshStringSpec.
Qed.

(* only commented code below *)
(*
Fixpoint FreshDistinctRenListList
  {T :Type} (ft : FreshType T)
  (llv : list (list T))
  (lvAvoid :list T)
  {struct llv}
  : list (AssocList T T) :=
match  llv with
  | [] => []
  | lvh :: lvtl =>
    let ren :=  (FreshDistinctRenamings ft lvh lvAvoid) in
    ren :: (FreshDistinctRenListList
               ft lvtl ((ALRange ren) ++ lvAvoid) )
end.

Lemma FreshDistRenLLSpec: forall
  {T :Type} (ft : FreshType T)
  (llv : list (list T))
  (lvAvoid :list T),
  let llsw := (FreshDistinctRenListList ft llv lvAvoid) in
  let rangeVars := flat_map (@ALRange _ _) llsw in
  no_repeats rangeVars
  # disjoint rangeVars lvAvoid
  # map (@ALDom _ _) llsw = llv.
Proof.
  induction llv as [|lvh lvtl Hind]; cpx;[].
  intros. subst llsw. subst rangeVars.
  specialize
    (Hind (ALRange (FreshDistinctRenamings ft  lvh lvAvoid) ++ lvAvoid)).
  pose proof (FreshDistRenSpec ft lvh lvAvoid) as XXh.
  allsimpl. exrepnd.
  repeat(disjoint_reasoning).
  - apply no_repeats_app. dands; cpx.
    repeat(disjoint_reasoning); cpx.
  - f_equal; cpx.
Qed.

Lemma FreshDistRenLLSpec2: forall
  {T :Type} (ft : FreshType T)
  (llv : list (list T))
  (lvAvoid :list T),
  let llsw := (FreshDistinctRenListList ft llv lvAvoid) in
  let rangeVars := flat_map (@ALRange _ _) llsw in
  no_repeats rangeVars
  # disjoint rangeVars lvAvoid
  # flat_map (@ALDom _ _) llsw = flatten llv.
Proof.
  induction llv as [|lvh lvtl Hind]; cpx;[].
  intros. subst llsw. subst rangeVars.
  specialize
    (Hind (ALRange (FreshDistinctRenamings ft  lvh lvAvoid) ++ lvAvoid)).
  pose proof (FreshDistRenSpec ft lvh lvAvoid) as XXh.
  allsimpl. exrepnd.
  repeat(disjoint_reasoning).
  - apply no_repeats_app. dands; cpx.
    repeat(disjoint_reasoning); cpx.
  - f_equal; cpx.
Qed.
Ltac AddFDLLSpec :=
  let FdSpec := fresh "FdSpec" in
  let FdLL := fresh "FdLL" in
  match goal with
  [ |- context [FreshDistinctRenListList ?ft ?llv ?lvA] ]
    => pose proof (FreshDistRenLLSpec ft llv lvA) as FdSpec;
        simpl in FdSpec;
     remember (FreshDistinctRenListList ft llv lvA) as FdLL

  end.

*)

(*
*** Local Variables:
*** coq-load-path: ("../")
*** End:
*)


Require Import Program.Equality Lia.

Require Export ListExtra.

Notation "x ⊆ y" := (incl x y) (at level 50).

Inductive Prefix {A : Type} : list A -> list A -> Prop :=
| PreSame l : Prefix l l
| PreStep {a l l'} : Prefix l l' -> Prefix l (a :: l').

Lemma prefix_cons_in {A : Type} `{EqDec A eq} (a : A) l l' : Prefix (a :: l) l' -> In a l'.
Proof.
  intro Q. revert dependent l. induction l'; cbn in *; intros l Q.
  - inversion Q.
  - destruct (a == a0).
    + auto.
    + inversion Q; subst.
      * exfalso; apply c; reflexivity.
      * eauto.
Qed.

Inductive Postfix {A : Type} : list A -> list A -> Prop :=
| PostSame l : Postfix l l
| PostStep {a l l'} : Postfix l l' -> Postfix l (l' :r: a).

Fixpoint prefix_nincl {A : Type} `{EqDec A eq} (a : A) (l : list A) : list A :=
  match l with
  | nil => nil
  | b :: l => if a == b then l else prefix_nincl a l
  end.

Lemma prefix_nincl_prefix {A : Type} `{EqDec A eq} (a : A) l :
  In a l -> Prefix (a :: prefix_nincl a l) l.
Proof.
  intros Q.
  induction l; cbn;
    inversion Q.
  - subst a0. destruct (a == a); [|exfalso; apply c; reflexivity].
    econstructor.
  - destruct (a == a0).
    + destruct e. econstructor.
    + econstructor. eauto.
Qed.

Lemma prefix_cons {A : Type} (l l' : list A) :
  forall a, Prefix (a :: l) l' -> Prefix l l'.
Proof.
  intros a H. dependent induction H.
  - econstructor. econstructor.
  - econstructor. eapply IHPrefix; eauto.
Qed.

Lemma prefix_trans {A : Type} (l1 l2 l3 : list A) :
  Prefix l1 l2 -> Prefix l2 l3 -> Prefix l1 l3.
Proof.
  revert l1 l3. induction l2; intros l1 l3 pre1 pre2; inversion pre1; inversion pre2; subst; eauto.
  econstructor. eapply IHl2; eauto. eapply prefix_cons; eauto.
Qed.

Global Instance Prefix_Transitive (A : Type) : Transitive (@Prefix A).
Proof.
  unfold Transitive.
  eapply prefix_trans.
Qed.

Lemma in_prefix_in {A : Type} `{EqDec A eq} (a : A) l l' :
  In a l -> Prefix l l' -> In a l'.
Proof.
  intros Hin Hpre. induction l.
  - inversion Hin.
  - destruct (a == a0).
    + destruct e. eapply prefix_cons_in; eauto.
    + eapply IHl; eauto.
      * destruct Hin; [exfalso; subst; apply c; reflexivity|assumption].
      * eapply prefix_cons; eauto.
Qed.

Fixpoint postfix_nincl {A : Type} `{EqDec A eq} (a : A) (l : list A) : list A :=
  match l with
  | nil => nil
  | b :: l => if a == b then nil else b :: postfix_nincl a l
  end.

Lemma postfix_nil {A : Type} (l : list A) : Postfix nil l.
  apply rcons_ind; [econstructor|].
  intros. econstructor; eauto.
Qed.

Ltac rinduction L := revert dependent L; intro L; eapply rcons_ind with (l:=L); intros.

Lemma postfix_cons {A : Type} a (l l': list A) :
  Postfix l l' -> Postfix (a :: l) (a :: l').
Proof.
  intros post.
  - induction post.
    + econstructor.
    + rewrite <-cons_rcons_assoc. econstructor. assumption.
Qed.

Lemma postfix_eq {A : Type} (l1 l2 : list A) :
  Postfix l1 l2 <-> exists l2',  l2 = l1 ++ l2'.
Proof.
  split.
  - intro post. induction post.
    + exists nil. apply app_nil_end.
    + destruct IHpost as [l2' IH].
      exists (l2' :r: a). rewrite IH. rewrite app_assoc. reflexivity.
  - intros [l2' H]. subst l2.
    rinduction l2'.
    + rewrite <-app_nil_end. econstructor.
    + rewrite app_assoc. econstructor. eauto.
Qed.

Lemma cons_postfix {A : Type} a b (l l': list A) :
  Postfix (a :: l) (b :: l') -> Postfix l l'.
Proof.
  intros post. apply postfix_eq. apply postfix_eq in post as [l1' leq].
  exists l1'. inversion leq. reflexivity.
Qed.

Lemma postfix_app {A : Type} (l1 l2 l' : list A) :
  Postfix (l' ++ l1) (l' ++ l2) -> Postfix l1 l2.
Proof.
  revert l1 l2. induction l'; intros; cbn; eauto.
  apply IHl'. cbn in H. inversion H.
  - rewrite H2. econstructor.
  - eapply cons_postfix; eauto.
Qed.

Lemma postfix_nincl_postfix {A : Type} `{EqDec A eq} a l : Postfix (postfix_nincl a l) l.
Proof.
  induction l; cbn; [econstructor; reflexivity|].
  destruct (a == a0); cbn; eauto using postfix_nil, postfix_cons.
Qed.

Lemma postfix_nil_nil {A : Type} (l : list A) :
  Postfix l nil -> l = nil.
Proof.
  intro H. inversion H; eauto. destruct l'; cbn in H0; congruence.
Qed.

Lemma prefix_nil_nil {A : Type} (l : list A) :
  Prefix l nil -> l = nil.
Proof.
  intro H. inversion H; eauto.
Qed.

Lemma postfix_rcons_nil_eq {A : Type} l (a b : A) :
  Postfix (l :r: a) (b :: nil) -> a = b /\ l = nil.
Proof.

  intros post. apply postfix_eq in post as [l2' post]. destruct l; cbn in *; eauto.
  - inversion post; eauto.
  - inversion post. destruct l; cbn in H1; congruence.
Qed.

Lemma postfix_nincl_spec {A : Type} `{EqDec A eq} (a : A) l :
  In a l -> Postfix (postfix_nincl a l :r: a) l.
Proof.
  intros ina.
  induction l; inversion ina.
  - subst a0. cbn. destruct equiv_dec;[|exfalso; apply c; reflexivity].
    cbn. apply postfix_cons, postfix_nil.
  - cbn. destruct equiv_dec; cbn.
    + destruct e; apply postfix_cons, postfix_nil.
    + apply postfix_cons. eauto.
Qed.

Lemma postfix_nincl_invariant {A : Type} `{EqDec A eq} (a : A) l :
  ~ In a l -> postfix_nincl a l = l.
Proof.
  intros nin.
  induction l; cbn; eauto.
  destruct equiv_dec.
  - destruct e. exfalso. apply nin. econstructor; eauto.
  - rewrite IHl; eauto. (*contradict nin. econstructor 2; eauto.*)
Qed.

Lemma postfix_incl {A : Type} (l l' : list A) : Postfix l l' -> incl l l'.
Proof.
  intros post. induction post.
  - apply incl_refl.
  - apply incl_appl; eauto.
Qed.

Lemma postfix_hd_eq (A : Type) (a b : A) l l' :
  Postfix (a :: l) (b :: l') -> a = b.
Proof.
  intro post. eapply postfix_eq in post as [l2' pst].
  cbn in pst. inversion pst. eauto.
Qed.

Lemma postfix_order_destruct' {A : Type} (l1 l2 l3 : list A) :
  Postfix l1 l3 -> Postfix l2 l3 -> length l1 <= length l2 -> Postfix l1 l2.
Proof.
  revert l1 l3. induction l2; intros l1 l3 post1 post2 len; cbn in *.
  - destruct l1; cbn in len; [econstructor|lia].
  - destruct l1; [eapply postfix_nil|].
    destruct l3; [eapply postfix_nil_nil in post1; congruence|].
    eapply postfix_hd_eq in post1 as aeq. destruct aeq.
    eapply postfix_hd_eq in post2 as aeq. destruct aeq.
    eapply postfix_cons, IHl2. 1,2: eapply cons_postfix; eauto. cbn in len. lia.
Qed.

Lemma postfix_order_destruct {A : Type} (l1 l2 l3 : list A) :
  Postfix l1 l3 -> Postfix l2 l3 -> Postfix l1 l2 \/ Postfix l2 l1.
Proof.
  intros post1 post2.
  destruct (Nat.ltb (length l1) (length l2)) eqn:H.
  - left. eapply postfix_order_destruct'; eauto. eapply Nat.ltb_lt in H. lia.
  - right. eapply postfix_order_destruct'; eauto. eapply Nat.ltb_nlt in H. lia.
Qed.

Lemma postfix_step_left {A : Type} (l l' : list A) a :
  Postfix (l :r: a) l' -> Postfix l l'.
Proof.
  intros.
  remember (l :r: a) as l0.
  induction H. subst l0.
  - econstructor. econstructor.
  - econstructor; eauto.
Qed.

Lemma postfix_length {A : Type} (l l' : list A) :
  Postfix l l' -> length l <= length l'.
Proof.
  intros post. induction post.
  - reflexivity.
  - rewrite length_rcons. rewrite IHpost. lia.
Qed.

Lemma postfix_order {A : Type} (l1 l2 l' : list A) (a : A) :
  ~ In a l1 -> In a l2 -> Postfix l1 l'  -> Postfix l2 l' -> Postfix l1 l2.
Proof.
  intros nin1 in2 pst1 pst2. eapply postfix_order_destruct'; eauto.
  eapply postfix_order_destruct in pst1; eauto. clear pst2.
  destruct pst1.
  { exfalso. apply postfix_incl in H. firstorder. }
  apply postfix_length; eauto.
Qed.

Lemma postfix_elem {A : Type} `{EqDec A eq} (a:A) l l':
  length l > 0 -> Postfix l (a :: l') -> In a l.
Proof.
  intros len post.
  destruct l.
  { cbn in len; lia. }
  eapply postfix_hd_eq in post.
  subst a0. econstructor; eauto.
Qed.

Lemma postfix_trans {A : Type} (l l' l'': list A) :
  Postfix l l' -> Postfix l' l'' -> Postfix l l''.
Proof.
  intros post1; revert l''.
  induction post1; intros l'' post2.
  - induction post2; econstructor; eauto.
  - apply IHpost1. eapply postfix_step_left; eauto.
Qed.

Lemma postfix_nincl_nincl {A : Type} `{EqDec A eq} (a : A) l :
  ~ In a (postfix_nincl a l).
Proof.
  induction l; cbn; eauto. destruct (a == a0).
  - tauto.
  - contradict IHl. inversion IHl.
    + subst a0. exfalso; apply c; reflexivity.
    + assumption.
Qed.

Definition prefix_incl : forall (A : Type) (l l' : list A), Prefix l l' -> l ⊆ l'
  := fun (A : Type) (l l' : list A) (post : Prefix l l') =>
       @Prefix_ind A (fun l0 l'0 : list A => l0 ⊆ l'0) (fun l0 : list A => incl_refl l0)
                  (fun (a : A) (l0 l'0 : list A) (_ : Prefix l0 l'0) (IHpost : l0 ⊆ l'0) =>
                     incl_appr (a :: nil) IHpost) l l' post.

Lemma prefix_in_list {A : Type} l (a:A) :
  In a l
  -> exists l', Prefix (a :: l') l.
Proof.
  intro Hin.
  induction l.
  - inversion Hin.
  - destruct Hin;[subst;exists l; cbn;econstructor|].
    eapply IHl in H. destruct H as [l' H]. exists l'. cbn; econstructor; assumption.
Qed.

Lemma prefix_nil {A : Type} (l : list A) : Prefix nil l.
Proof.
  induction l; econstructor; firstorder.
Qed.

Lemma prefix_NoDup {A : Type} (l l' : list A) : Prefix l l' -> NoDup l' -> NoDup l.
Proof.
  intros Hpre Hnd. induction Hpre; eauto.
  inversion Hnd; subst; eauto.
Qed.

Section Pre.
  Variable A : Type.

  Lemma prefix_eq :
    forall (l1 l2 : list A), Prefix l1 l2 <-> (exists l2' : list A, l2 = l2' ++ l1).
  Proof.
    intros.
    split;intros.
    - induction H.
      + exists nil; cbn; eauto.
      + destructH. exists (a :: l2'). cbn. f_equal;eauto.
    - destructH. rewrite H.
      revert dependent l2.
      induction l2'; intros;cbn;econstructor;eauto.
  Qed.

  Lemma prefix_length `{EqDec A eq} (l1 l2 : list A)
        (Hpre : Prefix l1 l2)
        (Hlen : length l1 = length l2)
    : l1 = l2.
  Proof.
    eapply prefix_eq in Hpre. destructH. subst l2.
    destruct l2';cbn in *; eauto.
    exfalso.
    rewrite app_length in Hlen. lia.
  Qed.

  Lemma prefix_rev_postfix (l l' : list A)
        (Hpre : Prefix l l')
    : Postfix (rev l) (rev l').
  Proof.
    induction Hpre.
    - econstructor.
    - rewrite rev_cons. econstructor;eauto.
  Qed.

  Lemma prefix_rev_postfix' (l l' : list A)
        (Hpre : Prefix (rev l) (rev l'))
    : Postfix l l'.
  Proof.
    rewrite <-(rev_involutive l).
    rewrite <-(rev_involutive l').
    eapply prefix_rev_postfix;eauto.
  Qed.

  Lemma postfix_rev_prefix (l l' : list A)
        (Hpost : Postfix l l')
    : Prefix (rev l) (rev l').
  Proof.
    induction Hpost.
    - econstructor.
    - rewrite rev_rcons. econstructor;eauto.
  Qed.

  Lemma postfix_rev_prefix' (l l' : list A)
        (Hpost : Postfix (rev l) (rev l'))
    : Prefix l l'.
  Proof.
    rewrite <-(rev_involutive l).
    rewrite <-(rev_involutive l').
    eapply postfix_rev_prefix;eauto.
  Qed.

  Lemma prefix_order_destruct
    : forall l3 l4 l5 : list A, Prefix l3 l5 -> Prefix l4 l5 -> Prefix l3 l4 \/ Prefix l4 l3.
  Proof.
    intros.
    eapply prefix_rev_postfix in H. eapply prefix_rev_postfix in H0.
    eapply postfix_order_destruct in H;eauto.
    destruct H;[right|left]; eapply postfix_rev_prefix';eauto.
  Qed.

  Lemma prefix_length_eq `{EqDec A eq} (l1 l2 l : list A)
        (Hlen : length l1 = length l2)
        (Hpre1 : Prefix l1 l)
        (Hpre2 : Prefix l2 l)
    : l1 = l2.
  Proof.
    eapply prefix_order_destruct in Hpre1 as Hor;eauto.
    destruct Hor as [Hor|Hor]; eapply prefix_length in Hor; eauto; symmetry; eauto.
  Qed.

  Lemma prefix_induction {P : list A -> Prop}
    : P nil
      -> (forall (a : A) (l : list A) (l' : list A), P l' -> Prefix (a :: l') l -> P l)
      -> forall l : list A, P l.
  Proof.
    intros Hbase Hstep l. induction l;eauto.
    eapply Hstep;eauto. econstructor.
  Qed.

  Lemma prefix_ex_cons (l l' : list A) (a : A)
    : Prefix l l' -> exists a', Prefix (a' :: l) (a :: l').
  Proof.
    intros Hpre. revert a. induction Hpre; intros b.
    - exists b. econstructor.
    - specialize (IHHpre a). destructH. eexists. econstructor. eauto.
  Qed.

  Lemma postfix_ex_cons
    : forall (l l' : list A) (a : A), Postfix l l' -> exists a' : A, Postfix (l :r: a') (l' :r: a).
  Proof.
    intros. eapply postfix_rev_prefix in H. eapply prefix_ex_cons in H. destructH.
    exists a'. eapply prefix_rev_postfix'. do 2 rewrite rev_rcons. eauto.
  Qed.

  Lemma rcons_inj (l l' : list A) (a b : A)
    : l ++ [a] = l' ++ [b] -> l = l' /\ a = b.
  Proof.
    revert dependent l'.
    induction l;intros.
    - cbn in H. destruct l';cbn in *;eauto.
      + split;inversion H;eauto.
      + inversion H. congruence'.
    - destruct l';cbn in *.
      + inversion H. congruence'.
      + inversion H. subst. split;[f_equal|];eapply IHl;eauto.
  Qed.

  Lemma postfix_rcons_rcons (l l' : list A) (a a' : A)
    : Postfix (l ++ [a]) (l' ++ [a']) -> Postfix l l'.
  Proof.
    intros Hpost.
    eapply postfix_eq in Hpost. destructH.
    revert dependent a. revert a' l.
    induction l2';intros.
    - rewrite app_nil_r in Hpost. eapply rcons_inj in Hpost. destructH. subst. constructor.
    - eapply postfix_step_left. eapply IHl2'. rewrite <-app_cons_assoc. eauto.
  Qed.

  Lemma tl_prefix (l : list A)
    : Prefix (tl l) l.
  Proof.
    induction l;cbn;econstructor;eauto. econstructor.
  Qed.

  Lemma prefix_tl (l l' : list A) (a : A)
    : Prefix (a :: l) l' -> Prefix l (tl l').
  Proof.
    clear. intros. inversion H;subst;cbn.
    - econstructor.
    - eapply prefix_cons;eauto.
  Qed.

  Lemma prefix_rcons (l l' : list A) (a : A)
        (Hpref : Prefix l l')
    : Prefix (l :r: a) (l' :r: a).
  Proof.
    clear - Hpref.
    revert dependent l.
    induction l';intros l Hpref;cbn.
    - destruct l;cbn.
      + econstructor.
      + inversion Hpref.
    - inversion Hpref;subst.
      + cbn. econstructor.
      + econstructor. eapply IHl';eauto.
  Qed.

  Lemma postfix_take (l l' : list A)
    : take ( |l'| ) l = l' <-> Postfix l' l.
  Proof.
    split; intro H.
    - rewrite <-H.
      remember (|l'|) as n. clear.
      revert l. induction n.
      + cbn. eapply postfix_nil.
      + intros l. destruct l.
        * cbn. econstructor;auto.
        * cbn. eapply postfix_cons;eauto.
    - revert dependent l. induction l';intros;cbn;auto.
      destruct l. 1: inversion H;congruence'.
      f_equal.
      + symmetry;eapply postfix_hd_eq;eauto.
      + eapply IHl'. eapply cons_postfix;eauto.
  Qed.

  Lemma prefix_take_r (l l' : list A)
    : take_r ( |l'| ) l = l' <-> Prefix l' l.
  Proof.
    split; intro H.
    - eapply postfix_rev_prefix'.
      eapply postfix_take.
      eapply rev_rev_eq.
      rewrite rev_involutive.
      rewrite rev_length.
      unfold take_r in H.
      assumption.
    - eapply prefix_rev_postfix in H.
      eapply postfix_take in H.
      eapply rev_rev_eq in H.
      rewrite rev_involutive in H.
      rewrite rev_length in H.
      unfold take_r.
      assumption.
  Qed.

  Global Instance Prefix_Reflexive : Reflexive (@Prefix A).
  Proof.
    econstructor.
  Qed.

  Global Instance Postfix_Reflexive : Reflexive (@Postfix A).
  Proof.
    econstructor.
  Qed.

  Global Instance Prefix_dec (B : eqType)(l l' : list B) : dec (Prefix l l').
  Proof.
    clear.
    revert l;induction l';intros l.
    - destruct l;[left; eapply prefix_nil|]. right. intro N. inversion N.
    - destruct (IHl' l).
      + left. econstructor;eauto.
      + decide (l = a :: l').
        * left. subst. econstructor.
        * right. contradict n. inversion n;subst;[contradiction|].
          eauto.
  Qed.

  Lemma prefix_antisym (l l' : list A)
        (H : Prefix l l')
        (Q : Prefix l' l)
    : l = l'.
  Proof.
    eapply prefix_eq in H.
    eapply prefix_eq in Q.
    do 2 destructH.
    rewrite Q in H.
    rewrite app_assoc in H.
    induction (l2'0 ++ l2') eqn:E.
    - destruct l2'0.
      + cbn in E. rewrite E in Q. cbn in Q. eauto.
      + cbn in E. congruence.
    - exfalso. cbn in H. clear - H.
      revert dependent a. revert l0. induction l';intros.
      + congruence.
      + destruct l0;cbn in H.
        * inversion H. subst. eapply IHl'. instantiate (1:=nil). cbn. eapply H2.
        * inversion H. subst. eapply IHl'. rewrite app_cons_assoc in H2.
          eapply H2.
  Qed.

  Lemma prefix_cons_cons (a a' : A) l l' :
    Prefix (a :: l) (a' :: l') -> Prefix l l'.
  Proof.
    intros H. dependent induction H; cbn.
    - econstructor.
    - destruct l'.
      + inversion H.
      + econstructor. eapply IHPrefix; eauto.
  Qed.

  Lemma prefix_nincl_prefix' `{EqDec A eq} (l : list A) a
    : Prefix (prefix_nincl a l) l.
  Proof.
    induction l;cbn;eauto.
    - econstructor.
    - destruct (a == a0).
      + econstructor. econstructor.
      + econstructor. eauto.
  Qed.

End Pre.

Lemma postfix_map {A B : Type} (f : A -> B) :
  forall l l', Postfix l l' -> Postfix (map f l) (map f l').
Proof.
  intros ? ? Hpost.
  induction Hpost;[econstructor|rewrite map_rcons;econstructor;assumption].
Qed.

Lemma prefix_map_fst (A B : Type) (l l' : list (A * B))
      (Hpre: Prefix l l')
  : Prefix (map fst l) (map fst l').
Proof.
  induction Hpre.
  - econstructor.
  - destruct a. cbn. econstructor;eauto.
Qed.

Lemma postfix_map_fst (A B : Type) (l l' : list (A * B))
      (Hpre: Postfix l l')
  : Postfix (map fst l) (map fst l').
Proof.
  eapply prefix_rev_postfix'.
  do 2 rewrite <-map_rev.
  eapply prefix_map_fst.
  eapply postfix_rev_prefix;eauto.
Qed.

Lemma prefix_len_leq (A : Type) (l l' : list A)
      (Hpre : Prefix l l')
  : | l | <= | l' |.
Proof.
  induction Hpre;cbn;eauto.
Qed.

Lemma in_postfix_in {A : Type} l l' (a : A)
  :  a ∈ l -> Postfix l l' -> a ∈ l'.
Proof.
  intros Hin Hpost.
  revert dependent l.
  induction l'.
  - intros. eapply postfix_nil_nil in Hpost. subst. inv Hin.
  - intros.
    destruct l as [| b  l].
    + inv Hin.
    + simpl in Hin.
      destruct Hin.
      * left. symmetry. rewrite H in Hpost. eauto using postfix_hd_eq.
      * right. eauto using cons_postfix.
Qed.

Lemma prefix_fst_prefix {S T : Type} (a b : list (S * T))
      (Hprefix: Prefix a b)
  : Prefix (map fst a) (map fst b).
Proof.
  induction Hprefix.
  - econstructor.
  - simpl. econstructor. eauto.
Qed.

Lemma prefix_cycle (A : Type) (l : list A) a
  : Prefix (a :: l) l -> False.
Proof.
  revert a.
  induction l;cbn;intros.
  - inv H.
  - inv H.
    + exfalso;eapply list_cycle;eauto.
    + eapply prefix_cons in H2. eauto.
Qed.

(** StrictPrefix **)

Section StrictPre.

  Variable (A : Type).

  Definition StrictPrefix' :=
    fun (l l' : list A) => exists a : A, Prefix (a :: l) l'.

  Lemma prefix_strictPrefix:
    forall (e : A) (x ϕ : list A), Prefix ϕ x -> StrictPrefix' ϕ (e :: x).
  Proof.
    intros e x ϕ Hϕ1.
    unfold StrictPrefix'. cbn.
    revert dependent e.
    induction Hϕ1; intros.
    - exists e; econstructor.
    - specialize(IHHϕ1 a). destructH. exists a0. econstructor. auto.
  Qed.

  Lemma StrictPrefix_well_founded : well_founded (StrictPrefix').
  Proof.
    unfold well_founded.
    intros.
    induction a.
    - econstructor. intros. unfold StrictPrefix' in *. destructH. inversion H.
    - constructor. intros.
      unfold StrictPrefix' in H.
      destructH. cbn in *. inversion H;subst.
      + subst. auto.
      + eapply IHa. unfold StrictPrefix'. exists a1. cbn. auto.
  Qed.

End StrictPre.


Require Import x86proved.charge.ilogic.

Set Implicit Arguments.
Unset Strict Implicit.

Section PullQuantifier.
  Context {A} `{IL: ILogic A}.

  Inductive term :=
    | t_atom (P : A)
    | t_and (t1 t2 : term)
    | t_exists T (f : T -> A)
    | t_forall T (f : T -> A)
    | t_propand (P : Prop) (t : term)
    | t_propimpl (P : Prop) (t : term).

  Fixpoint eval (t : term) : A :=
    match t with
      | t_atom P => P
      | t_and t1 t2 => eval t1 //\\ eval t2
      | t_exists _ f => Exists a, f a
      | t_forall _ f => Forall a, f a
      | t_propand p t => p /\\ eval t
      | t_propimpl p t => p ->> eval t
    end.

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

  Fixpoint find_exists (t: term) : option find_res :=
    match t with
      | t_and t1 t2 =>
        match find_exists t1 with
          | Some (mkf _ f1) => Some (mkf (fun P' => (f1 P') //\\ eval t2))
          | None =>
            match find_exists t2 with
              | Some (mkf _ f2) => Some (mkf (fun P' => eval t1 //\\ (f2 P')))
              | None => None
            end
        end
      | t_propand P t =>
        match (find_exists t) with
          | Some (mkf _ f) => Some (mkf (fun P' => P /\\ (f P')))
          | None => None
        end
      | t_exists _ f => Some (mkf f)
      | _ => None
    end.

  Fixpoint find_forall (t: term) : option find_res :=
    match t with
      | t_and t1 t2 =>
        match find_forall t1 with
          | Some (mkf _ f1) => Some (mkf (fun P' => (f1 P') //\\ eval t2))
          | None =>
            match find_forall t2 with
              | Some (mkf _ f2) => Some (mkf (fun P' => eval t1 //\\ (f2 P')))
              | None => None
            end
        end
      | t_propand P t =>
        match (find_forall t) with
          | Some (mkf _ f) => Some (mkf (fun P' => P /\\ (f P')))
          | None => None
        end
      | t_forall _ f => Some (mkf f)
      | _ => None
    end.

  Fixpoint find_propand (t: term) : option (Prop * A) :=
    match t with
      | t_and t1 t2 =>
        match find_propand t1 with
          | Some (P, Q) => Some (P, Q //\\ eval t2)
          | None =>
            match find_propand t2 with
              | Some (P, Q) => Some (P, eval t1 //\\ Q)
              | None => None
            end
        end
      | t_propand P t => Some (P, eval t)
      | _ => None
    end.

  Fixpoint find_propimpl (t: term) : option (Prop * A) :=
    match t with
      | t_and t1 t2 =>
        match find_propimpl t1 with
          | Some (P, Q) => Some (P, Q //\\ eval t2)
          | None =>
            match find_propimpl t2 with
              | Some (P, Q) => Some (P, eval t1 //\\ Q)
              | None => None
            end
        end
      | t_propimpl P t => Some (P, eval t)
      | _ => None
    end.

End PullQuantifier.

Section PullExistential.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_exists_pull t:
    match find_exists t with
    | Some (mkf _ f) => eval t |-- Exists a, f a
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_exists t1) as [[T f]|].
      + rewrite -> IHt1, landexistsD; reflexivity.
      + destruct (find_exists t2) as [[T f]|]; [|tauto].
        rewrite -> IHt2, landC, landexistsD.
        setoid_rewrite landC at 1; reflexivity.
    - reflexivity.
    - fold find_exists. destruct (find_exists t) as [[T f]|]; [|tauto].
      rewrite IHt, lpropandexistsD; reflexivity.
  Qed.

  Lemma find_correct_exists_push t:
    match find_exists t with
    | Some (mkf _ f) => Exists a, f a |-- eval t
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_exists t1) as [[T f]|].
      + rewrite <- IHt1, landexistsD; reflexivity.
      + destruct (find_exists t2) as [[T f]|]; [|tauto].
        rewrite <- IHt2, landC, landexistsD.
        setoid_rewrite landC at 1; reflexivity.
    - reflexivity.
    - destruct (find_exists t) as [[T f]|]; [|tauto].
      rewrite <- IHt, lpropandexistsD; reflexivity.
  Qed.

  Lemma find_correct_exists t:
    match find_exists t with
    | Some (mkf _ f) => eval t -|- Exists a, f a
    | None => True
    end.
  Proof.
    pose proof (find_correct_exists_pull t) as Hpull.
    pose proof (find_correct_exists_push t) as Hpush.
    destruct (find_exists t) as [[T f]|]; [split; assumption|tauto].
  Qed.

  Lemma find_lhs_exists t Q:
    match find_exists t with
    | Some (mkf _ f) => (forall a, f a |-- Q) -> eval t |-- Q
    | None => True
    end.
  Proof.
    pose proof (@find_correct_exists_pull t) as Hpull.
    destruct (find_exists t) as [[T f]|]; [..|tauto].
    intros HQ. rewrite Hpull; apply lexistsL; assumption.
  Qed.

  Lemma find_rhs_exists t P:
    match find_exists t with
    | Some (mkf _ f) => P |-- Exists a, f a -> P |-- eval t
    | None => True
    end.
  Proof.
    pose proof (find_correct_exists_push t) as Hpush.
    destruct (find_exists t) as [[H f]|]; [..|tauto].
    rewrite Hpush; intros; assumption.
  Qed.

End PullExistential.

Ltac quote_term_exists P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_exists P1 in
      let t2 := quote_term_exists P2 in
      constr:(t_and t1 t2)
    | lexists ?f => constr:(t_exists f)
    | ?P1 /\\ ?P2 =>
      let t := quote_term_exists P2 in
      constr:(t_propand P1 t)
    | _ => constr:(t_atom P)
  end.

Ltac lexistsL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_exists P in
      apply (find_lhs_exists t Q) || fail 1 "No existential found in" P;
        cbv [eval]
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lexistsR_aux x :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_exists Q in
      apply (find_rhs_exists t P);
        cbv [eval]; apply lexistsR with x || fail 1 "Unable to existentialise" x "in" P
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Tactic Notation "lexistsR" constr(x) := lexistsR_aux x.

Section ExampleExists.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

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

  Example ex2 P : lfalse |-- P //\\ (Exists x1, 0 = 0 /\\ f x1) //\\ (Exists x2, f (1 + x2)).
  Proof.
    lexistsR 0.
    lexistsR 0.
    apply (lfalseL).
  Qed.
End ExampleExists.

Section PullUniversal.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_forall_pull t:
    match find_forall t with
    | Some (mkf _ f) => eval t |-- Forall a, f a
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_forall t1) as [[T f]|].
      + rewrite -> IHt1, landforallDL; reflexivity.
      + destruct (find_forall t2) as [[B f]|]; [|tauto].
        rewrite -> IHt2, landC, landforallDL.
        setoid_rewrite landC at 1; reflexivity.
    - reflexivity.
    - fold find_forall. destruct (find_forall t) as [[H f]|]; [|tauto].
      rewrite IHt, lpropandforallDL; reflexivity.
  Qed.

  Lemma find_correct_forall_push t:
    match find_forall t with
    | Some (mkf T f) => Inhabited T -> Forall a, f a |-- eval t
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_forall t1) as [[T f]|].
      + intro IT. rewrite <- IHt1, landforallDR; [reflexivity | assumption].
      + destruct (find_forall t2) as [[T f]|]; [|tauto].
        intro IT. rewrite <- IHt2, landC, <- landforallDR;
        [setoid_rewrite landC at 1; reflexivity | assumption].
    - reflexivity.
    - destruct (find_forall t) as [[T f]|]; [|tauto].
      intro IT; rewrite <- IHt, lpropandforallDR; [reflexivity | assumption].
  Qed.

  Lemma find_lhs_forall t Q:
    match find_forall t with
    | Some (mkf _ f) => (Forall a, f a |-- Q) -> eval t |-- Q
    | None => True
    end.
  Proof.
    pose proof (@find_correct_forall_pull t) as Hpull.
    destruct (find_forall t) as [[H f]|]; [..|tauto].
    intros HQ. rewrite Hpull; assumption.
  Qed.

  Lemma find_rhs_forall t P:
    match find_forall t with
    | Some (mkf T f) => Inhabited T -> (forall a, P |-- f a) -> P |-- eval t
    | None => True
    end.
  Proof.
    pose proof (find_correct_forall_push t) as Hpush.
    destruct (find_forall t) as [[T f]|]; [..|tauto].
    intros HT. rewrite <- Hpush; [apply lforallR |assumption].
  Qed.

End PullUniversal.

  Ltac quote_term_forall P :=
    match P with
    | ?P1 //\\ ?P2 =>
        let t1 := quote_term_forall P1 in
        let t2 := quote_term_forall P2 in
        constr:(t_and t1 t2)
    | lforall ?f => constr:(t_forall f)
    | ?P1 /\\ ?P2 =>
      let t := quote_term_forall P2 in
      constr:(t_propand P1 t)
    | _ => constr:(t_atom P)
    end.

  Ltac lforallL_aux x :=
    match goal with
    | |- ?P |-- ?Q =>
        let t := quote_term_forall P in
        apply (find_lhs_forall t Q);
        cbv [eval]; apply lforallL with x || fail 1 "Unable to existentialise" x "in" P
    | |- _ => fail 1 "Goal is not an entailment"
    end.

  Ltac lforallR :=
    first [apply lforallR |
    match goal with
    | |- ?P |-- ?Q =>
        let t := quote_term_forall Q in
        apply (find_rhs_forall t P);
        cbv [eval]; [apply _ || fail 1 "Not an inhabited type" |]
    | |- _ => fail 1 "Goal is not an entailment"
    end].

  Tactic Notation "lforallL" constr(x) := lforallL_aux x.

  Section ExampleForall.
    Context {A} `{IL: ILogic A}.
    Variable f: nat -> A.

    Example fa1 P: P //\\ (Forall x1, 0 = 1 /\\ f x1) //\\ (Forall x2, f (1 + x2)) |-- ltrue.
    Proof.
      lforallL 0. lforallL 1.
      Fail lforallL 0. apply ltrueR.
    Qed.

    Example fa2 P : lfalse |-- P //\\ (Forall x1, 0 = 0 /\\ f x1) //\\ (Forall x2, f (1 + x2)).
    Proof.
      lforallR; intro x.
      lforallR; intro y.
      apply (lfalseL).
    Qed.
  End ExampleForall.

Section PullAndProp.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_and_pull t:
    match find_propand t with
    | Some (P, Q) => eval t |-- P /\\ Q
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_propand t1) as [[T f]|].
      + rewrite -> IHt1. unfold lpropand.
        lexistsL; intro a; lexistsR a; reflexivity.
      + destruct (find_propand t2) as [[T f]|]; [|tauto].
        rewrite -> IHt2; unfold lpropand.
        lexistsL; intro a; lexistsR a; rewrite landC; reflexivity.
    - reflexivity.
  Qed.

  Lemma find_correct_and_push t:
    match find_propand t with
    | Some (P, Q) => P /\\ Q |-- eval t
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_propand t1) as [[T f]|].
      + rewrite <- IHt1; unfold lpropand.
        lexistsL; intro a; lexistsR a; reflexivity.
      + destruct (find_propand t2) as [[T f]|]; [|tauto].
        rewrite <- IHt2; unfold lpropand.
        lexistsL; intro a; lexistsR a; rewrite landC; reflexivity.
    - reflexivity.
  Qed.

  Lemma find_correct_and t:
    match find_propand t with
    | Some (P, Q) => eval t -|- P /\\ Q
    | None => True
    end.
  Proof.
    pose proof (find_correct_and_pull t) as Hpull.
    pose proof (find_correct_and_push t) as Hpush.
    destruct (find_propand t) as [[T f]|]; [split; assumption|tauto].
  Qed.

  Lemma find_lhs_and t R:
    match find_propand t with
    | Some (P, Q) => (P -> Q |-- R) -> eval t |-- R
    | None => True
    end.
  Proof.
    pose proof (@find_correct_and_pull t) as Hpull.
    destruct (find_propand t) as [[T f]|]; [..|tauto].
    intros HR. rewrite Hpull; apply lpropandL; assumption.
  Qed.

  Lemma find_rhs_and t P:
    match find_propand t with
    | Some (Q, R) => (P |-- R) /\ Q -> P |-- eval t
    | None => True
    end.
  Proof.
    pose proof (find_correct_and_push t) as Hpush.
    destruct (find_propand t) as [[Q R]|]; [..|tauto].
    intros [HR HQ].
    rewrite <- Hpush. apply lpropandR; assumption.
  Qed.

End PullAndProp.

Ltac quote_term_andprop P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_andprop P1 in
      let t2 := quote_term_andprop P2 in
      constr:(t_and t1 t2)
    | ?P1 /\\ ?P2 => constr:(t_propand P1 (t_atom P2))
    | _ => constr:(t_atom P)
  end.

Ltac lpropandL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_andprop P in
      apply (find_lhs_and t Q) || fail 1 "No propositional found in" P;
        cbv [eval]
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lpropandR :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_andprop Q in
      apply (find_rhs_and t P);
        cbv [eval]; split || fail 1 "No propositional found in" P
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Section ExamplePropAnd.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

  Example exprop1 P: P //\\ (Exists x1, 0 = 1 /\\ f x1) //\\ (Exists x2, f (1 + x2)) |-- ltrue.
  Proof.
    lexistsL; intro a; lexistsL; intro b.
    lpropandL; intro H.
    Fail lexistsL. apply ltrueR.
  Qed.

  Example exprop2 P : lfalse |-- P //\\ (Exists x1, 0 = 0 /\\ f x1) //\\ (Exists x2, f (1 + x2)).
  Proof.
    lexistsR 0.
    lexistsR 0.
    lpropandR.
    apply (lfalseL).
    reflexivity.
  Qed.
End ExamplePropAnd.

Section PullPropImpl.
  Context {A} `{IL: ILogic A}.

  Lemma find_correct_impl_pull t:
    match find_propimpl t with
    | Some (P, Q) => eval t |-- P ->> Q
    | None => True
    end.
  Proof.
    induction t; simpl; try tauto.
    - destruct (find_propimpl t1) as [[T f]|].
      + rewrite -> IHt1. unfold lpropimpl.
        lforallR; intro H; lforallL H; reflexivity.
      + destruct (find_propimpl t2) as [[T f]|]; [|tauto].
        rewrite -> IHt2; unfold lpropimpl.
        lforallR; intro H; lforallL H; reflexivity.
    - reflexivity.
  Qed.

  Lemma find_lhs_impl t R:
    match find_propimpl t with
    | Some (P, Q) => (P /\ Q |-- R) -> eval t |-- R
    | None => True
    end.
  Proof.
    pose proof (@find_correct_impl_pull t) as Hpull.
    destruct (find_propimpl t) as [[T f]|]; [..|tauto].
    intros [HT HR]. rewrite Hpull; apply lpropimplL; assumption.
  Qed.

End PullPropImpl.

Ltac quote_term_implprop P :=
  match P with
    | ?P1 //\\ ?P2 =>
      let t1 := quote_term_implprop P1 in
      let t2 := quote_term_implprop P2 in
      constr:(t_and t1 t2)
    | ?P1 ->> ?P2 => constr:(t_propimpl P1 (t_atom P2))
    | _ => constr:(t_atom P)
  end.

Ltac lpropimplL :=
  match goal with
    | |- ?P |-- ?Q =>
      let t := quote_term_implprop P in
      apply (find_lhs_impl t Q) || fail 1 "No propositional found in" P;
        cbv [eval]; split
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lpropimplR x := apply lpropimplR; intro x.

Section ExamplePropImpl.
  Context {A} `{IL: ILogic A}.
  Variable f: nat -> A.

  Example expropimpl1 P: P //\\ (Exists x1, 0 = 0 ->> f x1) //\\ (Exists x2, f (1 + x2)) |-- ltrue.
  Proof.
    lexistsL; intro a; lexistsL; intro b.
    lpropimplL. reflexivity.
    Fail lpropimplL. apply ltrueR.
  Qed.

End ExamplePropImpl.


Require Export Coq.Unicode.Utf8.
Require Export LambdaOmega.

(*************************************************************************)
(* Evaluation.                                                           *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _  => True
    | _        => False
  end.

Inductive red : Tm → Tm → Prop :=
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12).


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import Basic_Cons.Terminal.
Require Import PreSheaf.PreSheaf.

Section Terminal.
  Context (C : Category).

  (** The terminal element of the category of presheafs. *)
  Program Definition PSh_Term_PreSheaf : Functor (C^op) Type_Cat :=
    {|
      FO := fun _ => UNIT
    |}.

  Local Hint Resolve NatTrans_eq_simplify.
  Local Hint Resolve UNIT_SINGLETON.

  (** The functor that maps to the unit type in coq is the terminal object of presheafs. *)
  Program Instance PSh_Terminal : Terminal (PShCat C) :=
    {
      terminal := PSh_Term_PreSheaf;
      t_morph := fun _ => {|Trans := fun _ _ => TT|}
    }.

End Terminal.


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.micromega.Psatz.
Require Import Coq.Arith.Arith.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.

Inductive expr {Var: Type}: Type :=
  | impp : expr -> expr -> expr
  | varp : Var -> expr.

Arguments expr Var: clear implicits.

Instance L (Var: Type): Language :=
  Build_Language (expr Var).

Instance minL (Var: Type): MinimumLanguage (L Var) :=
  Build_MinimumLanguage (L Var) impp.

Definition rank {Var: Type}: expr Var -> nat :=
  fix rank (x: expr Var): nat :=
    match x with
    | impp y z => 1 + rank y + rank z
    | varp p => 0
    end.

Definition formula_countable: forall Var, Countable Var -> Countable (expr Var).
  intros.
  assert (forall n, Countable (sig (fun x: expr Var => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ Var); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun p => exist (fun x: expr Var => rank x <= 0) (varp p) (le_n 0))).
      * hnf; intros.
        inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        exists v.
        eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Var => rank x <= n)).
      apply (@injection_Countable _ (s * s + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (exist _ y _, exist _ z _) => proj1_sig x = impp y z
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by lia. assert (rank z <= n) by lia.
                exists (inl (exist _ y H0, exist _ z H1)); auto.
        (* 2 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | p] ?H];
        destruct b1 as [[[y1 ?H] [z1 ?H]] | p1]; try solve [inversion H];
        destruct b2 as [[[y2 ?H] [z2 ?H]] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[y ?H] [z ?H]] | p];
        destruct a1 as [[y1 z1 | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Var => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed.


(*
 - Definition of the displayed prebicategory of F-algebras (DFalg)
 - The type of 2-cells is `unit`
From 'UniMath/Bicategories/DisplayedBicats/Examples/Algebras.v' *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Require Import Integers.Prebicategories.Invertible_2cells.
Require Import Integers.Prebicategories.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import Integers.Prebicategories.DispPrebicat.
Import DispPrebicat.Notations.

Local Open Scope cat.
Section Algebra.
  Context {C : prebicat}.
  Variable (F : pseudofunctor C C).

  Locate disp_functor_data.
  Definition disp_alg_ob_mor : Core.disp_cat_ob_mor C.
  Proof.
    use tpair.
    - intro a.
      exact (F a --> a).
    - intros a b ha hb f.
      exact (invertible_2cell (ha · f) (#F f · hb)).
  Defined.

  Definition disp_alg_id_comp
    : Core.disp_cat_id_comp C disp_alg_ob_mor.
  Proof.
    split.
    - cbn. intros a ha.
      refine (runitor ha • linvunitor ha • (pseudofunctor_id F a ▹ ha) ,, _).
      is_iso.
      exact (pseudofunctor_id F a).
    - cbn. intros a b c f g ha hb hc ff gg.
      refine ((lassociator ha f g)
                • (ff ▹ g)
                • rassociator (#F f) hb g
                • (#F f ◃ gg)
                • lassociator (#F f) (#F g) hc
                • (pseudofunctor_comp F f g ▹ hc) ,, _).
      is_iso.
      + exact ff.
      + exact gg.
      + exact (pseudofunctor_comp F f g).
  Defined.

  Definition disp_alg_1_id_comp_cells : disp_prebicat_1_id_comp_cells C.
  Proof.
    use tpair.
    - use tpair.
      + exact disp_alg_ob_mor.
      + exact disp_alg_id_comp.
    - intros a b f g θ. cbn. intros ha hb ff gg.
      exact unit.
  Defined.

  Definition disp_alg_ops : disp_prebicat_ops' disp_alg_1_id_comp_cells.
  Proof.
    repeat split.
  Qed.

  Definition disp_alg_ops_laws : disp_prebicat_laws (_ ,, disp_alg_ops).
  Proof.
    repeat split; intro; intros; apply isapropunit.
  Qed.

  (* DFalg *)
  Definition disp_alg_prebicat : disp_prebicat C
    := (_ ,, disp_alg_ops_laws).

  Definition prebicat_algebra := total_prebicat disp_alg_prebicat.
End Algebra.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Bool Arith Lia Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Require Import unif_graph_def unif_fun unif_fix.

Set Implicit Arguments.

(** We can show partial correction and termination, but first
    we need so preliminary notions and results *)

(** Substitution equivalence *)

Definition subst_eq σ υ := forall x, (µ x)⦃σ⦄ = (µ x)⦃υ⦄.

Infix "≈" := subst_eq (at level 70, no associativity).

(* ≈ preserves substituted terms *)

Fact subst_eq_trm σ υ : σ ≈ υ → ∀t, t⦃σ⦄  = t⦃υ⦄.
Proof. intros H; induction t; simpl; f_equal; auto; apply H. Qed.

(* ≈ is an equivalence relation *)

Fact subst_eq_refl σ : σ ≈ σ.
Proof. red; auto. Qed.

Fact subst_eq_sym σ υ : σ ≈ υ → υ ≈ σ.
Proof. intros H ?; symmetry; apply H. Qed.

Fact subst_eq_trans σ υ τ : σ ≈ υ → υ ≈ τ → σ ≈ τ.
Proof. intros H1 H2 ?; rewrite H1, H2; auto. Qed.

(* composition is associative and a congruence under ≈ *)

Fact subst_eq_assoc σ υ τ  : (σ o υ) o τ ≈ σ o (υ o τ).
Proof. intro; repeat rewrite subst_comp_spec; auto. Qed.

Fact subst_eq_congrl σ υ τ : υ ≈ τ → σ o υ ≈ σ o τ.
Proof. intros H x; do 2 rewrite subst_comp_spec; apply subst_eq_trm; trivial. Qed.

(** The notion of most general unifier (mgu). Due to the list representation
    of subsitution, mgus are not unique and they can do whatever permutations
    on variables outside of m and n *)

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Definition mgu m n σ :=
    m⦃σ⦄ = n⦃σ⦄ ∧ ∀υ, m⦃υ⦄ = n⦃υ⦄ → ∃τ, υ ≈ σ o τ.

Fact mgu_refl u : mgu u u ∅.
Proof. split; auto; intros r ?; exists r; unfold subst_comp; simpl; auto; apply subst_eq_refl. Qed.

Fact mgu_sym u v σ : mgu u v σ → mgu v u σ.
Proof. intros []; split; auto. Qed.

(** mgus compose *)

Lemma mgu_comp m m' σ n n' υ :
         mgu m m' σ
       → mgu n⦃σ⦄ n'⦃σ⦄ υ
       → mgu (m⋄n) (m'⋄n') (σ o υ).
Proof.
  intros (H1 & H2) (H3 & H4); split.
  + do 2 rewrite subst_comp_spec; simpl.
    rewrite H1, H3; trivial.
  + intros p Hp.
    simpl in Hp.
    trm eq inv Hp as E1 E2.
    destruct (H2 _ E1) as (k1 & Hk1).
    do 2 rewrite (subst_eq_trm Hk1), subst_comp_spec in E2.
    destruct (H4 _ E2) as (k2 & Hk2).
    exists k2.
    apply subst_eq_trans with (1 := Hk1),
          subst_eq_sym,
          subst_eq_trans with (1 := subst_eq_assoc _ _ _),
          subst_eq_sym,
          subst_eq_congrl, Hk2.
Qed.

Section mgu_Var.

  (* a more intricate proof here, with two generalizations *)

  Let nocc_check_subst_rec t x m : x ⊀ m → m=µ x ∨ m⦃(x,t)::∅⦄ = m.
  Proof.
    revert t; induction m as [ y | c | m IHm n IHn ]; intros t; simpl occ_check.
    + simpl; destruct (eqV_dec y x); subst; auto.
    + simpl; auto.
    + intros H; simpl; right.
      destruct (IHm t).
      * tauto.
      * destruct H; subst; auto.
      * destruct (IHn t).
        - tauto.
        - destruct H; subst; auto.
        - simpl; f_equal; auto.
  Qed.

  Let nocc_check_subst x m : x ⊀ m → m⦃(x,m)::∅⦄ = m.
  Proof.
    intros H.
    destruct (nocc_check_subst_rec m x m); auto.
    subst; simpl; auto.
    destruct (eqV_dec x x) as [ | [] ]; auto.
  Qed.

  (** If x does not occur (check) in m then [(x,m)] is an mgu of µ x and m *)

  Lemma mgu_Var x m : x ⊀ m → mgu (µ x) m ((x,m)::∅).
  Proof.
    intros Hx; split.
    + simpl.
      destruct (eqV_dec x x) as [ | [] ]; auto.
      symmetry; apply nocc_check_subst; auto.
    + intros r Hr; exists r.
      intros y; simpl.
      destruct (eqV_dec y x) as [ H | ]; auto.
      subst; apply Hr.
  Qed.

End mgu_Var.

(** When there is no unifier *)

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Definition no_unif u v := forall σ, u⦃σ⦄ ≠ v⦃σ⦄ .

Infix "≬" := no_unif (at level 70).

Fact no_unif_sym u v : u ≬ v → v ≬ u.
Proof. intros H s E; apply (H s); auto. Qed.

Section occ_check_no_unif.

  (* also a non-obvious lemma here *)

  Let occ_check_size σ x t : x ≺ t → ⟦(µ x)⦃σ⦄⟧ < ⟦t⦃σ⦄⟧.
  Proof.
    induction t as [ y | c | m IHm n IHn ]; simpl in *; try tauto.
    revert IHm IHn.
    case_eq (σ↑x).
    + intros v Hv IHm IHn.
      intros [ H | [ H | [ H | H ] ] ]; subst; simpl.
      1,2: rewrite Hv; lia.
      * apply IHm in H; lia.
      * apply IHn in H; lia.
    + intros v Hv IHm IHn.
      simpl; lia.
  Qed.

  (** if x occur checks in m the µ x and m cannot by unified *)

  Lemma occ_check_no_unif x m : x ≺ m → µ x ≬  m.
  Proof.
    intros H s E.
    apply f_equal with (f := trm_size) in E.
    generalize (occ_check_size s _ _ H); lia.
  Qed.

End occ_check_no_unif.

Section unif_partial_correctness_1.

  (** We can now show partial correctness of unif on its domain
      We use the dependent induction principle *)

  (* Called on its domain unif produces an mgu or a proof of
     non-unifiability *)

  Theorem unif_partial_correct m n (D : 𝔻unif m n) :
             match unif D with
               | Some s => mgu m n s
               | None   => m ≬ n
             end.
  Proof.
    induction D as
      [ u v H1 H2 IH
      | c m n
      | c m n
      | c x
      | m n x
      | x m
      | c d
      | m n m' n' D1 ID1 H1
      | m n m' n' D1 ID1 s H1 D2 ID2
      ] using 𝔻unif_rect.
    + rewrite (unif_pirr _ H1); auto.
    + rewrite unif_fix_1; discriminate.
    + rewrite unif_fix_2; discriminate.
    + rewrite unif_fix_3.
      apply mgu_sym, mgu_Var; simpl; tauto.
    + destruct (occ_check_dec x (m⋄n)) as [ H | H ].
      * rewrite unif_fix_4; auto.
        apply no_unif_sym, occ_check_no_unif; auto.
      * rewrite unif_fix_4'; auto.
        apply mgu_sym, mgu_Var; auto.
    + destruct (occ_check_dec x m) as [ H | H ].
      * rewrite unif_fix_5; auto.
        apply occ_check_no_unif; auto.
      * rewrite unif_fix_5'; auto.
        apply mgu_Var; auto.
    + destruct (eqC_dec c d) as [ -> | H ].
      * rewrite unif_fix_6; apply mgu_refl.
      * rewrite unif_fix_6'; auto.
        now inversion 1.
    + rewrite unif_fix_7.
      rewrite H1 in ID1.
      intros s E; apply (ID1 s).
      trm eq inv E as E1 E2; auto.
    + rewrite H1 in ID1.
      case_eq (unif D2).
      * intros r Hr.
        rewrite Hr in ID2.
        rewrite unif_fix_8' with (1 := Hr).
        apply mgu_comp; auto.
      * intros H2.
        rewrite H2 in ID2.
        rewrite unif_fix_8; auto.
        intros s' E; simpl in E.
        trm eq inv E as E1 E2.
        apply ID1 in E1.
        destruct E1 as (k & Hk).
        apply (ID2 k).
        now rewrite <- !subst_comp_spec,
                    <- !subst_eq_trm with (1 := Hk).
  Qed.

End unif_partial_correctness_1.

(** Now we finish with totality/termination but we need
    more tools obtained as partial correctness results *)

(* A convenient tactic used several times below
   for inclusions between lists with ++ :: *)

Tactic Notation "finish" "by" hyp(H) :=
  revert H; simpl; rewrite !in_app_iff; simpl; tauto.

(** variable lists and substitutions *)

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Fact trm_vars_subst σ t : ⟪t⦃σ⦄⟫ ⊆ ⟪t⟫ ++ flat_map (λ c, ⟪snd c⟫) σ.
Proof.
  induction t as [ x | c | m Hm n Hn ].
  + simpl.
    destruct (subst_var_spec σ x) as [ (m & -> & H2) | (-> & H2) ].
    * intros y Hy.
      right; apply in_flat_map.
      exists (x,m); simpl; auto.
    * intros ? [ | [] ]; left; auto.
  + intros _ [].
  + intros x Hx; simpl in Hx.
    destruct ∈ at Hx;
    [ apply Hm in Hx
    | apply Hn in Hx ]; finish by Hx.
Qed.

Fact trm_vars_subst_In x m t : x ∈ ⟪t⦃(x,m)::∅⦄⟫ → x ∈ ⟪m⟫.
Proof.
  induction t as [ y | d | m' Hm' n' Hn' ]; simpl.
  + destruct (eqV_dec y x); auto.
    intros [| []]; subst; tauto.
  + tauto.
  + rewrite in_app_iff; tauto.
Qed.

Section unif_partial_correctness_2.

  (** Another partial correctness result:

      the variables in the output of unif m n = Some σ
      already occur in m or n *)

  Lemma mgu_trm_vars_incl m n (D : 𝔻unif m n) :
          match unif D with
            | Some σ => ∀t, ⟪t⦃σ⦄⟫ ⊆ ⟪m⟫++⟪n⟫++⟪t⟫
            | None   => True
          end.
  Proof.
    induction D as
      [ u v H1 H2 IH
      | c m n
      | c m n
      | c x
      | m n x
      | x m
      | c d
      | m n m' n' D1 ID1 H1
      | m n m' n' D1 ID1 s H1 D2 ID2
      ] using 𝔻unif_rect.
    + rewrite (unif_pirr _ H1); auto.
    + rewrite unif_fix_1; auto.
    + rewrite unif_fix_2; auto.
    + rewrite unif_fix_3.
      intros t y Hy.
      apply trm_vars_subst in Hy; finish by Hy.
    + destruct (occ_check_dec x (m⋄n)) as [ H | H ].
      * rewrite unif_fix_4; auto.
      * rewrite unif_fix_4'; auto.
        intros t y Hy.
        apply trm_vars_subst in Hy; finish by Hy.
    + destruct (occ_check_dec x m) as [ H | H ].
      * rewrite unif_fix_5; auto.
      * rewrite unif_fix_5'; auto.
        intros t y Hy.
        apply trm_vars_subst in Hy; finish by Hy.
    + destruct (eqC_dec c d) as [ -> | H ].
      * rewrite unif_fix_6.
        intros t y Hy.
        apply trm_vars_subst in Hy; finish by Hy.
      * rewrite unif_fix_6'; auto.
    + rewrite unif_fix_7; auto.
    + rewrite H1 in ID1.
      case_eq (unif D2).
      * intros r Hr.
        rewrite Hr in ID2.
        rewrite unif_fix_8' with (1 := Hr).
        intros t x Hx.
        rewrite subst_comp_spec in Hx; apply ID2 in Hx.
        destruct ∈ at Hx; apply ID1 in Hx; finish by Hx.
      * intros E; rewrite E in ID2.
        rewrite unif_fix_8; auto.
  Qed.

End unif_partial_correctness_2.

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Section unif_partial_correctness_3.

  (** Another partial correctness result:

      the output of unif m n = Some σ is either
      - the identity substitution
      - σ erases some variable x of m or n, ie
        x always disappears after substitution by σ *)

  Lemma mgu_trm_vars_dec m n (D : 𝔻unif m n) :
         match unif D with
           | Some σ => σ ≈ ∅ ∨ ∃x, x ∈ ⟪m⟫++⟪n⟫ ∧ ∀t, x ∉ ⟪t⦃σ⦄⟫
           | None   => True
         end.
  Proof.
    induction D as
      [ u v H1 H2 IH
      | c m n
      | c m n
      | c x
      | m n x
      | x m
      | c d
      | m n m' n' D1 ID1 H1
      | m n m' n' D1 ID1 s H1 D2 ID2
      ] using 𝔻unif_rect.
    + now rewrite (unif_pirr _ H1).
    + now rewrite unif_fix_1.
    + now rewrite unif_fix_2.
    + rewrite unif_fix_3; right.
      exists x; split.
      * simpl; auto.
      * intros t; induction t as [ y | d | m Hm n Hn ]; simpl.
        - simpl; destruct (eqV_dec y x); intros []; subst; tauto.
        - intros [].
        - rewrite in_app_iff; tauto.
    + destruct (occ_check_dec x (m⋄n)) as [ H | H ].
      * now rewrite unif_fix_4.
      * rewrite unif_fix_4'; auto; right.
        exists x; split.
        - simpl; rewrite !in_app_iff; simpl; auto.
        - intros t Ht.
          apply H, trm_vars_occ_check.
          split; try discriminate.
          revert Ht; apply trm_vars_subst_In.
    + destruct (occ_check_dec x m) as [ H | H ].
      * now rewrite unif_fix_5.
      * rewrite unif_fix_5'; auto.
        rewrite trm_vars_nocc_check in H.
        destruct H as [ H | H ].
        - left; subst.
          intros y; simpl; destruct (eqV_dec y x); subst; auto.
        - right; exists x; split.
          ++ simpl; auto.
          ++ intros t Ht; apply H; revert Ht; apply trm_vars_subst_In.
    + destruct (eqC_dec c d) as [ [] | H ].
      * rewrite unif_fix_6; left; apply subst_eq_refl.
      * now rewrite unif_fix_6'.
    + now rewrite unif_fix_7.
    + rewrite H1 in ID1.
      case_eq (unif D2).
      * intros r Hr.
        rewrite Hr in ID2.
        rewrite unif_fix_8' with (1 := Hr).
        destruct ID1 as [ ID1 | ID1 ];
        destruct ID2 as [ ID2 | ID2 ].
        - left; intros x.
          rewrite subst_comp_spec,
                  subst_eq_trm with (1 := ID1),
                  subst_eq_trm with (1 := ID2); auto.
        - destruct ID2 as (x & G1 & G2).
          right; exists x; split.
          ++ do 2 rewrite subst_eq_trm with (1 := ID1), subst_nil in G1; finish by G1.
          ++ intro; rewrite subst_comp_spec, subst_eq_trm with (1 := ID1), subst_nil; apply G2.
        - destruct ID1 as (x & G1 & G2).
          right; exists x; split.
          ++ finish by G1.
          ++ intro; rewrite subst_comp_spec, subst_eq_trm with (1 := ID2), subst_nil; apply G2.
        - destruct ID2 as (x & G1 & G2).
          right; exists x; split.
          ++ generalize (mgu_trm_vars_incl D1); rewrite H1.
             intros G3; destruct ∈ at G1; apply G3 in G1; finish by G1.
          ++ intro; rewrite subst_comp_spec; apply G2.
      * intros E; rewrite E in ID2.
        now rewrite unif_fix_8.
  Qed.

End unif_partial_correctness_3.