Require Import Arith.
Require Import List.

(*
Require Import Peano.
Require Import Peano_dec.
*)

Inductive Ty : nat -> Set :=
| TV : forall n, Ty (S n)
| Imp : forall n, Ty n -> Ty n -> Ty n
| All : forall n, Ty (S n) -> Ty n
| TW : forall n, Ty n -> Ty (S n).

Implicit Arguments TW [n].
Implicit Arguments Imp [n].
Implicit Arguments All [n].

Inductive Term : Set :=
| V : nat -> Term
| App : Term -> Term -> Term
| TApp : forall n, Term -> Ty n -> Term
| Abs : forall n, Ty n -> Term -> Term
| Lam : Term -> Term.

Implicit Arguments TApp [n].
Implicit Arguments Abs [n].

Inductive Holds : Set :=
| H : forall n, list (Ty n) -> Term -> Ty n -> Holds.

Notation "n ; l |= t @ ty" := (H n l t ty) (at level 60).
Open Scope list_scope.

Definition tyshift : forall i (ty : Ty i) (d : nat), Ty (S i).
Proof.
  refine
    (fix tyshift (i : nat) (ty : Ty i) (d : nat) {struct ty} : Ty (S i) :=
      (match ty in Ty i' return (i=i' -> Ty (S i)) with
         | TV m =>
           (fun p =>
             if le_lt_dec d m
               then _
               else _)
         | Imp i' t s => (fun t' s' p => _) (tyshift i' t d) (tyshift i' s d)
         | All i' t => (fun t' p => All _) (tyshift (S i') t (d+1))
         | TW i' t => (fun t' p => TW _) (tyshift i' t d)
       end) (refl_equal i)).
  (* d <= m *)
  rewrite p. exact (TV (S m)).
  (* d > m *)
  rewrite p. exact (TW (TV m)).
  (* Imp *)
  rewrite p. exact (Imp t' s').
  (* All *)
  rewrite p. exact t'.
  (* TW *)
  rewrite p. exact t'.
Defined.

Print tyshift.

