(* Author: Masaki Hara, 2014 *)
(* Linear Logic Toy for Coq *)
Require Import LWeight LType_base LGoal.

(*************************************************)
(*         Linear Universal Quantification       *)
(*************************************************)

Record LForallVal{E:LEnv} {T:Type} (A:T -> LType) := {
  lforallval : forall t : T, ltype (A t);
  lforallval_weight : LWeight;
  lforallval_weight_eqn t : lweight (lforallval t) = lforallval_weight
}.
Arguments LForallVal [E] [T] A%LL.
Arguments lforallval [E] [T] [A] _ _.
Arguments lforallval_weight [E] [T] [A] _.
Arguments lforallval_weight_eqn [E] [T] [A] _ _.
Coercion lforallval : LForallVal >-> Funclass.

Definition LForall{E:LEnv} {T:Type} (A:T -> LType) : LType := {|
  ltype := LForallVal A;
  lweight := @lforallval_weight _ _ _
|}.
Notation "'lforall' x .. y , p"
    := (LForall (fun x => .. (LForall (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'lforall'  '/  ' x  ..  y ,  '/  ' p ']'")
  : LL_scope.

Instance LForall_weight_delegate{E:LEnv} {T:Type} (A:T->LType)
    (f : ltype (LForall A)) (t : T)
    : LWeightCastSelf (lweight (f t)) (lweight f).
Proof.
  rewrite lforallval_weight_eqn.
  exists; reflexivity.
Defined.

Definition LForallIntroduction{E:LEnv} {T:Type} (A:T -> LType) {W:LWeight}
    : (forall t, LGoal (A t) W) -> LGoal (LForall A) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lforallval t := H0 t;
      lforallval_weight := W
    |} : ltype (LForall A)
  |}.
Grab Existential Variables.
  intros t; simpl.
  refine (lweight_eqn _).
Defined.

Definition LForallSpecialization{E:LEnv} {T:Type} {A:T -> LType} {B:LType}
    {W:LWeight} (t:T)
    : LGoal (A t -o B) W -> LGoal (LForall A -o B) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(a:ltype (LForall A)) =>
        lgoal_proof H0 (lforallval a t);
      lfun_weight := W
    |} : ltype (LForall A -o B)
  |}.
Grab Existential Variables.
  intros x; simpl; refine (lweight_eqn _).
Defined.

Instance lgoal_autoapply_forall{E:LEnv} {T:Type} {A:T->LType} {B:LType}
  {n:nat} {l:list (nat * LWeight)} {W:LWeight}
  {f:ltype (LForall A)}
  {Impls:list Type}
  {t:T}
  {H: LHintedApp n l Impls (LGoal B (W + lweight (f t))%LWeight)}
  : LHintedApp n l Impls (LGoal B (W + lweight f)%LWeight).
Proof.
  exists.
  destruct H as [H].
  revert H; apply implication_list_map; intros H.
  refine {|
    lgoal_proof := lgoal_proof H
  |}.
Defined.

Local Ltac introll_base x ::=
  introll_base_limpl x ||
  (apply LForallIntroduction; intros x) ||
  fail "Linear Introduction Failed".
Tactic Notation "specializell" "(" constr(x) constr(t) ")" :=
  revertll x; apply (LForallSpecialization t); introll x.

Local Open Scope LL_goal_scope.
Example LForallComm{E:LEnv} {S T:Type} (A:S -> T -> LType) :
  (ILL |- (lforall s t, A s t) -o (lforall t s, A s t)).
Proof.
  introsll x t s.
  (* specializell (x s). *)
  (* specializell (x t). *)
  applyll x.
Defined.
Local Close Scope LL_goal_scope.


Require Import all_ssreflect all_algebra presburger.
Require Extraction.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Load "../extraction_common_dffun.v".

Extraction Inline fst snd.

(* range *)

Extraction Inline
  range_eqType range_eqMixin range_subType range_choiceType range_countType
  range_finType range_finMixin.

(* automata *)

Extraction Inline
  automata.dfa_state automata.dfa_s automata.dfa_fin automata.dfa_trans
  automata.dfa_lang
  automata.nfa_state automata.nfa_s automata.nfa_fin automata.nfa_trans
  automata.nfa_to_dfa automata.dfa_compl automata.dfa_op
  leq_dfa eq_dfa nfa_of_exists.

(* Avoid extractor bugs: type mismatch, assertion failure, etc. *)

Extract Constant SetDef.pred_of_set =>
  "(Obj.magic (fun t a x -> tnth a (t.Finite.mixin.Finite.mixin_enc x)))".

(* matrix *)

Definition matrix_mult_test (n : nat) :=
  let mx := (\matrix_(i < n, j < n) (i%:Z + j%:Z))%R in
  (mx *m mx)%R.

