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

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import COC.Base.Main.

Require Import List.
Import List.ListNotations.

Definition _list := list.
Program Definition list: Types --> Types :=
  [Functor by f :-> map f].
Next Obligation.
  - intros f g Heq l.
    induction l as [| x l IHl]; simpl; auto.
    now rewrite IHl, Heq.
  - now rewrite map_map.
  - now rewrite map_id.
Qed.

Program Definition length_natrans: list ==> [* in Types |-> nat in Types] :=
  [X :=> @length X].
Next Obligation.
  now induction x as [| x l IHl]; simpl; [| rewrite IHl].
Qed.

Definition _option := option.
Program Definition option: Types --> Types :=
  [Functor by f :-> option_map f].
Next Obligation.
  - now intros f g Heq [x |]; simpl; [rewrite Heq |].
  - now destruct x as [x |]; simpl.
  - now destruct x as [x |]; simpl.
Qed.

Program Definition hd_error_natrans: list ==> option :=
  [X :=> @hd_error X].
Next Obligation.
  now induction x as [| x l IHl]; simpl.
Qed.

Inductive _tree (X: Type) :=
| leaf (x: X)
| node (tl tr: _tree X).

Fixpoint tree_map (X Y: Type)(f: X -> Y)(t: _tree X): _tree Y :=
  match t with
  | leaf x => leaf (f x)
  | node tl tr => node (tree_map f tl) (tree_map f tr)
  end.
Notation "[: x :]" := (leaf x).
Infix "-:-" := node (at level 50, left associativity).

Lemma tree_map_map:
  forall (X Y Z: Type)(f: X -> Y)(g: Y -> Z)(t: _tree X),
    tree_map (fun x => g (f x)) t = tree_map g (tree_map f t).
Proof.
  induction t as [x | tl IHl tr IHr]; simpl in *; auto.
  now rewrite IHl, IHr.
Qed.
Hint Resolve tree_map_map.

Lemma tree_map_id:
  forall (X: Type)(t: _tree X),
    tree_map (fun x: X => x) t = t.
Proof.
  induction t as [x | tl IHl tr IHr]; simpl in *; auto.
  now rewrite IHl, IHr.
Qed.
Hint Resolve tree_map_id.

Program Definition tree: Types --> Types :=
  [Functor by f :-> tree_map f with X :-> _tree X].
Next Obligation.
  intros f g Heq t.
  induction t as [x | tl IHl tr IHr]; simpl in *.
  - now rewrite Heq.
  - now rewrite IHl, IHr.
Qed.

Fixpoint tree_flatten (X: Type)(t: tree X): list X :=
  match t with
  | [:x:] => [x]
  | tl -:- tr => tree_flatten tl ++ tree_flatten tr
  end.

Program Definition tree_flatten_natrans: tree ==> list :=
  [X :=> tree_flatten (X:=X)].
Next Obligation.
  induction x as [x | tl IHl tr IHr]; simpl; auto.
  now rewrite IHl, IHr, map_app.
Qed.

Fixpoint list_equal (X: Setoid)(l1 l2: list X) :=
  match l1, l2 with
  | [], [] => True
  | x :: l1, y :: l2 => x == y /\ list_equal l1 l2
  | _, _ => False
  end.

Inductive list_equal_inductive (X: Setoid): list X -> list X -> Prop :=
| list_equal_nil: list_equal_inductive [] []
| list_equal_cons: forall (x y: X)(l1 l2: list X),
    x == y -> list_equal_inductive l1 l2 ->
    list_equal_inductive (x :: l1) (y :: l2).
Hint Resolve list_equal_nil list_equal_cons.

Lemma list_equal_equiv:
  forall (X: Setoid)(l1 l2: list X),
    list_equal l1 l2 <-> list_equal_inductive l1 l2.
Proof.
  intros; split.
  - revert l2; induction l1 as [| x l1 IH].
    + now intros [| y l2] H; try contradiction; auto.
    + intros [| y l2] H; try contradiction; simpl in *.
      apply list_equal_cons; [apply H |].
      now apply IH, H.
  - now intros H; induction H.
Qed.

Program Definition list_setoid (X: Setoid) :=
  [Setoid by @list_equal X].
Next Obligation.
  - now intros l; induction l as [| x l IHl].
  - intros l1 l2 Heq; apply list_equal_equiv in Heq.
    now induction Heq.
  - intros l1 l2 l3 Heq12; revert l3.
    apply list_equal_equiv in Heq12; induction Heq12; try now idtac.
    intros l3 Heq23; apply list_equal_equiv in Heq23; inversion Heq23.
    simpl; subst.
    split; [now transitivity y |].
    now apply IHHeq12, list_equal_equiv.
Qed.
Canonical Structure list_setoid.

Program Definition list_functor: Setoids --> Setoids :=
  [Functor by f :-> [Map by map f] with X :-> list_setoid X].
Next Obligation.
  intros l1 l2 Heq; apply list_equal_equiv in Heq; induction Heq; simpl; try now idtac.
  now rewrite H1.
Qed.
Next Obligation.
  - intros f g Heq l.
    now induction l as [| x l IHl].
  - rewrite map_map.
    now apply (Equivalence_Reflexive (Equivalence:=list_setoid_obligation_1 Z)).
  - rewrite map_id.
    now apply (Equivalence_Reflexive (Equivalence:=list_setoid_obligation_1 X)).
Qed.


(*==========================================================================
  Variables
  ==========================================================================*)

Require Import List.
Require Import Program.Equality.
Set Implicit Arguments.
Unset Strict Implicit.
Set Printing Implicit Defensive.

Section Vars.

Variable Ty : Type.

Definition Env := list Ty.

Inductive Var : Env -> Ty -> Type :=
| ZVAR : forall env ty, Var (ty :: env) ty
| SVAR : forall env ty ty', Var env ty -> Var (ty' :: env) ty.

(*==========================================================================
  Variable-domain maps.
  By instantiating P with Var we get renamings.
  By instantiating P with terms we get substitutions.
  ==========================================================================*)

Definition Map (P : Env -> Ty -> Type) env env' := forall t, Var env t -> P env' t.

(* Head, tail and cons *)
Definition tlMap P env env' ty (m : Map P (ty :: env) env') : Map P env env' := fun ty' v => m ty' (SVAR ty v).
Definition hdMap P env env' ty (m : Map P (ty :: env) env') : P env' ty := m ty (ZVAR _ _).
Implicit Arguments tlMap [P env env' ty].
Implicit Arguments hdMap [P env env' ty].

Program Definition consMap P env env' ty (v : P env' ty) (m:Map P env env') : Map P (ty :: env) env' :=
    fun ty' (var:Var (ty :: env) ty') =>
    match var with
    | ZVAR _ _ => v
    | SVAR _ _ _ var => m _ var
    end.
Implicit Arguments consMap [P env env' ty].

Axiom MapExtensional : forall P env env' (r1 r2 : Map P env env'), (forall ty var, r1 ty var = r2 ty var) -> r1 = r2.

Lemma hdConsMap : forall P env env' ty (v : P env' ty) (s : Map P env env'), hdMap (consMap v s) = v. Proof. auto. Qed.
Lemma tlConsMap : forall P env env' ty (v : P env' ty) (s : Map P env env'), tlMap (consMap v s) = s. Proof. intros. apply MapExtensional. auto. Qed.

Lemma consMapInv : forall P env env' ty (m:Map P (ty :: env) env'), exists m', exists v, m = consMap v m'.
intros. exists (tlMap m). exists (hdMap m).
apply MapExtensional. dependent destruction var; auto.
Qed.

Definition Renaming := Map Var.

Definition idRenaming env : Renaming env env := fun ty (var : Var env ty) => var.
Implicit Arguments idRenaming [].

