(*************************************************************)
(*   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 Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic fo_sat Sig_no_syms.

Import fol_notations.

Set Implicit Arguments.

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊑" := incl (at level 70, no associativity).

(* * Removal of function symbols from full monadic signatures *)

Fixpoint find_non_empty_word X (l : list (list X)) :
           { s & { w | s::w ∊ l } }
         + { concat l = nil }.
Proof.
  destruct l as [ | [ | s w ] l ].
  + right; auto.
  + destruct (find_non_empty_word X l) as [ (s & w & H) | H ].
    * left; exists s, w; right; auto.
    * right; simpl; auto.
  + left; exists s, w; left; auto.
Qed.

Local Notation ø := vec_nil.

Section fot_word_var.

  (* when arity of symbols is 1, terms have the shape s1(s2(...sn(i)...))
     where [s1,...,sn] is a list of symbols and i is a variable *)

  Variable (X : Type).

  Implicit Type t : fo_term (fun _ : X => 1).

  Fixpoint fot_var t :=
    match t with
      | in_var i   => i
      | in_fot s v => fot_var (vec_pos v pos0)
    end.

  Fixpoint fot_word t :=
    match t with
      | in_var i   => nil
      | in_fot s v => s::fot_word (vec_pos v pos0)
    end.

  Fixpoint fot_word_var w i : fo_term (fun _ : X => 1) :=
    match w with
      | nil  => in_var i
      | s::w => in_fot s (fot_word_var w i##ø)
    end.

  Fact fot_word_var_eq t : t = fot_word_var (fot_word t) (fot_var t).
  Proof.
    induction t as [ | s v IH ]; simpl in *; auto; f_equal.
    generalize (IH pos0); clear IH; vec split v with t; vec nil v; clear v; simpl.
    intros; f_equal; auto.
  Qed.

  Fact fot_word_eq w i : fot_word (fot_word_var w i) = w.
  Proof. induction w; simpl; f_equal; auto. Qed.

  Fact fot_var_eq w i : fot_var (fot_word_var w i) = i.
  Proof. induction w; simpl; f_equal; auto. Qed.

End fot_word_var.

Section Σ11_words.

  Variable (X Y : Type).

  (* Signatures with arity always 1 for both syms and rels *)

  Definition Σ11 : fo_signature.
  Proof.
    exists X Y; intros _.
    + exact 1.
    + exact 1.
  Defined.

  Fixpoint Σ11_words (A : fol_form Σ11) : list (list X) :=
    match A with
      | ⊥              => nil
      | fol_atom r v   => (fot_word (vec_pos v pos0))::nil
      | fol_bin _ A B  => Σ11_words A++Σ11_words B
      | fol_quant _ A  => Σ11_words A
    end.

End Σ11_words.

Section Σfull_mon_rem.

  (* The proof of Proposition 6.2.7 (Gradel) of pp 251 in
        "The Classical Decision Problem"

     cannot be impleted as is. The individual step is ok
     but the induction does not work because
          SAT (A /\ C) <-> SAT (B /\ C)
     is NOT implied by SAT A <-> SAT B !!

     At least I do not see how the implement the iterative
     process in a sound way ... termination is OK but
     invariants pose problems
  *)

  (* Hence we do the conversion in a single pass !! *)

  Variable (Y : Type) (HY : finite_t Y)
           (n m : nat).

  Notation X := (pos n).

  (* Bounded lists *)

  Let Yw := { w : list X | length w < S m }.

  Let YwY_fin : finite_t (Yw*Y).
  Proof.
    apply finite_t_prod; auto.
    apply finite_t_list, finite_t_pos.
  Qed.

  Let lwY := proj1_sig YwY_fin.
  Let HlwY p : p ∊ lwY.
  Proof. apply (proj2_sig YwY_fin). Qed.

  (* The new signature is not finite (list X !!)
      but this of no impact on decidability. However,
      the signature is discrete, if Y is discrete *)

  Notation Σ := (Σ11 X Y).
  Notation Σ' := (Σ11 X (list X*Y + Y)).

  Let f s v := @in_fot _ (ar_syms Σ') s v##ø.
  Let P r v : fol_form Σ' := @fol_atom Σ' (inr r) v.
  Let Q w r v : fol_form Σ' :=  @fol_atom Σ' (inl (w,r)) v.

  Arguments f : clear implicits.
  Arguments P : clear implicits.
  Arguments Q : clear implicits.

  (* An atomic formula of Σ as the form r(s1(...(sn(x))))
     and we encode it as the monadic Q_([sn;...;s1],r) (x)

     To ensure correctness, we have to add the non-simply
     monadic equations:

                  P_r x <-> Q_(nil,r) x
         and Q_(s::w,r) <-> Q_(w,r) (s x)

     In these, there is still Q_* (s x) which is not
     simply monodic. Later, we skolemize those equations
     to get rid of the compound term (s x)

     Notice that we have to bound n above to ensure that
     those equations are finitely many
   *)

  Local Fixpoint encode (A : fol_form Σ) : fol_form Σ' :=
    match A with
      | ⊥              => ⊥
      | fol_atom r v   =>
        let t := vec_head v in
        let w := fot_word t in
        let x := fot_var  t
        in  Q (rev w) r (£x##ø)
      | fol_bin b A B => fol_bin b (encode A) (encode B)
      | fol_quant q A => fol_quant q (encode A)
    end.

  Notation Σfull_mon_rec := encode.

  (* The reduction function does not map to a signature void of
     functions to simplify the above expression. However, the
     obtained formula is void of any function symbols *)

  Fact Σfull_mon_rec_syms A : fol_syms (Σfull_mon_rec A) = nil.
  Proof.
    induction A as [ | r v | b A HA B HB | q A HA ].
    1,2,4: simpl; tauto.
    simpl; rewrite HA, HB; auto.
  Qed.

  Variable (A : fol_form Σ) (HwA : forall w, w ∊ Σ11_words A -> length w < S m).

  (* Equations P_r (£0) <-> Q_(nil,r) (£0)
           and Q_(s::w,r) (£0) <-> Q_(w,r) (s(£0)) *)

  Let Eq (p : Yw * Y) : fol_form Σ' :=
    let v := £0##ø in
    let (w,r) := p in
    let (w,_) := w in
    match w with
      | nil   => Q nil r v ↔ P r v
      | s::w' => Q w' r (f s v) ↔ Q w r v
    end.

  (* The previous equations but skolemized by s(£0) <-> £(s) *)

  Let Eq' (p : Yw * Y) :=
    let m := £n##ø  in
    let (w,r) := p  in
    let (w,_) := w  in
    match w with
      | nil   => Q nil r m ↔ P r m
      | s::w' => Q w' r (£(pos2nat s)##ø) ↔ Q w r m
    end.

  (* We first deals with the non-skolemized reduction *)

  Definition Σfull_mon_red : fol_form Σ' :=
    Σfull_mon_rec A ⟑ ∀ fol_lconj (map Eq lwY).

  Variable (K : Type).

  (* Interpretation of a list of functions mapped on a value *)

  Let Fixpoint g (M : fo_model Σ K) w x :=
    match w with
      | nil  => x
      | s::w => g M w (fom_syms M s (x##ø))
    end.

  Let g_app M w1 w2 x : g M (w1++w2) x = g M w2 (g M w1 x).
  Proof. revert x; induction w1; simpl; auto. Qed.

  Let g_snoc M w s x : g M (w++s::nil) x = fom_syms M s (g M w x##ø).
  Proof. rewrite g_app; auto. Qed.

  Section soundness.

    Variable (M : fo_model Σ K).

    Let M' : fo_model Σ' K.
    Proof.
      split.
      + exact (fom_syms M).
      + intros [ (w,r) | r ]; simpl in r |- *.
        * exact (fun v  => fom_rels M r (g M w (vec_head v)##ø)).
        * exact (fom_rels M r).
    Defined.

    Fact Σfull_mon_rec_sound φ :
         fol_sem M' φ (Σfull_mon_rec A) <-> fol_sem M φ A.
    Proof.
      revert φ HwA; induction A as [ | r v | b B HB C HC | q B HB ]; intros φ HA.
      + simpl; tauto.
      + simpl in v; unfold Σfull_mon_rec.
        revert HA; vec split v with t; vec nil v; clear v; simpl vec_head; simpl syms; intros HA.
        specialize (HA _ (or_introl eq_refl)); simpl in HA |- *.
        replace (fo_term_sem M φ t)
        with    (fo_term_sem M φ (fot_word_var (fot_word t) (fot_var t))).
        * simpl; apply fol_equiv_ext; do 2 f_equal.
          generalize (fot_word t) (fot_var t); clear t HA; intros w.
          induction w as [ | s w IHw ]; simpl; auto; intros i.
          rewrite g_snoc; simpl; do 2 f_equal; auto.
        * f_equal; symmetry; apply fot_word_var_eq.
      + simpl; apply fol_bin_sem_ext.
        * apply HB; intros ? ?; apply HA, in_app_iff; auto.
        * apply HC; intros ? ?; apply HA, in_app_iff; auto.
      + simpl; apply fol_quant_sem_ext; intro; apply HB; auto.
    Qed.

    Variable (Kfin : finite_t K)
             (Mdec : fo_model_dec M)
             (φ : nat -> K)
             (HA : fol_sem M φ A).

    Theorem Σfull_mon_rem_sound : fo_form_fin_dec_SAT_in Σfull_mon_red K.
    Proof.
      exists M', Kfin.
      exists.
      { intros [ (w,r) | r ]; simpl in r |- *; intro; apply Mdec. }
      exists φ; simpl; split.
      + apply Σfull_mon_rec_sound; auto.
      + intro x; rewrite fol_sem_lconj.
        intros ?; rewrite in_map_iff.
        intros ((([|s w]&Hw),r) & <- & Hr); unfold Eq.
        * simpl; auto.
        * simpl; auto.
    Qed.

  End soundness.

  Section completeness.

    Variable (M' : fo_model Σ' K).

    Let M : fo_model Σ K.
    Proof.
      split.
      + exact (fom_syms M').
      + exact (fun r => fom_rels M' (inr r)).
    Defined.

    Section Σfull_mon_rec_complete.

      Hypothesis HM1' : forall s w r x, length (s::w) < S m
                                 -> fom_rels M' (inl (s::w, r)) (x##ø)
                                <-> fom_rels M' (inl (w, r)) (fom_syms M s (x##ø)##ø).

      Hypothesis HM2' : forall r x, fom_rels M' (inr r) (x##ø)
                                <-> fom_rels M' (inl (nil,r)) (x##ø).

      Let Hf φ w i : g M (rev w) (φ i) = fo_term_sem M φ (fot_word_var w i).
      Proof.
        induction w; simpl; auto.
        rewrite g_snoc; simpl in *; rewrite IHw; auto.
      Qed.

      Fact Σfull_mon_rec_complete φ :
        fol_sem M' φ (Σfull_mon_rec A) <-> fol_sem M φ A.
      Proof.
        revert φ HwA; induction A as [ | r v | b B HB C HC | q B HB ]; intros φ HwA.
        + simpl; tauto.
        + simpl in v; unfold Σfull_mon_rec.
          revert HwA; vec split v with t; vec nil v; clear v; simpl vec_head; simpl syms; intros HwA.
          specialize (HwA _ (or_introl eq_refl)); simpl in HwA |- *.
          replace (fo_term_sem M φ t)
          with    (fo_term_sem M φ (fot_word_var (fot_word t) (fot_var t))).
          * revert HwA; generalize (fot_word t) (fot_var t); intros w i.
            rewrite <- (rev_length w), <- Hf.
            simpl; generalize (rev w) (φ i); clear w; intros w.
            induction w as [ | s w IHw ]; simpl; auto; intros Hw x.
            - rewrite HM2'; tauto.
            - rewrite HM1', IHw; simpl; try tauto; lia.
          * f_equal; symmetry; apply fot_word_var_eq.
        + apply fol_bin_sem_ext.
          * apply HB; intros ? ?; apply HwA, in_app_iff; auto.
          * apply HC; intros ? ?; apply HwA, in_app_iff; auto.
        + simpl; apply fol_quant_sem_ext; intro; apply HB; auto.
      Qed.

    End Σfull_mon_rec_complete.

    Variable (Kfin : finite_t K)
             (M'dec : fo_model_dec M')
             (φ : nat -> K)
             (HA : fol_sem M' φ Σfull_mon_red).

    Theorem Σfull_mon_rem_complete : fo_form_fin_dec_SAT_in A K.
    Proof.
      exists M, Kfin.
      exists.
      { intros r'; simpl in r'; intros v; apply M'dec. }
      exists φ; simpl.
      simpl in HA. destruct HA as [ H1 H2 ].
      revert H1; apply Σfull_mon_rec_complete.
      + intros s w r x Hw.
        simpl in H2; specialize (H2 x).
        rewrite fol_sem_lconj in H2.
        symmetry; apply (H2 (Eq (exist _ (s::w) Hw,r))), in_map_iff.
        exists (exist _ (s::w) Hw,r); split; auto.
      + intros r x.
        simpl in H2; specialize (H2 x).
        rewrite fol_sem_lconj in H2.
        symmetry; apply (H2 (Eq (exist _ nil (lt_0_Sn _),r))), in_map_iff.
        exists (exist _ nil (lt_0_Sn _),r); split; auto.
    Qed.

  End completeness.

  (* The non-skolemized reduction is correct *)

  Theorem Σfull_mon_red_correct : fo_form_fin_dec_SAT_in A K
                              <-> fo_form_fin_dec_SAT_in Σfull_mon_red K.
  Proof.
    split.
    + intros (M & H1 & H2 & phi & H3).
      apply Σfull_mon_rem_sound with M phi; auto.
    + intros (M' & H1 & H2 & phi & H3).
      apply Σfull_mon_rem_complete with M' phi; auto.
  Qed.

  (* Now we skolemize the right part (equations) and show correctness *)

  Definition Σfull_mon_red' : fol_form Σ' :=
    Σfull_mon_rec A ⟑ ∀ fol_mquant fol_ex n (fol_lconj (map Eq' lwY)).

  Local Lemma Σfull_mon_red'_sound :
          fo_form_fin_dec_SAT_in Σfull_mon_red K
       -> fo_form_fin_dec_SAT_in Σfull_mon_red' K.
  Proof.
    intros (M & Kfin & Mdec & φ & H1 & H2); simpl in H1, H2.
    exists M, Kfin, Mdec, φ; simpl; split; auto.
    intros x; specialize (H2 x).
    rewrite fol_sem_mexists.
    exists (vec_set_pos (fun p => fom_syms M p (x##ø))).
    rewrite fol_sem_lconj; intros ?; rewrite in_map_iff.
    intros (c & <- & H).
    rewrite fol_sem_lconj in H2.
    specialize (H2 (Eq c) (in_map _ _ _ H)).
    clear H; revert H2.
    destruct c as (([ | s w ],?),r); simpl.
    + rewrite env_vlift_fix1 with (k := 0); simpl; auto.
    + rewrite env_vlift_fix1 with (k := 0).
      rewrite env_vlift_fix0; simpl; rew vec.
  Qed.

  Section Σfull_mon_red'_complete.

    Variable (M : fo_model Σ' K)
             (Kfin : finite_t K)
             (Mdec : fo_model_dec M)
             (φ : nat -> K)
             (HA : fol_sem M φ Σfull_mon_red').

    Let R x (v : vec _ n) := fol_sem M (env_vlift x·φ v) (fol_lconj (map Eq' lwY)).

    Let Rreif : { r : K -> vec K n | forall x, R x (r x) }.
    Proof.
      apply finite_t_dec_choice.
      + apply finite_t_vec; auto.
      + intros x v; apply fol_sem_dec; auto.
      + simpl in HA; apply proj2 in HA.
        intros x; generalize (HA x).
        rewrite fol_sem_mexists; auto.
    Qed.

    Let r := proj1_sig Rreif.
    Let Hg x : fol_sem M (env_vlift x·φ (r x)) (fol_lconj (map Eq' lwY)).
    Proof. apply (proj2_sig Rreif). Qed.

    Let M' : fo_model Σ' K.
    Proof.
      split.
      + simpl; intros p v.
        exact (vec_pos (r (vec_head v)) p).
      + exact (fom_rels M).
    Defined.

    Local Lemma Σfull_mon_red'_complete : fo_form_fin_dec_SAT_in Σfull_mon_red K.
    Proof.
      exists M', Kfin, Mdec, φ.
      simpl; split.
      + simpl in HA; generalize (proj1 HA).
        apply fo_model_nosyms.
        * apply Σfull_mon_rec_syms.
        * intros; simpl; tauto.
      + intros x.
        specialize (Hg x).
        rewrite fol_sem_lconj in Hg.
        rewrite fol_sem_lconj.
        intros u; rewrite in_map_iff.
        intros (c & <- & Hc).
        specialize (Hg (Eq' c) (in_map _ _ _ Hc)).
        revert Hg.
        destruct c as (([|s w]&?),?); simpl.
        * rewrite env_vlift_fix1 with (k := 0); simpl; auto.
        * rewrite env_vlift_fix1 with (k := 0).
          rewrite env_vlift_fix0; simpl; rew vec.
    Qed.

  End Σfull_mon_red'_complete.

  (* The non-skolemized reduction is correct *)

  Theorem Σfull_mon_red'_correct :
          fo_form_fin_dec_SAT_in A K
      <-> fo_form_fin_dec_SAT_in Σfull_mon_red' K.
  Proof.
    rewrite Σfull_mon_red_correct.
    split.
    + apply Σfull_mon_red'_sound.
    + intros (M & H1 & H2 & phi & H3).
      apply Σfull_mon_red'_complete with M phi; auto.
  Qed.

  (* And produce a syms-free formula *)

  Theorem Σfull_mon_red'_no_syms : fol_syms Σfull_mon_red' = nil.
  Proof.
    cut (incl (fol_syms Σfull_mon_red') nil).
    + generalize (fol_syms Σfull_mon_red').
      intros [ | x l ] H; auto.
      destruct (H x); simpl; auto.
    + simpl.
      rewrite Σfull_mon_rec_syms, fol_syms_mquant.
      rewrite fol_syms_bigop, <- app_nil_end; simpl.
      intros x; rewrite in_flat_map.
      intros (u & H & Hu); revert H.
      rewrite in_map_iff.
      intros (c & <- & Hc).
      revert Hu.
      destruct c as (([|s w]&?),r); simpl; auto.
  Qed.

End Σfull_mon_rem.

Section Σ11_reduction.

  (* We can lower the hypotheses now by computing m from A *)

  Variable (n : nat) (Y : Type) (HY : finite_t Y) (A : fol_form (Σ11 (pos n) Y)) (K : Type).

  Local Definition max_depth := lmax (map (@length _) (Σ11_words A)).

  Notation m := max_depth.

  Let Hmd w : w ∊ Σ11_words A -> length w < S m.
  Proof.
    intros Hw; apply le_n_S, lmax_prop, in_map_iff.
    exists w; auto.
  Qed.

  Definition Σ11_red := Σfull_mon_red' HY m A.

  Theorem Σ11_red_correct : fo_form_fin_dec_SAT_in A K <-> fo_form_fin_dec_SAT_in Σ11_red K.
  Proof. apply Σfull_mon_red'_correct; auto. Qed.

  Theorem Σ11_red_no_syms : fol_syms Σ11_red = nil.
  Proof. apply Σfull_mon_red'_no_syms. Qed.

End Σ11_reduction.

(* We get the elimination of symbols *)

Section Σ11_Σ1.

  Variable (n : nat) (P : Type) (HY : finite_t P) (A : fol_form (Σ11 (pos n) P)).

  Theorem Σ11_Σ1_reduction : { B : fol_form (Σ11 Empty_set (list (pos n)*P + P))
                                 | fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT B }.
  Proof.
    destruct Σ_no_sym_correct with (A := Σ11_red HY A) as (B & HB).
    { rewrite Σ11_red_no_syms; apply incl_refl. }
    exists B; rewrite <- HB; split; intros (X & H); exists X; revert H; apply Σ11_red_correct.
  Qed.

End Σ11_Σ1.


(** * ImpList: Imp Extended with Lists *)

Require Export SfLib.

(* ####################################################### *)
(** * Imp Programs with Lists *)

(** There are only so many numeric functions with interesting
    properties that have simple proofs.  (Of course, there are lots of
    interesting functions on numbers and they have many interesting
    properties -- this is the whole field of number theory! -- but
    proving these properties often requires developing a lot of
    supporting lemmas.)  In order to able to write a few more programs
    to reason about, we introduce here an extended version of Imp
    where variables can range over both numbers and lists of numbers.
    The basic operations are extended to also include taking the head
    and tail of lists, and testing lists for nonemptyness.

    To do this, we only need to change the definitions of [state],
    [aexp], [aeval], [bexp], and [beval]. The definitions of [com] and
    [ceval] can be reused verbatim, although we need to copy-and-paste
    them in the context of the new definitions.

    We start by repeating some material from [Imp.v]. *)

(** ** Repeated Definitions *)

Inductive id : Type :=
  Id : nat -> id.

Definition beq_id id1 id2 :=
  match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Theorem not_eq_beq_id_false : forall i1 i2,
  i1 <> i2 -> beq_id i1 i2 = false.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  assert (n <> n0).
    intros C. subst. apply H. reflexivity.
  apply not_eq_beq_false. assumption.  Qed.

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

(** ** Extensions *)

(** Now we come to the key changes.

    Rather than evaluating to a [nat], an [aexp] in our new language
    will evaluate to a _value_ -- an element of type [val] -- which
    can be either a [nat] or a list of [nat]s.

    Similarly, [state]s will now map identifiers to [val]s rather than
    [nat]s, so that we can store lists in mutable variables. *)

Inductive val : Type :=
| VNat : nat -> val
| VList : list nat -> val.

Definition state := id -> val.

Definition empty_state : state := fun _ => VNat 0.
Definition update (st : state) (V:id) (n : val) : state :=
  fun V' => if beq_id V V' then n else st V'.

(** Imp does not have a static type system, so nothing prevents the
    programmer from e.g. adding two lists or taking the head of a
    number. We have to decide what to do in such nonsensical
    situations.

    We adopt a simple solution: if an arithmetic function is given a
    list as an argument we treat the list as if it was the number
    [0]. Similarly, if a list function is given a number as an
    argument we treat the number as if it was [nil].  (Cf. Javascript,
    where adding [3] to the empty list evaluates to [3]...)

    The two functions [asnat] and [aslist] interpret [val]s in a
    numeric or a list context; [aeval] calls these whenever it
    evaluates an arithmetic or a list operation.*)

Definition asnat (v : val) : nat :=
  match v with
  | VNat n => n
  | VList _ => 0
  end.

Definition aslist (v : val) : list nat :=
  match v with
  | VNat n => []
  | VList xs => xs
  end.

(** Now we fill in the definitions of abstract syntax and
    evaluation functions for arithmetic and boolean expressions. *)

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp
  (* Four new cases: *)
  | AHead : aexp -> aexp
  | ATail : aexp -> aexp
  | ACons : aexp -> aexp -> aexp
  | ANil  : aexp.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "AId" | Case_aux c "APlus"
  | Case_aux c "AMinus" | Case_aux c "AMult"
  | Case_aux c "AHead" | Case_aux c "ATail"
  | Case_aux c "ACons" | Case_aux c "ANil" ].

Definition tail (l : list nat) :=
  match l with
  | x::xs => xs
  | [] => []
  end.

Definition head (l : list nat) :=
  match l with
  | x::xs => x
  | [] => 0
  end.

Fixpoint aeval (st : state) (e : aexp) : val :=
  match e with
  | ANum n => VNat n
  | AId i => st i
  | APlus a1 a2   => VNat (asnat (aeval st a1) + asnat (aeval st a2))
  | AMinus a1 a2  => VNat (asnat (aeval st a1) - asnat (aeval st a2))
  | AMult a1 a2   => VNat (asnat (aeval st a1) * asnat (aeval st a2))
  (* Four new cases: *)
  | ATail a => VList (tail (aslist (aeval st a)))
  | AHead a => VNat (head (aslist (aeval st a)))
  | ACons a1 a2 => VList (asnat (aeval st a1) :: aslist (aeval st a2))
  | ANil => VList []
  end.

(** We extend [bexp]s with an operation to test if a list is nonempty
    and adapt [beval] acordingly. *)

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp
  (* New case: *)
  | BIsCons : aexp -> bexp.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" | Case_aux c "BEq"
  | Case_aux c "BLe" | Case_aux c "BNot" | Case_aux c "BAnd"
  | Case_aux c "BIsCons" ].

Fixpoint beval (st : state) (e : bexp) : bool :=
  match e with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (asnat (aeval st a1)) (asnat (aeval st a2))
  | BLe a1 a2   => ble_nat (asnat (aeval st a1)) (asnat (aeval st a2))
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  (* New case: *)
  | BIsCons a    => match aslist (aeval st a) with
                     | _::_ => true
                     | [] => false
                   end
  end.

(** ** Repeated Definitions *)

(** Now we need to repeat a little bit of low-level work from Imp.v,
    plus the definitions of [com] and [ceval].  There are no
    interesting changes -- it's just a matter of repeating the same
    definitions, lemmas, and proofs in the context of the new
    definitions of arithmetic and boolean expressions.

    (Is all this cutting and pasting really necessary?  No: Coq
    includes a powerful module system that we could use to abstract
    the repeated definitions with respect to the varying parts.  But
    explaining how it works would distract us from the topic at hand.)
 *)

Theorem update_eq : forall n V st,
  (update st V n) V = n.
Proof.
  intros n V st.
  unfold update.
  rewrite <- beq_id_refl.
  reflexivity.
Qed.

Theorem update_neq : forall V2 V1 n st,
  beq_id V2 V1 = false ->
  (update st V2 n) V1 = (st V1).
Proof.
  intros V2 V1 n st Hneq.
  unfold update.
  rewrite -> Hneq.
  reflexivity. Qed.

Theorem update_shadow : forall x1 x2 k1 k2 (f : state),
   (update  (update f k2 x1) k2 x2) k1 = (update f k2 x2) k1.
Proof.
  intros x1 x2 k1 k2 f.
  unfold update.
  destruct (beq_id k2 k1); reflexivity.  Qed.

Theorem update_same : forall x1 k1 k2 (f : state),
  f k1 = x1 ->
  (update f k1 x1) k2 = f k2.
Proof.
  intros x1 k1 k2 f Heq.
  unfold update. subst.
  remember (beq_id k1 k2) as b.
  destruct b.
  Case "true".
    apply beq_id_eq in Heqb. subst. reflexivity.
  Case "false".
    reflexivity.  Qed.

Theorem update_permute : forall x1 x2 k1 k2 k3 f,
  beq_id k2 k1 = false ->
  (update (update f k2 x1) k1 x2) k3 = (update (update f k1 x2) k2 x1) k3.
Proof.
  intros x1 x2 k1 k2 k3 f H.
  unfold update.
  remember (beq_id k1 k3) as b13.
  remember (beq_id k2 k3) as b23.
  apply beq_id_false_not_eq in H.
  destruct b13; try reflexivity.
  Case "true".
    destruct b23; try reflexivity.
    SCase "true".
      apply beq_id_eq in Heqb13.
      apply beq_id_eq in Heqb23.
      subst. apply ex_falso_quodlibet. apply H. reflexivity.  Qed.

(** We can keep exactly the same old definitions of [com] and
    [ceval]. *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE" ].

Notation "'SKIP'" :=
  CSkip.
Notation "l '::=' a" :=
  (CAss l a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Asgn  : forall st a1 n l,
      aeval st a1 = n ->
      (l ::= a1) / st || (update st l n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ; c2) / st || st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      c1 / st || st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      c2 / st || st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      (WHILE b1 DO c1 END) / st || st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      c1 / st || st' ->
      (WHILE b1 DO c1 END) / st' || st'' ->
      (WHILE b1 DO c1 END) / st || st''

  where "c1 '/' st '||' st'" := (ceval st c1 st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Asgn" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop" ].

Definition loop : com :=
  WHILE BTrue DO
    SKIP
  END.

Theorem loop_never_stops : forall st st',
  ~(loop / st || st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef.
  ceval_cases (induction contra) Case; try (inversion Heqloopdef).
    Case "E_WhileEnd".
      rewrite -> H1 in H. inversion H.
    Case "E_WhileLoop".
      apply IHcontra2. subst. reflexivity.  Qed.


From Coq Require Import Arith Lia.
Unset Elimination Schemes.
Definition dec (X: Type) := sum X (X -> False).
Definition eqdec X := forall x y: X, dec (x = y).
Definition nat_eqdec : eqdec nat :=
  fun x y => match Nat.eq_dec x y with left H => inl H | right H => inr H end.
Notation "'Sigma' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Definition XM := forall P, P \/ ~P.

Fact neg_xm (P: Prop) {Q} :
  (P -> ~Q) -> (~P -> ~Q) -> ~Q.
Proof.
  tauto.
Qed.
Fact neg_skip (Q: Prop) :
  Q -> ~ ~Q.
Proof.
  tauto.
Qed.
Fact neg_skip' (P: Prop) {Q} :
  (P -> ~Q) -> ~ ~P -> ~Q.
Proof.
  tauto.
Qed.

Module Scratch.
Section Scratch.
  Variable X: Type.

  Inductive list: Type := nil | cons (x:X) (A: list).

  Implicit Types (x y z: X) (A B C: list).

  Definition list_elim (p: list -> Type)
    : p nil -> (forall x A, p A -> p (cons x A)) -> forall A, p A
    := fun a f => fix F A := match A with nil => a | cons x A' => f x A' (F A') end.

  Fact cons_nil x A :
      cons x A <> nil.
  Proof.
    intros H.
    change (if cons x A then True else False).
    rewrite H. exact I.
  Qed.

  Fact cons_injective x x' A A' :
      cons x A = cons x' A' -> x = x' /\ A = A'.
  Proof.
    intros H.
    change (match cons x A with nil => True | cons x A => x = x' /\ A = A' end).
    rewrite H. auto.
  Qed.

  Goal forall x A,
      cons x A <> A.
  Proof.
    intros *; revert A x.
    refine (list_elim _ _ _).
    - intros x. apply cons_nil.
    - intros x A H1 x' H2. eapply H1, cons_injective, H2.
  Qed.
End Scratch.
End Scratch.

(* From now on we use Coq's predefined lists *)
From Coq Require Import List.
Import ListNotations.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "x 'nel' A" := (~ In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).

Section List.
  Variable X : Type.
  Implicit Types (x y z : X) (A B C : list X).

  Goal forall x A,
      x::A <> A.
  Proof.
    induction A as [|y A IH].
    - intros [=].
    - intros [= <- H]. easy.
  Qed.

  Goal forall A B,
      length (A ++ B) = length A + length B.
  Proof.
    intros A B.
    induction A as [|x A IH]; cbn.
    - reflexivity.
    - f_equal. exact IH.
  Qed.

  Fact mem_ex x A :
    x el A -> exists A1 A2, A = A1 ++ x::A2.
  Proof.
    intros H.
    induction A as [|y A IH].
    - contradict H.
    - destruct H as [<-|H1].
      + exists [], A. reflexivity.
      + destruct (IH H1) as (A1&A2&->).
        exists (y::A1), A2. reflexivity.
  Qed.

  Variables X_eqdec: eqdec X.

  Fact mem_sum x a A :
    x el a :: A -> (x = a) + (x el A).
  Proof.
    intros H.
    destruct (X_eqdec x a) as [H1|H1].
    - left. exact H1.
    - right. destruct H as [H|H].
      + exfalso. auto.
      + exact H.
  Defined.

  Fact mem_sig x A :
    x el A -> Sigma A1 A2, A = A1 ++ x::A2.
  Proof.
    intros H.
    induction A as [|y A IH].
    - contradict H.
    - apply mem_sum in H as [<-|H1].
      + exists [], A. reflexivity.
      + destruct (IH H1) as (A1&A2&->).
        exists (y::A1), A2. reflexivity.
  Qed.

  Goal eqdec (list X).
  Proof.
    intros A B.
    induction A as [|x A IH] in B |-*; destruct B as [|y B].
    - left. reflexivity.
    - right. intros [=].
    - right. intros [=].
    - specialize (X_eqdec x y) as [<-|H].
      + specialize (IH B) as [<-|IH].
        * left. reflexivity.
        * right. intros [= <-]. easy.
      + right. intros [= <- _]. easy.
  Defined.

  Fact mem_dec x A :
    dec (x el A).
  Proof.
    induction A as [|a A IH].
    - right. auto.
    - destruct (X_eqdec x a) as [<-|H].
      + left. cbn. auto.
      + destruct IH as [IH|IH].
        * left. cbn. auto.
        * right. cbn. intuition.
  Defined.

  (*** Inclusion and Equivalence *)

  Definition equi A B := A <<= B /\ B <<= A.
  Notation "A == B" := (equi A B) (at level 70).
  Fact equi_refl A :
    A == A.
  Proof.
    unfold equi, incl. auto.
  Qed.

  Fact equi_symm A B :
    A == B -> B ==A.
  Proof.
    unfold equi, incl. intuition.
  Qed.

  Fact equi_trans A B C :
    A == B -> B == C -> A == C.
  Proof.
    unfold equi, incl. intuition.
  Qed.

  Fact mem_del_ex {x A} :
    x el A -> exists A', A == x::A' /\ length A = S (length A').
  Proof.
    intros (A1&A2&->) %mem_ex.
    exists (A1++A2). split.
    - split; intros z; cbn; rewrite !in_app_iff; cbn; intuition.
      (* Note the use of setoid rewriting *)
    - rewrite !app_length. cbn. lia.
  Qed.

  (* Direct proof also possible *)
  Fact mem_del_ex' {x A} :
    x el A -> exists A', A == x::A' /\ length A = S (length A').
  Proof.
    induction A as [|a A IH].
    - intros [].
    - intros [->|H].
      + exists A. split.
        * firstorder.
        * cbn. lia.
      + specialize (IH H) as (A'&IH1&IH2).
        exists (a::A'). split.
        * firstorder.
        * cbn. congruence.
  Qed.

  Fact mem_del_sig {x A} :
    x el A -> Sigma A', A == x::A' /\ length A = S (length A').
  Proof.
    intros (A1&A2&->) %mem_sig.
    exists (A1++A2). cbn. split.
    - split; intros z; cbn; rewrite !in_app_iff; cbn; intuition.
    (* Note the use of setoid rewriting *)
    - rewrite !app_length. cbn. lia.
  Qed.

  (* Direct proof also possible *)
  Fact mem_del_sig' {x A} :
    x el A -> Sigma A', A == x::A' /\ length A = S (length A').
  Proof.
    induction A as [|a A IH].
    - intros [].
    - intros [->|H] %mem_sum.
      + exists A. split.
        * firstorder.
        * cbn. lia.
      + specialize (IH H) as (A'&IH1&IH2).
        exists (a::A'). split.
        * firstorder.
        * cbn. congruence.
  Qed.

  (*** Non-Repeating Lists *)

  Fixpoint rep A : Prop :=
    match A with
    | [] => False
    | x::A => x el A \/ rep A
    end.

  Fixpoint nrep A : Prop :=
    match A with
    | [] => True
    | x::A => x nel A /\ nrep A
    end.

  Fact rep_nrep_False A :
    rep A -> nrep A -> False.
  Proof.
    induction A as [|x A IH]; cbn; tauto.
  Qed.

  Fact rep_plus_nrep A :
    rep A + nrep A.
  Proof.
    induction A as [|x A IH]; cbn.
    - auto.
    - destruct (mem_dec x A) as [H|H].
      + auto.
      + destruct IH as [IH|IH]; auto.
  Qed.

  Goal forall A, dec (rep A).
  Proof.
    intros A.
    generalize (rep_plus_nrep A), (rep_nrep_False A).
    unfold dec. tauto.
  Qed.

  Fact nrep_not_rep A :
    nrep A <-> ~rep A.
  Proof.
    generalize (rep_plus_nrep A), (rep_nrep_False A).
    tauto.
  Qed.

  Fact rep_not_nrep A :
    rep A <-> ~nrep A.
  Proof.
    generalize (rep_plus_nrep A), (rep_nrep_False A).
    tauto.
  Qed.

  Fact rep_sig A :
    rep A -> Sigma A1 x A2, A=A1++x::A2 /\ x el A2.
  Proof.
    induction A as [|x A IH].
    - intros [].
    - destruct (mem_dec x A) as [H|H].
      + intros _. exists [], x, A. easy.
      + intros H1.
        destruct IH as (A1&y&A2&IH1&IH2).
        * revert H H1. cbn. tauto.
        * subst A. exists (x::A1), y, A2. cbn. easy.
  Qed.

  Fact nrep_equiv :
    forall A, Sigma B, B == A /\ nrep B.
  Proof.
    induction A as [|x A (B&IH1&IH2)].
    - exists nil. cbn. auto using equi_refl.
    - destruct (mem_dec x A) as [H3|H3].
      + exists B. split. 2:exact IH2.
        split; intros z H.
        * cbn. right. apply IH1, H.
        * specialize H as [->|H]; apply IH1; assumption.
      + exists (x::B); cbn. split.
        * split; intros z [->|H]; cbn; auto; right; apply IH1, H.
        * split. 2: exact IH2. contradict H3. apply IH1, H3.
  Qed.

  Fact nrep_discriminate {A B} :
    nrep A -> length B < length A -> Sigma x, x el A /\ x nel B.
  Proof.
    induction A as [|a A IH] in B |-*; cbn.
    - lia.  (* computational falsity elimination *)
    - intros [H1 H2] H3.
      destruct (mem_dec a B) as [H|H].
      2: {exists a. auto. }
      destruct (mem_del_sig H) as (B'&H4&H5).
      destruct (IH B' H2 ltac:(lia)) as (x&H6&H7).
      exists x. split.
      + auto.
      + contradict H7. apply H4 in H7 as [->|H7]; easy.
  Qed.

  Fact nrep_le A B :
    nrep A -> A <<= B -> length A <= length B.
  Proof.
    intros H1 H2.
    enough (length B < length A -> False) by lia.
    intros H3.
    destruct (nrep_discriminate H1 H3) as (x&H4&H5).
    auto.
   Qed.

  Fact nrep_length A B :
    nrep A -> nrep B -> A == B -> length A = length B.
  Proof.
    intros H1 H2 [H3 H4].
    enough (length A <= length B <= length A) by lia.
    split; eapply nrep_le; eassumption.
  Qed.

  Fact rep_length_lt A B :
    A <<= B -> length B < length A -> rep A.
  Proof.
    intros H1 H2. apply rep_not_nrep. intros H3.
    enough (length A <= length B) by lia.
    apply nrep_le; assumption.
  Qed.

  Fact nrep_nrep A B :
    nrep A -> A <<= B -> length B <= length A -> nrep B.
  Proof.
    intros H1 H2 H3.
    apply nrep_not_rep.
    intros (B1&x&B2&->&H5)%rep_sig.
    assert (H6: length A <= length (B1 ++ B2)).
    {  apply nrep_le. exact H1.
       intros z [H6|[<-|H6]] %H2 %in_app_iff; apply in_app_iff; auto. }
     revert H3 H6. rewrite !app_length. cbn. lia.
  Qed.

  Fact nrep_incl A B :
    nrep A -> A <<= B -> length B <= length A -> B <<= A.
  Proof.
    intros H1 H2 H3 x H4.
    destruct (mem_dec x A) as [H5|H5]. exact H5. exfalso.
    destruct (@nrep_discriminate (x::A) B) as (z&H6&H7).
    - easy.
    - cbn; lia.
    - destruct H6 as [->|H6]; auto.
  Qed.

  (* Proof not using discreteness *)
  Fact nrep_le_con A B :
    nrep A -> A <<= B -> length A <= length B.
  Proof.
    (* Variant not using discreteness *)
    induction A as [|a A IH] in B |-*; cbn.
    - lia.
    - intros [H1 H2] H3.
      assert (a el B) as H by intuition.
      destruct (mem_del_ex H) as (B'&H4&H5).
      enough (length A <= length B') by lia.
      apply IH. exact H2. firstorder congruence.
   Qed.

  (*** Constructive Discrimination *)

  Fact nrep_discriminate_ex {A B} :
    XM -> nrep A -> length B < length A -> exists x, x el A /\ x nel B.
  Proof.
    intros xm.
    induction A as [|a A IH] in B |-*; cbn.
    - lia.
    - intros [H1 H2] H3.
      destruct (xm (a el B)) as [H|H].
      2: {exists a. auto. }
      destruct (mem_del_ex H) as (B'&H4&H5).
      destruct (IH B' H2 ltac:(lia)) as (x&H6&H7).
      exists x. split.
      + auto.
      + contradict H7. apply H4 in H7 as [->|H7]; easy.
  Qed.

  Fact nrep_discriminate_DN_ex {A B} :
    nrep A -> length B < length A -> ~ ~exists x, x el A /\ x nel B.
  Proof.
    induction A as [|a A IH] in B |-*; cbn.
    - lia.
    - intros [H1 H2] H3.
      apply (neg_xm (a el B)); intros H.
      2:{ apply neg_skip. exists a. auto. }
      destruct (mem_del_ex H) as (B'&H4&H5).
      specialize (IH B' H2 ltac:(lia)).
      revert IH. apply neg_skip'. intros (x&H6&H7).
      apply neg_skip. exists x. split.
      + auto.
      + contradict H7. apply H4 in H7 as [->|H7]; easy.
  Qed.

  (*** Coverings and Listings *)

  Definition covering A : Prop := forall x, x el A.
  Definition listing A : Prop := nrep A /\ covering A.

  Fact covering_listing A :
    covering A -> Sigma B: list X, listing B.
  Proof.
    intros H.
    destruct (nrep_equiv A) as (B&H1&H2).
    exists B. split. exact H2.
    intros x. apply H1, H.
  Qed.

  Fact listing_nrep A B :
    covering A -> nrep B -> length B <= length A.
  Proof.
    intros H1 H2. apply nrep_le. exact H2. intros x _. apply H1.
  Qed.

  Fact covering_nrep A B :
    covering A -> nrep B -> length A <= length B -> listing B.
  Proof.
    intros H1 H2 H3. split. exact H2.
    intros x. generalize (H1 x). revert x.
    eapply nrep_incl. exact H2. 2:exact H3.
    intros x _. apply H1.
  Qed.

  Fact listing_length_unique A B :
    listing A -> listing B -> length A = length B.
  Proof.
    intros H1 H2.
    apply nrep_length. {apply H1. } {apply H2. } split.
    - intros x _. apply H2.
    - intros x _. apply H1.
  Qed.

  (*** Cardinality *)

  Fixpoint card A : nat :=
    match A with
      [] => 0
    | x:: A' => if mem_dec x A' then card A' else S (card A')
    end.

  Fact card_sig :
    forall A, Sigma B, B == A /\ nrep B /\ length B = card A.
  Proof.
    induction A as [|x A (B&IH1&IH2&IH3)]; cbn.
    - exists []. cbv; auto.
    - destruct mem_dec as [H|H].
      + exists B.
        enough (B == x :: A) by auto.
        split; intros z H1.
        * right. apply IH1, H1.
        * apply IH1. destruct H1 as [->|H1]; assumption.
      + exists (x::B). cbn. split. 2:split.
        *  split; intros z [->|H1].
           -- cbn. auto.
           -- right. apply IH1, H1.
           -- cbn; auto.
           -- right. apply IH1, H1.
        * split. 2: exact IH2. contradict H. apply IH1, H.
        * lia.
  Qed.

  Fact  card_agree A n :
    card A = n <-> exists B, B == A /\ nrep B /\ length B = n.
  Proof.
    split.
    - intros <-.
      destruct (card_sig A) as (B&H). exists B. exact H.
    - intros (B&H1&H2&<-).
      destruct (card_sig A) as (C&H4&H5&<-).
      apply nrep_length. 1-2:assumption.
      eapply equi_trans. exact H4. apply equi_symm, H1.
  Qed.

  Fact card_length A :
    card A <= length A.
  Proof.
    destruct (card_sig A) as (A'&H1&H2&<-).
    apply nrep_le. exact H2. apply H1.
  Qed.

  Fact card_le A B :
    A <<= B -> card A <= card B.
  Proof.
    destruct (card_sig A) as (A'&H1&H2&<-).
    destruct (card_sig B) as (B'&H3&H4&<-).
    intros H5. eapply nrep_le. exact H2.
    intros z H6. apply H3, H5, H1, H6.
  Qed.

  Fact card_eq A B :
    A == B -> card A = card B.
  Proof.
    intros H.
    enough (card A <= card B /\ card B <= card A) by lia.
    split; apply card_le, H.
  Qed.

  Fact rep_card_length A :
    rep A <-> card A < length A.
  Proof.
    destruct (card_sig A) as (A'&H1&H2&<-).
    split.
    - intros H3.
      enough (length A <= length A' -> False) by lia. intros H4.
      eapply rep_not_nrep. exact H3.
      eapply nrep_nrep. exact H2. apply H1. exact H4.
    - apply rep_length_lt, H1.
  Qed.

  Fact nrep_card_length A :
    nrep A <-> card A = length A.
  Proof.
    (* Note the use of setoid rewriting *)
    rewrite nrep_not_rep, rep_card_length.
    generalize (card_length A). lia.
  Qed.

  Fixpoint Card A n : Prop :=
    match A, n with
    | nil, 0 => True
    | nil, S n' => False
    | x::A', 0 => False
    | x::A', S n' => if mem_dec x A' then Card A' (S n') else Card A' n'
    end.

  Fact Card_card A :
    Card A (card A).
  Proof.
    induction A as [|x A IH].
    - exact I.
    - cbn. destruct mem_dec as [H|H].
      + destruct A as [|y A].
        * destruct H.
        * exact IH.
      + exact IH.
  Qed.

  Fact Card_agree A n :
    Card A n <-> card A = n.
  Proof.
    split.
    - induction A as [|x A IH] in n |-*; destruct n; cbn.
      + auto.
      + intros [].
      + intros [].
      + destruct mem_dec as [H|H].
        * apply IH.
        * intros <-%IH. reflexivity.
    - intros <-.
      induction A as [|x A IH].
      + exact I.
      + cbn. destruct mem_dec as [H|H].
        * destruct A as [|y A].
          -- destruct H.
          -- exact IH.
        * exact IH.
    Qed.

  (*** Element Removal *)

  Fixpoint rem A x : list X :=
    match A with
      [] => []
    | y::A' => if X_eqdec y x then rem A' x else y::rem A' x
    end.

  Fact rem_el A x y :
    x el rem A y <-> x el A /\ x<> y.
  Proof.
    induction A as [|z A IH].
    - cbn. tauto.
    - cbn [rem].
      destruct (X_eqdec z y) as [<-|H]; cbn;
        intuition congruence.
  Qed.

  Fact rem_length_le A  x:
    length (rem A x) <= length A.
  Proof.
    induction A as [|y A IH]; cbn.
    - lia.
    - destruct X_eqdec as [<-|H1]; cbn; lia.
  Qed.

  Fact rem_length_lt x A :
    x el A -> length (rem A x) < length A.
  Proof.
    induction A as [|y A IH]; cbn.
    - intros [].
    - destruct X_eqdec as [->|H1].
      + generalize (rem_length_le A x). lia.
      + intros [->|H2]; cbn.
        * exfalso. easy.
        * apply IH in H2. lia.
  Qed.

  Fact rem_eq_nel A x :
    x nel A -> rem A x = A.
  Proof.
    induction A as [|y A IH]; cbn.
    - intros _. reflexivity.
    - destruct (X_eqdec y x) as [<-|H].
      + intros []. auto.
      + intros H1. f_equal. tauto.
  Qed.

  Fact rem_eq_cons x A :
    rem (x :: A) x = rem A x.
  Proof.
    cbn. destruct (X_eqdec x x) as [_|H]; tauto.
  Qed.

  Fact rem_eq_cons' x y A :
    x <> y -> rem (y::A) x = y::rem A x.
  Proof.
    cbn. destruct (X_eqdec y x) as [<-|H]; tauto.
  Qed.

  Fact card_rem_eq A x :
    x el A -> card A = S (card (rem A x)).
  Proof.
    intros H.
    replace (card A) with (card (x::(rem A x))).
    - cbn. destruct mem_dec as [H1|H1].
      + exfalso. apply rem_el in H1. apply H1. reflexivity.
      + reflexivity.
    - apply card_eq. split; intros z H1.
      + destruct H1 as [->|H1%rem_el]. exact H. apply H1.
      + cbn. destruct (X_eqdec x z) as [<-|H2].
        * auto.
        * right. apply rem_el. auto.
  Qed.

  (*** Sub and Pos *)

  Section SubPos.
  Variable X_escape: X.

  Fixpoint sub A n : X :=
    match A, n with
      [], _ => X_escape
    | x::A', 0 => x
    | x::A', S n' => sub A' n'
    end.

  Fixpoint pos A x : nat :=
    match A with
      [] => 0
    | y::A' => if X_eqdec y x then 0 else S (pos A' x)
    end.

  Fact sub_pos x A :
    x el A -> sub A (pos A x) = x.
  Proof.
    induction A as [|y A IH]; cbn.
    - intros [].
    - destruct X_eqdec as [<-|H]. easy.
      intros [->|H1]. easy. auto.
  Qed.

  Fact pos_bnd A x :
    x el A -> pos A x < length A.
  Proof.
    induction A as [|y A IH]; cbn.
    - intros [].
    - destruct X_eqdec as [->|H].
      + lia.
      + intros [->|H1].
        * easy.
        * apply IH in H1; lia.
  Qed.

  Fact sub_neq A n :
    n < length A -> sub A n el A.
  Proof.
    induction A as [|y A IH] in n |-*; cbn.
    - lia.
    - destruct n.
      + auto.
      + intros H. right. apply IH. lia.
  Qed.

  Fact pos_sub A n :
    nrep A -> n < length A -> pos A (sub A n) = n.
  Proof.
    induction A as [|y A IH] in n |-*.
    - cbn. lia.
    - intros [H1 H2] H3.
      destruct n as [|n]; cbn.
      { destruct X_eqdec as [_|H]. reflexivity. easy. }
      cbn in H3.
      destruct X_eqdec as [->|_].
      { contradict H1. apply sub_neq. lia. }
      f_equal. apply IH. exact H2. lia.
  Qed.
  End SubPos.

  (*** Disjointness *)

  Fixpoint disjoint A B : Prop :=
    match A with
      [] => True
    | x::A' => x nel B /\ disjoint A' B
    end.

  Goal forall A B, disjoint A B <-> ~ exists z, z el A /\ z el B.
  Proof.
    intros A B.
    induction A as [|x A IH]; cbn.
    - firstorder.
    - split.
      + intros [H1 H2] [z [H3 H4]].
        apply IH. exact H2. exists z. intuition congruence.
      + intros H. split.
        * eauto 6.
        * apply IH. intros (z&H1&H2). eauto.
  Qed.
End List.
Arguments mem_dec {X}.
Arguments mem_sum {X}.
Arguments nrep {X}.
Arguments rep {X}.

Definition injective {X Y} (f: X -> Y) :=
  forall x x', f x = f x' -> x = x'.

Fact nrep_map X Y (f: X -> Y) A :
  injective f -> nrep A -> nrep (map f A).
Proof.
  intros H1.
  induction A as [|x A IH]; cbn.
  - auto.
  - intros [H2 H3].
    split. 2:{ apply IH, H3. }
    intros (x'&H4&H5)%in_map_iff.
    apply H1 in H4 as ->.
    auto.
Qed.

Lemma nrep_injective X Y (f: X -> Y) x x' A :
  f x = f x' -> x el A -> x' el A ->  nrep (map f A) -> x = x'.
Proof.
  intros H1.
  induction A as [|a A IH]; cbn.
  - intros [].
  - intros [->|H3] [->|H4] [H5 H6].
    + reflexivity.
    + contradict H5. apply in_map_iff. exists x'. easy.
    + contradict H5. apply in_map_iff. exists x. easy.
    + auto.
Qed.

(*** Lists of Numbers *)

Fixpoint seq n k : list nat :=
  match k with
    0 => []
  | S k' => n :: seq (S n) k'
  end.

Fact seq_length n k :
  length (seq n k) = k.
Proof.
  induction k as [|k IH] in n |-*; cbn.
  - reflexivity.
  - f_equal. apply IH.
Qed.

Fact seq_in x n k :
  x el seq n k <-> n <= x < n + k.
Proof.
  induction k as [|k IH] in n |-*; cbn.
  - lia.
  - rewrite IH. lia.
Qed.

Fact seq_nrep n k :
  nrep (seq n k).
Proof.
  induction k as [|k IH] in n |-*; cbn.
  - exact I.
  - rewrite seq_in. split. lia. apply IH.
Qed.

Fact nat_list_le (A: list nat) n :
  (Sigma k, k el A /\ k >= n) + forall k, k el A -> k < n.
Proof.
  induction A as [|x A IH].
  - right. easy.
  - destruct (le_lt_dec n x) as [H|H].
    + left. exists x. cbn;auto.
    + destruct IH as [(k&H1&H2)|H1].
      * left. exists k. cbn. auto.
      * right. intros k [<-|H3]; auto.
Qed.

Fact nat_list_nrep (A: list nat) n :
  nrep A -> length A = S n -> Sigma k, k el A /\ k >= n.
Proof.
  intros H1 H2.
  destruct (nat_list_le A n) as [H|H]. exact H.
  exfalso. (* computational exfalso *)
  enough (length A <= n) by lia.
  rewrite <-(seq_length 0 n).
  apply nrep_le. exact nat_eqdec. exact H1.
  intros k H3. apply seq_in. apply H in H3. lia.
Qed.

(*** Exercises: List Reversal *)

Section Reversal.
  Variable X : Type.
  Implicit Types (x: X) (A B: list X).

  Fact rev_app A B :
    rev (A ++ B) = rev B ++ rev A.
  Proof.
    induction A as [|x A IH]; cbn.
    - symmetry. apply app_nil_r.
    - rewrite IH.  symmetry. apply app_assoc.
  Qed.

  Fact rev_rev A :
    rev (rev A) = A.
  Proof.
    induction A as [|x A IH]; cbn.
    - reflexivity.
    - rewrite rev_app, IH. reflexivity.
  Qed.

  Fact rev_in x A :
    x el A <-> x el rev A.
  Proof.
    induction A as [|y A IH]; cbn.
    - easy.
    - split.
      + intros [->|H]; apply in_or_app.
        * cbn. auto.
        * left. apply IH, H.
      + intros [H|H] %in_app_or.
        * right. apply IH, H.
        * left. destruct H; easy.
  Qed.

  Fact nrep_snoc A x :
    nrep A -> x nel A -> nrep (A ++ [x]).
  Proof.
    induction A as [|y A IH]; cbn.
    - easy.
    - intros [H1 H2] H3. split.
      + contradict H1.
        apply in_app_or in H1 as [H1|H1].
        * exact H1.
        * contradict H3. left. destruct H1; easy.
      + apply IH. exact H2. contradict H3. right. exact H3.
  Qed.

  Fact rev_nrep A :
    nrep A -> nrep (rev A).
  Proof.
    induction A as [|x A IH]; cbn.
    - reflexivity.
    - intros [H1 H2%IH]. apply nrep_snoc. exact H2.
      contradict H1. apply rev_in, H1.
  Qed.

  Fact list_rec_snoc (p: list X -> Type) :
    p [] ->
    (forall x A, p A -> p (A ++ [x])) ->
    forall A, p A.
  Proof.
    intros e1 e2.
    enough (forall A, p (rev A)) as H.
    { intros A. rewrite <-rev_rev. apply H. }
    induction A as [|x A IH].
    - exact e1.
    - apply e2, IH.
  Qed.

End Reversal.


(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Definitions      *
* Brian Aydemir & Arthur Charguéraud, March 2007                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.
Implicit Types X : var.

(* ********************************************************************** *)
(** * Description of the Language *)

(** Representation of pre-types *)

Inductive typ : Set :=
  | typ_top   : typ
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_all   : typ -> typ -> typ.

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_tabs : typ -> trm -> trm
  | trm_tapp : trm -> typ -> trm.

(** Opening up a type binder occuring in a type *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top         => typ_top
  | typ_bvar J      => If K = J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T1 T2   => typ_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

(** Opening up a type binder occuring in a term *)

Fixpoint open_te_rec (K : nat) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | trm_app e1 e2 => trm_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | trm_tabs V e1 => trm_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | trm_tapp e1 V => trm_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Definition open_te t U := open_te_rec 0 U t.

(** Opening up a term binder occuring in a term *)

Fixpoint open_ee_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs V (open_ee_rec (S k) f e1)
  | trm_app e1 e2 => trm_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | trm_tabs V e1 => trm_tabs V (open_ee_rec k f e1)
  | trm_tapp e1 V => trm_tapp (open_ee_rec k f e1) V
  end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "T 'open_tt_var' X" := (open_tt T (typ_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (open_te t (typ_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (open_ee t (trm_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (typ_all T1 T2).

(** Terms as locally closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_abs V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2)
  | term_tabs : forall L V e1,
      type V ->
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs V e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Binding are either mapping type or term variables.
 [X ~<: T] is a subtyping asumption and [x ~: T] is
 a typing assumption *)

Inductive bind : Set :=
  | bind_sub : typ -> bind
  | bind_typ : typ -> bind.

Notation "X ~<: T" := (X ~ bind_sub T)
  (at level 23, left associativity) : env_scope.
Notation "x ~: T" := (x ~ bind_typ T)
  (at level 23, left associativity) : env_scope.

(** Environment is an associative list of bindings. *)

Definition env := LibEnv.env bind.

(** Well-formedness of a pre-type T in an environment E:
  all the type variables of T must be bound via a
  subtyping relation in E. This predicates implies
  that T is a type *)

Inductive wft : env -> typ -> Prop :=
  | wft_top : forall E,
      wft E typ_top
  | wft_var : forall U E X,
      binds X (bind_sub U) E ->
      wft E (typ_fvar X)
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T1 T2,
      wft E T1 ->
      (forall X, X \notin L ->
        wft (E & X ~<: T1) (T2 open_tt_var X)) ->
      wft E (typ_all T1 T2).

(** A environment E is well-formed if it contains no duplicate bindings
  and if each type in it is well-formed with respect to the environment
  it is pushed on to. *)

Inductive okt : env -> Prop :=
  | okt_empty :
      okt empty
  | okt_sub : forall E X T,
      okt E -> wft E T -> X # E -> okt (E & X ~<: T)
  | okt_typ : forall E x T,
      okt E -> wft E T -> x # E -> okt (E & x ~: T).

(** Subtyping relation *)

Inductive sub : env -> typ -> typ -> Prop :=
  | sub_top : forall E S,
      okt E ->
      wft E S ->
      sub E S typ_top
  | sub_refl_tvar : forall E X,
      okt E ->
      wft E (typ_fvar X) ->
      sub E (typ_fvar X) (typ_fvar X)
  | sub_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      sub E U T ->
      sub E (typ_fvar X) T
  | sub_arrow : forall E S1 S2 T1 T2,
      sub E T1 S1 ->
      sub E S2 T2 ->
      sub E (typ_arrow S1 S2) (typ_arrow T1 T2)
  | sub_all : forall L E S1 S2 T1 T2,
      sub E T1 S1 ->
      (forall X, X \notin L ->
          sub (E & X ~<: T1) (S2 open_tt_var X) (T2 open_tt_var X)) ->
      sub E (typ_all S1 S2) (typ_all T1 T2).

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_tabs : forall L E V e1 T1,
      (forall X, X \notin L ->
        typing (E & X ~<: V) (e1 open_te_var X) (T1 open_tt_var X)) ->
      typing E (trm_tabs V e1) (typ_all V T1)
  | typing_tapp : forall T1 E e1 T T2,
      typing E e1 (typ_all T1 T2) ->
      sub E T T1 ->
      typing E (trm_tapp e1 T) (open_tt T2 T)
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T.

(** Values *)

Inductive value : trm -> Prop :=
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1)
  | value_tabs : forall V e1, term (trm_tabs V e1) ->
                 value (trm_tabs V e1).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (trm_tapp e1 V) (trm_tapp e1' V)
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_ee e1 v2)
  | red_tabs : forall V1 e1 V2,
      term (trm_tabs V1 e1) ->
      type V2 ->
      red (trm_tapp (trm_tabs V1 e1) V2) (open_te e1 V2).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E e e' T,
  typing E e T ->
  red e e' ->
  typing E e' T.

Definition progress := forall e T,
  typing empty e T ->
     value e
  \/ exists e', red e e'.


(*|
#######################################################################################################
How to prove non-equality of terms produced by two different constructors of the same inductive in Coq?
#######################################################################################################

:Link: https://stackoverflow.com/q/60616748
|*)

(*|
Question
********

Consider I have an inductive:
|*)

Inductive DirectSum {L R: Type}: Type :=
| Left: L -> @DirectSum L R
| Right: R -> @DirectSum L R.

(*| How do I prove that |*)

Goal forall L R: Type, forall l: L, forall r: R, Left L <> Right R.

(*| ? |*)

(*|
Answer
******

The ``easy`` tactic is powerful enough to solve this:
|*)

Reset Initial. (* .none *)
Inductive DirectSum (L R: Type): Type :=
| Left: L -> DirectSum L R
| Right: R -> DirectSum L R.

Arguments Left {_ _}.
Arguments Right {_ _}.

Goal forall L R: Type, forall l: L, forall r: R, Left l <> Right r.
  easy.
Qed.

(*|
The reason this works, internally, is pattern matching. We can write a
function that returns ``True`` on ``Left`` and ``False`` on ``Right``.
If the terms were equal, we would get ``True = False``, which entails
a contradiction.
|*)