Definition finfun_app_test (n : nat) :=
  let f := [ffun i : 'I_n => i] in
  \sum_i f i.

(******************************************************************************)

Extraction Language Ocaml.
Set Extraction Flag 8175.

Extraction "../../ocaml/matrix_after.ml" matrix_mult_test finfun_app_test.

Extraction "../../ocaml/presburger_after.ml"
           bool_finType finfun_finType exp_finIndexType f_divisible
           presburger_dec presburger_st_dec presburger_sat presburger_valid.


Require Import
  TList
  Lib
  Ltac
  Ty
  Exp
  Value
  Ren
  Sub
  Sem.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

(** Evaluation contexts *)

Section Step.

Import ListNotations.

Context {A : Type}.
Context `{HostExprs A}.

Open Scope Ty_scope.

Unset Elimination Schemes.

Inductive Redex {Γ} : ∀ {τ}, Exp Γ τ → Exp Γ τ → Prop :=
  | R_Beta {dom cod} (e : Exp (dom :: Γ) cod) v :
    ValueP v →
    Redex (APP (LAM e) v) (SubExp {|| v ||} e).

Derive Signature for Redex.

Scheme Redex_ind := Induction for Redex Sort Prop.

(* A context defines a hole which, after substitution, yields an expression of
   the index type. *)
Inductive Ctxt1 Γ : ∀ {τ τ'}, (Exp Γ τ' → Exp Γ τ) → Prop :=
  | C_AppL {dom cod} (x : Exp Γ dom) :
    Ctxt1 Γ (λ f : Exp Γ (dom ⟶ cod), APP f x)
  | C_AppR {dom cod} (f : Exp Γ (dom ⟶ cod)) :
    Ctxt1 Γ (λ x : Exp Γ dom, APP f x).

Derive Signature for Ctxt1.

Scheme Ctxt1_ind := Induction for Ctxt1 Sort Prop.

Arguments C_AppL {_ _ _} x.
Arguments C_AppR {_ _ _} f.

Inductive Ctxt Γ : nat → ∀ {τ τ'}, (Exp Γ τ' → Exp Γ τ) → Prop :=
  | Ctxt_nil {τ} : Ctxt Γ 0 (λ x : Exp Γ τ, x)
  | Ctxt_cons {n τ τ' τ''} {f : Exp Γ τ' → Exp Γ τ} {g : Exp Γ τ'' → Exp Γ τ'} :
    Ctxt1 Γ f → Ctxt Γ n g → Ctxt Γ (S n) (f ∘ g).

Derive Signature for Ctxt.

Scheme Ctxt_ind := Induction for Ctxt Sort Prop.

Arguments Ctxt_nil {_ _}.
Arguments Ctxt_cons {_ _ _ _ _ _ _} _ _.

Notation "⦉ e ; .. ; f ⦊" := (Ctxt_cons e .. (Ctxt_cons f Ctxt_nil) ..).

Notation "x ∷ xs" := (Ctxt_cons x xs) (at level 70).

(* [Ctxt] forms a category with objects = types and morphisms = contexts. *)

Definition Ctxt_id {Γ τ} : Ctxt Γ 0 id := @Ctxt_nil Γ τ.
Arguments Ctxt_id {Γ τ} /.

Equations Ctxt_comp {Γ τ τ' τ'' n m}
          {f : Exp Γ τ' → Exp Γ τ}
          {g : Exp Γ τ'' → Exp Γ τ'}
          (Cf : Ctxt Γ n f) (Cg : Ctxt Γ m g) : Ctxt Γ (n + m) (f ∘ g) :=
  Ctxt_comp Ctxt_nil gs := gs;
  Ctxt_comp (f ∷ fs) gs := f ∷ Ctxt_comp fs gs.

Theorem Ctxt_id_left {Γ τ τ' n} {f : Exp Γ τ' → Exp Γ τ} {C : Ctxt Γ n f} :
  Ctxt_comp Ctxt_id C = C.
Proof.
  simpl.
  pose proof (Ctxt_comp_equation_1 _ _ _ _ f C).
  unfold compose in H0.
  now apply H0.
Qed.

Theorem Ctxt_id_right {Γ τ τ' n} {f : Exp Γ τ' → Exp Γ τ} {C : Ctxt Γ n f} :
  Ctxt_comp C Ctxt_id ~= C.
Proof.
  simpl.
  dependent induction C; simp Ctxt_comp; auto.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ n 0 _ _ _ _ c C Ctxt_id).
  simpl in *.
  unfold compose in H0.
  rewrite H0; clear H0.
Abort.

Theorem Ctxt_comp_assoc {Γ τ τ' τ'' τ''' n m o}
        {f : Exp Γ τ' → Exp Γ τ}
        {g : Exp Γ τ'' → Exp Γ τ'}
        {h : Exp Γ τ''' → Exp Γ τ''}
        (Cf : Ctxt Γ n f) (Cg : Ctxt Γ m g) (Ch : Ctxt Γ o h) :
  Ctxt_comp Cf (Ctxt_comp Cg Ch) ~= Ctxt_comp (Ctxt_comp Cf Cg) Ch.
Proof.
  simpl.
  dependent induction Cf; simp Ctxt_comp; auto.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ n _ _ _ _ _ c Cf (Ctxt_comp Cg Ch)).
  simpl in *.
  rewrite H0; clear H0.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ n _ _ _ _ _ c Cf Cg).
  simpl in *.
  rewrite H0; clear H0.
  pose proof (Ctxt_comp_equation_2 Γ _ _ _ _ _ _ _ _ _ c (Ctxt_comp Cf Cg) Ch).
  simpl in *.
  rewrite H0; clear H0.
  Fail rewrite PeanoNat.Nat.add_assoc.
  Fail rewrite IHCf.
Abort.

(*
Equations Plug {Γ τ' τ} (e : Exp Γ τ') (c : Ctxt Γ τ' τ) : Exp Γ τ :=
  Plug e (C_Hole _ _)      := e;
  Plug e (C_App1 _ _ C e1) := APP (Plug e C) e1;
  Plug e (C_App2 _ _ e1 C) := APP e1 (Plug e C).
*)

(*
Unset Elimination Schemes.

Inductive Plug {Γ τ'} (e : Exp Γ τ') : ∀ {τ}, Ctxt Γ τ' τ → Exp Γ τ → Prop :=
  | Plug_Hole : Plug e (C_Hole _ _) e

  (* | Plug_If1 {Γ τ} (C : Ctxt Γ TyBool) (e e' : Exp Γ TyBool) (e1 e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If1 _ C e1 e2) e (If e' e1 e2) *)
  (* | Plug_If2 {Γ τ} (C : Ctxt Γ τ) (e e' : Exp Γ τ) e1 (e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If2 _ e1 C e2) e (If e1 e' e2) *)
  (* | Plug_If3 {Γ τ} (C : Ctxt Γ τ) (e e' : Exp Γ τ) e1 (e2 : Exp Γ τ) : *)
  (*   Plug C e e' → Plug (C_If3 _ e1 e2 C) e (If e1 e2 e') *)

  | Plug_App1 {dom cod} {C : Ctxt Γ τ' (dom ⟶ cod)}
              {e' : Exp Γ (dom ⟶ cod)} {e1 : Exp Γ dom} :
    Plug e C e' →
    Plug e (C_App1 _ _ C e1) (APP e' e1)
  | Plug_App2 {dom cod} {C : Ctxt Γ τ' dom}
              {e' : Exp Γ dom} {e1 : Exp Γ (dom ⟶ cod)} :
    ValueP e1 →
    Plug e C e' →
    Plug e (C_App2 _ _ e1 C) (APP e1 e').

Derive Signature for Plug.

Set Elimination Schemes.

Scheme Plug_ind := Induction for Plug Sort Prop.

(* [Plug] forms a category with objects = expressions and morphisms = plugs
   over existential contexts. *)

Definition Plug_id {Γ τ} {x : Exp Γ τ} : Plug x (C_Hole Γ τ) x := Plug_Hole _.
Arguments Plug_id {_ _ _} /.

Equations Plug_comp {Γ τ τ' τ''}
          {x : Exp Γ τ''} {y : Exp Γ τ'} {z : Exp Γ τ}
          {C : Ctxt Γ τ' τ} {C' : Ctxt Γ τ'' τ'}
          (P : Plug x C' y) (P' : Plug y C z) : Plug x (Ctxt_comp C C') z :=
  Plug_comp p (Plug_Hole _)    := p;
  Plug_comp p (Plug_App1 _ p')   := Plug_App1 _ (Plug_comp p p');
  Plug_comp p (Plug_App2 _ H p') := Plug_App2 _ H (Plug_comp p p').

(* This should be provable, but the dependent types get in the way. *)
Theorem Plug_id_left {Γ τ τ'} {C : Ctxt Γ τ' τ} {x : Exp Γ τ'} {y : Exp Γ τ}
        (P : Plug x C y) :
  Plug_comp Plug_id P ~= P.
Proof.
  dependent induction P; auto.
  - rewrite (Plug_comp_equation_2 _ _ _ _ _ _ _ _ _ _ _ Plug_id P).
    unfold Ctxt_comp_obligations_obligation_1.
    pose proof (@Ctxt_id_right _ _ _ C).
    simpl in *.
    Fail rewrite H0 in IHP.
    Fail now rewrite IHP.
Abort.
(*
  - rewrite (Plug_comp_equation_3 _ _ _ _ _ _ _ _ _ _ _ Plug_id _ P).
    pose proof (@Ctxt_id_right _ _ _ C).
    simpl in *.
    Fail now rewrite IHP.
*)
*)

Reserved Notation " t '--->' t' " (at level 40).

Inductive Step {Γ τ} : Exp Γ τ → Exp Γ τ → Prop :=
  | StepRule {n τ' C} {e1 e2 : Exp Γ τ'} :
    Ctxt Γ n C →
    Redex e1 e2 →
    C e1 ---> C e2

  | StepError {n τ'} {C : Exp Γ τ' → Exp Γ τ} {m : Err} :
    Ctxt Γ (S n) C →
    C (Error m) ---> Error m

  where " t '--->' t' " := (Step t t').

Derive Signature for Step.

(* #[local] Hint Constructors ValueP Plug Redex Step : core. *)
#[local] Hint Constructors ValueP Redex Ctxt1 Ctxt Step : core.

Ltac step :=
  first [ now eapply (StepRule Ctxt_nil); eauto
        | now eapply (StepError Ctxt_nil); eauto
        | now eapply (StepRule ⦉ C_AppL _ ⦊); eauto
        | now eapply (StepError ⦉ C_AppL _ ⦊); eauto
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepRule (C_AppL _ ∷ H)); eauto
              end
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepError (C_AppL _ ∷ H)); eauto
              end
        | now eapply (StepRule ⦉ C_AppR _ ⦊); eauto
        | now eapply (StepError ⦉ C_AppR _ ⦊); eauto
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepRule (C_AppR _ ∷ H)); eauto
              end
        | now match goal with
              | [ H : Ctxt [] _ _ |- _ ] =>
                  eapply (StepError (C_AppR _ ∷ H)); eauto
              end ].

Theorem strong_progress {τ} (e : Exp [] τ) :
  ValueP e ∨ ErrorP e ∨ ∃ e', e ---> e'.
Proof.
  dependent induction e.
  - now right; left.
  - now inv v.
  - now left; constructor.
  - reduce.
    right; right.
    destruct IHe1 as [V1|[E1|[e1' H1']]];
    destruct IHe2 as [V2|[E2|[e2' H2']]].
    + dependent elimination V1.
      now eexists; step.
    + dependent elimination V1.
      dependent elimination E2.
      now eexists; step.
    + dependent elimination H2'.
      * now eexists; step.
      * now eexists; step.
    + dependent elimination V2.
      dependent elimination E1.
      now eexists; step.
    + dependent elimination E1.
      now eexists; step.
    + dependent elimination E1.
      now eexists; step.
    + dependent elimination H1'.
      * now eexists; step.
      * now eexists; step.
    + dependent elimination H1'.
      * now eexists; step.
      * now eexists; step.
    + dependent elimination H1'.
      * dependent elimination H2'.
        ** now eexists; step.
        ** now eexists; step.
      * now eexists; step.
Qed.

Lemma Redex_ValueP {Γ τ} (e v : Exp Γ τ) :
  ValueP v → ¬ Redex v e.
Proof.
  repeat intro.
  dependent elimination H0.
  now inv H1.
Qed.

Lemma Plug_deterministic {Γ τ} :
  ∀  τ' n {Ce : Exp Γ τ' → Exp Γ τ} e1 e1',
    Ctxt Γ n Ce →
    Redex e1 e1' →
  ∀ τ'' m {Cf : Exp Γ τ'' → Exp Γ τ} f1 f1',
    Ctxt Γ m Cf →
    Redex f1 f1' →

    Ce e1 = Cf f1 →
      τ' = τ'' ∧ Ce ~= Cf ∧ e1 ~= f1.
Proof.
  intros.
  generalize dependent Cf.
  dependent induction H1; intros; subst.
  inv H3; auto.
  - exfalso.
    dependent elimination H0.
    dependent elimination H2.
    now inv H6.
  - exfalso.
    dependent elimination H0.
    dependent elimination H1.
    now inv H7.
  - dependent elimination H3.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv H2.
    + intuition.
      now destruct (IHPlug _ p); reduce.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv H2.
  - dependent elimination H3.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv H2.
    + exfalso.
      dependent elimination H0.
      dependent elimination H1.
      now inv p.
    + intuition.
      now destruct (IHPlug _ p0); reduce.
Qed.

Lemma Plug_functional {Γ τ τ'} {C : Ctxt Γ τ' τ} e e1 :
  Plug e C e1
    → ∀ e2, Plug e C e2 → e1 = e2.
Proof.
  intros.
  dependent induction H0.
  - now inv H1.
  - dependent destruction H1.
    now f_equal; auto.
  - dependent destruction H1.
    now f_equal; auto.
Qed.
*)

Theorem Ctxt1_injective {Γ τ τ'} {C : Exp Γ τ' → Exp Γ τ} {e1 e2 : Exp Γ τ'} :
  Ctxt1 Γ C →
  C e1 = C e2 → e1 = e2.
Proof.
  intros.
  generalize dependent e2.
  generalize dependent e1.
  induction H0; simpl; intros; auto.
  - now inv H1.
  - now inv H1.
Qed.

Theorem Ctxt_injective {Γ τ τ' n} {C : Exp Γ τ' → Exp Γ τ} {e1 e2 : Exp Γ τ'} :
  Ctxt Γ n C →
  C e1 = C e2 → e1 = e2.
Proof.
  intros.
  generalize dependent e2.
  generalize dependent e1.
  induction H0; simpl; intros; auto.
  now eapply Ctxt1_injective in c; eauto.
Qed.

Lemma Redex_deterministic : ∀ Γ τ (e e' : Exp Γ τ),
  Redex e e' → ∀ e'', Redex e e'' → e' = e''.
Proof.
  intros.
  dependent elimination H0.
  dependent elimination H1.
  reflexivity.
Qed.

Lemma App_Lam_loop {Γ τ ty} {v : Exp Γ ty} {e : Exp (ty :: Γ) τ} :
  ¬ (SubExp {||v||} e = APP (LAM e) v).
Admitted.
(*
Proof.
  dependent induction e; repeat intro; inv H.
  - dependent induction v0; simp consSub in *.
    + simp SubVar in H1.
  (*     now induction v; inv H1; intuition. *)
  (*   + simp SubVar in H1. *)
  (*     rewrite SubVar_idSub in H1. *)
  (*     now induction v0; inv H1; intuition. *)
Admitted.
*)

(*
Lemma If_loop_true {Γ τ} b {x : Exp Γ τ} {y : Exp Γ τ} :
  ¬ (If b x y = x).
Proof.
  induction x; intro; inv H.
  now eapply IHx2; eauto.
Qed.

Lemma If_loop_false {Γ τ} b {x : Exp Γ τ} {y : Exp Γ τ} :
  ¬ (If b x y = y).
Proof.
  induction y; intro; inv H.
  now eapply IHy3; eauto.
Qed.

Lemma Seq_loop {Γ τ ty} {x : Exp Γ ty} {y : Exp Γ τ} :
  ¬ (Seq x y = y).
Proof.
  induction y; intro; inv H.
  now eapply IHy2; eauto.
Qed.
*)

(* A term never reduces to itself. *)
#[export]
Program Instance Step_Irreflexive {Γ τ} :
  Irreflexive (Step (Γ:=Γ) (τ:=τ)).
Next Obligation.
  dependent induction H0.
  - eapply Ctxt_injective in H0; eauto; subst.
    dependent destruction H1.
    now eapply App_Lam_loop; eauto.
  - inv H0.
    inv H3;
    now inv x.
Qed.

Corollary Step_productive {Γ τ} {x x' : Exp Γ τ} : x ---> x' → x ≠ x'.
Proof.
  repeat intro; subst.
  now eapply Step_Irreflexive; eauto.
Qed.

#[export]
Program Instance RenExp_Step {Γ Γ' τ} (σ : Ren Γ' Γ) :
  Proper (Step (Γ:=Γ) (τ:=τ) ==> Step) (RenExp σ).
Next Obligation.
  dependent elimination H0; simpl.
  - dependent induction r;
    induction c; simpl.
    + rewrite <- SubExp_ScR.
      simp ScR.
      rewrite <- RcS_idSub.
      pose proof (SubExp_RcS (Keep σ) (Push (RenExp σ v) idSub) e) as H1.
      simp RcS in H1.
      rewrite H1.
      apply (StepRule Ctxt_nil).
      repeat econstructor.
      now apply RenExp_ValueP.
    + specialize (IHc e).
      admit.
  - inv c0.
    admit.
Admitted.

#[export]
Program Instance SubExp_Step {Γ Γ' τ} (σ : Sub Γ' Γ) :
  Proper (Step (Γ:=Γ) (τ:=τ) ==> Step) (SubExp σ).
Next Obligation.
  intros.
Admitted.
(*
  induction H; simpl;
  try solve [ now constructor; intuition idtac
            | now constructor; intuition; apply SubExp_ValueP ].
  (* - now apply Reduce_preserves_substitution. *)
  (* - now apply CallHost_preserves_substitution. *)
  - rewrite <- SubExp_ScS.
    simpl ScS.
    rewrite ScS_idSub_left.
    pose proof (SubExp_ScS (Keepₛ σ) (Push (SubExp σ v) idSub) e) as H1.
    simpl in H1.
    simp SubVar in H1.
    unfold Dropₛ in H1.
    rewrite ScS_ScR in H1.
    rewrite RcS_skip1 in H1.
    rewrite ScS_idSub_right in H1.
    rewrite H1.
    constructor.
    now apply SubExp_ValueP.
Qed.
*)

Lemma pluggable {Γ τ τ' n} {e e' : Exp Γ τ'} {C : Exp Γ τ' → Exp Γ τ} :
  ¬ ErrorP e' →
  e ---> e' →
  Ctxt Γ n C →
  C e ---> C e'.
Proof.
  intros.
  dependent elimination H1.
  - exact (StepRule (Ctxt_comp H2 c) r).
  - exfalso.
    now apply H0.
Qed.

Lemma APP_LAM_R {Γ dom cod} {f : Exp Γ (dom ⟶ cod)} {x x' : Exp Γ dom} :
  ¬ ErrorP x' →
  x ---> x' →
  APP f x ---> APP f x'.
Proof.
  intros.
  now eapply (pluggable H0 H1 ⦉ C_AppR _ ⦊); eauto.
Qed.

End Step.

Arguments C_AppL [A]%type_scope [H Γ] [dom]%Ty_scope [cod]%Ty_scope x.
Arguments C_AppR : default implicits.

Arguments Ctxt_nil {A}%type_scope {H Γ} {τ}%Ty_scope.
Arguments Ctxt_cons : default implicits.

Notation "⦉ e ; .. ; f ⦊" := (Ctxt_cons e .. (Ctxt_cons f Ctxt_nil) ..).

Notation "x ∷ xs" := (Ctxt_cons x xs) (at level 70).

Notation " t '--->' t' " := (Step t t') (at level 40).


Require Import Utf8.
Require Import Coq.Program.Equality.

(** printing Γ %\ensuremath{\Gamma}% #Γ# *)
(** printing Γ' %\ensuremath{\Gamma}% #Γ'# *)
(** printing Γ'' %\ensuremath{\Gamma}% #Γ''# *)
(** printing τ %\ensuremath{\tau}% #τ# *)
(** printing σ %\ensuremath{\sigma}% #σ# *)
(** printing ⊓ %\ensuremath{\sqcap}% #∩# *)
(** printing ⋂ %\ensuremath{\bigcap}% #∩# *)

(** * DSL Primitives
   Heaps, refined references, stability, etc. *)

Axiom heap : Set.
Definition hpred (A:Set) := A -> heap -> Prop.
Definition hrel (A:Set) := A -> A -> heap -> heap -> Prop.
Definition subhrel {A} (G R:hrel A) := forall x x' h h', G x x' h h' -> R x x' h h'.
Definition hreflexive {A}(R:hrel A) := forall x h, R x x h h.

(** Predicate and Relation Combinators *)
Definition pred_and {A:Set} (P:hpred A) (Q:hpred A) : hpred A :=
  fun a => fun h =>
    P a h /\ Q a h.
Infix "⊓" := (pred_and) (at level 40).

Definition pred_or {A:Set} (P Q:hpred A) : hpred A :=
  fun a => fun h => P a h \/ Q a h.
Infix "⊔" := (pred_or) (at level 41).

Definition rel_and {A:Set} (R:hrel A) (S:hrel A) : hrel A :=
  fun a a' h h' =>
    R a a' h h' /\ S a a' h h'.
Infix "⋂" := (rel_and) (at level 40).

Definition rel_or {A:Set} (R S:hrel A) : hrel A :=
  fun a a' h h' => R a a' h h' \/ S a a' h h'.
Infix "⋃" := (rel_or) (at level 41).

Definition rel_sub_eq {A:Set} (R S:hrel A) : Prop :=
  forall a a' h h', R a a' h h' -> S a a' h h'.
Infix "⊆" := (rel_sub_eq) (at level 45).

Definition stable {A} (P:hpred A) (R:hrel A) :=
  forall x x' h h', P x h -> R x x' h h' -> P x' h'.

(** * References
    ref must be defined completely, otherwise Coq's positivity checks are extremely conservative *)
Inductive ref (A:Set) (P:hpred A) (R G:hrel A) : Set :=
  | ref_placeholder : nat -> ref A P R G.
(*  mkref {ptr:nat}.*)
Notation "ref{ τ | P }[ R , G ]" := (ref τ P R G) (at level 80).
Axiom ref_stable : forall {A P R G}(r:ref{A|P}[R,G]), stable P R.
(* TODO: Nuke this? if alloc only creates stable refs, then this is okay, though awkward. *)
Hint Resolve @ref_stable.

(** ** Heap interaction primitives
    Including reachability, containment, precision, and relation folding *)

Axiom heap_write : forall {A P R G} (p:ref A P R G) (v:A) (h:heap), heap.
Axiom heap_alloc : forall (A:Set) (a:A) (P:hpred A) (R G:hrel A), heap -> (ref A P R G * heap).
(** heap_deref doesn't need to fold types because it's entirely propositional; "inside the heap" if you will,
    and does not actually affect execution *)
Axiom heap_deref : forall {A P R G} (h:heap), ref{A|P}[R,G] -> A.
Notation "h [ r ]" := (heap_deref h r) (at level 40).
Axiom heap_lookup2 : forall {A P R G} (h:heap) (r:ref{A|P}[R,G]), P (h[r]) h.
(** Some concepts require a parameter-polymorphic reference equality. *)
Axiom ptr_eq : forall {A A' P P' R R' G G'}, ref A P R G -> ref A' P' R' G' -> Prop.
Infix "≡" := (ptr_eq) (at level 80).

Axiom type_based_nonaliasing : forall h τ σ P R G Q R' G' `(a:ref{τ|P}[R,G]) `(b:ref{σ|Q}[R',G']) v, τ<>σ ->
  (heap_write a v h)[b] = h[b].

(** ** Reachability
    We need to define what is reachable from a given type in order to define precise prediates and relations. *)
Class ImmediateReachability (A:Set) := {
  imm_reachable_from_in : forall {T:Set}{P R G} (p:ref{T|P}[R,G]) (a:A), Prop
}.
Global Instance ref_reach `{A:Set,P:hpred A,R:hrel A,G:hrel A}: ImmediateReachability (ref{A|P}[R,G]) :=
  { imm_reachable_from_in := fun T P' R' G' dst src => src≡dst}.
(** This is the reachability definition used globally.  Each structure must define a trusted
    ImmediateReachability instance to find pointers in a local structure.
    This relation adds the transitive and reflexive parts of reachability.
    This setup allows us to implement reference immutability generically over any
    type with an ImmediateReachability instance, and prove it precise without
    needing details about an unknown type's internal structure *)
Inductive reachable_from_in : forall {A:Set} {IRA:ImmediateReachability A}{T:Set}{P R G} (p:ref{T|P}[R,G]) (a:A) (h:heap), Prop :=
  | reflexively_reachable : forall (T:Set) P R G (r:ref{T|P}[R,G]) h, reachable_from_in r r h
  | directly_reachable : forall (U:Set) {IRU:ImmediateReachability U} {T:Set}{P R G}(p:ref{T|P}[R,G]) u h,
                           imm_reachable_from_in p u -> reachable_from_in p u h
  | trans_reachable : forall (A:Set){IRA:ImmediateReachability A} (a:A) (* value *)
                             (I:Set){ReI:ImmediateReachability I}{PI RI GI}(i:ref{I|PI}[RI,GI]) (* intermediate *)
                             {T:Set}{P R G}(p:ref{T|P}[R,G]) (* dest *)
                             h, (* heap *)
                        imm_reachable_from_in i a -> reachable_from_in p (h[i]) h ->
                        reachable_from_in p a h.
(** ** Precision
    Predicates and relations must be agnostic to changes outside the heap reachable
    from their target. *)
(** For predicates, precision really means stability over any heap changes that don't touch
    the predicates footprint *)
Definition precise_pred {A:Set}{AR:ImmediateReachability A} (P:hpred A) :=
  forall a h h', P a h ->
                 (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a h -> h[r]=h'[r]) ->
                 P a h'.
(** For relations, precision means they accept any heap changes outside their footprint. *)
Definition precise_rel {A:Set}{AR:ImmediateReachability A} (R:hrel A) :=
  forall a a' h h' h2 h2',
    (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a h -> h[r]=h2[r]) ->
    (forall T P' R' G' (r:ref{T|P'}[R',G']), reachable_from_in r a' h' -> h'[r]=h2'[r]) ->
    (R a a' h h' -> R a a' h2 h2').

(** ** Relation Folding:
    Folding a rely-guarantee pair through a type to restrict the results of
    heap reads.  For any well-formed ref type the rely relation must already
    contain the literal rely of any reachable refs, so the rely portion
    is essentially a no-op.  The guarantee, however, still needs to be
    projected and intersected component-wise in any structure. *)
Class rel_fold (A:Set) :=
  { rgfold : forall (R G:hrel A), Set ;
    fold : forall {R G}, A -> rgfold R G
  }.
(** In meta-proofs, of things like satisfying a guarantee, we use this
    identity fold instead of the appropriate developer instance so
    G and P don't have to have polymorphic arities and relation arguments
    to work on all sorts of folded versions of A. We place it in its
    own section so it isn't used as an instance by user programs.
*)
Section HideMetaFold.
Local Instance meta_fold {A:Set} : rel_fold A :=
  { rgfold := fun R G => A ;
    fold := fun _ _ x => x
  }.
End HideMetaFold.
Notation "{{{ e }}}" := (let mfold : forall A, rel_fold A := @meta_fold in e) (at level 50).

(** ** Containment
    Containment means a reference's rely admits at least as much interference
    on references reachable from it as those reachable references themselves. *)
Class Containment (A:Set) := {
  contains : forall (R:hrel A), Prop
}.

(* TODO: relation folding on heap reads, and enforcing that G is reflexive/permits reads! *)
(** Ideally deref would have the type
<<
forall {A:Set}`{rel_fold A}{P:hpred A}{R G:hrel A}, hreflexive G -> ref A P R G -> rgfold R G.
>>
But unforunately, Coq's default type conversion procedure doesn't fully reduce the rgfold instance,
which in most cases is reduced naturally by
<<
cbv iota delta beta
>>
But that reduction is stronger than default conversion (at least in 8.3... still building 8.4).
*)
Axiom deref : forall {A:Set}{B:Set}`{rel_fold A}{P:hpred A}{R G:hrel A}, hreflexive G -> rgfold R G = B -> ref A P R G -> B.
(*Axiom deref : forall {A:Set}{P:hpred A}{R G:hrel A}, ref A P R G -> A.*)
Notation "! e" := (deref _ _ e) (at level 30). (* with reflexivity, add an _ in there *)

(* This axiom asserts that all folds that produce the same result type operate equally on
   the underlying values. This is fragile if a developer specifies multiple instances for
   folding the same type.  This is a weaker version of a more general axiom that
   the relationship between the results of folds of different result types depends on the
   relationship between results of the fold members of the instances when applied to the
   same value.  This version is really only useful for equating identity folds with
   the identity meta_fold instance results. *)
Axiom deref_conversion : forall (A B:Set)(f f':rel_fold A) P R G  rf1 rf2 fe1 fe2,
                         @deref A B f P R G rf1 fe1 = @deref A B f' P R G rf2 fe2.

Axiom ptr_eq_deref : forall A P P' R R' G G' h (p:ref{A|P}[R,G]) (r:ref{A|P'}[G',R']), p≡r -> h[p]=h[r].
Hint Resolve ptr_eq_deref.
Axiom ptr_eq_update : forall A P P' R R' G G' (p:ref{A|P}[R,G]) (r:ref{A|P'}[G',R']),
                        p≡r -> (forall h h' v, h'=heap_write p v h -> h'[r]=v).
(* ptr_eq_update is not likely to be effective for automated solving.  Possibly a good
   candidate for a custom tactic, or with experience with goals that need this
   perhaps we can rewrite it to be more useful as a general hint. *)
Require Import Coq.Setoids.Setoid.
Global Instance refl_ptr_eq {A P R G} : Reflexive (@ptr_eq A A P P R R G G). Admitted.
Global Instance trans_ptr_eq {A P R G} : Transitive (@ptr_eq A A P P R R G G). Admitted.

(** * Default Instances for reachability, containment, precision, folding *)
(** ** Reachability *)

(** A parameterized reachability instance useful for closed base types *)
Definition closed (A:Set) (T:Set){P R G} (p:ref{T|P}[R,G]) (a:A) : Prop := False.
Global Instance nat_reach : ImmediateReachability nat := {imm_reachable_from_in := closed nat}.
Global Instance bool_reach : ImmediateReachability bool := {imm_reachable_from_in := closed bool}.
Global Instance unit_reach : ImmediateReachability unit := {imm_reachable_from_in := closed unit}.
Global Instance pair_reach `{A:Set,B:Set,AR:ImmediateReachability A,BR:ImmediateReachability B} : ImmediateReachability (A*B) :=
  { imm_reachable_from_in :=
    fun T P R G v a => match a with
                   | (l,r) => imm_reachable_from_in v l \/ imm_reachable_from_in v r
                   end
  }.
Fixpoint list_reachable {A:Set}{AR:ImmediateReachability A} (T:Set){P R G} (v:ref{T|P}[R,G]) (a:list A) : Prop :=
  match a with
  | nil => False
  | cons hd tl => imm_reachable_from_in v hd \/ list_reachable T v tl
  end.
Global Instance list_reach `{A:Set,AR:ImmediateReachability A} : ImmediateReachability (list A) :=
  { imm_reachable_from_in := fun T P R G v a => list_reachable T v a }.
(** The reference immediate reachability instance (i.e. reflexivity) was defined earlier *)

(** TODO: Containment and folding are currently formulated as functions. I might get
    better expressiveness if they were formulated as relations (propositions) instead *)
(** ** Containment *)
(** For primitives, any relation contains the permitted interference (none) *)
Definition closed_contains (A:Set) (R:hrel A) : Prop := True.
Global Instance nat_contains : Containment nat := { contains := closed_contains nat }.
Global Instance bool_contains : Containment bool := { contains := closed_contains bool }.
Global Instance unit_contains : Containment unit := { contains := closed_contains unit }.
(** TODO: This pair contains is quite weak. If R cares assumes a certain domain
    of values for either component, this basically becomes unprovable. *)
Global Instance pair_contains `{A:Set,B:Set,CA:Containment A,CB:Containment B} : Containment (A*B) :=
  { contains :=
    fun R => contains (fun a a' h h' => forall b, R (a,b) (a',b) h h')
          /\ contains (fun b b' h h' => forall a, R (a,b) (a,b') h h')
  }.
Global Instance ref_contains {A:Set}{P:hpred A}{R G:hrel A} : Containment (ref{A|P}[R,G]) :=
  { contains :=
    fun R' => forall a a' h h',
                R a a' h h' ->
                forall (r:ref{A|P}[R,G]),
                  h[r]=a -> h'[r]=a' ->
                  R' r r h h'
  }.
(** TODO: polymorphic lists *)

(** ** Relation Folding *)
Definition const_rel_fold (A:Set) (R G:hrel A) : Set := A.
Definition const_id_fold {A:Set}(R G:hrel A)(x:A) := x.
Global Instance nat_fold : rel_fold nat := {rgfold := const_rel_fold nat; fold := const_id_fold}.
Global Instance bool_fold : rel_fold bool := {rgfold := const_rel_fold bool; fold := const_id_fold}.
Global Instance unit_fold : rel_fold unit := {rgfold := const_rel_fold unit; fold := const_id_fold}.
Global Instance pair_fold `{A:Set,B:Set,FA:rel_fold A,FB:rel_fold B}: rel_fold (A*B) :=
  { rgfold := fun R G =>
    prod (rgfold (fun _ _ _ _ => True) (fun a a' h h' => forall b, G (a,b) (a',b) h h'))
         (rgfold (fun _ _ _ _ => True) (fun b b' h h' => forall a, G (a,b) (a,b') h h')) ;
    fold := fun R G xy => match xy with (x,y) => (fold x, fold y) end
  }.
Global Instance ref_fold `{A:Set,P:hpred A,R:hrel A,G:hrel A} : rel_fold (ref{A|P}[R,G]) :=
  { rgfold := fun R' G' => ref{A|P}[R,G ⋂ (fun a a' h h' =>
                                             forall (r:ref{A|P}[R,G]), h[r]=a -> h'[r]=a' -> G' r r h h')]
  }.
(* We'll admit the runtime fold for references; the semantics for proofs will need an extensional treatment
   as an axiom. *)
Admitted.
Global Instance fn_fold {T : Set}{B : T -> Set} : rel_fold (forall x : T, B x) := {
    rgfold := fun _ _ => (forall x : T, B x);
    fold := fun _ _ x => x
  }.

(** TODO: polymorphic lists *)

(** ** Reachability, containment, and folding for pure types *)
(** A pure type is one that contains no references, anywhere.
    A polymorphic type is pure if all arguments to the type constructor
    and all data constructors are themselves pure. *)
Class pure_type (T:Set).
Global Instance pure_reachable `{A:Set,PA:pure_type A} : ImmediateReachability A :=
  { imm_reachable_from_in := fun _ _ _ _ _ _ => False }.
Global Instance pure_contains `{A:Set,PA:pure_type A} : Containment A :=
  { contains := fun _ => True }.
Global Instance pure_fold `{A:Set,PA:pure_type A} : rel_fold A :=
  { rgfold := fun _ _ => A ; fold := const_id_fold }.
Global Instance nat_pure : pure_type nat.
Global Instance bool_pure : pure_type bool.
Global Instance unit_pure : pure_type unit.
Global Instance list_pure `{A:Set,PA:pure_type A} : pure_type (list A).

(** ** Additional Axioms
    Things like heap dereference being the same between converted and unconverted references, etc. *)
(** For now we need an explicit subtyping operator *)
Axiom convert_P : forall {A:Set}{P P':hpred A}{R G}`{ImmediateReachability A},(forall v h, P v h -> P' v h) -> precise_pred P' -> stable P' R -> ref{A|P}[R,G] -> ref{A|P'}[R,G].
Axiom conversion_P_refeq : forall h A (P P':hpred A) (R G:hrel A)`{ImmediateReachability A} pf1 pf2 pf3 x, h[(@convert_P A P P' R G _ pf1 pf2 pf3 x)]=h[x].
Axiom convert : forall {A:Set}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A},
                ref{A|P}[R,G] ->
                (forall v h, P v h -> P' v h) ->
                (G' ⊆ G) -> (R ⊆ R') -> stable P' R' ->
                (G' ⊆ R') -> (* <-- self-splitting, this is a pure conversion *)
                ref{A|P'}[R',G'].
Axiom convert_equiv : forall {A}{P P':hpred A}{R R' G G':hrel A}`{ImmediateReachability A}
                             (r:ref{A|P}[R,G]) pfP pfG pfR stab splt,
                             forall h, h[r]=h[@convert A P P' R R' G G' _ r pfP pfG pfR stab splt].

Axiom refine_ref : forall {A:Set}{P P' R G}{fld : rel_fold A}{rfl : hreflexive G}
                   (r : ref{A|P}[R,G])
                   (x : rgfold R G),
                   stable P' R ->
                   ((@deref _ _ fld _ _ _ rfl (eq_refl) r) = x) -> (* <-- This is only available in special match statements, and flow is restricted! *)
                   (forall h, (fold (h[r]))=(deref rfl (eq_refl) r) -> (deref rfl eq_refl r) = x -> P (h[r]) h -> P' (h[r]) h) ->
                   ref{A|P'}[R,G].
Axiom refinement_equiv : forall {A P P' R G}{fld : rel_fold A}{rfl : hreflexive G}
                                (r:ref{A|P}[R,G]) x stab pf refpf,
                                forall h, h[r] = h[@refine_ref A P P' R G fld rfl r x stab pf refpf].


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* LIST LEMMAS                                                           *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Omega.

Require Import misc_arith.

Import ListNotations.
Open Scope list_scope.

Lemma map_expand:
forall (A B: Type) (f: A -> B) (l: list A) (s1 s2: list B),
s1 ++ s2 = map f l ->
exists s1' s2': list A,
l = s1' ++ s2' /\ map f s1' = s1 /\ map f s2' = s2.
Proof.
intros A B f l.
induction l.
- intros s1 s2 H.
  simpl in H.
  apply app_eq_nil in H.
  destruct H as [H1 H2].
  subst.
  exists [], [].
  auto.
- intros s1 s2 H.
  simpl in H.
  destruct s1.
  + simpl in H.
    destruct s2.
    * inversion H.
    * inversion H.
      exists [], (a::l). {
      split.
      - simpl.
        reflexivity.
      - split.
        + simpl.
          reflexivity.
        + simpl.
          reflexivity. }
  + destruct s2.
    * inversion H.
      exists (a::l), []. {
      split.
      - simpl.
        rewrite app_nil_r.
        reflexivity.
      - split.
        + simpl.
          rewrite <- H2.
          rewrite app_nil_r.
          reflexivity.
        + simpl.
          reflexivity. }
    * inversion H.
      specialize (IHl s1 (b0::s2)).
      specialize (IHl H2).
      destruct IHl as [s1' [s2' [H3 [H4 H5]]]].
      exists (a::s1').
      exists s2'. {
      split.
      - rewrite H3.
        simpl.
        reflexivity.
      - split.
        + simpl.
          rewrite H4.
          reflexivity.
        + rewrite H5.
          reflexivity. }
Qed.

Lemma equal_app (A: Type) :
forall l1 l2 s1 s2 : list A,
l1 ++ l2 = s1 ++ s2 ->
(exists l, s1 = l1 ++ l /\ l2 = l ++ s2) \/ (exists l, l1 = s1 ++ l /\ s2 = l ++ l2).
Proof.
intros l1.
induction l1 as [|a l1 IH].
- intros l2 s1 s2 H.
  simpl in H.
  subst.
  simpl.
  left.
  exists s1.
  split.
  reflexivity.
  reflexivity.
- intros l2 s1 s2 H.
  simpl in H.
  destruct s1 as [|a' s1].
  + simpl in H.
    subst.
    simpl.
    right.
    exists (a::l1).
    split.
    * reflexivity.
    * simpl.
      reflexivity.
  + simpl in H.
    inversion H.
    subst a'.
    clear H.
    apply IH in H2.
    destruct H2 as [(l & ? & ?) | (l & ? & ?)].
    * subst.
      simpl.
      left.
      exists l. {
      split.
      - reflexivity.
      - reflexivity. }
    * right.
      exists l. {
      split.
      - rewrite H.
        simpl.
        reflexivity.
      - rewrite H0.
        reflexivity. }
Qed.

Lemma last_last:
forall A: Type,
forall s d: A,
forall l: list A,
last (l++[s]) d = s.
Proof.
intros A s d l.
induction l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl.
    reflexivity.
  + rewrite <- app_comm_cons.
    exact IHl.
Qed.

Lemma length_ge_0:
forall A: Type,
forall l: list A,
length l >= 0.
Proof.
intros A l.
destruct l.
- simpl.
  omega.
- simpl.
  omega.
Qed.

Lemma length_ge_2:
forall A: Type,
forall a1 a2: A,
forall l: list A,
length (a1::a2::l) >= 2.
Proof.
intros A a1 a2 l.
simpl.
apply Le.le_n_S.
apply Le.le_n_S.
apply Le.le_0_n.
Qed.

Lemma length_lt_1:
forall A: Type,
forall l: list A,
length l < 1 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- replace (a::l) with ([a]++l) in H.
  + rewrite app_length in H.
    simpl in H.
    apply lt_S_n in H.
    apply lt_n_O in H.
    contradiction.
  + simpl.
    reflexivity.
Qed.

Lemma nth_cons:
forall A: Type,
forall a e: A,
forall l: list A,
forall i: nat,
nth (S i) (a::l) e = nth i l e.
Proof.
intros A a e l i.
simpl.
destruct i.
- simpl.
  reflexivity.
- reflexivity.
Qed.

Lemma length_not_zero:
forall A: Type,
forall l: list A,
length l > 0 -> [] <> l.
Proof.
intros A l H.
destruct l.
- simpl in H.
  apply gt_irrefl in H.
  contradiction.
- apply nil_cons.
Qed.

Lemma length_not_zero_inv:
forall A: Type,
forall l: list A,
l <> [] -> length l > 0.
Proof.
intros A l H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  omega.
Qed.

Lemma not_nil:
forall A: Type,
forall l: list A,
l <> [] -> length l <> 0.
Proof.
destruct l.
- intro H.
  auto.
- intro H.
  replace (a::l) with ([a]++l).
  + rewrite app_length.
    simpl.
    apply not_eq_sym.
    apply O_S.
  + simpl.
    reflexivity.
Qed.

Lemma not_nil_ge_1:
forall A: Type,
forall l: list A,
l <> [] -> length l >= 1.
Proof.
intros A l H.
apply not_nil in H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- simpl.
  apply le_n_S.
  apply le_0_n.
Qed.

Lemma list_last:
forall A: Type,
forall d: A,
forall l: list A,
removelast l <> [] -> nth (length (removelast l) - 1) (removelast l ++ [last l d]) d = last (removelast l) d.
Proof.
intros A d l H.
rewrite app_nth1 with (l:=removelast l).
- rewrite app_removelast_last with (l:=removelast l)(d:=d).
  + rewrite app_nth2.
    * rewrite app_length.
      assert (H1: Datatypes.length (removelast (removelast l)) + 1 - 1 -
                  Datatypes.length (removelast (removelast l)) = 0).
        {
        omega.
        }
      simpl.
      rewrite H1.
      rewrite last_last.
      reflexivity.
    * rewrite app_length.
      simpl.
      omega.
  + exact H.
- apply n_minus_1.
  apply not_nil.
  exact H.
Qed.

Lemma length_zero:
forall A: Type,
forall l: list A,
length l = 0 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- simpl in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma list_single:
forall A: Type,
forall l: list A,
forall d e: A,
nth 0 l d = e -> length l = 1 -> l = [e].
Proof.
intros A l d e H1 H2.
destruct l.
- simpl in H2.
  apply O_S in H2.
  contradiction.
- simpl in H1.
  rewrite H1.
  simpl in H2.
  inversion H2.
  apply length_zero in H0.
  rewrite H0.
  reflexivity.
Qed.

Lemma hd_nth0:
forall A: Type,
forall d: A,
forall l: list A,
hd d l = nth 0 l d.
Proof.
intros A d l.
destruct l.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma last_nth1:
forall A: Type,
forall d: A,
forall l: list A,
length l = 2 -> last l d = nth 1 l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl in H.
    inversion H.
  + replace (a :: a0 :: l) with ([a] ++ [a0] ++ l) in H.
    * repeat rewrite app_length in H.
      simpl in H.
      inversion H.
      apply length_zero in H1.
      subst.
      simpl.
      reflexivity.
    * simpl.
      reflexivity.
Qed.

Lemma hd_tl_nth1:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 -> hd d (tl l) = nth 1 l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  apply hd_nth0.
Qed.

Lemma last_tl_last:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 -> last (tl l) d = last l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl in H.
    apply gt_S_n in H.
    apply lt_n_0 in H.
    contradiction.
  + reflexivity.
Qed.

Lemma nth_S:
forall A: Type,
forall i: nat,
forall s s0 s1: A,
forall l: list A,
nth (S i) (s::s0::s1::l) = nth i (s0::s1::l).
Proof.
intros A i s s0 s1 l.
destruct i.
- simpl.
  reflexivity.
- destruct i.
  + simpl.
    reflexivity.
  + destruct i.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
Qed.

Lemma skipn_S:
forall i: nat,
forall A: Type,
forall a: A,
forall l: list A,
skipn (S i) (a :: l) = skipn i l.
Proof.
intros i A a l.
destruct i.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + reflexivity.
  + reflexivity.
Qed.

Lemma hd_skip:
forall i: nat,
forall A: Type,
forall d: A,
forall l: list A,
hd d (skipn i l) = nth i l d.
Proof.
intros i A d.
induction i as [| i IH].
- intros l.
  destruct l.
  + trivial.
  + trivial.
- intros l.
  destruct l.
  + trivial.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

Lemma last_skip:
forall i: nat,
forall A: Type,
forall d: A,
forall l: list A,
i < length l -> last (skipn i l) d = last l d.
Proof.
intros i A d.
induction i as [|i IH].
- intros l.
  destruct l.
  + trivial.
  + trivial.
- intros l.
  destruct l.
  + trivial.
  + simpl.
    intros Hl.
    assert (Hl' : i < length l) by omega.
    rewrite IH.
    * {
      destruct l.
      - simpl in Hl'.
        omega.
      - trivial.
      }
    * trivial.
Qed.

Lemma hd_hd:
forall A: Type,
forall d: A,
forall l l': list A,
length l >= 1 -> hd d l = hd d (l ++ l').
Proof.
intros A d l l' H.
destruct l.
- simpl in H.
  apply le_Sn_0 in H.
  contradiction.
- simpl.
  reflexivity.
Qed.

Lemma hd_first:
forall A: Type,
forall d: A,
forall l: list A,
forall i: nat,
i >= 1 -> hd d (firstn i l) = hd d l.
Proof.
intros A d l i H.
destruct l.
- destruct i.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
- destruct i.
  + apply le_Sn_0 in H.
    contradiction.
  + simpl.
    reflexivity.
Qed.

Lemma firstn_empty:
forall A: Type,
forall a: A,
forall i: nat,
a :: firstn i [] = [a].
Proof.
intros A a i.
destruct i.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma firstn_single:
forall A: Type,
forall a: A,
forall i: nat,
firstn (S i) [a] = [a].
intros A a i.
destruct i.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma nth_S':
forall i: nat,
forall A: Type,
forall a d: A,
forall l: list A,
nth (S i) (a :: l) d = nth i l d.
Proof.
intros i A a d l.
destruct i.
- simpl. reflexivity.
- simpl. reflexivity.
Qed.

Lemma firstn_S:
forall A: Type,
forall a: A,
forall l: list A,
forall i: nat,
firstn (S i) (a :: l) = a :: firstn i l.
Proof.
intros A a l.
induction l.
- intros i. simpl. reflexivity.
- intros i. destruct i.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

Lemma last_cons:
forall A: Type,
forall a d: A,
forall l: list A,
l <> [] -> last (a :: l) d = last l d.
Proof.
intros A a d l H.
induction l.
- destruct H. reflexivity.
- trivial.
Qed.

Lemma not_nil_firstn:
forall A: Type,
forall l: list A,
forall i: nat,
l <> [] -> firstn (S i) l <> [].
Proof.
intros A l i H.
destruct l.
- simpl. exact H.
- simpl. apply not_eq_sym. apply nil_cons.
Qed.

Lemma nil_not_nil:
forall A: Type,
forall l: list A,
l = [] \/ l <> [].
Proof.
destruct l.
- left.
  reflexivity.
- right.
  apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma last_first_nth:
forall A: Type,
forall d: A,
forall l: list A,
forall i: nat,
length l >= S i -> last (firstn (S i) l) d = nth i l d.
Proof.
intros A d l.
induction l.
- destruct i.
  + trivial.
  + trivial.
- destruct i.
  + trivial.
  + intros H.
    rewrite nth_S'.
    rewrite <- IHl.
    * rewrite firstn_S.
      {
      rewrite last_cons.
      - reflexivity.
      - apply not_nil_firstn.
        specialize (IHl i).
        replace (a::l) with ([a]++l) in H.
        + rewrite app_length in H.
          simpl in H.
          assert (H1: length l > 0) by omega.
          destruct l.
          * simpl in H1.
            omega.
          * apply not_eq_sym.
            apply nil_cons.
        + simpl.
          reflexivity.
      }
    * {
      replace (a::l) with ([a]++l) in H.
      - rewrite app_length in H.
        simpl in H.
        omega.
      - simpl.
        reflexivity.
      }
Qed.

Lemma nth_last:
forall A: Type,
forall l: list A,
forall d: A,
nth (length l - 1) l d = last l d.
Proof.
intros A l d.
destruct l.
- simpl.
  reflexivity.
- remember (a::l) as l0.
  rewrite app_removelast_last with (l:=l0) (d:=d).
  + rewrite app_length.
    simpl.
    rewrite last_last.
    rewrite app_nth2.
    * assert (H: (Datatypes.length (removelast l0) + 1 - 1 - Datatypes.length (removelast l0) = 0)) by omega.
      rewrite H.
      simpl.
      reflexivity.
    * omega.
  + rewrite Heql0.
    apply not_eq_sym.
    replace (a::l) with ([]++a::l).
    * apply app_cons_not_nil.
    * simpl.
      reflexivity.
Qed.

Lemma hd_app:
forall A: Type,
forall l l': list A,
forall a d: A,
l <> [] ->
l' <> [] ->
hd d l = hd d l' ->
hd d (l ++ [a]) = hd d (l' ++ [a]).
Proof.
intros A l l' a d H1 H2 H3.
destruct l.
- destruct l'.
  + simpl.
    reflexivity.
  + destruct H1.
    reflexivity.
- destruct l'.
  + destruct H2.
    reflexivity.
  + simpl.
    simpl in H3.
    exact H3.
Qed.

Lemma last_2_1:
forall A: Type,
forall l: list A,
forall a1 a2 d: A,
last (a1 :: a2 :: l) d = last (a2 :: l) d.
Proof.
intros A l a1 a2 d.
simpl.
reflexivity.
Qed.

Lemma last_app:
forall A: Type,
forall l l': list A,
forall a d: A,
l <> [] ->
l' <> [] ->
last l d = last l' d ->
last ([a] ++ l) d = last ([a] ++ l') d.
Proof.
intros A l l' a d H1 H2 H3.
induction l, l'.
- simpl.
  reflexivity.
- destruct H1.
  reflexivity.
- destruct H2.
  reflexivity.
- replace ([a] ++ a0 :: l) with (a :: a0 :: l).
  + replace ([a] ++ a1 :: l') with (a :: a1 :: l').
    * repeat rewrite last_2_1.
      exact H3.
    * simpl.
      reflexivity.
  + simpl.
    reflexivity.
Qed.

Lemma hd_not_nil:
forall A: Type,
forall l: list A,
forall a d: A,
d <> a ->
hd d l = a ->
l <> [].
Proof.
intros A l a d H1 H2.
destruct l.
- simpl in H2.
  contradiction.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma hd_not_nil_v2:
forall A: Type,
forall l: list A,
forall d: A,
hd d l <> d -> l <> [].
Proof.
intros A l d H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma hd_not_zero:
forall A: Type,
forall l: list A,
forall a d: A,
d <> a ->
hd d l = a ->
length l > 0.
Proof.
intros A l a d H1 H2.
destruct l.
- simpl in H2.
  contradiction.
- simpl.
  apply gt_Sn_O.
Qed.

Lemma hd_removelast:
forall A: Type,
forall s d: A,
forall l l': list A,
l <> [] -> hd d (removelast (s :: l) ++ l') = s.
Proof.
intros A s d l l' H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma length_cons_gt_1:
forall A: Type,
forall s: A,
forall l: list A,
length (s :: l) > 1 -> l <> [].
Proof.
intros A s l H.
replace (s :: l) with ([s] ++ l) in H.
- rewrite app_length in H.
  simpl in H.
  apply gt_S_n in H.
  apply not_eq_sym.
  apply length_not_zero.
  exact H.
- simpl.
  reflexivity.
Qed.

Lemma length_cons_eq_1:
forall A: Type,
forall s: A,
forall l: list A,
length (s :: l) = 1 -> l = [].
Proof.
intros A s l H.
destruct l.
- reflexivity.
- simpl in H.
  apply eq_add_S in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma not_exists_forall_not:
forall A B: Type,
forall l: list (A+B),
~ (exists a': A, l = [inl a']) ->
forall a': A, (l <> [inl a']).
Proof.
intros A B l H a'.
unfold not at 1 in H.
unfold not.
destruct l.
- intro H1.
  inversion H1.
- intro H1.
  apply H.
  exists a'.
  exact H1.
Qed.

Lemma in_in:
forall A: Type,
forall s: A,
forall s1 s2: list A,
In s (s1 ++ [s] ++ s2).
Proof.
intros A s s1 s2.
induction s1.
- simpl.
  left.
  reflexivity.
- apply in_app_iff.
  right.
  simpl.
  left.
  reflexivity.
Qed.

Lemma in_out:
forall A: Type,
forall s: A,
forall l s1 s2: list A,
l = s1 ++ [s] ++ s2 ->
In s l.
Proof.
intros A s l s1 s2 H.
rewrite H.
apply in_in.
Qed.

Lemma exists_length_eq_2:
forall A: Type,
forall l: list A,
length l = 2 ->
exists s1 s2: A,
l = [s1] ++ [s2].
Proof.
intros A l H.
destruct l.
- simpl in H.
  apply O_S in H.
  contradiction.
- destruct l.
  + simpl in H.
    apply eq_add_S in H.
    apply O_S in H.
    contradiction.
  + destruct l.
    * exists a, a0.
      reflexivity.
    * simpl in H.
      repeat apply eq_add_S in H.
      symmetry in H.
      apply O_S in H.
      contradiction.
Qed.

Lemma exists_length_gt_2:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 ->
exists s1 s2: A,
exists l': list A,
l = [s1] ++ l' ++ [s2].
Proof.
intros A d l H.
destruct l.
- simpl in H.
  apply lt_n_0 in H.
  contradiction.
- destruct l.
  + simpl in H.
    apply gt_S_n in H.
    apply lt_n_0 in H.
    contradiction.
  + destruct l.
    * simpl in H.
      repeat apply gt_S_n in H.
      apply lt_n_0 in H.
      contradiction.
    * assert (H1: l = [] \/ l <> []).
        {
        apply nil_not_nil.
        }
      {
      destruct H1 as [H1 | H1].
      - subst.
        exists a, a1, [a0].
        reflexivity.
      - change (a :: a0 :: a1 :: l) with (([a] ++ [a0] ++ [a1]) ++ l) in H.
        exists a.
        rewrite app_removelast_last  with (A:=A) (l:=l) (d:=d).
        + exists (last l d).
          exists (a0 :: a1 :: removelast l).
          reflexivity.
        + exact H1.
      }
Qed.

Lemma exists_length_ge_2:
forall A: Type,
forall def: A,
forall l: list A,
length l >= 2 ->
exists s1 s2: A,
exists l': list A,
l = [s1] ++ l' ++ [s2].
Proof.
intros A def l H1.
assert (H2: length l > 2 \/ length l = 2) by omega.
destruct H2 as [H2 | H2].
- apply exists_length_gt_2 in H2.
  + exact H2.
  + exact def.
- apply exists_length_eq_2 in H2.
  destruct H2 as [s1 [s2 H3]].
  exists s1, s2, [].
  simpl.
  exact H3.
Qed.

Lemma length_eq_0:
forall A: Type,
forall l: list A,
length l = 0 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- change (a ::l) with ([a] ++ l) in H.
  rewrite app_length in H.
  simpl in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma elem_not_nil:
forall A: Type,
forall w1 w2: list A,
forall X: A,
w1 ++ [X] ++ w2 <> [].
Proof.
intros A w1 w2 X.
destruct w1.
- simpl.
  apply not_eq_sym.
  apply nil_cons.
- simpl.
  apply not_eq_sym.
  replace (a :: w1 ++ X :: w2) with (([a] ++ w1) ++ [X] ++ w2).
  + apply app_cons_not_nil.
  + simpl.
    reflexivity.
Qed.

Lemma map_map_app:
forall A B : Type,
forall f: A -> B,
forall x y: list A,
forall z: list B,
map f x = map f y ++ z ->
exists z': list A,
z = map f z'.
Proof.
intros A B f x y z H.
symmetry in H.
apply map_expand in H.
destruct H as [s1' [s2' [H1 [H2 H3]]]].
exists s2'.
symmetry.
exact H3.
Qed.

Lemma cat_left:
forall A: Type,
forall a: A,
forall l1 l2: list A,
l1 = l2 -> [a] ++ l1 = [a] ++ l2.
Proof.
intros A a l1 l2 H.
rewrite H.
reflexivity.
Qed.

Lemma map_not_nil:
forall A B: Type,
forall f: A -> B,
forall l: list A,
map f l <> [] -> l <> [].
Proof.
intros A B f l H.
destruct l.
- destruct H.
  simpl.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma map_not_nil_inv:
forall A B: Type,
forall f: A -> B,
forall l: list A,
l <> [] -> map f l <> [].
Proof.
intros A B f l H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma app_not_nil:
forall A: Type,
forall x y: list A,
x ++ y <> [] ->
(x <> [] \/ y <> []).
Proof.
intros A x y H.
assert (H1: x = [] \/ x <> []).
  {
  apply nil_not_nil.
  }
assert (H2: y = [] \/ y <> []).
  {
  apply nil_not_nil.
  }
destruct H1 as [H1 | H1].
- destruct H2 as [H2 | H2].
  + rewrite H1 in H.
    rewrite H2 in H.
    simpl in H.
    destruct H.
    reflexivity.
  + right.
    exact H2.
- destruct H2 as [H2 | H2].
  + rewrite H2 in H.
    rewrite app_nil_r in H.
    left.
    exact H.
  + left.
    exact H1.
Qed.

Lemma app_not_nil_inv:
forall A: Type,
forall x y: list A,
(x <> [] \/ y <> []) ->
x ++ y <> [].
Proof.
intros A x y H.
destruct H as [H | H].
- intros H2.
  apply app_eq_nil in H2.
  destruct H2 as [H2 _].
  contradiction.
- intros H2.
  apply app_eq_nil in H2.
  destruct H2 as [_ H2].
  contradiction.
Qed.

Lemma list_not_nil:
forall A: Type,
forall l: list A,
l <> [] ->
exists l1 l2 l3: list A,
l = l1 ++ l2 ++ l3 /\
l2 <> [].
Proof.
intros A l H.
destruct l.
- destruct H.
  reflexivity.
- exists [], [a], l.
  split.
  + simpl.
    reflexivity.
  + apply not_eq_sym.
    apply nil_cons.
Qed.

Lemma app_eq:
forall A: Type,
forall a: A,
forall l1 l2: list A,
l1 = l2 -> [a] ++ l1 = [a] ++ l2.
Proof.
intros A a l1 l2 H.
destruct l1, l2.
- simpl.
  reflexivity.
- inversion H.
- inversion H.
- rewrite H.
  reflexivity.
Qed.

Lemma list_single_elem:
forall A: Type,
forall l1 l2: list A,
forall a b: A,
l1 ++ a :: l2 = [b] ->
l1 = []/\ l2 = [].
Proof.
intros A l1 l2 a b H1.
split.
- destruct l1.
  + reflexivity.
  + inversion H1.
    destruct l1.
    * inversion H2.
    * inversion H2.
- destruct l1.
  + inversion H1.
    reflexivity.
  + inversion H1.
    destruct l1.
    * inversion H2.
    * inversion H2.
Qed.

Lemma last_not_nil:
forall A: Type,
forall l: list A,
forall d: A,
(last l d) <> d -> l <> [].
Proof.
intros A l d H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma app_cons_eq:
forall A: Type,
forall s1 s2: list A,
forall a b: A,
s1 ++ a :: s2 = [b] ->
s1 = [] /\ s2 = [] /\ a = b.
Proof.
intros A s1 s2 a b H.
destruct s1.
- inversion H.
  subst.
  auto.
- inversion H.
  destruct s1.
  + inversion H2.
  + inversion H2.
Qed.

Lemma not_in_not_eq:
forall A: Type,
forall a b: A,
~ In a [b] -> a <> b.
Proof.
intros A a b H.
simpl in H.
intros H2.
apply H.
left.
symmetry.
exact H2.
Qed.

Lemma inl_neq:
forall X Y: Type,
forall a b: X,
@inl X Y a <> @inl X Y b -> a <> b.
Proof.
intros X Y a b H.
intro.
apply H.
subst.
reflexivity.
Qed.

Lemma length_cons_le:
forall A: Type,
forall l1 l2: list A,
forall a: A,
forall n: nat,
length (l1 ++ a :: l2) <= n ->
length (l1 ++ l2) <= n.
Proof.
intros A l1 l2 a n H.
rewrite app_length.
change (a :: l2) with ([a] ++ l2) in H.
repeat rewrite app_length in H.
simpl in H.
omega.
Qed.

Lemma in_app_cons:
forall A: Type,
forall l1 l2: list A,
forall a b: A,
In a (l1 ++ l2) ->
In a (l1 ++ b :: l2).
Proof.
intros A l1 l2 a b H.
apply in_app_or in H.
apply in_or_app.
destruct H as [H | H].
- left.
  exact H.
- right.
  change (b :: l2) with ([b] ++ l2).
  apply in_or_app.
  right.
  exact H.
Qed.

Lemma cons_app:
forall (A: Type) (s: A) (l: list A),
s :: l = [s] ++ l.
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma length_map_ge:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length s >= n ->
length (map f s) >= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma length_map_le:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length s <= n ->
length (map f s) <= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma length_map_le_inv:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length (map f s) <= n ->
length s <= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma map_eq:
forall A B: Type,
forall f: A -> B,
forall l1 l2: list A,
injective A B f ->
map f l1 = map f l2 -> l1 = l2.
Proof.
intros A B f.
induction l1.
- intros l2 H1 H2.
  simpl in H2.
  symmetry in H2.
  apply map_eq_nil in H2.
  symmetry.
  exact H2.
- intros l2 H1 H2.
  simpl in H2.
  destruct l2.
  + simpl in H2.
    inversion H2.
  + simpl in H2.
    inversion H2.
    assert (H1':= H1).
    specialize (H1 a a0 H0).
    specialize (IHl1 l2 H1' H3).
    subst.
    reflexivity.
Qed.

Fixpoint iter {A: Type} (w: list A) (n: nat): list A:=
match n with
| O => []
| S n => w ++ iter w n
end.

Lemma iter_comm:
forall A: Type,
forall l: list A,
forall i: nat,
l ++ iter l i = iter l i ++ l.
Proof.
intros A l i.
revert l.
induction i.
- simpl.
  intros l.
  rewrite app_nil_r.
  reflexivity.
- intros l.
  simpl.
  rewrite <- app_assoc.
  rewrite <- IHi.
  reflexivity.
Qed.

Lemma iter_length:
forall A: Type,
forall w: list A,
forall i: nat,
length (iter w i) = i*(length w).
Proof.
induction i.
- simpl.
  reflexivity.
- simpl.
  rewrite app_length.
  rewrite IHi.
  reflexivity.
Qed.

Lemma cons_neq:
forall A: Type,
forall a: A,
forall l: list A,
l <> a :: l.
Proof.
intros A a l.
induction l.
- intros H.
  inversion H.
- intros H.
  inversion H.
  contradiction.
Qed.

Lemma list_split:
forall A: Type,
forall l: list A,
forall n m: nat,
length l = n + m ->
exists l1 l2: list A,
l = l1 ++ l2 /\
length l1 = n /\
length l2 = m.
Proof.
intros A l n m H1.
assert (H2: firstn n l ++ skipn n l = l).
  {
  apply firstn_skipn.
  }
assert (H3: length (firstn n l) = min n (length l)).
  {
  apply firstn_length.
  }
assert (H4: min n (n + m) = n).
  {
  apply min_l.
  omega.
  }
assert (H5: length (firstn n l) = n).
  {
  rewrite H1 in H3.
  rewrite H4 in H3.
  exact H3.
  }
clear H3 H4.
rewrite <- H2 in H1.
rewrite app_length in H1.
rewrite H5 in H1.
assert (H6: length (skipn n l) = m) by omega.
exists (firstn n l), (skipn n l).
split.
- symmetry.
  exact H2.
- split.
  + exact H5.
  + exact H6.
Qed.

Lemma list_split_exists:
forall A: Type,
forall l: list A,
exists l1 l2: list A,
l = l1 ++ l2.
Proof.
intros A.
induction l.
- exists [], [].
  reflexivity.
- destruct IHl as [l1 [l2 IHl]].
  rewrite IHl.
  exists (a :: l1), l2.
  reflexivity.
Qed.

Fixpoint get_As (A B: Type) (l: list (A + B)): list A:=
match l with
| [] => []
| inl a :: l => a :: get_As A B l
| inr b :: l => get_As A B l
end.

Lemma get_As_correct:
forall A B: Type,
forall r: list (A + B),
(forall e: (A + B), In e r -> exists a: A, e = inl a) ->
r = map inl (get_As A B r).
Proof.
intros A B r H.
induction r.
- simpl.
  reflexivity.
- destruct a.
  + simpl.
    rewrite <- IHr.
    * reflexivity.
    * intros e H1.
      apply H.
      simpl.
      right.
      exact H1.
  + specialize (H (inr b)).
    assert (H1: In (inr b) (inr b :: r)).
      {
      simpl.
      left.
      reflexivity.
      }
    specialize (H H1).
    destruct H as [n H].
    discriminate.
Qed.

Fixpoint get_Bs (A B: Type) (l: list (A + B)): list B:=
match l with
| [] => []
| inl a :: l => get_Bs A B l
| inr b :: l => b :: get_Bs A B l
end.

Lemma get_Bs_correct:
forall A B: Type,
forall r: list (A + B),
(forall e: (A + B), In e r -> exists b: B, e = inr b) ->
r = map inr (get_Bs A B r).
Proof.
intros A B r H.
induction r.
- simpl.
  reflexivity.
- destruct a.
  + specialize (H (inl a)).
    assert (H1: In (inl a) (inl a :: r)).
      {
      simpl.
      left.
      reflexivity.
      }
    specialize (H H1).
    destruct H as [n H].
    discriminate.
  + simpl.
    rewrite <- IHr.
    * reflexivity.
    * intros e H1.
      apply H.
      simpl.
      right.
      exact H1.
Qed.

Lemma split_app:
forall A: Type,
forall l l1 l2: list A,
l = l1 ++ l2 ->
exists l' l'': list A,
l = l' ++ l'' /\
l' = l1 /\
l'' = l2.
Proof.
intros A l.
destruct l.
- intros l1 l2 H.
  symmetry in H.
  apply app_eq_nil in H.
  destruct H as [H H1].
  subst.
  exists [], [].
  simpl.
  auto.
- intros l1 l2 H.
  exists l1, l2.
  split.
  + exact H.
  + auto.
Qed.

Lemma not_nil_app:
forall A: Type,
forall l1 l2: list A,
l1 <> [] ->
l1 ++ l2 <> [].
Proof.
intros A l1 l2 H.
destruct l1.
- destruct H.
  reflexivity.
- apply not_eq_sym.
  intros H1.
  inversion H1.
Qed.

Fixpoint flat {A: Type} (l: list (list A)): list A:=
match l with
| [] => []
| s :: l => s ++ flat l
end.

Lemma flat_app:
forall A: Type,
forall l1 l2: list (list A),
flat (l1 ++ l2) = flat l1 ++ flat l2.
Proof.
induction l1.
- simpl.
  reflexivity.
- intros l2.
  simpl.
  specialize (IHl1 l2).
  rewrite IHl1.
  rewrite <- app_assoc.
  reflexivity.
Qed.

Lemma app_single:
forall A: Type,
forall l1 l2: list A,
forall a: A,
l1 ++ l2 = [a] ->
l1 = [a] /\ l2 = [] \/
l1 = [] /\ l2 = [a].
Proof.
intros A l1 l2 a H.
destruct l1, l2.
- inversion H.
- inversion H.
  subst.
  right.
  auto.
- inversion H.
  subst.
  left.
  rewrite app_nil_r.
  auto.
- inversion H.
  destruct l1.
  + inversion H2.
  + inversion H2.
Qed.

Lemma length_tl:
forall A: Type,
forall w: list A,
forall i: nat,
length w = i ->
i > 0 ->
length (tl w) = i - 1.
Proof.
destruct w.
- intros i H1 H2.
  simpl in H1.
  omega.
- intros i H1 H2.
  simpl.
  simpl in H1.
  omega.
Qed.

Lemma length_split_3:
forall A: Type,
forall i n: nat,
forall w x y z: list A,
length w = 3*n ->
w=x++y++z ->
length x = i ->
length y = i ->
length z = i ->
n = i.
Proof.
destruct i.
- intros n w x y z H1 H2 H3 H4 H5.
  apply length_zero in H3.
  apply length_zero in H4.
  apply length_zero in H5.
  rewrite H3, H4, H5 in H2.
  rewrite H2 in H1.
  simpl in H1.
  omega.
- intros n w x y z H1 H2 H3 H4 H5.
  rewrite H2 in H1.
  repeat rewrite app_length in H1.
  rewrite H3, H4, H5 in H1.
  omega.
Qed.

Lemma length_split_4:
forall A: Type,
forall i n: nat,
forall w v x y z: list A,
length w = 4*n ->
w=v++x++y++z ->
length v = i ->
length x = i ->
length y = i ->
length z = i ->
n = i.
Proof.
destruct i.
- intros n w v x y z H1 H2 H3 H4 H5 H6.
  apply length_zero in H3.
  apply length_zero in H4.
  apply length_zero in H5.
  apply length_zero in H6.
  rewrite H3, H4, H5, H6 in H2.
  rewrite H2 in H1.
  simpl in H1.
  omega.
- intros n w v x y z H1 H2 H3 H4 H5 H6.
  rewrite H2 in H1.
  repeat rewrite app_length in H1.
  rewrite H3, H4, H5, H6 in H1.
  omega.
Qed.

Lemma app_last:
forall A: Type,
forall w1 w2: list A,
forall d: A,
w2 <> [] -> last (w1++w2) d = last w2 d.
Proof.
induction w1.
- intros w2 d _.
  rewrite app_nil_l.
  reflexivity.
- intros w2 d H1.
  simpl.
  rewrite IHw1.
  + destruct w1, w2.
    * destruct H1.
      reflexivity.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
  + exact H1.
Qed.

Lemma hd_to_last:
forall A: Type,
forall w: list A,
forall t: A,
exists w': list A,
exists t': A,
t::w=w'++[t'].
Proof.
induction w.
- intros t.
  exists [], t.
  reflexivity.
- intros t.
  specialize (IHw t).
  destruct IHw as [w' [t' IHw]].
  destruct w'.
  + inversion IHw.
    exists [t'], a.
    reflexivity.
  + inversion IHw.
    exists (a0::a::w'), t'.
    reflexivity.
Qed.

Lemma length_iter:
forall A: Type,
forall a: A,
forall n: nat,
length (iter [a] n) = n.
Proof.
intros A a.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma iter_sym:
forall A: Type,
forall a: A,
forall n: nat,
iter [a] n ++ [a] = [a] ++ iter [a] n.
Proof.
intros A a.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma app_single_v2:
forall A: Type,
forall s1 s2: list A,
forall a b: A,
s1 ++ [a] ++ s2 = [b] ->
s1=[] /\ s2=[] /\ a=b.
Proof.
intros A s1 s2 a b H1.
split.
- destruct s1.
  + reflexivity.
  + inversion H1.
    apply app_eq_nil in H2.
    destruct H2 as [_ H2].
    inversion H2.
- split.
  + destruct s1.
    * simpl in H1.
      inversion H1.
      reflexivity.
    * inversion H1.
      apply app_eq_nil in H2.
      destruct H2 as [_ H2].
      inversion H2.
  + destruct s1.
    * inversion H1.
      reflexivity.
    * inversion H1.
      apply app_eq_nil in H2.
      destruct H2 as [_ H2].
      inversion H2.
Qed.

Lemma not_empty_eq_app_single:
forall A: Type,
forall a: A,
forall s: list A,
~ [] = s ++ [a].
Proof.
intros A a s H.
destruct s.
- inversion H.
- inversion H.
Qed.

Lemma length_gt_0:
forall A: Type,
forall w: list A,
length w > 0 ->
(exists w': list A, exists a: A, w = [a] ++ w') /\
(exists w': list A, exists a: A, w = w' ++ [a]).
Proof.
intros A w H1.
split.
- destruct w.
  + simpl in H1.
    omega.
  + exists w, a.
    reflexivity.
- apply length_not_zero in H1.
  apply not_eq_sym in H1.
  apply exists_last in H1.
  destruct H1 as [l' [a H1]].
  exists l', a.
  exact H1.
Qed.

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

Section Sublist.

Variable A: Type.

Definition sublist {A: Type} (w1 w2: list A): Prop:=
exists p s: list A,
w1 = p ++ w2 ++ s.

Lemma sublist_cat_l:
forall w1 w2: list A,
sublist w1 w2 ->
forall w: list A,
sublist (w++w1) w2.
Proof.
intros w1 w2 H1.
induction w.
- exact H1.
- destruct IHw as [p [s IHw]].
  change ((a :: w) ++ w1) with (a :: (w ++ w1)).
  rewrite IHw.
  exists (a :: p),s.
  reflexivity.
Qed.

Lemma sublist_last:
forall w1 w2: list A,
sublist w1 w2 ->
forall t: A,
sublist (w1 ++ [t]) w2.
Proof.
intros w1 w2 H1 t.
destruct H1 as [p [s H1]].
rewrite H1.
exists p,(s++[t]).
repeat rewrite <- app_assoc.
reflexivity.
Qed.

Lemma sublist_cat_r:
forall w1 w2: list A,
sublist w1 w2 ->
forall w: list A,
sublist (w1++w) w2.
Proof.
intros w1 w2 H1 w.
revert w1 w2 H1.
induction w.
- intros w1 w2 H1.
  rewrite app_nil_r.
  exact H1.
- intros w1 w2 H1.
  specialize (IHw (w1 ++ [a]) w2).
  apply sublist_last with (t:=a) in H1.
  specialize (IHw H1).
  change (w1 ++ a :: w) with (w1 ++ [a] ++ w).
  repeat rewrite <-app_assoc in IHw.
  exact IHw.
Qed.

End Sublist.

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

Section Suffix.

Variable A: Type.

Definition suffix_v1 (l1 l2: list A): Prop:=
exists l,
l2 = l ++ l1.

Inductive suffix_v2: list A -> list A -> Prop:=
| suffix_eq:  forall l1 l2: list A, l1 = l2 -> suffix_v2 l1 l2
| suffix_app: forall l1 l2: list A, forall a: A, suffix_v2 l1 l2 -> suffix_v2 l1 (a :: l2).

Fixpoint suffix_v3 (l1 l2: list A): Prop:=
l1 = l2 \/
match l2 with
| [] => False
| e :: l' => suffix_v3 l1 l'
end.

Lemma suffix_v1_nil:
forall l: list A,
suffix_v1 [] l.
Proof.
intros l.
exists l.
rewrite app_nil_r.
reflexivity.
Qed.

Lemma suffix_v2_nil:
forall l: list A,
suffix_v2 [] l.
Proof.
induction l.
- apply suffix_eq.
  reflexivity.
- apply suffix_app.
  exact IHl.
Qed.

Lemma suffix_v3_nil:
forall l: list A,
suffix_v3 [] l.
Proof.
intros l.
induction l.
- simpl.
  left.
  reflexivity.
- simpl.
  right.
  exact IHl.
Qed.

Lemma suffix_v1_equiv_suffix_v2:
forall l1 l2: list A,
suffix_v1 l1 l2 <-> suffix_v2 l1 l2.
Proof.
intros l1 l2.
split.
- intros H.
  destruct H as [l H].
  subst.
  induction l.
  + simpl.
    apply suffix_eq.
    reflexivity.
  + simpl.
    apply suffix_app.
    exact IHl.
- intros H.
  induction H.
  + subst.
    exists [].
    reflexivity.
  + destruct IHsuffix_v2 as [l IHsuffix_v2].
    subst.
    exists (a :: l).
    reflexivity.
Qed.

Lemma suffix_v2_equiv_suffix_v3:
forall l1 l2: list A,
suffix_v2 l1 l2 <-> suffix_v3 l1 l2.
Proof.
intros l1 l2.
split.
- intros H.
  induction H.
  + subst.
    destruct l2.
    * simpl.
      left.
      reflexivity.
    * simpl.
      left.
      reflexivity.
  + simpl.
    right.
    exact IHsuffix_v2.
- generalize dependent l2.
  induction l2.
  + intros H.
    simpl in H.
    destruct H as [H | H].
    * subst.
      apply suffix_eq.
      reflexivity.
    * contradiction.
  + intros H.
    simpl in H.
    destruct H as [H | H].
    * subst.
      apply suffix_eq.
      reflexivity.
    * apply suffix_app.
      apply IHl2.
      exact H.
Qed.

Lemma suffix_v1_split:
forall l1 l2: list A,
suffix_v1 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
intros l1 l2 H.
unfold suffix_v1 in H.
destruct H as [l H].
subst.
exists l.
reflexivity.
Qed.

Lemma suffix_v2_split:
forall l1 l2: list A,
suffix_v2 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
intros l1 l2 H.
induction H.
- subst.
  exists [].
  reflexivity.
- destruct IHsuffix_v2 as [l H2].
  rewrite <- H2.
  exists (a :: l).
  reflexivity.
Qed.

Lemma suffix_v3_split:
forall l1 l2: list A,
suffix_v3 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
induction l2.
- intros H.
  simpl in H.
  destruct H as [H | H].
  + subst.
    exists [].
    reflexivity.
  + contradiction.
- intros H.
  simpl in H.
  destruct H as [H | H].
  + subst.
    exists [].
    reflexivity.
  + specialize (IHl2 H).
    destruct IHl2 as [l H2].
    subst.
    exists (a :: l).
    reflexivity.
Qed.

End Suffix.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

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

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

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

----
*)

From Coq Require Import List Arith.

(**
  Useful functions on lists, not part of the Coq standard library.
  Most functions are taken from the Haskell standard libary module Data.List.

 *)

Section ListFunctions.
  Variable A : Type.
  Variable B : Type.
  Variable P : A -> Prop.
  Variable P_dec : forall a, {P a}+{~ P a}.

  (** Make a singleton list from the given element a. *)
  Definition singleton (a:A) : list A := a :: nil.

  (** Drop all prefix elements of l that satisfy p. *)
  Fixpoint dropWhile (p:A->bool) (l:list A) {struct l} : list A :=
    match l with
    | nil     => nil
    | (x::xs) => if p x then dropWhile p xs else xs
    end.

  (** Concatenate all given lists into a flat list. *)
  Definition concat : list (list A) -> list A := flat_map (fun x:list A => x).

  (** Maximum element of the given list of natural numbers. *)
  Fixpoint maximum (e:nat) (l:list nat) {struct l} : nat :=
    match l with
    | nil     => e
    | (x::xs) => max x (maximum e xs)
    end.

  (**
    Like fold_left but take e for the empty list.
    e is not used for a non-empty list.
   *)
  Definition fold_left1 (op:A->A->A) (l:list A) (e:A) : A :=
    match l with
    | nil   => e
    | x::xs => fold_left op xs x
    end.

  (**
    Like fold_right but take e for the empty list.
    e is not used for a non-empty list.
   *)
  Fixpoint fold_right1 (op:A->A->A) (l:list A) (e:A) : A :=
    match l with
    | nil    => e
    | x::nil => x
    | x::xs  => op x (fold_right1 op xs e)
    end.

  Program Fixpoint Find (l : list A) {struct l} :
    { a : A | In a l & P a }+{ AllS (fun a' => ~ P a') l } :=
    match l with
    | nil => inright _
    | a0 :: l' =>
      match P_dec a0 with
      | left Hdec => inleft (exist2 _ _ a0 _ _)
      | right Hdec =>
        match Find l' with
        | inleft (exist2 _ _ a1 _ _) => inleft (exist2 _ _ a1 _ _)
        | inright Hdec => inright _
        end
      end
    end.

End ListFunctions.

Arguments singleton [A].
Arguments dropWhile [A].
Arguments concat [A].
Arguments fold_left1 [A].
Arguments fold_right1 [A].

Inductive Expr : Set :=
    | Lit : nat -> Expr
    | Add : Expr -> Expr -> Expr.

(* Eval compute in fold_right1 Add (Lit 1 :: Lit 2 :: Lit 3 :: nil) (Lit 10). *)

Section Proofs.
  Variable A : Type.

  (**
    For every element y in the result list (concat l),
    there exists a list x in l that contains y.
   *)
  Lemma in_concat : forall (l:list (list A)) (y:A),
    In y (concat l) <-> exists x, In x l /\ In y x.
  Proof.
    apply (in_flat_map (fun x:list A => x)).
  Qed.

  (** e is the maximum of the empty list. *)
  Lemma maximum_e_nil : forall (e:nat) (l:list nat), l=nil -> maximum e l=e.
  Proof.
    intros e l H.
    rewrite H.
    simpl.
    reflexivity.
  Qed.

  (** maximum is composable using max and cons. *)
  Lemma maximum_e_cons : forall (e:nat) (x:nat) (l:list nat),
    maximum e (x::l) = max x (maximum e l).
  Proof.
    intros e x l.
    simpl.
    reflexivity.
  Qed.

  (** fold_left1 op nil e = e *)
  Lemma fold_left1_e_nil : forall (op:A->A->A) (e:A) (l:list A),
    l=nil ->
    fold_left1 op l e = e.
  Proof.
    intros op e l H.
    rewrite H.
    simpl.
    reflexivity.
  Qed.

  (** fold_left1 op (x::l) e = fold_left1 op l x,
     e vanishes for a non-empty list.
    *)
  Lemma fold_left1_fold_left : forall (op:A->A->A) (e:A) (x:A) (l:list A),
    fold_left1 op (x::l) e = fold_left op l x.
  Proof.
    intros op e x l.
    simpl.
    reflexivity.
  Qed.

  (** The element found by find satisfies predicate p. *)
  Lemma find_def : forall (p:A->bool) (l:list A) (x:A), find p l = Some x -> p x = true.
  Proof.
    intros p l x H.
    induction l.
    (* BC *)
    discriminate H.
    (* IH *)
    simpl in H.
    assert (p a = true \/ p a = false).
    case (p a); auto.

    elim H0; intro Hpa; rewrite Hpa in H.
    congruence.
    auto.
  Qed.

End Proofs.


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

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

Require Import int.EuclideanDivision.

(* Why3 goal *)
Lemma div2 : forall (x:Z), exists y:Z, (x = (2%Z * y)%Z) \/
  (x = ((2%Z * y)%Z + 1%Z)%Z).
Proof.
intros x.
exists (div x 2).
refine (_ (Mod_bound x 2 _) (Div_mod x 2 _)) ; try easy.
intros H1 H2.
simpl in H1.
omega.
Qed.