Definition composeRenaming P env env' env'' (m : Map P env' env'') (r : Renaming env env') : Map P env env'' := fun t var => m _ (r _ var).

Lemma composeRenamingAssoc :
  forall P env env' env'' env''' (m : Map P env'' env''') r' (r : Renaming env env'),
  composeRenaming m (composeRenaming r' r) = composeRenaming (composeRenaming m r') r.
Proof. auto. Qed.

Lemma composeRenamingIdLeft : forall env env' (r : Renaming env env'), composeRenaming (idRenaming _) r = r.
Proof. intros. apply MapExtensional. auto. Qed.

Lemma composeRenamingIdRight : forall P env env' (m:Map P env env'), composeRenaming m (idRenaming _) = m.
Proof. intros. apply MapExtensional. auto. Qed.

End Vars.


Require Import List.
Require Import String.
Require Import ZArith.

Open Scope list_scope.
Open Scope string_scope.
Open Scope Z_scope.

Require Import StructTactics.
Require Import ImpSyntax.
Require Import ImpCommon.

Definition interp_op1
  (op : op1) (v : val) : option val :=
  match op, v with
  | Oneg, Vint i =>
      Some (Vint (Z.opp i))
  | Onot, Vbool b =>
      Some (Vbool (negb b))
  | _, _ =>
      None
  end.

Definition interp_op2
  (op : op2) (v1 v2 : val) : option val :=
  match op, v1, v2 with
  | Oadd, Vint i1, Vint i2 =>
      Some (Vint (Z.add i1 i2))
  | Oadd, Vstr s1, Vstr s2 =>
      Some (Vstr (String.append s1 s2))
  | Osub, Vint i1, Vint i2 =>
      Some (Vint (Z.sub i1 i2))
  | Omul, Vint i1, Vint i2 =>
      Some (Vint (Z.mul i1 i2))
  | Odiv, Vint i1, Vint i2 =>
      if Z.eq_dec i2 0 then
        None
      else
        Some (Vint (Z.div i1 i2))
  | Omod, Vint i1, Vint i2 =>
      if Z.eq_dec i2 0 then
        None
      else
        Some (Vint (Z.modulo i1 i2))
  | Oeq, v1, v2 =>
      Some (Vbool (imp_eq v1 v2))
  | Olt, Vint i1, Vint i2 =>
      Some (Vbool (imp_lt i1 i2))
  | Ole, Vint i1, Vint i2 =>
      Some (Vbool (imp_le i1 i2))
  | Oconj, Vbool b1, Vbool b2 =>
      Some (Vbool (andb b1 b2))
  | Odisj, Vbool b1, Vbool b2 =>
      Some (Vbool (orb b1 b2))
  | _, _, _ =>
      None
  end.

Fixpoint interp_e (s : store) (h : heap)
  (e : expr) : option val :=
  match e with
  | Eval v => Some v
  | Evar x => lkup s x
  | Eop1 op e1 =>
      match interp_e s h e1 with
      | Some v1 => interp_op1 op v1
      | _ => None
      end
  | Eop2 op e1 e2 =>
      match interp_e s h e1, interp_e s h e2 with
      | Some v1, Some v2 => interp_op2 op v1 v2
      | _, _ => None
      end
  | Elen e1 =>
      match interp_e s h e1 with
      | Some (Vaddr a) =>
          match read h a with
          | Some (Vint l) => Some (Vint l)
          | _ => None
          end
      | Some (Vstr cs) =>
          Some (Vint (Z.of_nat (String.length cs)))
      | _ => None
      end
  | Eidx e1 e2 =>
      match interp_e s h e1, interp_e s h e2 with
      | Some (Vaddr a), Some (Vint i) =>
          match read h a with
          | Some (Vint l) =>
              if Z_le_dec 0 i then
                if Z_lt_dec i l then
                  read h (Zsucc (a + i))
                else
                  None
              else
                None
          | _ => None
          end
      | Some (Vstr cs), Some (Vint i) =>
          if Z_le_dec 0 i then
            match String.get (Z.to_nat i) cs with
            | Some c =>
                Some (Vstr (String c EmptyString))
            | None => None
            end
          else
            None
      | _, _ => None
      end
  end.

Fixpoint interps_e (s : store) (h : heap)
  (es : list expr) : option (list val) :=
  match es with
  | nil => Some nil
  | e :: t =>
      match interp_e s h e, interps_e s h t with
      | Some v, Some vs => Some (v :: vs)
      | _, _ => None
      end
  end.

Fixpoint interp_s (env : env) (s : store) (h : heap)
  (p : stmt) : option (store * heap * stmt) :=
  match p with
  | Snop => None
  | Sset x e =>
      match interp_e s h e with
      | Some v => Some (update s x v, h, Snop)
      | _ => None
      end
  | Salloc x e1 e2 =>
      match interp_e s h e1, interp_e s h e2 with
      | Some (Vint i), Some v =>
          if Z_le_dec 0 i then
            Some ( update s x (Vaddr (zlen h))
                 , alloc h i v
                 , Snop
                 )
          else
            None
      | _, _ => None
      end
  | Swrite x e1 e2 =>
      match lkup s x
          , interp_e s h e1
          , interp_e s h e2 with
      | Some (Vaddr a), Some (Vint i), Some v =>
          match read h a with
          | Some (Vint l) =>
              if Z_le_dec 0 i then
                if Z_lt_dec i l then
                  match write h (Zsucc (a + i)) v with
                  | Some h' => Some (s, h', Snop)
                  | None => None
                  end
                else
                  None
              else
                None
          | _ => None
          end
      | _, _, _ => None
      end
  | Scall x f es =>
      match interps_e s h es with
      | Some vs =>
          match locate env f with
          | Some (Func _ params body ret) =>
              match updates store_0 params vs with
              | Some sf =>
                  Some (sf, h, Sincall body ret x s)
              | None =>
                  None
              end
          | None =>
              if extcall_args_ok f vs h then
                let (v', h') := extcall f vs h in
                Some (update s x v', h', Snop)
              else
                None
          end
      | None => None
      end
  | Sifelse e p1 p2 =>
      match interp_e s h e with
      | Some (Vbool true) => Some (s, h, p1)
      | Some (Vbool false) => Some (s, h, p2)
      | _ => None
      end
  | Swhile e p =>
      match interp_e s h e with
      | Some (Vbool true) =>
          Some (s, h, Sseq p (Swhile e p))
      | Some (Vbool false) =>
          Some (s, h, Snop)
      | _ =>
          None
      end
  | Sseq p1 p2 =>
      if isNop p1 then
        Some (s, h, p2)
      else
        match interp_s env s h p1 with
        | Some (s', h', p1') =>
            Some (s', h', Sseq p1' p2)
        | None => None
        end
  | Sincall p ret x sr =>
      if isNop p then
        match interp_e s h ret with
        | Some v => Some (update sr x v, h, Snop)
        | None => None
        end
      else
        match interp_s env s h p with
        | Some (s', h', p') =>
            Some (s', h', Sincall p' ret x sr)
        | None => None
        end
  end.

Fixpoint interps_p (fuel : nat) (env : env)
  (s : store) (h : heap) (p : stmt)
  (ret : expr) : result :=
  match fuel with
  | O => Timeout s h p ret
  | S n =>
      if isNop p then
        match interp_e s h ret with
        | Some v => Done h v
        | None => Stuck s h p ret
        end
      else
        match interp_s env s h p with
        | Some (s', h', p') =>
            interps_p n env s' h' p' ret
        | _ =>
            Stuck s h p ret
        end
    end.

Definition interp_p (fuel : nat) (p : prog) : result :=
  match p with
  | Prog funcs body ret =>
      interps_p fuel funcs store_0 heap_0 body ret
  end.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.

Require Import Basic_Cons.Terminal.
Require Import Basic_Cons.Product.

Require Import NatTrans.NatTrans NatTrans.NatIso.
Require Import Yoneda.Yoneda.

(** 1 × a ≃ a. where 1 is the terminal object. *)
Section Term_Prod.
  Context {C : Category} {term : (𝟙_ C)%object} {CHP : Has_Products C}.

  Local Notation "1" := (terminal term) : object_scope.

  Local Notation "a × b" := (CHP a b) : object_scope.

  (** Natural transformations to be used with Yoneda. *)
  Program Definition Term_Prod_lr (a : C) :
      ((((Yoneda C) _o (a × 1))%object)
         –≻ ((Yoneda C) _o a)%object)%nattrans
    :=
      {|
        Trans := fun b f => @compose C _ _ _ f (@Pi_1 _ _ _ (CHP a term))
      |}.

  Program Definition Term_Prod_rl (a : C) :
    ((((Yoneda C) _o a)%object)
       –≻ ((Yoneda C) _o (a × 1))%object)%nattrans
    :=
      {|
        Trans := fun b f =>  @Prod_morph_ex C _ _ _ _ f (@t_morph C _ b)
      |}.

  Next Obligation. (* Trans_com *)
  Proof.
    extensionality g.
    eapply Prod_morph_unique; simpl_ids.
    apply Prod_morph_com_1.
    apply Prod_morph_com_2.
    rewrite <- assoc.
    rewrite Prod_morph_com_1; trivial.
    rewrite <- assoc.
    rewrite Prod_morph_com_2.
    apply t_morph_unique.
  Qed.

  Next Obligation. (* Trans_com *)
  Proof.
    symmetry.
    apply Term_Prod_rl_obligation_1.
  Qed.

  Theorem Term_Prod (a : C) : (((×ᶠⁿᶜ C) _o (a, 1)%object) ≃ a)%isomorphism.
  Proof.
    Yoneda.
    apply (NatIso _ _ (Term_Prod_lr a) (Term_Prod_rl a)).
    {
      intros c.
      extensionality g; simpl.
      simpl_ids.
      apply Prod_morph_com_1.
    }
    {
      intros c.
      extensionality g; simpl.
      simpl_ids.
      eapply Prod_morph_unique.
      apply Prod_morph_com_1.
      apply Prod_morph_com_2.
      trivial.
      apply t_morph_unique.
    }
  Qed.

End Term_Prod.


Require Export Coq.Relations.Relations.
Require Import CommonKnowledge.Relations.RelationConstructors.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.Equivalence.

Instance eq_preorder (A: Type): PreOrder (@eq A) :=
  Build_PreOrder _ (eq_Reflexive) (eq_Transitive).

Instance prod_relation_Reflexive {A B: Type} (RA: relation A) (RB: relation B)
  {_: Reflexive RA} {_: Reflexive RB} : Reflexive (prod_relation RA RB).
Proof. firstorder. Qed.

Instance prod_relation_Symmetric {A B: Type} (RA: relation A) (RB: relation B)
  {_: Symmetric RA} {_: Symmetric RB}: Symmetric (prod_relation RA RB).
Proof. firstorder. Qed.

Instance prod_relation_Transitive {A B: Type} (RA: relation A) (RB: relation B)
  {_: Transitive RA} {_: Transitive RB}: Transitive (prod_relation RA RB).
Proof. firstorder. Qed.

Program Instance prod_relation_Equivalence {A B: Type} (RA: relation A) (RB: relation B)
  {_: Equivalence RA} {_: Equivalence RB}: Equivalence (prod_relation RA RB).

Program Instance prod_relation_PreOrder {A B: Type} (RA: relation A) (RB: relation B)
  {_: PreOrder RA} {_: PreOrder RB}: PreOrder (prod_relation RA RB).

Program Instance pointwise_preorder A {B : Type} (RB : relation B) {_: PreOrder RB}:
  PreOrder (pointwise_relation A RB).

Instance option00_reflexive {A: Type} (R: relation A) {_: Reflexive R}: Reflexive (option00_relation R).
Proof.
  hnf; intros.
  destruct x.
  + constructor; reflexivity.
  + constructor.
Qed.

Instance option01_reflexive {A: Type} (R: relation A) {_: Reflexive R}: Reflexive (option01_relation R).
Proof.
  hnf; intros.
  destruct x.
  + constructor; reflexivity.
  + constructor.
Qed.

Instance option00_symmetric {A: Type} (R: relation A) {_: Symmetric R}: Symmetric (option00_relation R).
Proof.
  hnf; intros.
  inversion H0; subst.
  + constructor.
  + constructor.
    symmetry; auto.
Qed.

Instance option00_transitive {A: Type} (R: relation A) {_: Transitive R}: Transitive (option00_relation R).
Proof.
  hnf; intros.
  hnf; intros.
  inversion H0; inversion H1; subst; try first [congruence | constructor].
  inversion H6; subst.
  etransitivity; eauto.
Qed.

Instance option01_transitive {A: Type} (R: relation A) {_: Transitive R}: Transitive (option01_relation R).
Proof.
  hnf; intros.
  hnf; intros.
  inversion H0; inversion H1; subst; try first [congruence | constructor].
  inversion H6; subst.
  etransitivity; eauto.
Qed.

Instance option00_preorder {A: Type} (R: relation A) {_: PreOrder R}: PreOrder (option00_relation R)
  := Build_PreOrder _ (option00_reflexive R) (option00_transitive R).

Instance option01_preorder {A: Type} (R: relation A) {_: PreOrder R}: PreOrder (option01_relation R)
  := Build_PreOrder _ (option01_reflexive R) (option01_transitive R).

Instance option00_equiv {A: Type} (R: relation A) {_: Equivalence R}: Equivalence (option00_relation R)
  := Build_Equivalence _ (option00_reflexive R) (option00_symmetric R) (option00_transitive R).

Instance sum00_reflexive {A B: Type} (RA: relation A) (RB: relation B) {_: Reflexive RA} {_: Reflexive RB}: Reflexive (sum00_relation RA RB).
Proof.
  hnf; intros.
  destruct x; constructor; auto.
Qed.

Instance sum01_reflexive {A B: Type} (RA: relation A) (RB: relation B) {_: Reflexive RA} {_: Reflexive RB}: Reflexive (sum01_relation RA RB).
Proof.
  hnf; intros.
  destruct x; constructor; auto.
Qed.

Instance sum00_symmetric {A B: Type} (RA: relation A) (RB: relation B) {_: Symmetric RA} {_: Symmetric RB}: Symmetric (sum00_relation RA RB).
Proof.
  hnf; intros.
  inversion H1; subst; constructor; auto.
Qed.

Instance sum00_transitive {A B: Type} (RA: relation A) (RB: relation B) {_: Transitive RA} {_: Transitive RB}: Transitive (sum00_relation RA RB).
Proof.
  hnf; intros.
  inversion H1; subst; inversion H2; subst;
  constructor;
  etransitivity; eauto.
Qed.

Instance sum01_transitive {A B: Type} (RA: relation A) (RB: relation B) {_: Transitive RA} {_: Transitive RB}: Transitive (sum01_relation RA RB).
Proof.
  hnf; intros.
  inversion H1; subst; inversion H2; subst;
  constructor;
  etransitivity; eauto.
Qed.

Program Instance sum00_preorder {A B: Type} (RA: relation A) (RB: relation B)
  {_: PreOrder RA} {_: PreOrder RB}: PreOrder (sum00_relation RA RB).

Program Instance sum00_equivalence {A B: Type} (RA: relation A) (RB: relation B)
  {_: Equivalence RA} {_: Equivalence RB}: Equivalence (sum00_relation RA RB).

Program Instance sum01_preorder {A B: Type} (RA: relation A) (RB: relation B)
  {_: PreOrder RA} {_: PreOrder RB}: PreOrder (sum01_relation RA RB).

Instance full_reflexive (A: Type): Reflexive (full_relation A).
Proof. firstorder. Qed.

Instance full_symmetric (A: Type): Symmetric (full_relation A).
Proof. firstorder. Qed.

Instance full_transitive (A: Type): Transitive (full_relation A).
Proof. firstorder. Qed.

Program Instance full_preorder (A: Type): PreOrder (full_relation A).

Program Instance full_equivalence (A: Type): PreOrder (full_relation A).

Instance sigT_relation_reflexive {I: Type} {A: I -> Type} (RA: forall i, relation (A i))
  {_: forall i, Reflexive (RA i)}: Reflexive (sigT_relation RA).
Proof.
  hnf; intros.
  destruct x.
  econstructor.
  apply H.
Qed.

Instance sigT_relation_symmetric {I: Type} {A: I -> Type} (RA: forall i, relation (A i))
  {_: forall i, Symmetric (RA i)}: Symmetric (sigT_relation RA).
Proof.
  hnf; intros.
  inversion H0; subst.
  econstructor.
  apply H; auto.
Qed.

Lemma path_sigT {I: Type} {A: I -> Type} (x y : sigT A) (H : x = y) :
  { p : projT1 x = projT1 y & eq_rect _ A (projT2 x) _ p = projT2 y }.
Proof.
  exists (f_equal _ H).
  destruct H; reflexivity.
Qed.

Lemma path_sigT_relation {I: Type} {A: I -> Type} (RA: forall i, relation (A i))
  (x y : sigT A) (H: sigT_relation RA x y):
  { p : projT1 x = projT1 y & RA _ (eq_rect _ A (projT2 x) _ p) (projT2 y) }.
Proof.
  inversion H.
  simpl in *.
  exists eq_refl.
  simpl.
  auto.
Qed.

Instance sigT_relation_transitive {I: Type} {A: I -> Type} (RA: forall i, relation (A i))
  {_: forall i, Transitive (RA i)}: Transitive (sigT_relation RA).
Proof.
  intros; hnf; intros.
  inversion H0; inversion H1; subst.
  apply path_sigT in H6.
  destruct H6.
  simpl in *.
  subst.
  econstructor.
  eapply H; eassumption.
Qed.

Program Instance sigT_relation_equivalence {I} {A: I -> Type} (RA: forall i, relation (A i))
  {_: forall i, Equivalence (RA i)}: Equivalence (sigT_relation RA).

Instance sig_relation_reflexive {A: Type} {P: A -> Prop} (RA:relation A)
  {_: Reflexive RA}: Reflexive (sig_relation P RA).
Proof.
  hnf; intros.
  destruct x.
  constructor.
  apply H.
Qed.

Instance sig_relation_symmetric {A: Type} {P: A -> Prop} (RA:relation A)
  {_: Symmetric RA}: Symmetric (sig_relation P RA).
Proof.
  hnf; intros.
  destruct x, y.
  constructor.
  inversion H0; subst.
  apply H; auto.
Qed.

Instance sig_relation_transitive {A: Type} {P: A -> Prop} (RA:relation A)
  {_: Transitive RA}: Transitive (sig_relation P RA).
Proof.
  hnf; intros.
  destruct x, y, z.
  constructor.
  inversion H0; inversion H1; subst.
  eapply H; eauto.
Qed.

Program Instance sig_relation_equivalence {A: Type} {P: A -> Prop} (RA:relation A)
  {_: Equivalence RA}: Equivalence (sig_relation P RA).


Require Import Basics.

(* ** Binary Positive Integers *)

(** Most of this file has been adapted from the coq standard library for positive binary integers. *)

(** Here we define the inductive type of positive binary numbers. *)
Inductive Pos : Type0 :=
  | xH : Pos
  | x0 : Pos -> Pos
  | x1 : Pos -> Pos.

Declare Scope positive_scope.
Delimit Scope positive_scope with pos.

(** Here are some notations that let us right binary positive integers more easily. *)
Notation "1" := xH : positive_scope.
Notation "p ~ 1" := (x1 p)
 (at level 7, left associativity, format "p '~' '1'") : positive_scope.
Notation "p ~ 0" := (x0 p)
 (at level 7, left associativity, format "p '~' '0'") : positive_scope.

Local Open Scope positive_scope.

(** ** Successor *)
Fixpoint pos_succ x :=
  match x with
    | p~1 => (pos_succ p)~0
    | p~0 => p~1
    | 1 => 1~0
  end.

(** Peano induction (due to Daniel Schepler) *)
Fixpoint pos_peano_ind (P : Pos -> Type) (a : P 1)
  (f : forall p, P p -> P (pos_succ p)) (p : Pos) : P p
  := let f2 := pos_peano_ind (fun p => P (p~0))
    (f _ a) (fun p (x : P p~0) => f _ (f _ x))
  in match p with
      | q~1 => f _ (f2 q)
      | q~0 => f2 q
      | 1 => a
     end.

(** Computation rules for Peano induction *)
Definition pos_peano_ind_beta_1 (P : Pos -> Type) (a : P 1)
  (f : forall p, P p -> P (pos_succ p))
  : pos_peano_ind P a f 1 = a := idpath.

Definition pos_peano_ind_beta_pos_succ (P : Pos -> Type) (a : P 1)
  (f : forall p, P p -> P (pos_succ p)) (p : Pos)
  : pos_peano_ind P a f (pos_succ p) = f _ (pos_peano_ind P a f p).
Proof.
  revert P a f.
  induction p; trivial.
  intros P a f.
  serapply IHp.
Qed.

(** ** Properties of constructors *)

Definition x0_inj {z w : Pos} (p : x0 z = x0 w) : z = w
  := transport (fun s => z = (
    match s with xH => w | x0 a => a | x1 a => w end)) p idpath.

Definition x1_inj {z w : Pos} (p : x1 z = x1 w) : z = w
  := transport (fun s => z = (
    match s with xH => w | x0 a => w | x1 a => a end)) p idpath.

Definition x0_neq_xH {z : Pos} : x0 z <> xH
  := fun p => transport (fun s =>
    match s with xH => Empty | x0 a => z = a | x1 a => Empty end) p idpath.

Definition x1_neq_xH {z : Pos} : x1 z <> xH
  := fun p => transport (fun s =>
    match s with xH => Empty | x0 a => Empty | x1 a => z = a end) p idpath.

Definition x0_neq_x1 {z w : Pos} : x0 z <> x1 w
  := fun p => transport (fun s =>
    match s with xH => Empty | x0 a => z = a | x1 _ => Empty end) p idpath.

Definition xH_neq_x0 {z : Pos} : xH <> x0 z
  := x0_neq_xH o symmetry _ _.

Definition xH_neq_x1 {z : Pos} : xH <> x1 z
  := x1_neq_xH o symmetry _ _.

Definition x1_neq_x0 {z w : Pos} : x1 z <> x0 w
  := x0_neq_x1 o symmetry _ _.

(** * Positive binary integers have decidable paths *)

Global Instance decpaths_pos : DecidablePaths Pos.
Proof.
  intros n; induction n as [|zn|on];
  intros m; induction m as [|zm|om].
  + exact (inl idpath).
  + exact (inr xH_neq_x0).
  + exact (inr xH_neq_x1).
  + exact (inr x0_neq_xH).
  + destruct (IHzn zm) as [p|q].
    - apply inl, ap, p.
    - apply inr; intro p.
      by apply q, x0_inj.
  + exact (inr x0_neq_x1).
  + exact (inr x1_neq_xH).
  + exact (inr x1_neq_x0).
  + destruct (IHon om) as [p|q].
    - apply inl, ap, p.
    - apply inr; intro p.
      by apply q, x1_inj.
Defined.

(** Decidable paths imply Pos is a hSet *)
Global Instance ishset_pos : IsHSet Pos := _.

(** * Operations over positive numbers *)

(** ** Addition *)

Fixpoint pos_add x y :=
  match x, y with
    | p~1, q~1 => (pos_add_carry p q)~0
    | p~1, q~0 => (pos_add p q)~1
    | p~1, 1 => (pos_succ p)~0
    | p~0, q~1 => (pos_add p q)~1
    | p~0, q~0 => (pos_add p q)~0
    | p~0, 1 => p~1
    | 1, q~1 => (pos_succ q)~0
    | 1, q~0 => q~1
    | 1, 1 => 1~0
  end

with pos_add_carry x y :=
  match x, y with
    | p~1, q~1 => (pos_add_carry p q)~1
    | p~1, q~0 => (pos_add_carry p q)~0
    | p~1, 1 => (pos_succ p)~1
    | p~0, q~1 => (pos_add_carry p q)~0
    | p~0, q~0 => (pos_add p q)~1
    | p~0, 1 => (pos_succ p)~0
    | 1, q~1 => (pos_succ q)~1
    | 1, q~0 => (pos_succ q)~0
    | 1, 1 => 1~1
  end.

Infix "+" := pos_add : positive_scope.

(** ** Operation [x -> 2*x-1] *)

Fixpoint pos_pred_double x :=
  match x with
    | p~1 => p~0~1
    | p~0 => (pos_pred_double p)~1
    | 1 => 1
  end.

(** ** Predecessor *)

Definition pos_pred x :=
  match x with
    | p~1 => p~0
    | p~0 => pos_pred_double p
    | 1 => 1
  end.

(** ** An auxiliary type for subtraction *)

Inductive Pos_mask : Set :=
  | IsNul : Pos_mask
  | IsPos : Pos -> Pos_mask
  | IsNeg : Pos_mask.

(** ** Operation [x -> 2*x+1] *)

Definition pos_mask_succ_double (x : Pos_mask) : Pos_mask :=
  match x with
    | IsNul => IsPos 1
    | IsNeg => IsNeg
    | IsPos p => IsPos p~1
  end.

(** ** Operation [x -> 2*x] *)

Definition pos_mask_double (x : Pos_mask) : Pos_mask :=
  match x with
    | IsNul => IsNul
    | IsNeg => IsNeg
    | IsPos p => IsPos p~0
  end.

(** ** Operation [x -> 2*x-2] *)

Definition pos_mask_double_pred x : Pos_mask :=
  match x with
    | p~1 => IsPos p~0~0
    | p~0 => IsPos (pos_pred_double p)~0
    | 1 => IsNul
  end.

(** ** Predecessor with mask *)

Definition pos_mask_pred (p : Pos_mask) : Pos_mask :=
  match p with
    | IsPos 1 => IsNul
    | IsPos q => IsPos (pos_pred q)
    | IsNul => IsNeg
    | IsNeg => IsNeg
  end.

(** ** Subtraction, result as a mask *)

Fixpoint pos_mask_sub (x y : Pos) {struct y} : Pos_mask :=
  match x, y with
    | p~1, q~1 => pos_mask_double (pos_mask_sub p q)
    | p~1, q~0 => pos_mask_succ_double (pos_mask_sub p q)
    | p~1, 1 => IsPos p~0
    | p~0, q~1 => pos_mask_succ_double (pos_mask_sub_carry p q)
    | p~0, q~0 => pos_mask_double (pos_mask_sub p q)
    | p~0, 1 => IsPos (pos_pred_double p)
    | 1, 1 => IsNul
    | 1, _ => IsNeg
  end

with pos_mask_sub_carry (x y : Pos) {struct y} : Pos_mask :=
  match x, y with
    | p~1, q~1 => pos_mask_succ_double (pos_mask_sub_carry p q)
    | p~1, q~0 => pos_mask_double (pos_mask_sub p q)
    | p~1, 1 => IsPos (pos_pred_double p)
    | p~0, q~1 => pos_mask_double (pos_mask_sub_carry p q)
    | p~0, q~0 => pos_mask_succ_double (pos_mask_sub_carry p q)
    | p~0, 1 => pos_mask_double_pred p
    | 1, _ => IsNeg
  end.

(** ** Subtraction, result as a positive, returning 1 if [x<=y] *)

Definition pos_sub x y :=
  match pos_mask_sub x y with
    | IsPos z => z
    | _ => 1
  end.

Infix "-" := pos_sub : positive_scope.

(** ** Multiplication *)

Fixpoint pos_mul x y :=
  match x with
    | p~1 => y + (pos_mul p y)~0
    | p~0 => (pos_mul p y)~0
    | 1 => y
  end.

Infix "*" := pos_mul : positive_scope.

(** ** Iteration over a positive number *)

Definition pos_iter {A : Type} (f : A -> A)
  : Pos -> A -> A.
Proof.
  apply (pos_peano_ind (fun _ => A -> A) f).
  intros n g.
  exact (f o g).
Defined.

(** ** Power *)

Definition pos_pow (x : Pos) := pos_iter (pos_mul x) 1.

(* We cannot use this notation because it is reserved for path inverse. *)
(* Infix "^" := pos_pow : positive_scope. *)

(** ** Square *)

Fixpoint pos_square p :=
  match p with
    | p~1 => (pos_square p + p)~0~1
    | p~0 => (pos_square p)~0~0
    | 1 => 1
  end.

(** ** Division by 2 rounded below but for 1 *)

Definition pos_div2 p :=
  match p with
    | 1 => 1
    | p~0 => p
    | p~1 => p
  end.

(** Division by 2 rounded up *)

Definition pos_div2_up p :=
 match p with
   | 1 => 1
   | p~0 => p
   | p~1 => pos_succ p
 end.

(** ** Number of digits in a positive number *)

Fixpoint nat_pos_size p : nat :=
  match p with
    | 1 => S O
    | p~1 => S (nat_pos_size p)
    | p~0 => S (nat_pos_size p)
  end.

(** Same, with positive output *)

Fixpoint pos_size p :=
  match p with
    | 1 => 1
    | p~1 => pos_succ (pos_size p)
    | p~0 => pos_succ (pos_size p)
  end.

(** ** From binary positive numbers to Peano natural numbers *)

Definition pos_iter_op {A} (op : A -> A -> A)
  := fix pos_iter (p : Pos) (a : A) : A
    := match p with
        | 1 => a
        | p~0 => pos_iter p (op a a)
        | p~1 => op a (pos_iter p (op a a))
       end.

(** ** From Peano natural numbers to binary positive numbers *)

(** A version preserving positive numbers, and sending 0 to 1. *)

Fixpoint pos_of_nat (n : nat) : Pos :=
 match n with
   | O => 1
   | S O => 1
   | S x => pos_succ (pos_of_nat x)
 end.

(* Another version that converts [n] into [n+1] *)

Fixpoint pos_of_succ_nat (n : nat) : Pos :=
  match n with
    | O => 1
    | S x => pos_succ (pos_of_succ_nat x)
  end.

(** ** Conversion with a decimal representation for printing/parsing *)

Local Notation ten := 1~0~1~0.

Fixpoint pos_of_uint_acc (d : Decimal.uint) (acc : Pos) :=
  match d with
  | Decimal.Nil => acc
  | Decimal.D0 l => pos_of_uint_acc l (pos_mul ten acc)
  | Decimal.D1 l => pos_of_uint_acc l (pos_add 1 (pos_mul ten acc))
  | Decimal.D2 l => pos_of_uint_acc l (pos_add 1~0 (pos_mul ten acc))
  | Decimal.D3 l => pos_of_uint_acc l (pos_add 1~1 (pos_mul ten acc))
  | Decimal.D4 l => pos_of_uint_acc l (pos_add 1~0~0 (pos_mul ten acc))
  | Decimal.D5 l => pos_of_uint_acc l (pos_add 1~0~1 (pos_mul ten acc))
  | Decimal.D6 l => pos_of_uint_acc l (pos_add 1~1~0 (pos_mul ten acc))
  | Decimal.D7 l => pos_of_uint_acc l (pos_add 1~1~1 (pos_mul ten acc))
  | Decimal.D8 l => pos_of_uint_acc l (pos_add 1~0~0~0 (pos_mul ten acc))
  | Decimal.D9 l => pos_of_uint_acc l (pos_add 1~0~0~1 (pos_mul ten acc))
  end.

Fixpoint pos_of_uint (d : Decimal.uint) : option Pos :=
  match d with
    | Decimal.Nil => None
    | Decimal.D0 l => pos_of_uint l
    | Decimal.D1 l => Some (pos_of_uint_acc l 1)
    | Decimal.D2 l => Some (pos_of_uint_acc l 1~0)
    | Decimal.D3 l => Some (pos_of_uint_acc l 1~1)
    | Decimal.D4 l => Some (pos_of_uint_acc l 1~0~0)
    | Decimal.D5 l => Some (pos_of_uint_acc l 1~0~1)
    | Decimal.D6 l => Some (pos_of_uint_acc l 1~1~0)
    | Decimal.D7 l => Some (pos_of_uint_acc l 1~1~1)
    | Decimal.D8 l => Some (pos_of_uint_acc l 1~0~0~0)
    | Decimal.D9 l => Some (pos_of_uint_acc l 1~0~0~1)
  end.

Definition pos_of_decimal_int (d:Decimal.int) : option Pos :=
  match d with
  | Decimal.Pos d => pos_of_uint d
  | Decimal.Neg _ => None
  end.

Fixpoint pos_to_little_uint p :=
  match p with
  | 1 => Decimal.D1 Decimal.Nil
  | p~1 => Decimal.Little.succ_double (pos_to_little_uint p)
  | p~0 => Decimal.Little.double (pos_to_little_uint p)
  end.

Definition pos_to_uint p := Decimal.rev (pos_to_little_uint p).

Definition pos_to_decimal_int n := Decimal.Pos (pos_to_uint n).

Numeral Notation Pos pos_of_decimal_int pos_to_uint : positive_scope.


Require Import list_examples.

Definition length_def := FunDef "length" ["x"]
 {{Decl "l";"l"<-0
  ;SWhile ("x"<>0) {{"l"<-"l"+1; "x"<- arr_next "x"}}
  ;SReturn "l"}}.

Inductive length_spec : Spec kcfg :=
  length_claim : forall H x l, heap_fun length_spec nil
  length_def [Int x]
    (asP H (rep_list l x))
    (fun r => constraint (r = zlength l) :* litP H)
 |loop_claim : forall H k x l, heap_loop length_spec
  length_def 0 ("x" s|-> KInt x :* "l" s|-> KInt k)
    (asP H (rep_list l x))
    (fun r => constraint (r = k + zlength l) :* litP H).

Lemma length_proof : sound kstep length_spec.
Proof. list_solver. Qed.


Require Import Formula.
Import Formula.Properties.
Import Formula.Syntax.
Require Import Coq.Program.Basics.

From hahn Require Import Hahn.

Section PredTransformer.
Local Open Scope formula_scope.
Local Open Scope program_scope.

Record predTransformer (τ : Formula.t -> Formula.t) :=
  { pt_preserves_disj : forall φ ψ, τ (φ ∨ ψ) ⇔ τ φ ∨ τ ψ;
    pt_preserves_conj : forall φ ψ, τ (φ ∧ ψ) ⇔ τ φ ∧ τ ψ;
    pt_entails : forall φ ψ, φ ⊨ ψ -> τ φ ⊨ τ ψ;
  }.

Add Parametric Morphism τ (pt : predTransformer τ) : τ with signature
  Formula.equiv ==> Formula.equiv as pt_more.
Proof.
  specialize pt_entails.
  unfold "⇔" in *.
  basic_solver.
Qed.

Lemma pt_ext t t'
      (PT : predTransformer t)
      (EXT: forall x, t x ⇔ t' x) :
  predTransformer t'.
Proof.
  constructor; ins.
  all: rewrite <- !EXT.
  all: apply PT; auto.
Qed.

Lemma pt_equiv t t'
      (EQV : forall φ, t φ ⇔ t' φ) :
  predTransformer t <-> predTransformer t'.
Proof.
  split; intros HH; constructor; ins.
  all: try by (rewrite <- !EQV; apply HH).
  all: by rewrite !EQV; apply HH.
Qed.

Lemma pt_f_subst_loc x m :
  predTransformer (fun φ => Formula.subst_loc φ x m).
Proof.
  constructor; simpl; specialize Formula.Properties.equiv_refl;
    try basic_solver.
  by ins; apply entails_resp_subst_loc.
Qed.

Lemma pt_f_subst_reg x m :
  predTransformer (fun φ => Formula.subst_reg φ x m).
Proof.
  constructor; simpl; specialize Formula.Properties.equiv_refl;
    try basic_solver.
  by ins; apply entails_resp_subst_reg.
Qed.

Lemma pt_compose τ1 τ2
      (pt1 : predTransformer τ1)
      (pt2 : predTransformer τ2) :
  predTransformer (τ1 ∘ τ2).
Proof.
  unfold "∘".
  constructor; ins.
  { erewrite pt_more; [| done | by apply pt_preserves_disj].
    now erewrite pt_more; [by apply pt_preserves_disj | |]. }
  { erewrite pt_more; [| done | by apply pt_preserves_conj].
    now erewrite pt_more; [by apply pt_preserves_conj | |]. }
  repeat eapply pt_entails; auto.
Qed.

Lemma pt_conj_f_l φ :
  predTransformer (fun ψ => φ ∧ ψ).
Proof.
  constructor; ins.
  { rewrite conj_sym, disj_conj_distrib.
    now rewrite conj_sym, (conj_sym ψ φ). }
  { now rewrite
      <- (conjA _ φ ψ),
      (conj_sym _ φ),
      <- (conjA _ φ),
      <- equiv_conj_idemp,
      conjA. }
  now apply entails_conj.
Qed.

Lemma pt_conj_f_r φ :
  predTransformer (fun ψ => ψ ∧ φ).
Proof.
  erewrite pt_equiv.
  { eapply pt_conj_f_l. }
  ins. apply conj_sym.
Qed.

Lemma pt_disj φ :
  predTransformer (fun ψ => φ ∨ ψ).
Proof.
  constructor; ins.
  { now rewrite
      <- (disjA _ φ ψ),
      (disj_sym _ φ),
      <- (disjA _ φ),
      equiv_disj_idemp,
      disjA. }
  { rewrite <- disj_sym, conj_disj_distrib.
    apply conj_more; apply disj_sym. }
  now apply entails_resp_disj.
Qed.

Lemma pt_taut_impl_impl τ χ φ ψ
      (PT   : predTransformer τ)
      (TAUT : Formula.tautology (τ χ)) :
  τ ((χ ⇒ φ) ⇒ ψ) ⇔ τ (φ ⇒ ψ).
Proof.
  unfold "⇒".
  rewrite !pt_preserves_disj; auto.
  erewrite pt_more with (x := ¬ ((¬ χ) ∨ φ)); [| done |].
  2: now rewrite formula_de_morgan, elim_dneg.
  rewrite pt_preserves_conj, pt_preserves_disj; auto.
  apply equiv_true_taut_l in TAUT.
  now rewrite <-TAUT, conj_true_l.
Qed.

Lemma impl_preserves_pt τ ϕ
      (PT   : predTransformer τ) :
  predTransformer (fun ψ => ϕ ⇒ τ ψ).
Proof.
  eapply pt_compose; auto.
  apply pt_disj.
Qed.

Lemma conj_l_preserves_pt τ ϕ
      (PT   : predTransformer τ) :
  predTransformer (fun ψ => ϕ ∧ τ ψ).
Proof.
  eapply pt_compose with (τ1 := Formula.conj ϕ) ; auto.
  apply pt_conj_f_l.
Qed.

Lemma conj_r_preserves_pt τ ϕ
      (PT   : predTransformer τ) :
  predTransformer (fun ψ => τ ψ ∧ ϕ).
Proof.
  eapply pt_compose with (τ1 := fun x => x ∧ ϕ) ; auto.
  apply pt_conj_f_r.
Qed.

Lemma pt_split_world χ τ
      (PT1 : predTransformer (fun x => χ ⇒ τ x))
      (PT2 : predTransformer (fun x => (¬ χ) ⇒ τ x)) :
  predTransformer τ.
Proof.
  Local Ltac specializer :=
    repeat (
        match goal with
        | locf : _, regf : _, eregf : _, qf : _,
          PT : _ ⊨ _ |- _ => specialize (PT locf regf eregf qf)
        end).
  constructor; ins.
  1: eapply pt_preserves_disj with (φ := φ) (ψ := ψ) in PT1;
    eapply pt_preserves_disj with (φ := φ) (ψ := ψ) in PT2.
  2: eapply pt_preserves_conj with (φ := φ) (ψ := ψ) in PT1;
    eapply pt_preserves_conj with (φ := φ) (ψ := ψ) in PT2.
  3: eapply pt_entails with (φ := φ) (ψ := ψ) in PT1;
    eapply pt_entails with (φ := φ) (ψ := ψ) in PT2; auto.
  1-2:
    destruct PT1 as [PT11 PT12];
    destruct PT2 as [PT21 PT22];
    split; ins.
  all: do 4 intro; specializer.
  all: unfold "⊨", implb in *; simpls; unfold negb, "||" in *.
  all: ins; desf.
Qed.

Lemma pt_conj_impl  φ ψ t1 t2
      (PT1 : predTransformer t1)
      (PT2 : predTransformer t2)
      (DISJ : ~ Formula.satisfiable (φ ∧ ψ)) :
  predTransformer (fun x => (φ ⇒ t1 x) ∧ (ψ ⇒ t2 x)).
Proof.
  apply pt_split_world with (χ := φ).
  { eapply pt_equiv with (t' := fun _ => _).
    { ins.
      rewrite impl_as_disj_remember,
              conj_spread,
              conj_impl_weaker_premise,
              conj_impl_disjunctive_premise at 1; auto.
      { easy. }
      now eapply entails_impl with (φ := φ). }
    now apply impl_preserves_pt,
              conj_r_preserves_pt,
              conj_l_preserves_pt. }
  eapply pt_equiv with (t' := fun _ => _).
  { ins.
    rewrite impl_as_disj_remember,
            conj_spread,
            conj_impl_disjunctive_premise at 1; auto.
    { easy. }
    rewrite <- elim_dneg.
    apply taut_equiv_not_satisfiable_neg.
    rewrite formula_de_morgan2, elim_dneg.
    apply formula_lem. }
  now apply impl_preserves_pt,
            conj_l_preserves_pt,
            conj_l_preserves_pt,
            impl_preserves_pt.
Qed.

Lemma conj_list_pt {A} (l : list A) φ τ
      (DISJ : ForallPairs (fun i j => Formula.satisfiable (φ i ∧ φ j) -> i = j) l)
      (PT : Forall (fun i => predTransformer (τ i)) l) :
  predTransformer (fun x => Formula.conj_list (map (fun i => φ i ⇒ τ i x) l)).
Proof.
  induction l; ins; desf.
  apply pt_split_world with (χ := φ a).
  2: { eapply pt_equiv with (t' := fun _ => _).
       { ins.
         rewrite impl_as_disj_remember,
         conj_spread,
         conj_impl_disjunctive_premise at 1; auto; try easy.
         apply taut_equiv_not_satisfiable_neg.
         rewrite elim_dneg. apply formula_lem. }
       apply impl_preserves_pt,
             conj_l_preserves_pt,
             conj_l_preserves_pt.
       apply IHl.
       { unfold ForallPairs; ins.
         apply DISJ; basic_solver. }
       inv PT. }
  eapply pt_equiv with (t' := fun x => φ a ⇒ (φ a ⇒ τ a x)).
  2: { do 2 apply impl_preserves_pt. inv PT. }
  ins.
  rewrite impl_conj_r.
  split; [now apply entails_elim_conj_l1|].
  apply entails_elim_conj_r; split; try easy.
  clear IHl. induction l; ins.
  { red_helper; ins; desf. }
  rewrite impl_conj_r.
  apply entails_elim_conj_r. split.
  2: { apply IHl.
       { red; ins; apply DISJ; auto; desf; try by repeat constructor. }
       eapply incl_Forall; eauto.
       red; ins; desf; auto. }
  red_helper; ins; desf.
  enough (a = a0); subst; try easy.
  apply DISJ; try by repeat constructor.
  apply sat_iff. repeat eexists; ins.
  now rewrite Heq3, Heq2.
Qed.

End PredTransformer.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** In this file we define several types of automatas:
    - [MAUT] : automatas represented with matrices
    - [eNFA] : non-deterministric automatas with epsilon transitions
    - [NFA] : non-deterministric automatas without epsilon transitions
    - [DFA] : deterministic automatas

    We also define useful notations, generic functions, and lemmas.
*)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import Monoid.
Require Import SemiLattice.
Require Import SemiRing.
Require Import KleeneAlgebra.
Require Import MxGraph.
Require Import MxSemiLattice.
Require Import MxSemiRing.
Require Import MxKleeneAlgebra.
Require Export BoolView.
Require Export Model_RegExp.
        Export RegExp.Load.

Require Import MyFSets.
Require Import MyFSetProperties.
Require Import MyFMapProperties.
Require FMapAVL.

Require Numbers. Export Numbers.PositiveUtils.

Set Implicit Arguments.
Unset Strict Implicit.

Module Label := Pos_as_OT.
Module StateSet := NumSet.
Module StateSetProps := NumSetProps.

Module StateMap := NumMap.
Module StateMapProps := NumMapProps.

Module StateLabel := PairOrderedType NumOTA NumOTA.
Module StateLabelMap' := FMapAVL.Make StateLabel. Module StateLabelMap := FMapHide StateLabelMap'.
Module StateLabelMapProps := MyMapProps StateLabelMap.

Notation label := num (only parsing).
Notation state := num (only parsing).
Notation stateset := StateSet.t.
Notation statemap := StateMap.t.
Notation statelabelmap := StateLabelMap.t.

Notation eq_state_bool := eqb.
Notation lt_state_bool := ltb.
Notation eq_label_bool := eqb.

Open Scope nat_scope.
Open Scope A_scope.

Notation nat_of_state := nat_of_num.
Notation state_of_nat := num_of_nat.

Definition statesetelt_of_nat: nat -> StateSet.elt := state_of_nat.
Coercion statesetelt_of_nat : nat >-> StateSet.elt.

Definition statemapelt_of_nat: nat -> StateMap.key := state_of_nat.
Coercion statemapelt_of_nat : nat >-> StateMap.key.

Definition numota_of_nat: nat -> NumOTA.t := state_of_nat.
Coercion numota_of_nat : nat >-> NumOTA.t.

Notation below := lt.
Definition setbelow s n := forall i, StateSet.In i s -> below i n.

Definition optionset_to_set o :=
  match o with
    | Some p => p
    | None => StateSet.empty
  end.

Definition statemap_set_to_fun e := fun i => optionset_to_set (StateMap.find i e).

Notation fold_states := fold_num (only parsing).
Notation fold_labels := fold_num (only parsing).

Definition labelling max (mem: label -> bool): regex :=
  sum 0 max (fun a => xif (mem a) (RegExp.var (num_of_nat a): regex) 0).

(** High-level automata, represented with matrices *)
Module MAUT.
  Record t := mk {
    size:    nat;
    initial: KMX 1    size;
    delta:   KMX size size;
    final:   KMX size 1
  }.

  (** formal evaluation to a regex *)
  Definition eval A: regex := mx_to_scal (initial A * delta A # * final A).

  Inductive equal : relation t :=
  | equal_refl: forall n U U' (M M': KMX n n) V V',
    U == U' -> M == M' -> V == V' -> equal (mk U M V) (mk U' M' V').

  Infix " [==] " := equal (at level 80).

  Instance equal_equiv : Equivalence equal.
  Proof.
    constructor.
    intro x; destruct x. constructor; reflexivity.
    intros x y H. destruct H. constructor; auto.
    intros x y z Hxy Hyz.
    assert (Sxy: size x = size y /\
                 mx_equal_at 1 (size x) (initial x) (initial y) /\
                 mx_equal_at (size x) (size x) (delta x) (delta y) /\
                 mx_equal_at (size x) 1 (final x) (final y)
    ). destruct Hxy. auto.
    clear Hxy.
    destruct Hyz. destruct x. simpl in Sxy. intuition. subst.
    constructor.
     transitivity U; assumption.
     transitivity M; assumption.
     transitivity V; assumption.
  Qed.

  Instance eval_compat : Proper (equal ==> Classes.equal tt tt) eval.
  Proof.
    intros A B H. destruct H. auto with compat.
  Qed.

End MAUT.

(** Non deterministic automata, with epsilon transitions *)
Module eNFA.
  Record t := mk {
    size:      state;                  (* next fresh state (= size) *)
    epsilon:   state -> stateset;      (* epsilon-transitions *)
    deltamap:  statelabelmap stateset; (* visible transitions (we keep a map for efficiency reasons) *)
    initial:   state;                  (* starting state *)
    final:     state;                  (* accepting state *)
    max_label: label                   (* maximal label + 1 *)
  }.

  Definition delta A a i := optionset_to_set (StateLabelMap.find (i,a) (deltamap A)).

  Definition well_founded A := well_founded (fun x y => StateSet.mem x (epsilon A y) = true).

  Notation belong s A := (below s (size A)).
  Notation setbelong s A := (setbelow s (size A)).

  Record bounded A := {
    bounded_delta: forall a i, setbelong (delta A a i) A;
    bounded_eps: forall i, setbelong (epsilon A i) A;
    bounded_initial: belong (initial A) A;
    bounded_final: belong (final A) A
  }.

  (** translation to matricial automata *)
  Definition to_MAUT A :=
    let n := nat_of_state (size A) in
      MAUT.mk
      (mx_point 1 n 0 (initial A) 1)
      (mx_bool _ n n (fun i j => StateSet.mem j (epsilon A i))
         + box n n (fun i j => labelling (max_label A)
                       (fun a => StateSet.mem j (delta A a i))))
      (mx_point n 1 (final A) 0 1).

  Definition eval := to_MAUT >> MAUT.eval.

End eNFA.

(** Non deterministic, epsilon-free automata *)
Module NFA.
  Record t := mk {
    size:      state;
    delta:     label -> state -> stateset;
    initiaux:  stateset;
    finaux:    stateset;
    max_label: label
  }.

  Notation belong s A := (below s (size A)).
  Notation setbelong s A := (setbelow s (size A)).

  Record bounded A := {
    bounded_delta: forall a i, setbelow (delta A a i) (size A);
    bounded_initiaux: setbelong (initiaux A) A;
    bounded_finaux: setbelong (finaux A) A
  }.

  (** translation to matricial automata *)
  Definition to_MAUT A :=
    let n := nat_of_state (size A) in
      MAUT.mk
    (mx_bool _ 1 n (fun _ j => StateSet.mem j (initiaux A)))
    (box n n (fun i j => labelling (max_label A)
                 (fun a => StateSet.mem j (delta A a i))))
    (mx_bool _ n 1 (fun i _ => StateSet.mem i (finaux A))).

  Definition eval := to_MAUT >> MAUT.eval.

  Definition change_initial A i :=
    mk (size A) (delta A) i (finaux A) (max_label A).

End NFA.

(** Deterministic automata *)
Module DFA.
  Record t := mk {
    size:      state;
    delta:     label -> state -> state;
    initial:   state;
    finaux:    stateset;
    max_label: label
  }.

  Notation belong s A := (below s (size A)).
  Notation setbelong s A := (setbelow s (size A)).

  (* In order to ease the definition of merge, we require that
  the automata are bounded even outside their domain *)
  Record bounded A := {
    bounded_delta: forall a i,  belong (delta A a i) A;
    bounded_initial: belong (initial A) A;
    bounded_finaux: setbelong (finaux A) A
  }.

  (** translation to matricial automata *)
  Definition to_MAUT A :=
    let n := nat_of_state (size A) in
      MAUT.mk
      (mx_point 1 n 0 (initial A) 1)
      (box n n (fun i j => labelling (max_label A)
                   (fun a => eq_state_bool (state_of_nat j) (delta A a i))))
      (mx_bool _ n 1 (fun i _ => StateSet.mem i (finaux A))).

  Definition eval := to_MAUT >> MAUT.eval.

  Definition change_initial A i :=
    mk (size A) (delta A) i (finaux A) (max_label A).

End DFA.

(** algebraic lemmas, to prove correctness of various steps of the decision procedure  *)

Section Alg.

  Context `{KA: KleeneAlgebra}.

  (** this one is used when merging two DFAs  *)
  Lemma left_filter i k k' j (s: X k k') m m' u (u': X i k') v (v': X k' j):
    u*s ==   u' ->
    m*s == s*m' ->
    v   == s*v' ->
    u'*m'#*v' == u*m#*v.
  Proof.
    intros Hu Hm Hv.
    rewrite Hv, <- Hu, dot_assoc.
    monoid_rewrite (comm_iter_left Hm).
    semiring_reflexivity.
  Qed.

  (** this one is used for determinisation *)
  Lemma right_filter i k k' j (s: X k' k) m m' u (u': X i k') v (v': X k' j):
      u == u'*s ->
    s*m == m'*s ->
    s*v == v'   ->
    u'*m'#*v' == u*m#*v.
  Proof.
    intros Hu Hm Hv.
    rewrite Hu, <- Hv, dot_assoc.
    monoid_rewrite (comm_iter_right Hm).
    semiring_reflexivity.
  Qed.

  (** and [equiv_filter] below is used for the DFA equivalence check *)
  Lemma iter_equivalence n (y m: X n n): 1 <== y -> y * y <== y -> y * m <== m * y -> m# * y == y * (m * y)#.
  Proof.
    intros H1y Hyy Hym.
    apply comm_iter_left.
    apply leq_antisym.
     rewrite <- H1y at 2. semiring_reflexivity.
     rewrite dot_assoc, Hym. monoid_rewrite Hyy. reflexivity.
  Qed.

  Lemma equiv_filter n p q (y m: X n n) (ia ib : X p n) (v : X n q):
    ia * y == ib * y ->
    y * m <== m * y ->
    y * v == v ->
    1 <== y ->
    y * y <== y ->
    ia * m # * v == ib * m # * v.
  Proof.
    intros Hiy Hym Hyv H1y Hyy.
    rewrite <- Hyv, 2dot_assoc.
    monoid_rewrite (iter_equivalence H1y Hyy Hym).
    rewrite dot_assoc, Hiy.
    semiring_reflexivity.
  Qed.

End Alg.


(** * RIS.list tools : Toolbox of list operators and their properties. *)

Require Import notations Psatz Bool.
Require Export List.
Export ListNotations.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Global Hint Unfold Basics.compose : core.

(** * Lists *)

(** ** Notations *)
(** We associate the traditional containment symbol to list inclusion. *)
Infix " ⊆ " := incl (at level 80).

(** We use the following symbol to denote the membership predicate. *)
Infix " ∈ " := In (at level 60).

(** We'll write [P :> l] for the list [l] where we've removed elements that do not satisfy the boolean predicate [P]. *)
Infix " :> " := filter (at level 50).

(** The size of a list is its length. *)
Global Instance SizeList {A} : Size (list A) := (@length A).

Remark SizeLength {A : Type} (l : list A) : length l = ⎢l⎥.
Proof. reflexivity. Qed.
Remark SizeCons {A:Type} (a : A) (l : list A) : ⎢a::l⎥ = S ⎢l⎥.
Proof. reflexivity. Qed.
Remark SizeNil {A:Type} : ⎢@nil A⎥ = 0.
Proof. reflexivity. Qed.
Remark SizeApp {A:Type} (l m : list A) : ⎢l++m⎥ = ⎢l⎥+⎢m⎥.
Proof. setoid_rewrite app_length;reflexivity. Qed.
Remark SizeMap {A B:Type} (l : list A) (f : A -> B): ⎢map f l⎥ = ⎢l⎥.
Proof. setoid_rewrite map_length;reflexivity. Qed.
Global Hint Rewrite @SizeLength @SizeCons @SizeNil @SizeApp @SizeMap: simpl_typeclasses.

(** ** Induction principles *)

(** Induction principle for lists in the reverse order. *)
Lemma rev_induction {A} (P : list A -> Prop) :
  P [] -> (forall a l, P l -> P (l++[a])) -> forall l, P l.
Proof.
  intros;rewrite <- rev_involutive;induction (rev l);simpl;auto.
Qed.

(** Strong induction on the length of a list. *)
Lemma len_induction {A} (P : list A -> Prop) :
  P [] -> (forall a l, (forall m, ⎢m⎥ <= ⎢l⎥ -> P m) -> P (a::l)) -> forall l, P l.
Proof.
  intros h0 hn l;remember ⎢l⎥ as N.
  assert (len:⎢l⎥ <= N) by lia.
  clear HeqN;revert l len;induction N.
  - intros [|a l];rsimpl;try lia;auto.
  - intros [|a l];rsimpl;auto.
    intro len;apply hn;intros m;simpl;intros len'.
    apply IHN;lia.
Qed.

(** Strong induction on the length of a list, taken in the reverse order. *)
Lemma len_rev_induction {A} (P : list A -> Prop) :
  P [] -> (forall a l, (forall m, ⎢m⎥ <= ⎢l⎥ -> P m) -> P (l++[a])) -> forall l, P l.
Proof.
  intros h0 hn l;remember ⎢l⎥ as N.
  assert (len:⎢l⎥ <= N) by lia.
  clear HeqN;revert l len;induction N.
  - intros [|a l];rsimpl;try lia;auto.
  - intros l0;case_eq l0;[intros->;simpl;auto|].
    intros a0 l0' _;destruct (@exists_last _ (a0::l0')) as (l&a&->);[discriminate|].
    rsimpl;intro len;apply hn;intros m;simpl;intros len'.
    apply IHN;lia.
Qed.

(** ** General lemmas *)
(** A list is not empty if and only if it has a last element. *)
Lemma not_nil_add {A} (v : list A) : v <> [] <-> exists u l, v = u++[l].
Proof.
  split.
  - induction v;try tauto.
    intros _;destruct v.
    + exists [];exists a;reflexivity.
    + destruct IHv as (u&x&->);try discriminate.
      exists (a::u),x;split.
  - intros (u&l&E) -> .
    apply app_cons_not_nil in E;auto.
Qed.

(** A list is either empty or can be decomposed with its last element apparent.*)
Lemma nil_or_last {A} (v : list A) : {v = []} + {exists a v', v = v'++[a]}.
Proof.
  induction v.
  - left;reflexivity.
  - right;destruct IHv as [->|(b&v'&->)].
    + exists a,[];reflexivity.
    + exists b,(a::v');reflexivity.
Qed.

(** If the list [l++a::l'] is duplicate free, so are [l] and [l']. *)
Lemma NoDup_remove_3 {A} (l l' : list A) (a : A) :
    NoDup (l ++ a :: l') -> NoDup l /\ NoDup l'.
Proof.
  revert l' a;induction l;intros l' b;simpl;
    repeat rewrite NoDup_cons_iff.
  - intros (_&h);split;auto;apply NoDup_nil.
  - rewrite in_app_iff;intros (N&hyp);apply IHl in hyp as (h1&h2);
      repeat split;auto.
Qed.

(** Filtering a concatenation is the same as concatenating filters. *)
Lemma filter_app {A} (f : A -> bool) (l m : list A) :
  f :> (l++m) = f :> l ++ f :> m.
Proof.
  induction l;simpl;auto.
  destruct (f a);simpl;auto.
  f_equal;auto.
Qed.

(** Filtering reduces the length of the list. *)
Lemma filter_length {A} (f : A -> bool) l :
  ⎢f :> l⎥ <= ⎢l⎥ .
Proof.
  induction l;rsimpl;auto.
  destruct (f a);rsimpl;lia.
Qed.

(** The following lemma give a more precise description. *)
Lemma filter_length_eq {A} (f : A -> bool) l :
  ⎢f :> l⎥ + ⎢(fun x => negb (f x)) :> l⎥ = ⎢l⎥ .
Proof.
  induction l;rsimpl;auto.
  destruct (f a);rsimpl;lia.
Qed.

(** If there is an element in [l] not satisfying f, then  [f :> l] is strictly smaller than [l]. *)
Lemma filter_length_lt {A} (f : A -> bool) (l : list A) a :
  a ∈ l -> f a = false -> ⎢f :> l⎥<⎢l⎥.
Proof.
  induction l as [|b L];simpl;[tauto|].
  intros [<-|I].
  - intros ->;rsimpl.
    pose proof (filter_length f L) as hyp;lia.
  - intros F;pose proof (IHL I F) as hyp.
    destruct (f b);rsimpl;lia.
Qed.

(** [filter] and [map] commute. *)
Lemma filter_map {A B} (f : A -> bool) (g : B -> A) l :
  f :> (map g l) = map g ((fun x => f (g x)) :> l).
Proof.
  induction l;simpl;auto.
  unfold Basics.compose;destruct (f (g a));simpl;auto.
  f_equal;auto.
Qed.

(** [filter] only depends on the values of the filtering function, not its implementation. *)
Lemma filter_ext_In {A} (f g : A -> bool) l :
  (forall x, x ∈ l -> f x = g x) -> f :> l = g :> l.
Proof.
  intro hyp;induction l as [|x l];simpl;auto.
  case_eq (f x);case_eq (g x).
  - intros _ _; f_equal;apply IHl;intros y I;apply hyp;now right.
  - intros h1 h2;exfalso.
    cut (true=false);[discriminate|].
    rewrite <-h1,<-h2;apply hyp;now left.
  - intros h1 h2;exfalso.
    cut (true=false);[discriminate|symmetry].
    rewrite <-h1,<-h2;apply hyp;now left.
  - intros _ _;apply IHl;intros y I;apply hyp;now right.
Qed.

Lemma filter_ext {A} (f g : A -> bool) l :
  (forall x, f x = g x) -> f :> l = g :> l.
Proof. intros hyp;apply filter_ext_In;intros x _;apply hyp. Qed.

(** Filtering with the predicate [true] does not modify the list. *)
Lemma filter_true {A} (l : list A) :
  (fun _ => true) :> l = l.
Proof. induction l;simpl;auto;congruence. Qed.

(** Filtering preserves the property [NoDup] (absence of duplicates). *)
Lemma filter_NoDup {A} (f : A -> bool) l :
  NoDup l -> NoDup (f :> l).
Proof.
  induction l;simpl;auto.
  destruct (f a);repeat rewrite NoDup_cons_iff;
    try rewrite filter_In;tauto.
Qed.

(** A filtered list [P :> l] is empty if and only if [P x] is [false] for every element [x∈l]. *)
Lemma filter_nil {A} (P : A -> bool) l :
  P:>l = [] <-> forall a, a ∈ l -> P a = false.
Proof.
  induction l;simpl;[tauto|].
  case_eq (P a);intro E.
  - split;[discriminate|].
    intro h;exfalso;pose proof (h a) as F;rewrite E in F.
    intuition discriminate.
  - rewrite IHl;clear IHl;firstorder subst;auto.
Qed.

(** If two concatenations are equal, and if the two initial factors have the same length, then the factors are equal. *)
Lemma length_app {A} (l1 l2 m1 m2 : list A) :
  ⎢l1⎥ = ⎢m1⎥ -> l1++l2 = m1++m2 -> l1 = m1 /\ l2 = m2.
Proof.
  intros El Ea.
  cut (l1 = m1).
  - intros ->;split;auto.
    eapply app_inv_head,Ea.
  - transitivity (firstn ⎢l1⎥ (l1++l2)).
    + rewrite firstn_app,PeanoNat.Nat.sub_diag;simpl.
      rewrite app_nil_r.
      setoid_rewrite firstn_all;reflexivity.
    + rewrite Ea,El.
      rewrite firstn_app,PeanoNat.Nat.sub_diag;simpl.
      rewrite app_nil_r;setoid_rewrite firstn_all;reflexivity.
Qed.

(** If two concatenations are equal, and if the two final factors have the same length, then the factors are equal. *)
Lemma length_app_tail {A} (l1 l2 m1 m2 : list A) :
  ⎢l2⎥ = ⎢m2⎥ -> l1++l2 = m1++m2 -> l1 = m1 /\ l2 = m2.
Proof.
  intros L;revert m1;induction l1;intros [|b m];rsimpl;auto.
  - intros ->;exfalso;rsimpl in L;lia.
  - intros <-;exfalso;rsimpl in L;lia.
  - intro E;inversion E as [[Ea El]];apply IHl1 in El as (->&->);auto.
Qed.

(** If two concatenations are equal, and the first initial factor is
smaller than the second one, we can find a unifying factor [w]. *)
Lemma app_eq_app_length {A : Set} (u1 u2 v1 v2 : list A) :
  u1++u2 = v1 ++ v2 -> ⎢u1⎥ <= ⎢v1⎥ -> exists w, v1 = u1++w /\ u2 = w++v2.
Proof.
  set (k:= ⎢v1⎥ - ⎢u1⎥ ).
  intros E L.
  assert (EL : ⎢u1 ++ u2⎥ = ⎢v1 ++ v2⎥) by (rewrite E;reflexivity).
  repeat rewrite app_length in EL.
  rewrite <- (firstn_skipn k u2) in E.
  rewrite <- (firstn_skipn k u2).
  rewrite <-app_ass in E.
  apply length_app in E as (E1 & E2).
  - rewrite <-E1, <-E2;eexists;eauto.
  - rsimpl in *;setoid_rewrite firstn_length_le;rsimpl;unfold k;lia.
Qed.

(** If two concatenations are equal, we can always find a unifying factor. *)
Lemma Levi {A:Set} (u1 u2 v1 v2 : list A) :
  u1++u2 = v1++v2 -> exists w, (u1=v1++w /\ v2=w++u2) \/ (v1=u1++w /\ u2=w++v2).
Proof.
  intro E;destruct (Compare_dec.le_lt_dec ⎢u1⎥ ⎢v1⎥ ) as [L|L].
  - apply (app_eq_app_length E) in L as (w&->&->).
    exists w;right;auto.
  - symmetry in E;apply app_eq_app_length in E as (w&->&->);[|lia].
    exists w;left;auto.
Qed.

(** This next lemma makes the unifying factor unambiguous. *)
Lemma Levi_strict {A:Set} (u1 u2 v1 v2 : list A) :
  u1++u2 = v1++v2 -> (u1 = v1 /\ u2 = v2)
                    \/ exists a w, (u1=v1++a::w /\ v2=a::w++u2) \/ (v1=u1++a::w /\ u2=a::w++v2).
Proof.
  intro E;destruct (Compare_dec.le_lt_dec ⎢u1⎥ ⎢v1⎥ ) as [L|L];
    [apply Compare_dec.le_lt_eq_dec in L as [L|L]|].
  - apply app_eq_app_length in E as (w&->&->);[|lia];rsimpl in L.
    destruct w as [|a w];[rsimpl in L;lia|].
    right;exists a,w;right;auto.
  - apply length_app in E;tauto.
  - symmetry in E;apply app_eq_app_length in E as (w&->&->);[|lia].
    rsimpl in L;destruct w as [|a w];[rsimpl in L;lia|].
    right;exists a,w;left;auto.
Qed.

Ltac levi u v :=
  let a := fresh "a" in
  let w := fresh "w" in
  let h := fresh "h" in
  let E1 := fresh "E" in
  let E2 := fresh "E" in
  assert (h:u=v);
  [auto
  |destruct (Levi_strict h) as [E1|(a&w&[E1|E1])];
   destruct E1 as (E1&E2);repeat (rewrite E1 in * || rewrite E2 in * )].

Tactic Notation "levi" hyp(h) :=
  let a := fresh "a" in
  let w := fresh "w" in
  let E1 := fresh "E" in
  let E2 := fresh "E" in
  destruct (Levi_strict h) as [E1|(a&w&[E1|E1])];
  destruct E1 as (E1&E2);repeat (rewrite E1 in * || rewrite E2 in * ).

(** If the concatenation of two lists is duplication free, then so are they. *)
Lemma NoDup_app_inv {X:Set} : forall (l m : list X),
    NoDup (l++m) -> NoDup l /\ NoDup m.
Proof.
  induction l;simpl;intros m nd.
  - split;auto using NoDup_nil.
  - rewrite NoDup_cons_iff in *;rewrite in_app_iff in nd.
    firstorder.
Qed.

(** If [l] and [m] don't share any element, then if both of them don't have duplication their concatenation won't either. *)
Lemma NoDup_app {X : Set} l m:
  (forall a : X, a ∈ l -> ~ a ∈ m) -> NoDup l ->  NoDup m -> NoDup (l++m).
Proof.
  intros h1 h2 h3;revert h2 m h3 h1; induction l.
  - simpl;intros;auto.
  - intros hl m hm h; inversion hl.
    simpl;apply NoDup_cons;auto.
    + rewrite in_app_iff;firstorder.
    + apply IHl;firstorder.
Qed.

(** If the boolean predicate [forallb f l] is false, then me may extract a counter-example, that is an element in the list [l] where the predicate [f] is false. *)
Lemma forallb_false_exists {A} f (l:list A) :
  forallb f l = false <-> exists a, a ∈ l /\ f a = false.
Proof.
  induction l;simpl.
  - split;[discriminate|firstorder].
  - rewrite andb_false_iff,IHl;split.
    + intros [h|(b&I&h)].
      * exists a;auto.
      * exists b;auto.
    + intros (b&[<-|I]&h);firstorder.
Qed.

(** [l] appears in the list [concat m] exactly when there is a list [L] in [m] such that [l] appears in [L]. *)
Lemma in_concat {A : Set} l (m : list (list A)) :
  l ∈ concat m <-> exists L, L ∈ m /\ l ∈ L.
Proof.
  induction m as [|L m].
  - simpl;firstorder.
  - simpl;rewrite in_app_iff,IHm;clear;firstorder (subst;tauto).
Qed.

(** If [map f m] can be split into [l1++l2], then we may split [l] into [m1++m2] accordingly. *)
Lemma map_app_inverse {A B} (f : A -> B) m l1 l2 :
  map f m = l1 ++ l2 -> exists m1 m2, l1 = map f m1 /\ l2 = map f m2 /\ m = m1 ++ m2.
Proof.
  revert m;induction l1 as [|a l1];intros l E;simpl in *.
  - exists [],l;split;auto.
  - destruct l as [|b l];simpl in E;inversion E.
    apply IHl1 in H1 as (m1&m2&->&->&->).
    exists (b::m1),m2;repeat split;auto.
Qed.

(** [lift_prod f] is the pointwise extension of the binary operation [f] over [A] into a binary operation over [list A].  *)
Definition lift_prod {A} (f : A -> A -> A) : list A -> list A -> list A :=
  fun l m => flat_map (fun a => map (f a) m) l.

Lemma lift_prod_spec {A} f (l m : list A) :
  forall c, c ∈ lift_prod f l m <-> exists a b, a ∈ l /\ b ∈ m /\ c = f a b.
Proof. intro c; unfold lift_prod;rewrite in_flat_map;setoid_rewrite in_map_iff;firstorder. Qed.

Lemma incl_map {A B:Set} (f : A -> B) l m : l ⊆ map f m -> exists n, l = map f n /\ n ⊆ m.
Proof.
  induction l as [|a l].
  - intros _;exists [];split;[reflexivity|intro;simpl;tauto].
  - intros I.
    assert (Ia : a ∈ (a :: l)) by (now left).
    apply I,in_map_iff in Ia as (b&<-&Ib).
    destruct IHl as (n&->&I').
    + intros x Ix;apply I;now right.
    + exists (b::n);split;[reflexivity|].
      apply incl_cons;tauto.
Qed.

(** ** Lists of pairs *)
(** We introduce some notations for lists of pairs: [prj1 l] is the list obtained by applying pointwise to [l] the function [fun (x,y) => x]. *)
Notation prj1 := (map fst).
(** Similarly, [prj2 l] is the list obtained by applying pointwise to [l] the function [fun (x,y) => y]. *)
Notation prj2 := (map snd).

(** If the a projection of [l] is equal to a projection of [m], then they have the same length. *)
Lemma proj_length {A B C} (l : list (A*B)) (m:list (B*C)) : prj2 l = prj1 m -> ⎢l⎥=⎢m⎥.
Proof. intro E;setoid_rewrite<-(map_length snd);rewrite E;rsimpl;reflexivity. Qed.

(** *** Combine *)
Section combine.
  Context {A B : Set}.
  Context {l1 l3 : list A} {l2 l4: list B} {l: list (A*B)}.
  Hypothesis same_length : ⎢l1⎥ = ⎢l2⎥.

  (** The combine function can be described by the following recursive definition :
      - [[]⊗l = l⊗[] = []];
      - [(a::l)⊗(b::m)=(a,b)::(l⊗m)].
      In the following, we will only use [l⊗m] when [l] and [m] have the same length.
   *)
  Infix "⊗" := combine (at level 50).

  (** The first projection of [l1 ⊗ l2] is [l1]. *)
  Lemma combine_fst : prj1 (l1 ⊗ l2) = l1.
  Proof.
    revert l2 same_length;induction l1 as [|a l0];intros [|c l2];try (rsimpl;lia).
    - intros _;reflexivity.
    - simpl;intros L.
      rewrite IHl0;auto.
  Qed.

  (** The second projection of [l1 ⊗ l2] is [l2]. *)
  Lemma combine_snd : prj2 (l1 ⊗ l2) = l2.
  Proof.
    revert l2 same_length;induction l1 as [|a l0];intros [|b l2];try (rsimpl;lia).
    - intros _;reflexivity.
    - simpl;intros L.
      rewrite IHl0;auto.
  Qed.

  (** A combination of concatenations is the concatenation of combinations (assuming the first arguments of both concatenations have the same length). *)
  Lemma combine_app : (l1++l3) ⊗ (l2++l4) = l1 ⊗ l2 ++ l3 ⊗ l4.
  Proof.
    revert l2 l3 l4 same_length;induction l1 as [|a l0];intros [|b l2] l3 l4;try (rsimpl;lia).
    - intros _;reflexivity.
    - simpl;intros L;f_equal.
      rewrite IHl0;auto.
  Qed.

  (** Every list of pairs can be expressed as the combination of its first and second components. *)
  Lemma combine_split : l = (prj1 l) ⊗ (prj2 l).
  Proof. induction l as [|(a,b)l'];simpl;auto;f_equal;auto. Qed.

End combine.
Infix "⊗" := combine (at level 50).

(** *** Mix *)
Section mix.
  Context {A B : Set} {s1 s2 s3 s4 : list (A*B)}.
  Hypothesis same_length : ⎢s1⎥ = ⎢s2⎥.

  (** Given two lists of pairs [s1] and [s2], the mix of [s1] and [s2] is the combination of the first projection of [s1] with the second projection of [s2]. We will only use this construct when [s1] and [s2] have the same length. *)
  Definition mix (s1 s2 : list (A*B)) := (prj1 s1) ⊗ (prj2 s2).
  Infix "⋈" := mix (at level 50).

  Lemma mix_fst : prj1 (s1 ⋈ s2) = prj1 s1.
  Proof. intros;unfold mix;rewrite combine_fst;rsimpl;auto. Qed.

  Lemma mix_snd : prj2 (s1 ⋈ s2) = prj2 s2.
  Proof. intros;unfold mix;rewrite combine_snd;rsimpl;auto. Qed.

  Lemma mix_app : (s1++s3) ⋈ (s2++s4) = s1 ⋈ s2 ++ s3 ⋈ s4.
  Proof. intros;unfold mix;rewrite map_app,map_app,combine_app;rsimpl;auto. Qed.
End mix.
Infix "⋈" := mix (at level 50).

(** *** Flip *)
Section flip.
  Context {A B : Set} {l m : list (A*B)}.

  (** Flipping a list of pairs amounts to applying pointwise to the list the function [fun (x,y) => (y,x)], that is exchanging the order of every pair in the list. *)
  Definition flip {A B} : list (A*B) -> list (B*A) := map (fun x => (snd x,fst x)).
  Notation " l ` " := (flip l) (at level 20).

  (** Flip is an involution. *)
  Lemma flip_involutive : l`` = l.
  Proof.
    unfold flip;rewrite map_map;simpl.
    erewrite map_ext;[apply map_id|intros (?,?);simpl;auto].
  Qed.

  (** Flip distributes over concatenations. *)
  Lemma flip_app : (l++m)`=l`++m`.
  Proof. intros;apply map_app. Qed.

  (** Flip swaps first and second projections. *)
  Lemma flip_proj1 : prj1 (l `) = prj2 l.
  Proof. unfold flip;rewrite map_map;simpl;auto. Qed.

  Lemma flip_proj2 : prj2 (l `) = prj1 l.
  Proof. unfold flip;rewrite map_map;simpl;auto. Qed.

  (** The pair [(a,b)] is in [l] if and only if [(b,a)] is in [l`]. *)
  Lemma In_flip a b : (a,b) ∈ l ` <-> (b,a) ∈ l.
  Proof.
    unfold flip;rewrite in_map_iff;split.
    - intros ((c,d)&E&I);inversion E;subst;auto.
    - intro I;exists (b,a);simpl;auto.
  Qed.

End flip.
Notation " l ` " := (flip l) (at level 30).

(** ** Lists as finite sets *)

(** We say that two lists are equivalent if they contain the same elements. *)
Definition equivalent A l m := forall x : A , x ∈ l <-> x ∈ m.
Infix " ≈ " := equivalent (at level 80).

(** We now establish that [≈] is a congruence, and that [⊆] is a partial order.*)
Global Instance equivalent_Equivalence T : Equivalence (@equivalent T).
Proof.
  split.
  - intros l x; firstorder.
  - intros l m h x; firstorder.
  - intros l m h n h' x; firstorder.
Qed.
Global Instance incl_PreOrder T : PreOrder (@incl T).
Proof.
  split.
  - intros l x ;firstorder.
  - intros l m h n h' x;eauto.
Qed.
Global Instance incl_PartialOrder T :
  PartialOrder (@equivalent T) (@incl T).
Proof.
  intros l m;split.
  - intros h;split;intro x; firstorder.
  - intros (h1 & h2);intro x; firstorder.
Qed.

(** Concatenation preserves both relations. *)
Global Instance incl_app_Proper T :
  Proper ((@incl T) ==> (@incl T) ==> (@incl T)) (@app T).
Proof. intros l m h1 n o h2 x;repeat rewrite in_app_iff;intuition. Qed.
Global Instance equivalent_app_Proper T :
  Proper ((@equivalent T) ==> (@equivalent T) ==> (@equivalent T))
         (@app T).
Proof. intros l m h1 n o h2 x;repeat rewrite in_app_iff;firstorder. Qed.

(** The operation of adding an element to a list preserves both relations. *)
Global Instance incl_cons_Proper T a :
  Proper ((@incl T) ==> (@incl T)) (cons a).
Proof. intros l m h x;simpl in *;intuition. Qed.
Global Instance equivalent_cons_Proper T a :
  Proper ((@equivalent T) ==> (@equivalent T)) (cons a).
Proof. intros l m h x;simpl in *;firstorder. Qed.

(** For any function [f], the list morphism [map f] preserves both relations. *)
Global Instance map_incl_Proper {A B} (f : A -> B) :
  Proper (@incl A ==> @incl B) (map f).
Proof.
  intros l m I x;rewrite in_map_iff,in_map_iff.
  intros (y&<-&J);exists y;split;auto.
Qed.
Global Instance map_equivalent_Proper {A B} (f : A -> B) :
  Proper (@equivalent A ==> @equivalent B) (map f).
Proof.
  intros l m I x;rewrite in_map_iff,in_map_iff.
  split;intros (y&<-&J);exists y;split;auto;apply I,J.
Qed.

(** For any boolean predicate [f], the filtering map [filter f] preserves both relations. *)
Global Instance filter_incl_Proper {A} (f : A -> bool) :
  Proper (@incl A ==> @incl A) (filter f).
Proof.
  intros l m I x;repeat rewrite filter_In.
  intros (J&->);split;auto.
Qed.
Global Instance filter_equivalent_Proper {A} (f : A -> bool) :
  Proper (@equivalent A ==> @equivalent A) (filter f).
Proof.
  intros l m I x;repeat rewrite filter_In.
  split;intros (J&->);split;auto;apply I,J.
Qed.

(** The lemmas [In_incl_Proper] and [In_equivalent_Proper] are completely tautological, but turn out to be useful for technical reasons. *)
Global Instance In_incl_Proper {A} (x : A): Proper ((@incl A) ==> Basics.impl) (In x).
Proof. intros l m I;firstorder. Qed.
Global Instance In_equivalent_Proper {A} (x : A): Proper ((@equivalent A) ==> iff) (In x).
Proof. intros l m I;firstorder. Qed.

(** The operation of reversing a list preserves both relations. *)
Lemma rev_equivalent {A} (l : list A) : l ≈ rev l.
Proof. intro x;apply in_rev. Qed.
Global Instance incl_rev_Proper T : Proper ((@incl T) ==> (@incl T)) (@rev T).
Proof. intros l m h x;simpl in *;repeat rewrite <-in_rev;intuition. Qed.
Global Instance equivalent_rev_Proper T : Proper ((@equivalent T) ==> (@equivalent T)) (@rev T).
Proof. intros l m h x;simpl in *;repeat rewrite <-in_rev;apply h. Qed.

(** The [flat_map] function preserves both relations. *)
Global Instance incl_flat_map_Proper A B (f : A -> list B) :
  Proper ((@incl A) ==> (@incl B)) (flat_map f).
Proof. intros l m h x;simpl in *;repeat rewrite in_flat_map;firstorder. Qed.
Global Instance equivalent_flat_map_Proper A B (f : A -> list B) :
  Proper ((@equivalent A) ==> (@equivalent B)) (flat_map f).
Proof. intros l m h x;simpl in *;repeat rewrite in_flat_map;firstorder. Qed.

(** The [lift_prod f] function preserves both relations. *)
Global Instance incl_lift_prod_Proper {A:Set} (f : A -> A -> A) :
  Proper ((@incl _) ==> (@incl _) ==> (@incl _)) (lift_prod f).
Proof.
  intros l1 l2 E1 m1 m2 E2.
  transitivity (lift_prod f l1 m2).
  - clear l2 E1.
    induction l1;simpl.
    + reflexivity.
    + rewrite E2 at 1;rewrite IHl1;reflexivity.
  - clear m1 E2.
    induction l1;simpl.
    + intro;simpl;tauto.
    + rewrite IHl1 by (rewrite <- E1;apply incl_tl;reflexivity).
      clear IHl1;intro b;rewrite in_app_iff,in_map_iff;intros [(c&<-&Ic)|I];[|assumption].
      apply lift_prod_spec;exists a,c;rewrite <- E1;simpl;tauto.
Qed.
Global Instance equivalent_lift_prod_Proper {A:Set} (f : A -> A -> A) :
  Proper ((@equivalent _) ==> (@equivalent _) ==> (@equivalent _)) (lift_prod f).
Proof.
  intros l1 l2 E1 m1 m2 E2;apply incl_PartialOrder;unfold Basics.flip;simpl;split.
  - apply incl_PartialOrder in E1 as (->&_).
    apply incl_PartialOrder in E2 as (->&_).
    reflexivity.
  - apply incl_PartialOrder in E1 as (_&->).
    apply incl_PartialOrder in E2 as (_&->).
    reflexivity.
Qed.

(** The following simple facts about inclusion and equivalence are convenient to have in our toolbox. *)
Lemma incl_nil T (A : list T) : [] ⊆ A.
Proof. intros x;firstorder. Qed.
Lemma incl_app_or T (A B C : list T) : A ⊆ B \/ A ⊆ C -> A⊆B++C.
Proof. intros [?|?];auto using incl_appl, incl_appr. Qed.
Create HintDb eq_list.
Lemma incl_app_split {A} (l m p : list A) : l++m ⊆ p <-> l⊆ p /\ m ⊆ p.
Proof. unfold incl;setoid_rewrite in_app_iff;firstorder. Qed.
Global Hint Resolve incl_appl incl_appr incl_nil app_assoc : eq_list.
Lemma app_idem {A} (l : list A) : l ++ l ≈ l.
Proof. intro;rewrite in_app_iff;tauto. Qed.
Lemma app_comm {A} (l m : list A) : l ++ m ≈ m ++ l.
Proof. intro;repeat rewrite in_app_iff;tauto. Qed.
Lemma incl_split {A} (l m n : list A) :
  l ⊆ m ++ n -> exists l1 l2, l ≈ l1++l2 /\ l1 ⊆ m /\ l2 ⊆ n.
Proof.
  induction l as [|a l];simpl;intro I.
  - exists [],[];split;[reflexivity|split;apply incl_nil].
  - destruct IHl as (l1&l2&E&I1&I2).
    + intros x Ix;apply I;now right.
    + assert (Ia : a ∈ (m++n)) by (apply I;now left).
      apply in_app_iff in Ia as [Ia|Ia].
      * exists (a::l1),l2;split;[rewrite E;reflexivity|].
        split;[|assumption].
        intros x [<-|Ix];[assumption|].
        apply I1,Ix.
      * exists l1,(a::l2);split;[rewrite E;intro;repeat (rewrite in_app_iff;simpl);tauto|].
        split;[assumption|].
        intros x [<-|Ix];[assumption|].
        apply I2,Ix.
Qed.

(** ** More general lemmas *)
(** If a boolean predicate [f] fails to be true for every element of a list [l], then there must exists a witnessing element [y] falsifying [f]. This is an instance of a classical principle holding constructively when restricted to decidable properties over finite domains. *)
Lemma forall_existsb {A} (f : A -> bool) l :
  ~ (forall x, x ∈ l -> f x = true) -> exists y, y ∈ l /\ f y = false.
Proof.
  induction l as [|a l].
  - intro h;exfalso;apply h.
    intros x;simpl;tauto.
  - intros h;case_eq (f a).
    + intro p;destruct IHl as (y&I&E).
      * intro h';apply h;intros x [<-|I];auto.
      * exists y;split;auto.
        now right.
    + intro E;exists a;split;auto.
      now left.
Qed.

(** In [forallb f l] we may replace [f] with a function [g] outputting the same values on the elements of [l]. *)
Lemma forallb_ext_In {A} (f g : A -> bool) l : (forall a, a ∈ l -> f a = g a) -> forallb f l = forallb g l.
Proof.
  induction l;simpl;[|f_equal];auto.
  intros h;f_equal;[apply h|apply IHl];auto.
Qed.

(** In [forallb f l] we may replace [f] with a function [g] outputting the same values. *)
Lemma forallb_ext {A} (f g : A -> bool) l : (forall a, f a = g a) -> forallb f l = forallb g l.
Proof. intro h;apply forallb_ext_In;intros;apply h. Qed.

(** For every list [l] and every function [f], [l] is a fixpoint of [map f] if and only if every element of [l] is a fixpoint of [f]. *)
Lemma map_eq_id {A} (l : list A) (f : A -> A) :
  map f l = l <-> (forall x, x ∈ l -> f x = x).
Proof.
  split.
  - intros E x I.
    apply In_nth with (d:=x) in I as (n&len&<-).
    rewrite <- map_nth with (f:=f).
    rewrite E.
    apply nth_indep,len.
  - intro E;erewrite map_ext_in;[rewrite map_id;auto|].
    intros x I;apply E;auto.
Qed.

(** [fun f => map f l] is bijective, using extensional equality of functions. *)
Lemma map_bij {A B} (f g : A -> B) l : map f l = map g l -> forall a, a ∈ l -> f a = g a.
Proof.
  induction l;simpl;auto.
  - intros;tauto.
  - intros E b [I|I];inversion E;subst;auto.
Qed.

Lemma map_ext_in_iff (A B : Type) (f g : A -> B) (l : list A) :
  (forall a : A, a ∈ l -> f a = g a) <-> map f l = map g l.
Proof.
  split;[apply map_ext_in|].
  induction l;simpl;[tauto|].
  intros h b.
  inversion h as [[h1 h2]].
  intros [<-|I].
  - assumption.
  - apply IHl,I;assumption.
Qed.

Lemma map_eq_equivalent (A B : Set) (f g : A -> B) l m :
  l ≈ m -> map f m = map g m <-> map f l = map g l.
Proof.
  intros E;rewrite <- map_ext_in_iff.
  setoid_rewrite <- E.
  rewrite map_ext_in_iff;reflexivity.
Qed.

(** We may lift a decomposition of the second (respectively first) component of a list of pairs into a decomposition of the original list. *)
Lemma split_snd {A B} a (t : list (A * B)) t1 t2 :
  prj2 t = t1 ++ a :: t2 -> ~ a ∈ t1 -> exists k s1 s2, t = s1++(k,a)::s2 /\ t1 = prj2 s1 /\ t2 = prj2 s2.
Proof.
  revert t t2;induction t1;intros [|(k,b)t] t2;simpl;try discriminate.
  - intros E _;inversion E;subst.
    exists k,[],t;simpl;auto.
  - intros E0 I;inversion E0 as [[X E]];subst;clear E0.
    apply IHt1 in E as (m&s1&s2&->&->&->);[|tauto].
    exists m,((k,a0)::s1),s2;simpl;auto.
Qed.

Lemma split_fst {A B} a (t : list (A * B)) t1 t2 :
  prj1 t = t1 ++ a :: t2 -> ~ a ∈ t1 -> exists k s1 s2, t = s1++(a,k)::s2 /\ t1 = prj1 s1 /\ t2 = prj1 s2.
Proof.
  revert t t2;induction t1;intros [|(b,k) t] t2;simpl;try discriminate.
  - intros E _;inversion E;subst.
    exists k,[],t;simpl;auto.
  - intros E0 I;inversion E0 as [[X E]];subst;clear E0.
    apply IHt1 in E as (m&s1&s2&->&->&->);[|tauto].
    exists m,((a0,k)::s1),s2;simpl;auto.
Qed.

(** If [n] is smaller than the length of [u], then [u] can be split into a prefix of size [n], followed by a non-empty list. *)
Lemma split_word {A} n (u : list A) :
  n < ⎢u⎥ -> exists x u1 u2, u = u1++x::u2 /\ ⎢u1⎥ = n.
Proof.
  induction u using rev_induction;rsimpl;[lia|].
  destruct (PeanoNat.Nat.eq_dec n ⎢u⎥) as [E|N] ;subst.
  - intros _;exists a,u,[];split;auto.
  - rsimpl;intros L;destruct IHu as (x&u1&u2&->&E);[lia|].
    exists x,u1,(u2++[a]);split;auto.
    rewrite app_ass;simpl;auto.
Qed.

(** ** Subsets of a list *)
Fixpoint subsets {A : Set} (l : list A) :=
  match l with
  | [] => [[]]
  | a::l => map (cons a) (subsets l)++subsets l
  end.

Lemma subsets_In {A : Set}(l : list A) :
  forall m, m ∈ subsets l -> m ⊆ l.
Proof.
  induction l as [|a l];intros m;simpl;try rewrite in_app_iff.
  - intros [<-|F];[reflexivity|tauto].
  - rewrite in_map_iff;intros [(m'&<-&I)|I];apply IHl in I as ->.
    + reflexivity.
    + intro;simpl;tauto.
Qed.

Lemma incl_cons_disj {A : Set} (a : A) m l :
  m ⊆ a :: l -> m ⊆ l \/ exists m', m ≈ a::m' /\ m' ⊆ l.
Proof.
  induction m as [|b m];simpl.
  - intro;left;apply incl_nil.
  - intros I.
    destruct IHm as [IH|(m'&E&IH)].
    + intros x Ix;apply I;now right.
    + assert (I': b ∈ (b::m)) by now left.
      apply I in I' as [<-|Ib].
      * right;exists m;split;[reflexivity|assumption].
      * left;intros c [<-|Ic];[assumption|].
        apply IH,Ic.
    + assert (I': b ∈ (b::m)) by now left.
      apply I in I' as [<-|Ib].
      * right;exists m';split;[|assumption].
        rewrite E;clear;intro;simpl;tauto.
      * right;exists (b::m');split.
        -- rewrite E;intro;simpl;tauto.
        -- intros c [<-|Ic];[assumption|].
           apply IH,Ic.
Qed.

Lemma subsets_spec {A : Set} (l : list A) :
  forall m, m ⊆ l <-> exists m', m' ∈ subsets l /\ m ≈ m'.
Proof.
  intro m;split.
  - revert m; induction l as [|a l];intros m L.
    + exists [];split;[simpl;tauto|].
      apply incl_PartialOrder;split;[assumption|apply incl_nil].
    + simpl;destruct (incl_cons_disj L) as [h|(m'&E&h)];apply IHl in h as (m''&I&E').
      * exists m'';split;[|assumption].
        rewrite in_app_iff;tauto.
      * exists (a::m'');split.
        -- apply in_app_iff;left;apply in_map_iff;exists m'';tauto.
        -- rewrite E,E';reflexivity.
  - intros (m'&I&->);apply subsets_In,I.
Qed.

Lemma subsets_NoDup {A : Set} (k l : list A) :
  NoDup l -> k ∈ subsets l -> NoDup k.
Proof.
  revert k;induction l as [|a l];intros k;simpl.
  - intros h [<-|F];tauto.
  - rewrite NoDup_cons_iff,in_app_iff,in_map_iff.
    intros (nI&nd) [(k'&<-&Ik')|Ik].
    + apply NoDup_cons.
      * intro h;apply nI,(subsets_In Ik'),h.
      * apply IHl;tauto.
    + apply IHl;tauto.
Qed.

(** ** Pairs *)
Definition pairs {A B : Set} l r : list (A * B) :=
  fold_right (fun a acc => (map (fun b => (a,b)) r)++acc) [] l.

Lemma pairs_spec {A B : Set} l r (a : A) (b : B) : (a,b) ∈ pairs l r <-> a ∈ l /\ b ∈ r.
Proof.
  revert a b;induction l;simpl;[tauto|].
  intros a' b;rewrite in_app_iff.
  rewrite IHl;clear IHl.
  rewrite in_map_iff.
  split.
  - intros [(?&E&Ib)|I].
    + inversion E;subst;tauto.
    + tauto.
  - intros ([<-|Ia]&Ib).
    + left;exists b;tauto.
    + right;tauto.
Qed.

(** ** Enumerate lists of a certain length *)
Fixpoint lists_of_length {A} (elts:list A) n :=
  match n with
  | 0 => [[]]
  | S n => flat_map (fun l => map (fun e => e::l) elts) (lists_of_length elts n)
  end.

Lemma lists_of_length_spec {A} (elts : list A) n l :
  l ∈ lists_of_length elts n <-> ⎢l⎥ = n /\ l ⊆ elts.
Proof.
  revert l;induction n;intros l;simpl.
  - split.
    + intros [<-|F];[|tauto].
      split;[reflexivity|apply incl_nil].
    + destruct l;[tauto|simpl;intros (F&_);discriminate].
  - rewrite in_flat_map;setoid_rewrite IHn;clear IHn.
    setoid_rewrite in_map_iff.
    split.
    + intros (m&(Len&Lm)&(a&<-&Ia)).
      split;[rsimpl;rewrite Len;reflexivity|].
      apply incl_cons;tauto.
    + intros (Len&Incl).
      destruct l as [|a l];simpl in Len;inversion Len as [[Len']].
      exists l;split.
      * split;[reflexivity|].
        intros x Ix;apply Incl;now right.
      * exists a;split;[reflexivity|].
        apply Incl;now left.
Qed.

(** ** Pad a list with an element *)
Definition pad {A} (e : A) (l : list A) := e::flat_map (fun a => [a;e]) l.

Lemma pad_contents {A} (e : A) l : pad e l ≈ e::l.
Proof.
  unfold pad;induction l;simpl.
  - reflexivity.
  - rewrite IHl;intro;simpl;tauto.
Qed.

(** * Sum function *)
(** If [a1,...,an] are elements in [A] and [f] is a function from [A] to [nat], then [sum f [a1;...;an]] is the natural number [f a1+...+f an]. *)
Definition sum {A} f (l : list A) := fold_right (fun a acc => f a + acc) 0 l.

(** [sum f] distributes over concatenations. *)
Lemma sum_app {A} f (l m : list A) : sum f (l++m) = sum f l + sum f m.
Proof. induction l;simpl;try lia. Qed.

(** If [l] is contained in [m] and has no duplicates, then summing [f] on [l] yields a smaller value than summing [f] on [m]. *)
Lemma sum_incl_ND {A} f (l m : list A) :
  l ⊆ m -> NoDup l -> sum f l <= sum f m.
Proof.
  revert m;induction l;intros m Incl ND;simpl.
  - lia.
  - assert (Ia: a ∈ m) by (apply Incl;now left).
    apply in_split in Ia as (m1&m2&->).
    rewrite sum_app;simpl.
    apply NoDup_cons_iff in ND as (Ia&ND).
    apply (IHl (m1++m2)) in ND.
    + rewrite sum_app in ND;lia.
    + intro x;pose proof (Incl x) as h;revert h.
      repeat rewrite in_app_iff;simpl;intuition subst;tauto.
Qed.

(** If two duplicate-free list are equivalent, then summing [f] on any of them yields the same result. *)
Lemma sum_eq_ND {A} f (l m : list A) :
  l ≈ m -> NoDup l -> NoDup m -> sum f l = sum f m.
Proof.
  revert m;induction l;intros m Eq NDl NDm;simpl.
  - destruct m as [|a m];[simpl;lia|].
    exfalso;cut (a ∈ []);[simpl;tauto|].
    rewrite Eq;now left.
  - assert (Ia: a ∈ m) by (apply Eq;now left).
    apply in_split in Ia as (m1&m2&->).
    rewrite sum_app;simpl.
    apply NoDup_cons_iff in NDl as (Ial&NDl).
    apply NoDup_remove in NDm as (Iam&NDm).
    apply (IHl (m1++m2)) in NDl;auto.
    + rewrite sum_app in NDl;lia.
    + intro x;pose proof (Eq x) as h;revert h NDm.
      repeat rewrite in_app_iff;simpl;intuition subst;tauto.
Qed.

(** If [f] is pointwise smaller than [g], then the sum [sum f l] is smaller than [sum g l]. *)
Lemma sum_incr {A} f g (l : list A) : (forall x, f x <= g x) -> sum f l <= sum g l.
Proof.
  intro h;induction l;simpl;auto.
  pose proof (h a);lia.
Qed.

(** [sum f l] only depends on the values of [f], not its implementation. *)
Lemma sum_ext {A} f g (l : list A) : (forall x, f x = g x) -> sum f l = sum g l.
Proof. intro h;induction l;simpl;auto. Qed.

Lemma sum_ext_In {A} f g (l : list A) : (forall x, x ∈ l -> f x = g x) -> sum f l = sum g l.
Proof.
  induction l.
  - intro;reflexivity.
  - intro h;simpl.
    rewrite IHl,h;auto.
    + now left.
    + intros x I;apply h;now right.
Qed.

(** If [h] is the pointwise sum of [f] and [g], then [sum h l] is the sum of [sum f l] and [sum g l]. *)
Lemma sum_add {A} f g h (l : list A) : (forall x, h x = f x + g x) -> sum h l = sum f l + sum g l.
Proof.
  intro H;induction l;simpl;auto.
  pose proof (H a);lia.
Qed.

Lemma sum_add_distr {A} f g (l : list A) : sum f l + sum g l = sum (fun x => f x + g x) l.
Proof. symmetry;apply sum_add;tauto. Qed.

(** If [f] is uniformly [0] on the elements of the list [l], then [sum f l] is [0]. *)
Lemma sum_zero_in {A} f (l : list A) : (forall x, x ∈ l -> f x = 0) -> sum f l = 0.
Proof.
  induction l;intro hyp;simpl;auto.
  rewrite IHl,(hyp a);auto.
  - now left.
  - intros;apply hyp;now right.
Qed.

Lemma sum_le {A} f g (l : list A) :
  (forall a, a∈ l -> f a <= g a) -> sum f l <= sum g l.
Proof.
  induction l as [|a l];simpl.
  - intros _ ;reflexivity.
  - intros h;cut (f a<= g a /\ sum f l <= sum g l);[lia|split].
    + apply h;tauto.
    + apply IHl;intros b I;apply h;tauto.
Qed.

Lemma sum_lt {A} f g (l : list A) :
  (forall a, a∈ l -> f a <= g a) -> (exists b, b ∈ l /\ f b < g b) -> sum f l < sum g l.
Proof.
  induction l as [|a l];simpl.
  - intros _ (b&F&_);tauto.
  - intros h (b&[<-|Ib]&hb).
    + cut (sum f l <= sum g l);[lia|].
      apply sum_le;intros c Ic;apply h;tauto.
    + cut (f a <= g a /\ sum f l < sum g l);[lia|split].
      * apply h;tauto.
      * apply IHl.
        -- intros c Ic;apply h;tauto.
        -- exists b;split;auto.
Qed.

Lemma sum_filter {A : Set} (P : A -> bool) f l : sum f (P:>l) <= sum f l.
Proof. induction l as [|a l];simpl;[|destruct (P a)];simpl;lia. Qed.

(** * Enumerate permutations of a list *)
Section shuffle.
  Context {A : Set}.

  (** [insert a l] generates the list of all possibles lists [l1::a++l2] such that [l=l1++l2]. *)
  Fixpoint insert (a : A) l :=
    match l with
    | [] => [[a]]
    | b::l => (a::b::l)::(map (cons b) (insert a l))
    end.

  (** [shuffles l] generates the list of all lists obtained by reordering the elements of [l]. For instance [shuffles [a;b]=[[a;b];[b;a]]]. *)
  Fixpoint shuffles l :=
    match l with
    | [] => [[]]
    | a::l => flat_map (insert a) (shuffles l)
    end.

  Lemma insert_spec a l m :
    m ∈ insert a l <-> exists l1 l2, l = l1++l2 /\ m = l1++a::l2.
  Proof.
    revert m;induction l as [|b l];intros m;simpl.
    - split.
      + intros [<-|F];[|tauto];exists [],[];split;reflexivity.
      + intros (l1&l2&h&->);symmetry in h; apply app_eq_nil in h as (->&->).
        simpl;left;reflexivity.
    - rewrite in_map_iff;split.
      + intros [<-|(m'&<-&I)].
        * exists [],(b::l);simpl;split;reflexivity.
        * apply IHl in I as (l1&l2&->&->).
          exists (b::l1),l2;split;reflexivity.
      + intros (l1&l2&e&->).
        destruct l1 as [|c l1].
        * simpl in e;subst;simpl.
          left;reflexivity.
        * simpl in e;inversion e;subst;clear e.
          right;exists (l1++a::l2).
          split;[reflexivity|].
          apply IHl.
          exists l1,l2;tauto.
  Qed.

  (** Shuffles of [l] contain the same elements. *)
  Lemma shuffles_equiv l m : m ∈ shuffles l -> l ≈ m.
  Proof.
    revert m;induction l;intros m h;simpl in *.
    - destruct h as [<-|F];[reflexivity|exfalso;apply F].
    - apply in_flat_map in h as (x&Ix&Im).
      apply insert_spec in Im as (m1&m2&->&->).
      apply IHl in Ix as ->;intro;simpl;repeat rewrite in_app_iff;simpl.
      tauto.
  Qed.

  (** If [l] has no duplicates and [m] is a shuffle of [l], then [m] has no duplicates either. *)
  Lemma shuffles_nodup l m : NoDup l -> m ∈ shuffles l -> NoDup m.
  Proof.
    revert m;induction l;intros m nd h;simpl in *.
    - destruct h as [<-|F];[apply NoDup_nil|exfalso;apply F].
    - apply in_flat_map in h as (x&Ix&Im).
      apply NoDup_cons_iff in nd as (nI&nd).
      apply insert_spec in Im as (m1&m2&->&->).
      rewrite (shuffles_equiv Ix) in nI;apply (IHl _ nd) in Ix.
      clear IHl l nd;induction m1;simpl.
      + apply NoDup_cons;tauto.
      + simpl in Ix;apply NoDup_cons_iff in Ix as (Ix&nd).
        apply NoDup_cons.
        * clear IHm1 nd;simpl in *;rewrite in_app_iff in *;simpl.
          firstorder (subst;tauto).
        * apply IHm1;[|assumption].
          clear IHm1 nd;simpl in *;rewrite in_app_iff in *.
          firstorder (subst;tauto).
  Qed.

  (** Shuffles of [l] have the same length as [l]. *)
  Lemma shuffles_length l m : m ∈ shuffles l -> ⎢l⎥ = ⎢m⎥.
  Proof.
    revert m;induction l;intros m h;rsimpl in *.
    - destruct h as [<-|F];[reflexivity|exfalso;apply F].
    - apply in_flat_map in h as (x&Ix&Im).
      apply insert_spec in Im as (m1&m2&->&->).
      apply IHl in Ix;rewrite Ix;rsimpl;lia.
  Qed.

  (** If [l] has no duplicates, then [shuffles l] contain exactly the lists that are equivalent to [l] without having any duplicates. *)
  Lemma In_shuffles l m :
    NoDup l -> m ∈ shuffles l <-> l ≈ m /\ NoDup m.
  Proof.
    intros ndl;split;[intro Il;split;[apply shuffles_equiv|apply (shuffles_nodup ndl)];apply Il|].
    revert m;induction l;intros m (e&ndm);simpl.
    - destruct m as [|a m];[tauto|].
      cut (a ∈ []);[intro F;right;apply F|].
      apply e;now left.
    - apply NoDup_cons_iff in ndl as (nI&ndl).
      assert (Em : a ∈ m) by (apply e;now left).
      apply in_split in Em as (m1&m2&->).
      apply in_flat_map;exists (m1++m2);split.
      + pose proof (NoDup_remove_2 _ _ _ ndm) as Ia.
        apply NoDup_remove_1 in ndm.
        apply IHl;[assumption|split;[|assumption]].
        clear IHl ndl ndm.
        intro b;split;simpl in *;rewrite in_app_iff in *;intro h.
        -- cut (b ∈ (a::l));[|now right].
           rewrite e,in_app_iff;simpl;clear e;firstorder (subst;tauto).
        -- cut (b ∈ (m1++a::m2)).
           ++ rewrite <-e;clear e;simpl.
              firstorder (subst;tauto).
           ++ rewrite in_app_iff;simpl;tauto.
      + apply insert_spec;exists m1,m2;tauto.
  Qed.

  (** If [l1] is a shuffle of [l2], then being a shuffle of [l1] is equivalent to being a shuffle of [l2]. *)
  Lemma eq_shuffles l1 l2 : l1 ∈ shuffles l2 -> shuffles l1 ≈ shuffles l2.
  Proof.
    revert l1;induction l2;simpl;intros l1.
    - intros [<-|F];[reflexivity|tauto].
    - rewrite in_flat_map;intros (m&Im&Il1).
      apply insert_spec in Il1 as (m1&m2&->&->).
      apply IHl2 in Im;clear IHl2.
      rewrite <- Im;clear Im l2.
      unfold equivalent;setoid_rewrite in_flat_map;
        setoid_rewrite insert_spec.
      intro x.
      transitivity (exists l1 l2, (l1 ++ l2) ∈ shuffles (m1++m2)
                             /\ x = l1++a::l2);
        [|firstorder (subst;tauto)].
      revert x;induction m1 as [|b m1];simpl.
      + intro x;rewrite in_flat_map;setoid_rewrite insert_spec.
        firstorder (subst;tauto).
      + setoid_rewrite in_flat_map; setoid_rewrite insert_spec.
        setoid_rewrite IHm1;clear IHm1.
        intro x;split;[intros (?&(x1&x2&I& -> )&(y1&y2&E& -> ) )
                      |intros (x1&x2&( ? &I&y1&y2&->&E)& -> ) ];
        levi E;subst;clear E.
        * exists (y1++[b]),x2;split;[|rewrite app_ass;reflexivity].
          eexists;split;[eassumption|].
          exists y1,x2;rewrite app_ass;split;reflexivity.
        * exists (y1++b::a0::w),x2;split;[|rewrite app_ass;reflexivity].
          eexists;split;[eassumption|].
          exists y1,(a0::w++x2);repeat rewrite app_ass;tauto.
        * symmetry in E1;inversion E1;subst;clear E1.
          exists x1,(w++b::y2);split;[|rewrite app_ass;reflexivity].
          eexists;split;[eassumption|].
          exists (x1++w),y2;repeat rewrite app_ass;tauto.
        * exists (y1++a::y2);split.
          -- exists y1,y2;tauto.
          -- exists (y1++[a]),y2;split;rewrite app_ass;reflexivity.
        * symmetry in E1;inversion E1;subst;clear E1.
          exists (y1++w++a::x2);split.
          -- exists (y1++w),x2;split;rewrite app_ass;tauto.
          -- exists y1,(w++a::x2);rewrite app_ass;tauto.
        * exists (x1 ++ a :: a0 :: w ++ y2);split.
          -- exists x1,(a0::w++y2);rewrite app_ass in I;tauto.
          -- exists (x1++a::a0::w),y2;repeat rewrite app_ass;simpl;tauto.
  Qed.

  (** If [l] has no duplicates, neither does [shuffles l]. *)
  Lemma NoDup_shuffles (l : list A) : NoDup l -> NoDup (shuffles l).
  Proof.
    induction l as [|a l].
    - simpl;intro;apply NoDup_cons;simpl;auto using NoDup_nil.
    - simpl;rewrite NoDup_cons_iff.
      intros (I&nd);pose proof (IHl nd) as IH;clear IHl.
      assert (e: forall m, m ∈ shuffles l -> l ≈ m /\ NoDup m).
      + intros m Im;split.
        * apply shuffles_equiv,Im.
        * apply (shuffles_nodup nd Im).
      + induction (shuffles l) as [|m L];simpl;[apply NoDup_nil|].
        assert (h:m∈(m::L)) by (now left).
        apply e in h as (eq&nd').
        apply NoDup_app.
        * intros m' Im';rewrite in_flat_map.
          intros (m''&IL&Im'').
          apply NoDup_cons_iff in IH as (Im&IH).
          rewrite insert_spec in Im',Im''.
          destruct Im' as (l1&l2&->&->).
          destruct Im'' as (m1&m2&->&E).
          levi E;inversion E1;subst;clear E E1.
          -- tauto.
          -- apply I;rewrite eq.
             rewrite app_ass,in_app_iff;simpl;tauto.
          -- apply I;rewrite eq.
             rewrite <- app_ass,in_app_iff;simpl;tauto.
        * revert nd' I;rewrite eq;clear.
          induction m as [|b m];simpl.
          -- intros;apply NoDup_cons;simpl;auto using NoDup_nil.
          -- rewrite NoDup_cons_iff.
             intros (Ib&nd) e;apply NoDup_cons.
             ++ rewrite in_map_iff;intros (l'&E&I).
                inversion E;subst.
                tauto.
             ++ assert (~ a ∈ m) as Ia by tauto.
                pose proof (IHm nd Ia) as ih;clear IHm.
                clear e Ia nd Ib.
                generalize dependent (insert a m);clear a m.
                intro l;induction l as [|a l];simpl;auto.
                repeat rewrite NoDup_cons_iff.
                rewrite in_map_iff;firstorder subst.
                intros (x&E&I);inversion E; subst;tauto.
        * apply IHL.
          -- apply NoDup_cons_iff in IH;tauto.
          -- intros m' Im';apply e;now right.
  Qed.

End shuffle.

Lemma incl_cons_disj' {A : Set} (a : A) m l :
  NoDup m -> m ⊆ a :: l -> m ⊆ l \/ exists m', m ≈ a::m' /\ m' ⊆ l /\ NoDup m'.
Proof.
  induction m as [|b m];simpl.
  - intro;left;apply incl_nil.
  - intros ND I.
    apply NoDup_cons_iff in ND as (nI&ND).
    destruct (IHm ND) as [IH|(m'&E&IH&ND')].
    + intros x Ix;apply I;now right.
    + assert (I': b ∈ (b::m)) by now left.
      apply I in I' as [<-|Ib].
      * right;exists m;split;[reflexivity|split;assumption].
      * left;intros c [<-|Ic];[assumption|].
        apply IH,Ic.
    + assert (I': b ∈ (b::m)) by now left.
      apply I in I' as [<-|Ib].
      * right;exists m';split;[|split;assumption].
        rewrite E;clear;intro;simpl;tauto.
      * right;exists (b::m');split;[|split].
        -- rewrite E;intro;simpl;tauto.
        -- intros c [<-|Ic];[assumption|].
           apply IH,Ic.
        -- apply NoDup_cons;[|assumption].
           intro F;apply nI,E;now right.
Qed.

Lemma all_subsets_nodup {A : Set} (l : list A) :
  NoDup l -> forall m, m ∈ (flat_map shuffles (subsets l)) <-> NoDup m /\ m ⊆ l.
Proof.
  intros N m;rewrite in_flat_map;split.
  - intros (k&Ik&Im).
    apply In_shuffles in Im as (E&nd).
    + split;[tauto|].
      rewrite <- E;apply subsets_In,Ik.
    + eapply subsets_NoDup;eauto.
  - intros (Nd&Incl).
    apply subsets_spec in Incl as (m'&Im'&E).
    exists m';split;[assumption|].
    apply In_shuffles.
    + apply (subsets_NoDup N);assumption.
    + rewrite <- E;split;[reflexivity|assumption].
Qed.

(* begin hide *)
Create HintDb length.
Global Hint Resolve filter_length app_length : length.

Global Instance le_plus_Proper : Proper (le ==> le ==> le) plus.
Proof. intros ? ? ? ? ? ?;lia. Qed.
Global Instance lt_plus_Proper : Proper (lt ==> lt ==> lt) plus.
Proof. intros ? ? ? ? ? ?;lia. Qed.

(*  LocalWords:  bimap
 *)


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_nom_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.