Eval compute in (tyshift.

(*
Fixpoint tyshift (i : nat) (ty : Ty i) (d : nat) {struct ty} : Ty (S i):=
  match ty with
    | TV m => if le_lt_dec d m then TV (m+1) else TV m
    | Imp t s => Imp (tyshift t d) (tyshift s d)
    | All t => All (tyshift t (d+1))
  end.
  *)

Fixpoint tysub (ty : Ty) (d : nat) (n : nat) (s : Ty) {struct ty} : Ty :=
  match ty with
    | TV m =>
      if eq_nat_dec n m
        then s
        else if le_lt_dec d m
          then TV m
          else TV (m+1)
    | Imp ty1 ty2 => Imp (tysub ty1 d n s) (tysub ty2 d n s)
    | All t => All (tysub t (d+1) (n+1) (tyshift s d))
  end.

Fixpoint tysubt (t : Term) (d : nat) (n : nat) (s : Ty) {struct t} : Term :=
  match t with
    | V m => V m
    | Abs ty t => Abs (tysub ty d n s) (tysubt t d n s)
    | Lam t => Lam (tysubt t (d+1) n s)
    | App f g => App (tysubt f d n s) (tysubt g d n s)
    | TApp f ty => TApp (tysubt f d n s) (tysub ty d n s)
  end.

Inductive Derivation : Holds -> Set :=
| ImpIntro : forall n l t ty xty,
  Derivation (n  ; l |= t @ ty) ->
  Derivation (n ; xty::l |= (Abs xty t) @ (Imp xty ty))
| ImpElim : forall n l t f ty xty,
  Derivation (n ; l |= t @ xty) ->
  Derivation (n ; l |= f @ (Imp xty ty)) ->
  Derivation (n ; l |= (App f t) @ ty)
| AllIntro : forall n l t ty,
  Derivation (S n ; l |= t @ ty) ->
  Derivation (n ; l |= (Lam t) @ All ty)
| AllElim : forall n l t ty tyx,
  Derivation (n ; l |= (TApp t tyx) @ ty) ->
  Derivation (S n ; l |= t @ (tysub ty n n tyx))
| VarIntro : forall n l ty,
  Derivation (n ; ty::l |= V (length l) @ ty)
| Weaken : forall n l t ty,
  Derivation (n ; l |= t @ ty) ->
  Derivation (

Definition Zero := (All (TV 0)).
Definition One := (Imp Zero Zero).

Definition check : forall n l t ty, option (Derivation (n ; l |= t @ ty)).
Proof.
  induction t.


Require Import FunctionalExtensionality Setoid.
Require Export Schema.
Require Import Common Translation SetSchema.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Schema.
  Variable S : Schema.

  Record Instance := {
    TypeOf :> S -> Type;
    FunctionOf : forall s d (E : S.(Edge) s d), TypeOf s -> TypeOf d;
    EquivalenceOf : forall s d (p1 p2 : path S s d), S.(PathsEquivalent) p1 p2
      -> forall x, compose TypeOf FunctionOf p1 x = compose TypeOf FunctionOf p2 x
  }.

  Record ProgressiveUpdate (I J : Instance) := {
    PUComponentsOf :> forall c, I c -> J c;
    PUCommutes : forall s d (p : path S s d),
      forall x, PUComponentsOf d (compose I I.(FunctionOf) p x)
        = compose J J.(FunctionOf) p (PUComponentsOf s x)
  }.

  Variable I : Instance.

  Lemma compose_transferPath : forall s d (p : path S s d) x,
    compose I.(TypeOf) I.(FunctionOf) p x
    = compose (fun x => x) (fun _ _ e => e) (transferPath (I.(TypeOf) : S -> TypeSch)
      (fun _ _ e => AddEdge NoEdges (I.(FunctionOf) _ _ e)) p) x.
    induction p; simpl; intuition; f_equal; auto.
  Qed.

  Definition translationOf : Translation S TypeSch.
    refine (@Build_Translation S TypeSch
      I.(TypeOf)
      (fun _ _ e => AddEdge NoEdges (I.(FunctionOf) _ _ e))
      _);
    abstract (intros; hnf; extensionality x;
      do 2 rewrite <- compose_transferPath; apply EquivalenceOf; assumption).
  Defined.

End Schema.

Coercion translationOf : Instance >-> Translation.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import algebra.rat.
From mathcomp Require Import ssrint seq.

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

(*****************************

Próby stworzenia biekcji (N*N) <-> N

*****************************)

Notation "√ n" := (Nat.sqrt n) (at level 51).

(*
0: 0,0
1: 0,1
2: 1,0
3: 1,1
4: 0,2
5: 1,2
6: 2,0
7: 2,1
8: 2,2
9: 0,3

*)
Definition zgn (kw : nat) : (nat * nat) :=
  let n := √kw in
  let r := kw - n^2 in
  if r < n then (r,n) else (n,r-n).

Eval compute in (map (fun x => (x, zgn x)) (iota 0 20)).

Definition odgn (k : nat * nat) : nat :=
  let (a, b) := k in
  if a < b then b^2 + a else a^2+a +b.

Eval compute in (map (fun x => (odgn (zgn x)) == x) (iota 0 70)).

Lemma roznica_miedzy_kwadratami n : n.+1^2 = n^2 + 2*n +1.
Proof.
  rewrite -addn1 sqrnD -![n^2 + _ + _]addnA [1 ^2 + 2*_]addnC -[1^2]/1 muln1 //.
Qed.

Lemma roznica_miedzy_kwadratami' n : n.+1^2 = (n^2 + 2*n).+1.
Proof.
  rewrite -[in RHS]addn1.  apply: roznica_miedzy_kwadratami.
Qed.

Lemma xqnat n m : (n*m)%coq_nat = n*m.
Proof.
  done.
Qed.
Print xqnat.

Lemma sqrt_specif (n: nat): (((√ n) ^ 2) <= n) && (n < ((√ n).+1)^2).
Proof.
  move : (PeanoNat.Nat.sqrt_specif n) .
  rewrite !xqnat => [[h1 h2]].
  move : h1 h2 => /leP h1 /ltP h2.
  by apply /andP; split.
Qed.
Print sqrt_specif.
Eval compute in (map (fun n => (√ n) ^ 2 + (n - ((√ n) ^ 2)) == n) (iota 0 40)).

Lemma coo a b : a <= b -> a + (b - a) == b.
Proof.

  move=>H.
  apply /eqP .
  apply: subnKC.
  assumption.
Qed.

Lemma xd n : (√ n) ^ 2 + (n - ((√ n) ^ 2)) == n.
Proof.
  apply /eqP.
  apply: subnKC.
  by move: (sqrt_specif n) => /andP; case.
Qed.

Lemma roznica_miedzy_kwadratami'' n :
  ((√ (n.+1))^2 == ((√ n)^2 + 2*√(n)).+1) || ((√ (n.+1)) == √ n).
Proof.
  apply /orP.
  case: (PeanoNat.Nat.sqrt_succ_or n) => -> ; [left| by right].
  rewrite  roznica_miedzy_kwadratami' => //.
Qed.

Lemma roznica_miedzy_kwadratami''' n :
 (√ (n)) < √ (n.+1) -> (√ (n.+1))^2 == ((√ n)^2 + 2*√(n)).+1.
Proof.
  move => H.
  move : (roznica_miedzy_kwadratami'' n) => /orP. case => // .
  by   rewrite gtn_eqF.
Qed.

Lemma roznica_miedzy_kwadratami'''' n :
 (√ (n)) < √ (n.+1) -> (√ (n.+1))^2 = ((√ n)^2 + 2*√(n)).+1.
Proof.
  move => H.
  apply /eqP.
  apply:  roznica_miedzy_kwadratami'''.
done.
Qed.

Lemma reszta_ogr n : (n - ((√ n) ^ 2)) <= (√ n).*2.
  elim: n => // n H.
  case: (PeanoNat.Nat.sqrt_succ_or n).
  move => Hx. rewrite Hx.

    rewrite roznica_miedzy_kwadratami'.
  rewrite subSS.

  (*
subnDA: forall m n p : nat, n - (m + p) = n - m - p
subnDr: forall p m n : nat, m + p - (n + p) = m - n
subnDl: forall p m n : nat, p + m - (p + n) = m - n
   *)

  apply: (@leq_trans (n - (√ n) ^ 2)).

  apply: leq_sub2l.

  apply: leq_addr.
  apply: (@leq_trans (√ n).*2).
  apply: H.
  rewrite doubleS.
  rewrite -addn1 -addn1 -addnA.
  apply: leq_addr.
(***************)
  move => Hx. rewrite  Hx. (* rewrite [√ n.+1  in X in _ <= X]Hx.*)

Lemma zo1 n : odgn (zgn n) == n.
  rewrite /zgn /odgn .
  case: ifP; [by move => ->; rewrite xd|rewrite ltnNge; move => /negbFE H].
case: ifP.
  move => J.

  move: (roznica_miedzy_kwadratami'' n).
  (*
    H : nq <= r
    J : 2*nq < r (H potrzebne żeby to wywnioskować)
    Q: r <= 2*n

    2*nq < r <= 2*n
*)


From Tealeaves Require Export
  Classes.Monoid
  Classes.Bimonad
  Classes.RightModule
  Functors.Environment
  Data.Product.

Import Product.Notations.
Import Functor.Notations.
Import Strength.Notations.
Import Monoid.Notations.
Import Monad.Notations.

#[local] Generalizable Variables W T F A M.

(** ** Properties of <<strength>> w.r.t. monad operations *)
(** Formalizing the product functor allows expressing some general
    properties about how the monad operations interact with the
    tensorial strength operation. These laws play a role in reasoning
    about decorated monads in particular. *)
(******************************************************************************)
Section Monad_strength_laws.

  Context
    (T : Type -> Type)
    {W : Type}
    `{Monad T}.

  Lemma strength_ret : forall (A : Type),
      σ T ∘ fmap (W ×) (ret T) = ret T (A := W * A).
  Proof.
    intros. ext [w a]. unfold compose; cbn. compose near a on left.
    now rewrite (natural (G := T) (F := fun A => A)).
  Qed.

  Lemma strength_join : forall (A : Type),
      σ T ∘ fmap (W ×) (μ T) =
      μ T (A := W * A) ∘ fmap T (σ T) ∘ σ T.
  Proof.
    intros. ext [w t]. change_left (σ T (w, μ T t)).
    unfold strength, compose.
    compose near t on right.
    rewrite (fun_fmap_fmap T).
    unfold compose. change_right (μ T (fmap (T ∘ T) (pair w) t)).
    compose near t on right. now rewrite <- (natural (F := T ∘ T)).
  Qed.

  Context
    (F : Type -> Type)
    `{RightModule F T}.

  Lemma strength_right_action : forall (A : Type),
      σ F ∘ fmap (W ×) (right_action F) =
      right_action F (A := W * A) ∘ fmap F (σ T) ∘ σ F.
  Proof.
    intros. ext [w t]. change_left (σ F (w, right_action F t)).
    unfold strength, compose.
    compose near t on right.
    rewrite (fun_fmap_fmap F).
    unfold compose. change_right (right_action F (fmap (F ∘ T) (pair w) t)).
    compose near t on right. now rewrite <- (natural (F := F ∘ T)).
  Qed.

End Monad_strength_laws.

(** * Writer monad *)
(** In the even that [A] is a monoid, the product functor forms a monad. The
    return operation maps <<b>> to <<(1, b)>> where <<1>> is the monoid unit.
    The join operation monoidally combines the two monoid values. *)
(******************************************************************************)
Section writer_monad.

  Context
    `{Monoid M}.

  #[export] Instance Join_writer : Join (prod M) :=
    fun A (p : M * (M * A)) => map_fst (uncurry (@monoid_op M _)) (α^-1 p).

  #[export] Instance Return_writer : Return (prod M) :=
    fun A (a : A) => (Ƶ, a).

  #[export] Instance Natural_ret_writer : Natural (@ret (prod M) Return_writer).
  Proof.
    constructor; try typeclasses eauto.
    intros A B f. now ext a.
  Qed.

  #[export] Instance Natural_join_writer : Natural (@join (prod M) Join_writer).
  Proof.
    constructor; try typeclasses eauto.
    introv. now ext [x [x' a]].
  Qed.

  #[export, program] Instance Monad_writer : Monad (prod M).

  Solve Obligations with
      (intros; unfold transparent tcs; ext p;
      unfold compose in *; destruct_all_pairs;
      cbn; now simpl_monoid).

End writer_monad.

(** * Writer bimonad *)
(******************************************************************************)
#[export] Instance BeckDistribution_strength (W : Type) (T : Type -> Type) `{Fmap T}:
  BeckDistribution (W ×) T := (fun A => σ T).

(** ** <<T ∘ (W ×)>> is a monad *)
(******************************************************************************)
#[export] Instance Natural_strength `{Functor F} {W : Type} : Natural (F := prod W ∘ F) (@strength F _ W).
Proof.
  constructor; try typeclasses eauto.
  intros. unfold_ops @Fmap_compose. ext [a t].
  unfold compose; cbn.
  compose near t on left.
  compose near t on right.
  now rewrite 2(fun_fmap_fmap F).
Qed.

Section strength_as_writer_distributive_law.

  Context
    `{Monoid W}.

  Lemma strength_ret_l `{Functor F} : forall A : Type,
      σ F ∘ ret (W ×) (A := F A) =
      fmap F (ret (W ×)).
  Proof.
    reflexivity.
  Qed.

  Lemma strength_join_l `{Functor F} : forall A : Type,
      σ F ∘ join (W ×) (A := F A) =
      fmap F (join (W ×)) ∘ σ F ∘ fmap (W ×) (σ F).
  Proof.
    intros. ext [w1 [w2 t]]. unfold compose; cbn.
    compose near t. rewrite (fun_fmap_fmap F).
    compose near t on right. rewrite (fun_fmap_fmap F).
    reflexivity.
  Qed.

  Context
    `{Monad T}.

  #[export, program] Instance BeckDistributiveLaw_strength :
    BeckDistributiveLaw (W ×) T :=
    {| bdist_join_r := strength_join T;
       bdist_unit_r := strength_ret T;
       bdist_join_l := strength_join_l;
       bdist_unit_l := strength_ret_l;
    |}.

  #[export] Instance: Monad (T ∘ (W ×)) := Monad_Beck.

End strength_as_writer_distributive_law.

(** ** <<(W ×)>> is a bimonad *)
(******************************************************************************)
Section writer_bimonad_instance.

  Context
    `{Monoid W}.

  Lemma writer_dist_involution : forall (A : Type),
      bdist (prod W) (prod W) ∘ bdist (prod W) (prod W) = @id (W * (W * A)).
  Proof.
    intros. now ext [? [? ?]].
  Qed.

  Lemma bimonad_dist_counit_l : forall A,
      extract (W ×) ∘ bdist (W ×) (W ×) =
      fmap (W ×) (extract (W ×) (A := A)).
  Proof.
    intros. now ext [w1 [w2 a]].
  Qed.

  Lemma bimonad_dist_counit_r : forall A,
      fmap (W ×) (extract (W ×)) ∘ bdist (W ×) (W ×) =
      extract (W ×) (A := W * A).
  Proof.
    intros. now ext [w1 [w2 a]].
  Qed.

  Lemma bimonad_baton : forall A,
      extract (W ×) ∘ ret (W ×) = @id A.
  Proof.
    intros. reflexivity.
  Qed.

  Lemma bimonad_cup : forall A,
      cojoin (W ×) ∘ ret (W ×) = ret (W ×) ∘ ret (W ×) (A := A).
  Proof.
    intros. reflexivity.
  Qed.

  Lemma bimonad_cap : forall A,
      extract (W ×) ∘ join (W ×) = extract (W ×) ∘ extract (W ×) (A := W * A).
  Proof.
    intros. now ext [w1 [w2 a]].
  Qed.

  Lemma bimonad_butterfly : forall A,
      cojoin (W ×) ∘ join (W ×) (A := A) =
      fmap (W ×) (join (W ×)) ∘ join (W ×) ∘ fmap (W ×) (bdist (W ×) (W ×))
           ∘ cojoin (W ×) ∘ fmap (W ×) (cojoin (W ×)).
  Proof.
    intros. now ext [w1 [w2 a]].
  Qed.

  #[export] Instance Bimonad_Writer : Bimonad (W ×) :=
    {| bimonad_monad := Monad_writer;
       bimonad_comonad := Comonad_prod;
       Bimonad.bimonad_dist_counit_l := @bimonad_dist_counit_l;
       Bimonad.bimonad_dist_counit_r := @bimonad_dist_counit_r;
       Bimonad.bimonad_distributive_law := BeckDistributiveLaw_strength;
       Bimonad.bimonad_cup := @bimonad_cup;
       Bimonad.bimonad_cap := @bimonad_cap;
       Bimonad.bimonad_baton := @bimonad_baton;
       Bimonad.bimonad_butterfly := @bimonad_butterfly;
    |}.

End writer_bimonad_instance.

(** ** <<incr>> *)
(******************************************************************************)
Section incr.

  Context
    `{Monoid W}.

  (* It sometimes useful to have this curried operation, the
  composition of [strength] and [join]. *)
  Definition incr {A : Type} : W -> W * A -> W * A :=
    fun w2 '(w1, a) => (w2 ● w1, a).

  Lemma incr_zero {A : Type} :
    incr Ƶ = @id (W * A).
  Proof.
    ext [? ?]. cbn. now simpl_monoid.
  Qed.

  Lemma incr_incr {A : Type} : forall w1 w2,
    incr (A:=A) w2 ∘ incr w1 = incr (w2 ● w1).
  Proof.
    intros. ext [w a].
    cbn. now simpl_monoid.
  Qed.

End incr.

(** ** Miscellaneous properties *)
(******************************************************************************)
Section Writer_miscellaneous.

  Context
    (W : Type)
    `{Monoid W}.

  Lemma extract_incr {A : Type} :
    forall (w : W), extract (W ×) ∘ incr w = extract (W ×) (A := A).
  Proof.
    intros. now ext [w' a].
  Qed.

  (* This rewrite is useful when proving decoration-traversal compatibility
     in the binder case. *)
  Theorem strength_shift1 : forall (F : Type -> Type) `{Functor F} (w : W) (A : Type),
      σ F ∘ μ (W ×) ∘ pair w = fmap F (μ (W ×) ∘ pair w) ∘ σ F (B := A).
  Proof.
    intros. ext [w' x]. unfold compose; cbn.
    compose near x. now rewrite (fun_fmap_fmap F).
  Qed.

End Writer_miscellaneous.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Encode.
Require Import riscv.util.ZBitOps.
Require Import riscv.util.prove_Zeq_bitwise.

Lemma invert_encode_I: forall {opcode rd rs1 funct3 oimm12},
  verify_I opcode rd rs1 funct3 oimm12 ->
  forall inst,
  encode_I opcode rd rs1 funct3 oimm12 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  rd = bitSlice inst 7 12 /\
  rs1 = bitSlice inst 15 20 /\
  oimm12 = signExtend 12 (bitSlice inst 20 32).
Proof. intros. unfold encode_I, verify_I in *. prove_Zeq_bitwise. Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf2 : lst) (x : lst) : natural := len (append x lf2).


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

(* Certified Undecidability of Intuitionistic Linear Logic via Binary Stack Machines and Minsky Machines. Yannick Forster and Dominique Larchey-Wendling. CPP '19. http://uds-psl.github.io/ill-undecidability/ *)

Require Import List Permutation.

From Undecidability.ILL Require Import ILL.

Set Implicit Arguments.

Local Infix "~p" := (@Permutation _) (at level 70).

Notation eill_vars := nat.

Inductive eill_cmd : Set :=
  | in_eill_cmd_inc  : eill_vars -> eill_vars -> eill_vars -> eill_cmd
  | in_eill_cmd_dec  : eill_vars -> eill_vars -> eill_vars -> eill_cmd
  | in_eill_cmd_fork : eill_vars -> eill_vars -> eill_vars -> eill_cmd.

Notation LL_INC  := in_eill_cmd_inc.
Notation LL_DEC  := in_eill_cmd_dec.
Notation LL_FORK := in_eill_cmd_fork.

Definition eill_cmd_vars c :=
  match c with
    | LL_INC  a p q => a::p::q::nil
    | LL_DEC  a p q => a::p::q::nil
    | LL_FORK p q r => p::q::r::nil
  end.

(* The embedding of eill commands into ill
   or its (!,&,-o) fragment *)

Definition eill_cmd_map c :=
  match c with
    | LL_INC  a p q => (£a ⊸ £p) ⊸ £ q
    | LL_DEC  a p q => £a ⊸ £p ⊸ £ q
    | LL_FORK p q r => (£p & £q) ⊸ £ r
  end.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  !  ‼  ∅  ⊢ ⟦ ⟧ Γ Δ Σ *)

Section GeILL.

  Reserved Notation "Σ ; Γ ⊦ u" (at level 70, no associativity).

  Inductive G_eill (Σ : list eill_cmd) : list eill_vars -> eill_vars -> Prop :=
    | in_geill_ax  : forall u,                                    Σ; u::∅ ⊦ u
    | in_geill_perm : forall Γ Δ p,    Γ ~p Δ                 ->  Σ; Γ     ⊦ p
                                                              ->  Σ; Δ     ⊦ p
    | in_geill_inc : forall Γ a p q,   In (LL_INC a p q) Σ    ->  Σ; a::Γ  ⊦ p
                                                              ->  Σ; Γ     ⊦ q
    | in_geill_dec : forall Γ Δ p q r, In (LL_DEC p q r) Σ    ->  Σ; Γ     ⊦ p
                                                              ->  Σ; Δ     ⊦ q
                                                              ->  Σ; Γ++Δ  ⊦ r
    | in_geill_fork : forall Γ p q r,  In (LL_FORK p q r) Σ   ->  Σ; Γ     ⊦ p
                                                              ->  Σ; Γ     ⊦ q
                                                              ->  Σ; Γ     ⊦ r
  where "Σ ; Γ ⊦ u" := (G_eill Σ Γ u).

End GeILL.

Definition EILL_SEQUENT := (list eill_cmd * list eill_vars * eill_vars)%type.

Definition EILL_PROVABILITY (c : EILL_SEQUENT) := match c with (Σ,Γ,u) => G_eill Σ Γ u end.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   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 A def l) in H2.
  exact H2.
- 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 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.

(* --------------------------------------------------------------------- *)
(* 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.


(** * Nat-indexed infinite sequences *)

Require Import Automatik.lib.operators.
Require Import Arith List.
Import ListNotations.

Section Sequence.

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

Definition nth {A : Type} (s : t A) (i : nat) : A :=
  s i.

Definition equ {A : Type} (s1 s2 : t A) : Prop :=
  forall i, s1 i = s2 i.

Definition shift {A : Type} (s : t A) (i : nat) : t A :=
  fun x => s (i + x).

Lemma shift_assoc:
  forall A (s : @t A) i j,
    equ (shift (shift s i) j) (shift s (i + j)).
Proof.
  intros * n.
  unfold shift.
  now rewrite Nat.add_assoc.
Qed.

Fixpoint range {A : Type} (s : t A) (i j : nat) {struct j} : list A :=
  if j <? i then []
  else if i =? j then [s i]
  else match j with
  | 0 => []
  | S j' => (range s i j') ++ [s j]
  end.

Definition repeat {A : Type} (a : A) (l : list A) : t A :=
  fun i => List.nth (i mod (List.length l)) l a.

End Sequence.

Instance nth_op (A : Type) : NthOp (t A) A := nth.
Instance shift_op (A : Type) : ShiftOp (t A) A := shift.
Instance range_op (A : Type) : RangeOp (t A) A (list A) := range.
Instance equ_op (A : Type) : EquOp (t A) := equ.


Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 5.
Ltac z3 := why3 "z3" timelimit 5.

Require Export ZArith.
Open Scope Z_scope.
Require Export Lists.List.

Section S0.
  Variable a:Set->Set.

  Goal forall b:Set->Set, forall x:a nat, x=x.
    intros; ae.
  Qed.

Goal
  forall f: (nat->nat)->nat, f S = O -> True.
intros; ae.
Qed.

End S0.

(* Mutually inductive types *)

Inductive tree : Set :=
  | Leaf : tree
  | Node : Z -> forest -> tree
with forest : Set :=
  | Nil : forest
  | Cons : tree -> forest -> forest.

Fixpoint tree_size (t:tree) : Z := match t with
  | Leaf => 0
  | Node _ f => 1 + forest_size f end
with forest_size (f:forest) : Z := match f with
  | Nil => 0
  | Cons t f => tree_size t + forest_size f end.

Goal tree_size (Node 42 (Cons Leaf Nil)) = 1.
ae.
Qed.

Goal (match Leaf with Leaf => 1 | Node z f => 2 end)=1.
ae.
Qed.

Inductive foo : Set :=
  | OO : foo
  | SS : forall x:nat, p x -> foo
with p : nat -> Prop :=
  | cc : p O.

Goal p O.
(* not a first order goal
ae.
*)
exact cc.
Qed.

Inductive fooo : nat -> Prop :=
  c : bar O -> fooo O
with bar : nat -> Prop :=
  d : forall f:nat->nat, bar (f O).

Goal fooo O.
(* Don't know
ae.
*)
exact (c (d (fun x => O))).
Qed.

Inductive tree' : Set :=
  | Empty' : tree'
  | Node' : forest' -> tree'
with forest' : Set :=
  | Forest' : (nat -> tree') -> forest'.

Goal forall f: nat ->tree, True.
intros.
ae.
Qed.

Parameter f : (nat -> nat) -> nat.

Goal f (plus O) = f (plus O).
(* not a first order goal
ae.
*)
trivial.
Qed.

Parameter f' : nat -> nat.

Axiom f'_def: f' O = O.

Goal f' (f' O) = O.
ae.
Qed.

Variable b:Set.

Section S.

Variable b:Set->Set.

Variable a:Set.

Inductive sorted : list a -> Prop :=
  ccc: sorted (@nil a)
| ddd: forall x: a, sorted (cons x nil).

Variable f : a -> a.

Goal True.
ae.
Qed.

Goal forall x: a, f (f x) = f x -> f (f (f x)) = f x.
intros.
ae.
Qed.

Goal forall l: list a, l=l.
ae.
Qed.

End S.

Goal True.
ae.
Qed.

Parameter par: Z -> Prop.

(* let in *)
Goal
  let t := Z in
  let f := par 0 in
  (forall x:t, par x -> par (let y := x+1 in y)) ->
  f -> par 1.
ae.
Qed.

(* cast *)
Goal
  (
  (forall x:Z, par x -> par (x+1)) -> par (0 : Z) -> par 1 : Prop).
ae.
Qed.

(* type definitions *)

Parameter t : Set -> Set.

Inductive foobar : Set :=
  C : t nat -> foobar.

Goal forall x:foobar, x=x.
intros.
ae.
Qed.

(* predicate definition *)

Definition p' (x:nat) := x=O.

Goal p' O.
ae.
Qed.

Goal plus O O = O.
ae.
Qed.

Definition eq' (A:Set) (x y : A) := x=y.

Goal
  eq' nat O O.
ae.
Qed.

Definition pred (n:nat) := match n with
  | O => O
  | S p => p
  end.

Goal pred (S O) = O.
ae.
Qed.

(* function definition *)

Definition ff (x:Z) (y:Z) := x+y.

Goal ff 1 2 = 3.
ae.
Qed.

Definition id A (x:A) := x.

Goal id nat O = O.
ae.
Qed.

(* recursive function definition *)

Goal length (cons 1 (cons 2 nil)) = S (S O).
ae.
Qed.

(* recursive predicate definition *)

Goal In 0 (cons 1 (cons 0 nil)).
ae.
Qed.

(* inductive types *)

Parameter P : (nat -> nat) -> Prop.

Goal forall (a:Set), forall x:nat, x=S O -> P S ->
  let y := (S (S O)) in S x=y.
intros.
ae.
Qed.

Goal  forall (a:Set), forall x:Z, x=1 -> P S -> let y := 2 in x+1=y.
intros.
ae.
Qed.

Goal  forall x: list nat, x=x.
intros.
ae.
Qed.

Goal (match (S (S (S O))) with (S (S _)) => True | _ => False end).
ae.
Qed.

Goal
  forall a, forall (x: list (list a)),
  1<=2 -> match x with nil => 1 | x :: r => 2 end <= 2.
intros a x.
assert (x=nil \/ exists y: list a, exists z:list (list a),
                 x = cons y z).
destruct x; ae.
ae.
Qed.

(* Polymorphic, Mutually inductive types *)

Inductive ptree (a:Set) : Set :=
  | PLeaf : ptree a
  | PNode : a -> pforest a -> ptree a

with pforest (a:Set) : Set :=
  | PNil : pforest a
  | PCons : ptree a -> pforest a -> pforest a.

Goal forall x : ptree Z, x=x.
ae.
Qed.

Definition a := 0+0.
Definition bb := a.

Goal bb=0.
ae.
Qed.

Goal bb=0.
ae.
Qed.

Fixpoint ptree_size (a:Set) (t:ptree a) : Z := match t with
  | PLeaf => 0
  | PNode _ f => 1 + pforest_size _ f end
with pforest_size (a:Set) (f:pforest a) : Z := match f with
  | PNil => 0
  | PCons t f => ptree_size _ t + pforest_size _ f end.

Goal ptree_size _ (@PLeaf Z) = 0.
ae.
Qed.

Goal forall (a:Set), ptree_size a (PLeaf a) = 0.
intros.
ae.
Qed.

(* the same, without parameters *)

Inductive ptree' : Type -> Type :=
  | PLeaf' : forall (a:Type), ptree' a
  | PNode' : forall (a:Type), a -> pforest' a -> ptree' a

with pforest' : Type -> Type :=
  | PNil' : forall  (a:Type), pforest' a
  | PCons' : forall (a:Type), ptree' a -> pforest' a -> pforest' a.

Goal forall x : ptree' Z, x=x.
ae.
Qed.

(* order of type parameters matters *)

Definition wgt (k:(nat * Z)%type) := match k with
  | (_, p) => p
  end.
Implicit Arguments wgt.

Goal wgt (S O, 3) = 3.
ae.
Qed.

Require Import Rbase.
Require Import R_sqrt.
Require Import Rfunctions.
Require Import Rbasic_fun.

Goal forall (x:R), (0 <= x * x)%R.
(* don't know
ae
*)
(* timeout
z3.
*)
(* timeout
why3 "cvc3" timelimit 3.
*)
intros.
Admitted.


Set Warnings "-deprecated-hint-without-locality,-deprecated-hint-without-locality".
From PLF Require Import Maps.
From PLF Require Import Hoare.
Hint Constructors ceval : core.

Inductive derivable : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      derivable P <{skip}> P
  | H_Asgn : forall Q V a,
      derivable (Q [V |-> a]) <{V := a}> Q
  | H_Seq : forall P c Q d R,
      derivable P c Q -> derivable Q d R -> derivable P <{c;d}> R
  | H_If : forall P Q (b: bexp) c1 c2,
    derivable (P /\  b) c1 Q ->
    derivable (P /\ ~b) c2 Q ->
    derivable P <{if b then c1 else c2 end}> Q
  | H_While : forall P (b: bexp) c,
    derivable (P /\ b) c P ->
    derivable P <{while b do c end}> (P /\ ~b)
  | H_Consequence : forall (P Q P' Q' : Assertion) c,
    derivable P' c Q' ->
    (P ->> P') ->
    (Q' ->> Q) ->
    derivable P c Q.

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    derivable P' c Q ->
    (P ->> P') ->
    derivable P c Q.
Proof. eauto using H_Consequence. Qed.

Lemma H_Consequence_post : forall (P Q Q' : Assertion) c,
    derivable P c Q' ->
    (Q' ->> Q) ->
    derivable P c Q.
Proof. eauto using H_Consequence. Qed.

Example sample_proof :
  derivable
    ((assert (X = 3)) [X |-> X + 2] [X |-> X + 1])
    <{ X := X + 1; X := X + 2}>
    (assert (X = 3)).
Proof.
  eapply H_Seq.
  - apply H_Asgn.
  - apply H_Asgn.
Qed.

Theorem provable_true_post : forall c P,
    derivable P c True.
Proof.
  intro c.
  induction c; intro P.
  - eapply H_Consequence_post.
    eapply (H_Skip).
    auto.
  - eapply H_Consequence_pre.
    eapply (H_Asgn).
    auto.
  - eapply (H_Seq).
    apply IHc1.
    apply IHc2.
  - apply H_If.
    apply IHc1.
    apply IHc2.
  - eapply H_Consequence.
    eapply H_While.
    apply IHc.
    auto. auto.
Qed.

Lemma false_assrt: forall Q, False ->> Q.
Proof. intros Q st F. simpl in F. destruct F. Qed.

Theorem provable_false_pre : forall c Q,
    derivable False c Q.
Proof.
  intro c.
  induction c; intro Q.
  - eapply H_Consequence_pre.
    eapply (H_Skip).
    apply false_assrt.
  - eapply H_Consequence_pre.
    eapply (H_Asgn).
    apply false_assrt.
  - eapply (H_Seq).
    apply IHc1.
    apply IHc2.
  - eapply H_If.
    + eapply H_Consequence_pre.
      apply IHc1. simpl.
      intros st [F _]. apply F.
    + eapply H_Consequence_pre.
      apply IHc2. simpl.
      intros st [F _]. apply F.
  - eapply H_Consequence.
    + eapply H_While.
      eapply H_Consequence_pre.
      eapply IHc.
      intros st [F _]. apply F.
    + apply false_assrt.
    + simpl. intros st [F _]. destruct F.
Qed.

Theorem hoare_sound : forall P c Q,
  derivable P c Q -> {{P}} c {{Q}}.
Proof.
  intros P c Q Hder.
  induction Hder; intros st st' com Hp.
  - inversion com; subst. assumption.
  - inversion com; subst. unfold assn_sub in Hp. assumption.
  - inversion com; subst.
    eapply IHHder2. apply H4.
    eapply IHHder1. apply H1.
    apply Hp.
  - inversion com; subst.
    + (* if true *)
      eapply IHHder1. apply H5.
      split. apply Hp. apply H4.
    + (* if false *)
      eapply IHHder2. apply H5.
      split. apply Hp. simpl. intro Contra. congruence.
  - remember <{ while b do c end }> as k eqn:Ek.
    induction com; try (discriminate Ek).
    + injection Ek as Ek1 Ek2. subst. split.
      * assumption.
      * intro Contra. congruence.
    + injection Ek as Ek1 Ek2. subst.
      apply IHcom2; try reflexivity.
      eapply IHHder.
      apply com1.
      split.
      * assumption.
      * apply H.
  - apply a0.
    eapply IHHder.
    apply com.
    apply a.
    assumption.
Qed.

(* Weakest precondifiton for Q *)
Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', s =[ c ]=> s' -> Q s'.
Hint Unfold wp : core.

Theorem wp_is_precondition : forall c Q,
  {{wp c Q}} c {{Q}}.
Proof. intros c Q st st' com. unfold wp. intro H. auto. Qed.

Theorem wp_is_weakest : forall c Q P',
    {{P'}} c {{Q}} -> P' ->> (wp c Q).
Proof. eauto. Qed.

Lemma wp_seq : forall P Q c1 c2,
    derivable P c1 (wp c2 Q) -> derivable (wp c2 Q) c2 Q -> derivable P <{c1; c2}> Q.
Proof.
  intros P Q c1 c2 H1 H2.
  eapply H_Seq.
  apply H1.
  apply H2.
Qed.

Lemma wp_invariant : forall b c Q,
    hoare_triple (wp <{while b do c end}> Q /\ b) c (wp <{while b do c end}> Q).
Proof.
  intros b c Q st st' com [H1 H2].
  unfold wp in *.
  intros s' comWhile.
  apply H1.
  eapply E_WhileTrue.
  - apply H2.
  - apply com.
  - apply comWhile.
Qed.

(*
Lemma split_seq: forall P Q c1 c2,
  {{P}} c1; c2 {{Q}} -> {{wp c2 Q}} c2 {{Q}} /\ {{P}} c1 {{wp c2 Q}}.
Proof.
  intros P Q c1 c2 H.
  unfold hoare_triple in H.
  split.
  - intros st' st'' comC2 Hwp.
    eapply (H).
    eapply E_Seq.
*)

Theorem hoare_complete: forall P c Q,
  {{P}} c {{Q}} -> derivable P c Q.
Proof.
  intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* skip *)
    eapply H_Consequence_post.
    apply H_Skip.
    intros st Hpst.
    unfold hoare_triple in HT.
    apply (HT st st).
    + apply E_Skip.
    + assumption.
  - (* assign *)
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros st Hpst.
    unfold hoare_triple in HT.
    apply (HT st).
    + apply E_Asgn.
      reflexivity.
    + assumption.
  - (* seq *)
    apply wp_seq.
    + apply IHc1.
      unfold hoare_triple in HT.
      intros st st' comC1 Hpst. unfold wp.
      intros s' comC2.
      eapply HT.
      eapply E_Seq.
      apply comC1.
      apply comC2.
      apply Hpst.
    + apply IHc2.
      unfold hoare_triple in HT.
      intros st st' comC2 Hwp.
      apply Hwp.
      apply comC2.
  - (* if *)
    apply H_If.
    + (* true *)
      apply IHc1.
      intros st st' comC1 [Hpst Hb].
      eapply HT.
      apply E_IfTrue.
      apply Hb.
      apply comC1.
      apply Hpst.
    + (* false *)
      apply IHc2.
      intros st st' comC1 [Hpst Hnotb].
      eapply HT.
      apply E_IfFalse.
      assert (G: beval st b = false). {
        destruct (beval st b) eqn:Hb.
        * exfalso. apply Hnotb. apply Hb.
        * reflexivity.
      }
      apply G.
      apply comC1.
      apply Hpst.
  - (* while *)
    eapply H_Consequence.
    + eapply H_While.
      apply IHc.
      apply wp_invariant.
    + apply wp_is_weakest.
      apply HT.
    + intros st [H1 H2].
      apply H1.
      apply E_WhileFalse.
      assert (G: beval st b = false). {
        destruct (beval st b) eqn:Hb.
        * exfalso. apply H2. apply Hb.
        * reflexivity.
      }
      apply G.
Qed.


Require Export prosa.model.priority.classes.

(** * Cumulative Workload of Sets of Jobs *)

(** In this module, we define the notion of the cumulative workload of
    a set of jobs. *)
Section WorkloadOfJobs.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (** ... and any type of jobs with execution costs that are
      associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobCost Job}.

  (** Consider any job arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** First, we define the workload for generic sets of jobs. *)
  Section WorkloadOfJobs.

    (** Given any computable predicate on jobs, ... *)
    Variable P : pred Job.

    (** ... and any (finite) set of jobs, ... *)
    Variable jobs : seq Job.

    (** ... we define the total workload of the jobs that satisfy
        predicate [P]. *)
    Definition workload_of_jobs := \sum_(j <- jobs | P j) job_cost j.

  End WorkloadOfJobs.

  (** Next, we define the workload of jobs with higher or
      equal priority under JLFP policies. *)
  Section PerJobPriority.

    (** Consider any JLFP policy that indicates whether a job has
        higher or equal priority. *)
    Context `{JLFP_policy Job}.

    (** Let j be the job to be analyzed. *)
    Variable j : Job.

    (** Recall the notion of a job of higher or equal priority. *)
    Let of_higher_or_equal_priority j_hp := hep_job j_hp j.

    (** Then, we define the workload of higher or equal priority of all jobs
       with higher-or-equal priority than j. *)
    Definition workload_of_higher_or_equal_priority_jobs :=
      workload_of_jobs of_higher_or_equal_priority.

  End PerJobPriority.

  (** We also define workload of a task. *)
  Section TaskWorkload.

    (** Let [tsk] be the task to be analyzed. *)
    Variable tsk : Task.

    (** We define the task workload as the workload of jobs of task
        [tsk]. *)
    Definition task_workload jobs := workload_of_jobs (job_of_task tsk) jobs.

    (** Finally, we define the task's workload in a given interval [[t1,
        t2)]. *)
    Definition task_workload_between (t1 t2 : instant) :=
      task_workload (arrivals_between arr_seq t1 t2).

  End TaskWorkload.

End WorkloadOfJobs.


Require Export BPlusTree.
Require Export ValidBPlusTree.
Require Export SortingProofs.
Require Export AppearsInKVL.
Require Export HeightProofs.
Require Export InsertProofs.

Theorem not_appears_leaf_impl_search_leaf_not_found: forall (X: Type) k (l: list (nat *X)),
  kvl_sorted l ->
  ~ appears_in_kvl k l ->
  search_leaf k l = None.
Proof.
  intros. induction l. simpl. reflexivity.
  destruct a.
  assert ( ~ appears_in_kvl k ((n, x) :: l)) by assumption.
  apply not_appears_in_kvl_key_not_equal with (l1:=[]) in H1.
  simpl.
  assert (beq_nat n k = false).
    apply beq_nat_false_iff.
  omega. rewrite H2.
  apply IHl.
  apply list_tail_is_sorted in H. assumption.
  apply not_appears_in_kvl_impl_remove_element with (l1:=[]) in H0.
  assumption.
Qed.

Theorem not_appears_impl_search'_not_found : forall (X: Type) (b sk: nat)
                                             (t: bplustree b X),
  valid_bplustree b X t ->
  ~ appears_in_tree sk t ->
  search' (height t) sk t = None.
Proof.
  intros. remember (height t) as counter.
  generalize dependent b. generalize dependent sk.
  induction counter; intros.
  Case "height t = 0".
    simpl. destruct t. eapply not_appears_leaf_impl_search_leaf_not_found.
    inversion H. assumption.
    unfold not in H0. unfold not. intro. apply H0. apply ait_leaf. assumption.
    reflexivity.
  Case "height t = S height t".
    inversion H.
    SCase "bptLeaf".
      subst. simpl in Heqcounter. inversion Heqcounter.
    SCase "bptNode".
      simpl.
      remember (find_subtree sk kpl).
      destruct o.
      SSCase "find_subtree = Some p".
        symmetry in Heqo. destruct p.
        assert (find_subtree sk kpl = Some (n, b0)) by assumption.
        (* Our goal here is to find all the requirements for using IHcounter
         * on the tree b0. *)
        assert (valid_bplustree b X b0).
          apply find_subtree_impl_kpl_app in H10.
          do 2 destruct H10. inversion H10. clear H10.
          rewrite H11 in H5.
          apply all_values_single in H5.
          apply valid_sub_bplustree_impl_valid_bplustree in H5.
          apply H5.
        assert (~ appears_in_tree sk b0).
          unfold not. unfold not in H0. intro.
          apply not_appears_in_subtree_when_not_appears_in_tree_and_found in Heqo.
          unfold not in Heqo. apply Heqo in H12. assumption.
          rewrite <- H9 in H. assumption.
          rewrite <- H9 in H0. assumption.
        assert (counter = height b0).
          apply find_subtree_impl_kpl_app in H10.
          do 2 destruct H10. inversion H10. clear H10.
          apply height_of_parent_one_bigger in H13.
          rewrite H9 in H13.
          omega.
          apply H6.

        apply IHcounter; assumption. reflexivity.
Qed.

Theorem not_appears_impl_search_not_found: forall (b: nat) (X: Type) (t: bplustree b X) (k: nat),
  valid_bplustree b X t ->
  ~ appears_in_tree k t ->
  search k t = None.
Proof.
  intros. unfold search.
  apply not_appears_impl_search'_not_found; try assumption.
Qed.


(**************************************************************************************************)
(* Total Constructor/Destructorization for Local (Co)pattern Matching.                                   *)
(*                                                                                *)
(* File: Sublist.v                                                                                *)
(*                                                                                *)
(**************************************************************************************************)

Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import GenericTactics.
Require Import GenericLemmas.

Inductive sublist {A : Type} : list A -> list A -> Prop :=
| sublist_nil: forall (ls : list A), sublist [] ls
| sublist_skip: forall (sub tot: list A) (a : A),
    sublist sub tot ->
    sublist sub (a :: tot)
| sublist_cons: forall (sub tot: list A) (a : A),
    sublist sub tot ->
    sublist (a :: sub) (a :: tot).

Lemma In_sublist: forall {A : Type} (sub tot : list A) (a : A),
    sublist sub tot ->
    In a sub ->
    In a tot.
Proof.
  intros A sub tot a H H0.
  gen_induction sub tot; destruct sub; inversion H0; inversion H; subst.
  - right. apply IHtot with (sub := a :: sub); try assumption.
  - left; auto.
  - right. apply IHtot with (sub := a1 :: sub); try assumption.
  - right; IH_auto_tac.
Qed.

Lemma sublist_refl: forall {A : Type} (ls : list A),
    sublist ls ls.
Proof.
  intros A ls.
  induction ls; try apply sublist_nil.
  apply sublist_cons; assumption.
Qed.

Lemma sublist_trans: forall {A : Type} (l m r: list A),
    sublist l m ->
    sublist m r ->
    sublist l r.
Proof with try assumption; try apply sublist_nil.
  intros A l m r H H0.
  assert (Hy: forall s t (a : A), sublist s t -> sublist s (a :: t));
  [> clear; intros s t a H1; apply sublist_skip; assumption | ].
  assert (Hx: forall s t (a : A), sublist (a :: s) t -> sublist s t).
  { clear - Hy; intros s t a H1.
    gen_induction s t; inversion H1; subst...
    - apply sublist_skip. IH_auto_tac.
    - apply Hy...
  }
  gen_induction (r, m) l; try apply sublist_nil.
  gen_induction m r; destruct m; try solve [inversion H]; try solve [inversion H0].
  inversion H; subst.
  - inversion H0; subst.
    + apply Hy. IH_auto_tac.
    + apply Hy. IH_auto_tac.
  - inversion H0; subst.
    + apply Hy. specialize (IHr (a1 :: m)).
      IH_tac.
    + apply sublist_cons.
      apply IHl with (m := m)...
Qed.

Lemma sublist_app_extend_cov: forall {A : Type} (s t l r : list A),
    sublist s t ->
    sublist s (l ++ t ++ r).
Proof.
  intros A s t l r H.
  gen_induction s l.
  - gen_induction s t; simpl; destruct s as [|s s_rest]; inversion H; try apply sublist_nil.
    + apply sublist_skip. apply IHt; assumption.
    + apply sublist_cons. apply IHt; assumption.
  - apply sublist_skip; IH_auto_tac.
Qed.

Lemma sublist_app_extend_contrav: forall {A : Type} (s t l r : list A),
    sublist (l ++ s ++ r) t ->
    sublist s t.
Proof.
  intros A s t l r H.
  apply sublist_trans with (m := l ++ s ++ r); try assumption.
  apply sublist_app_extend_cov. apply sublist_refl.
Qed.

Lemma sublist_app_embed_l: forall {A : Type} (l r : list A),
    sublist l (l ++ r).
Proof.
  intros A l r.
  induction l.
  - apply sublist_nil.
  - simpl. apply sublist_cons; assumption.
Qed.

Lemma sublist_app_embed_r: forall {A : Type} (l r : list A),
    sublist r (l ++ r).
Proof.
  intros A l r.
  induction l.
  - simpl. apply sublist_refl.
  - simpl. apply sublist_skip; assumption.
Qed.

Lemma sublist_app: forall {A : Type} (l l' r r' : list A),
    sublist l r ->
    sublist l' r' ->
    sublist (l ++ l') (r ++ r').
Proof.
  intros A l l' r r' H H0.
  gen_induction l r; destruct l; inversion H; subst; try assumption; simpl; clear H.
  - apply sublist_skip. apply IHr with (l := []). apply sublist_nil.
  - apply sublist_skip. apply IHr with (l := []). apply sublist_nil.
  - apply sublist_skip. apply IHr with (l := (a0 :: l)). assumption.
  - apply sublist_cons. IH_auto_tac.
Qed.

Lemma sublist_concat': forall {A : Type} (ss ts : list (list A)),
    Forall2 (fun xs ys => sublist xs ys) ss ts ->
    sublist (concat ss) (concat ts).
Proof.
  intros A ss ts H.
  gen_induction ss ts; destruct ss; inversion H; try apply sublist_nil.
  subst; simpl. apply sublist_app; try assumption.
  IH_auto_tac.
Qed.

Lemma sublist_concat: forall {A B : Type} (ls : list A) (f g : A -> list B),
    Forall (fun x => sublist (f x) (g x)) ls ->
    sublist (concat (map f ls)) (concat (map g ls)).
Proof.
  intros A B ls f g H.
  induction ls; try apply sublist_nil.
  simpl; inversion H; subst.
  apply sublist_app; try assumption. IH_auto_tac.
Qed.

Lemma sublist_map: forall {A B : Type} (sub tot : list A) (f : A -> B),
    sublist sub tot ->
    sublist (map f sub) (map f tot).
Proof.
  intros A B sub tot f H.
  gen_induction sub tot; inversion H; simpl; try apply sublist_nil.
  - apply sublist_skip. apply IHtot; auto.
  - apply sublist_cons. apply IHtot; auto.
Qed.

Lemma sublist_singleton_In: forall {A : Type} (x : A) (ls : list A),
    In x ls <-> sublist [x] ls.
Proof.
  intros A x ls.
  split; intro; induction ls; inversion H; subst.
  - apply sublist_cons; apply sublist_nil.
  - apply sublist_skip; auto.
  - right; auto.
  - left; auto.
Qed.

Lemma sublist_filter: forall {A : Type} (p: A -> bool) (ls : list A),
    sublist (filter p ls) ls.
Proof.
  intros A p ls.
  induction ls.
  - simpl. apply sublist_nil.
  - simpl. match_destruct_tac.
    + apply sublist_cons; auto.
    + apply sublist_skip; auto.
Qed.

Ltac sublist_tac :=
  try assumption;
  try apply sublist_refl;
  try apply sublist_nil;
  try apply sublist_app_embed_l;
  try apply sublist_app_embed_r;
  try (apply sublist_map; sublist_tac);
  try (apply sublist_app_extend_cov; sublist_tac);
  try (rewrite <- app_nil_l; apply sublist_app_extend_cov; sublist_tac);
  try (rewrite <- app_nil_r; rewrite <- (app_assoc _ _ []) ; apply sublist_app_extend_cov; sublist_tac);
      (* checking for equality in match is too restrictive, e.g. alpha-equivalence *)
  match goal with
  | [  |- sublist (filter ?f ?l) ?l ] => apply sublist_filter
  | [  |- sublist (?x :: _) (?x :: _) ] => apply sublist_cons; sublist_tac
  | [  |- sublist ?sl (?x :: ?sl) ] =>
    rewrite <- app_nil_r; simpl;
    apply sublist_app_extend_cov with (l := [x]) (t := sl) (r := []); sublist_tac
  | [  |- sublist (?sl ++ ?sr) (?tl ++ ?tr) ] =>
    apply sublist_app; sublist_tac
  | [ H: sublist (?l' ++ ?s' ++ ?r') ?t |- sublist ?s' ?t' ] =>
    apply sublist_app_extend_contrav with (l := l') (r := r'); sublist_tac
  | [ H: sublist (?s' ++ ?r') ?t |- sublist ?s' ?t' ] =>
    apply sublist_app_extend_contrav with (l := []) (r := r'); sublist_tac
  | [ H: sublist (?l' ++ ?s') ?t |- sublist ?s' ?t' ] =>
    apply sublist_app_extend_contrav with (l := l') (r := []); rewrite app_nil_r; sublist_tac
  | [ H: sublist (?x ::?s') ?t |- sublist ?s' ?t' ] =>
    apply sublist_app_extend_contrav with (l := [x]) (r := []); rewrite app_nil_r; sublist_tac
  end.

Lemma Forall_sublist: forall {A : Type} (P : A -> Prop) (ss ts : list A),
    Forall P ts ->
    sublist ss ts ->
    Forall P ss.
Proof.
  intros A P ss ts H H0.
  gen_induction ss ts.
  - inversion H0; apply Forall_nil.
  - destruct ss; try apply Forall_nil.
    apply Forall_cons; inversion_clear H; inversion H0; subst.
    + specialize (IHts H2 (a0 :: ss) H4). inversion IHts; assumption.
    + assumption.
    + apply IHts; auto; sublist_tac.
    + apply IHts; auto.
Qed.

Lemma map_combine_fst_sublist: forall {A B : Type} (ls : list A) (rs : list B),
    sublist (map fst (combine ls rs)) ls.
Proof.
  intros A B ls rs.
  gen_induction rs ls; destruct rs; simpl; try apply sublist_nil.
  apply sublist_cons; auto.
Qed.

Lemma map_combine_snd_sublist: forall {A B : Type} (ls : list A) (rs : list B),
    sublist (map snd (combine ls rs)) rs.
Proof.
  intros A B ls rs.
  gen_induction ls rs; destruct ls; simpl; try apply sublist_nil.
  apply sublist_cons; auto.
Qed.

Ltac In_sublist_tac :=
  match goal with
  | [ H: In ?x ?sub' |- In ?x ?tot' ] =>
    apply In_sublist with (sub := sub') (tot := tot'); sublist_tac
  end.

Ltac Notin_sublist_tac :=
  match goal with
  | [ H: ~In ?x ?tot' |- ~In ?x ?sub' ] =>
    let H' := fresh in
    intro H'; apply H; In_sublist_tac
  end.

Ltac In_concat_tac :=
  match goal with
  | [ H': In ?e ?ls |- In ?e (concat ?ls') ] =>
    let H := fresh in
    pose proof (In_concat ls') as H;
    specialize H with (x := e) (2 := H');
    apply H;
    try unfold compose in *;
    match goal with
    | [  |- In _ (map ?ff _) ] => apply in_map with (f := ff); auto
    end
  end.

Ltac notin_reduce_tac ls :=
  match goal with
  | [ H: ~In ?x (?l ++ ?r) |- _ ] =>
    let H' := fresh in
    let sub :=
        match l with
        | context [ls] => l
        | _ => r
        end
    in assert (H': ~ In x sub); [> intro; apply H; In_sublist_tac | clear H; rename H' into H];
       notin_reduce_tac ls
  | _ => idtac
  end.

Lemma sublist_filter_cong: forall {A : Type} (f : A -> bool) (sub tot : list A),
    sublist sub tot ->
    sublist (filter f sub) (filter f tot).
Proof.
  intros A f sub tot H.
  induction H; simpl; try sublist_tac.
  - match_destruct_tac; auto.
    apply sublist_skip; auto.
  - match_destruct_tac; try apply sublist_cons; auto.
Qed.

Lemma sublist_map_inv: forall {A B : Type} (g : A -> B) (sub : list B) (l : list A),
    sublist sub (map g l) ->
    exists (sub': list A), map g sub' = sub.
Proof.
  intros A B g sub l H.
  gen_induction sub l; inversion_clear H; auto.
  - exists []; auto.
  - exists []; auto.
  - specialize (IHl _ H0).
    inversion IHl as (sub' & E).
    exists (a :: sub'); simpl; f_equal; auto.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype div tuple bigop ssralg poly polydiv finfun.
From mathcomp Require Import generic_quotient.

From Newtonsums Require Import auxresults valuation revpoly fraction.

(* This file gathers results on reverse of polynomial and fractions *)
(* to avoid cylic dependencies between revpoly.v and fraction.v *)

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

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope quotient_scope.

Reserved Notation "{ 'fracpoly' T }" (at level 0, format "{ 'fracpoly'  T }").
Reserved Notation "x %:F" (at level 2, format "x %:F").
Reserved Notation "p \FPo q" (at level 50, format "p  \FPo  q").

Section FracRev.

Variable (K : fieldType).

Lemma tofrac_revp (p : {poly K}) :
  (revp p) %:F = (p %:F \FPo 'X^-1) * ('X  %:F ^+(size p).-1).
Proof.
have [peq0 | pN0] := boolP (p == 0).
move/eqP : peq0 => peq0 ; rewrite peq0 comp_fracpoly0 mul0r.
  apply/eqP; rewrite raddf_eq0 ?revp_eq0 //.
  exact: tofrac_inj.
rewrite comp_poly_XV revp_sumE mulr_suml rmorph_sum /=; apply: eq_bigr => i _.
rewrite tofrac_scale -mulrA; congr (_ * _); rewrite mulrC.
rewrite -exprB; last 2 first.
+ by rewrite -ltnS prednK // size_poly_gt0.
+ rewrite unitfE raddf_eq0 ?polyX_eq0 //.
  exact: tofrac_inj.
by rewrite -subn1 -addn1 subnDA rmorphX subnAC.
Qed.

Lemma tofracpolyXV_eq0 (p : {poly K}) : (p%:F \FPo 'X^-1 == 0) = (p == 0).
Proof.
rewrite -revp_eq0 -[RHS](rmorph_eq0 [injmorphism of @tofrac]) /=.
by rewrite tofrac_revp mulf_eq0 orbC expf_eq0 rmorph_eq0 polyX_eq0 andbF.
Qed.

Lemma fracpolyXV_eq0 (f : {fracpoly K}) :
    (f \FPo 'X^-1 == 0) = (f == 0).
Proof.
have [[p q] /= -> /andP [a_neq0 cpq]] := fracpolyE f.
rewrite comp_frac_frac // !mulf_eq0 !invr_eq0.
by rewrite !tofracpolyXV_eq0 !rmorph_eq0.
Qed.

Lemma nocomp_fracpolyXV (f : {fracpoly K}) : nocomp_fracpoly f 'X^-1 = false.
Proof.
have [->|f_neq0]:= eqVneq f 0; first by rewrite nocomp_polyF.
by apply/negP => /comp_fracpoly_dflt; apply/eqP; rewrite fracpolyXV_eq0.
Qed.

End FracRev.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ *)

Require Import nm_graph_def.

Set Implicit Arguments.

(** Small tactic to identify the goal and and hypothesis *)

Tactic Notation "id" "with" hyp(H) :=
  match type of H with
    | ?A =>
    match goal with
      |- ?B => cut (A=B); [ intros <-; exact H | ]
    end
  end.

Tactic Notation "id" "with" hyp(H) "level" int(n) :=
  id with H; do n f_equal.

(** The sub recursive calls relation *)

Local Reserved Notation "x '<sc' y" (at level 70, no associativity).

Inductive nm_sub_calls : Ω → Ω → Prop :=
  | in_nm_sc0 : ∀ y z, y <sc ω α y z
  | in_nm_sc1 : ∀ y z, z <sc ω α y z
  | in_nm_sc2 : ∀ u v w y z, ω v y z <sc ω (ω u v w) y z
  | in_nm_sc3 : ∀ u v w y z, ω w y z <sc ω (ω u v w) y z
  | in_nm_sc4 : ∀ u v w y z na nb, ω v y z ⟼n na
                                 → ω w y z ⟼n nb
                                 → ω u na nb <sc ω (ω u v w) y z
where "x <sc y" := (nm_sub_calls x y).

(** The domain are the Acc(essible) expressions under <sc *)

Definition d_nm := Acc nm_sub_calls.
Notation 𝔻nm := d_nm.

Section nm_pwc.

  (** We give the proof term directly (programming style)
      but it could be built progressively using refine tactics.
      Using refine is the recommended method. Obtaining the code
      directly is not for the faint of heart ... even though
      it looks nice in the end.
      This proof term is a decoration of the OCaml code of nm
      with extra typing information consisting in:
        1/ a pre-condition De : 𝔻 e which is a termination certificate (ie. d_nm_inv_[1-5])
        2/ a post-condition relating the input e to the output n : e ⟼ n *)

  (* The explicit dependent pattern matching

     match e ** return 𝔻nm e → _ ** with

     ** ... ** added below, is not needed any more for Coq 8.11+ *)

  Let Fixpoint nm_pwc e (D : 𝔻nm e) {struct D} : {n | e ⟼n n}.
  Proof. refine(
    match e return 𝔻nm e → _ with
        | α               => λ _,
                          exist _ α _
        | ω α y z         => λ D,
          let (ny,Cy) := nm_pwc y _ in
          let (nz,Cz) := nm_pwc z _ in
                          exist _ (ω α ny nz) _
        | ω (ω a b c) y z => λ D,
          let (nb,Cb) := nm_pwc (ω b y z)   _ in
          let (nc,Cc) := nm_pwc (ω c y z)   _ in
          let (na,Ca) := nm_pwc (ω a nb nc) _ in
                          exist _ na _
    end D).
    2-3,5-7: apply Acc_inv with (1 := D); constructor; auto.
    + constructor.
    + now constructor.
    + now constructor 3 with (3 := Ca).
  Qed.

  (** Then we derive nm and nm_spec by projection *)

  Definition nm e D := proj1_sig (@nm_pwc e D).

  Fact nm_spec e D : e ⟼n @nm e D.
  Proof. apply (proj2_sig _). Qed.

End nm_pwc.

Arguments nm e D : clear implicits.

(** Inductive-Recursive domain constructors *)

(* → λ ∀ ∃ ↔ ∧ ∨ *)

Fact 𝔻nm_1 : 𝔻nm α.
Proof. constructor; inversion 1. Qed.

Fact 𝔻nm_2 y z : 𝔻nm y → 𝔻nm z → 𝔻nm (ω α y z).
Proof. constructor; inversion 1; auto. Qed.

Fact 𝔻nm_3 u v w y z Dv Dw : 𝔻nm (ω u (nm (ω v y z) Dv) (nm (ω w y z) Dw))
                            → 𝔻nm (ω (ω u v w) y z).
Proof.
  constructor; inversion 1; auto.
  unfold d_nm in H.
  id with H level 2; apply 𝔾nm_fun with (1 := nm_spec _); auto.
Qed.

(** Inductive-Recursive Type-bounded eliminator/induction principle *)

Section 𝔻nm_rect.

  Variables (P   : ∀ e, 𝔻nm e → Type)
            (HPi : ∀ e D1 D2, @P e D1 → @P e D2)
            (HP1 : P 𝔻nm_1)
            (HP2 : ∀ y z D1 (_ : P D1) D2 (_ : P D2), P (@𝔻nm_2 y z D1 D2))
            (HP3 : ∀ u v w y z D1 (_ : P D1) D2 (_ : P D2) D3 (_ : P D3), P (@𝔻nm_3 u v w y z D1 D2 D3)).

  Fixpoint 𝔻nm_rect e D { struct D } : @P e D.
  Proof.
    destruct e as [ | [ | u v w ] y z ].
    + apply HPi with (1 := HP1).
    + refine (HPi _ (HP2 (𝔻nm_rect _ _) (𝔻nm_rect _ _))).
      all: apply Acc_inv with (1 := D); constructor.
    + assert (𝔻nm (ω v y z)) as Da by (apply Acc_inv with (1 := D); constructor).
      assert (𝔻nm (ω w y z)) as Db by (apply Acc_inv with (1 := D); constructor).
      refine (HPi _ (HP3 (𝔻nm_rect _ Da) (𝔻nm_rect _ Db) (𝔻nm_rect _ _))).
      apply Acc_inv with (1 := D); constructor; apply nm_spec.
  Qed.

End 𝔻nm_rect.