Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From Coq Require Import
     Arith
     Basics
     List
     Recdef
     ZArith
     Lia.
From mathcomp Require Import
     ssrbool
     ssreflect
     ssrnat.
From QuickChick Require Import
     Classes
     Sets
     Producer
     Enumerators
     Generators
     Tactics.

Import ListNotations QcDefaultNotation.
Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

(** Basic generator instances *)
#[global] Instance genBoolSized : GenSized bool :=
  {| arbitrarySized x := elems_ true [true; false] |}.

#[global]
Instance genNatSized : GenSized nat :=
  {| arbitrarySized x := choose (0,x) |}.

#[global] Instance genZSized : GenSized Z :=
  {| arbitrarySized x := let z := Z.of_nat x in
                         choose (-z, z)%Z |}.

#[global] Instance genNSized : GenSized N :=
  {| arbitrarySized x := let n := N.of_nat x in
                         choose (N0, n) |}.

#[global] Instance genListSized {A : Type} `{GenSized A} : GenSized (list A) :=
  {| arbitrarySized x := listOf (arbitrarySized x) |}.

(* [3] is a lower priority than [Classes.GenOfGenSized],
   avoiding an infinite loop in typeclass resolution. *)

#[global] Instance genList {A : Type} `{Gen A} : Gen (list A) | 3 :=
  {| arbitrary := listOf arbitrary |}.

#[global] Instance genOption {A : Type} `{Gen A} : Gen (option A) | 3 :=
  {| arbitrary := freq [ (1, ret None)
                       ; (7, liftM Some arbitrary)] |}.

#[global] Instance genPairSized {A B : Type} `{GenSized A} `{GenSized B}
: GenSized (A*B) :=
  {| arbitrarySized x :=
       liftM2 pair (arbitrarySized x)
                   (arbitrarySized x)
  |}.

#[global] Instance genPair {A B : Type} `{Gen A} `{Gen B} : Gen (A * B) :=
  {| arbitrary := liftM2 pair arbitrary arbitrary |}.

(* Enumerator #[global] Instances *)

#[global] Instance enumBoolSized : EnumSized bool :=
  {| enumSized x := elems_ true [true; false] |}.

#[global] Instance enumNatSized : EnumSized nat :=
  {| enumSized x := chooseEnum (0,x) |}.

#[global] Instance enumZSized : EnumSized Z :=
  {| enumSized x := let z := Z.of_nat x in
                         chooseEnum (-z, z)%Z |}.

#[global] Instance enumNSized : EnumSized N :=
  {| enumSized x := let n := N.of_nat x in
                         chooseEnum (N0, n) |}.

#[global] Instance enumListSized {A : Type} `{Enum A} : EnumSized (list A) :=
  {| enumSized x := bindEnum (choose (0,x)) (fun x => vectorOf x enum) |}.

(* [3] is a lower priority than [Classes.EnumOfEnumSized],
   avoiding an infinite loop in typeclass resolution. *)

#[global] Instance enumList {A : Type} `{Enum A} : Enum (list A) | 3 :=
  {| enum := listOf enum |}.

#[global] Instance enumOption {A : Type} `{Enum A} : Enum (option A) | 3 :=
  {| enum := oneOf [ (ret None)
                   ; (liftM Some enum)] |}.

#[global] Instance enumPairSized {A B : Type} `{EnumSized A} `{EnumSized B}
: EnumSized (A*B) :=
  {| enumSized x :=
       liftM2 pair (enumSized x)
                   (enumSized x)
  |}.

#[global] Instance enumPair {A B : Type} `{Enum A} `{Enum B} : Enum (A * B) :=
  {| enum := liftM2 pair enum enum |}.

#[global] Instance enumOpt {A} (H : Enum A) : Enum (option A) :=
  {| enum :=
       match enum with
       | MkEnum f => MkEnum (fun n => LazyList.lcons None (fun _ => LazyList.mapLazyList Some (f n)))
       end
  |}.

(** Shrink#[global] Instances *)
#[global] Instance shrinkBool : Shrink bool :=
  {| shrink x :=
       match x with
         | false => nil
         | true  => cons false nil
       end
  |}.

#[global] Instance enumOptCorrect A `{EnumCorrect A} :
  Correct _ (@enum _ (enumOpt _)).
Proof.
  constructor.
  intros t; split; eauto.
  - intros. exact I.
  - intros _.
    simpl.
    inv H. inv H0. unfold semProd. simpl.
    destruct t.
    + destruct (prodCorrect a).
      destruct H3. now reflexivity.
      inv H3. simpl in *.
      eexists x. split. eassumption.
      destruct H. simpl in *. destruct enum0.
      unfold semEnumSize in *. simpl. right.
      eapply LazyList.lazy_in_map_iff.
      eexists. split. reflexivity.
      eassumption.
    + exists 0. split. reflexivity.
      destruct H. simpl. destruct enum0.
      unfold semEnumSize in *. simpl. left. reflexivity.
Qed.

#[global] Instance enumOpt_SizeMonotonic A `{EnumMonotonic A} :
  SizeMonotonic (@enum _ (enumOpt _)).
Proof.
  destruct H. destruct enum. simpl in *.
  intros s1 s2 Hleq [ x |]; simpl.
  - eapply H0 in Hleq. simpl in *.
    intros Hin.
    unfold semEnumSize in *. simpl in *. right.
    inv Hin; try congruence.
    eapply LazyList.lazy_in_map_iff.
    eexists. split. reflexivity.
    eapply Hleq.
    eapply LazyList.lazy_in_map_iff in H. destruct H.
    inv H. inv H2. eassumption.
  - unfold semEnumSize in *. simpl in *. firstorder.
Qed.

#[global] Instance enumOpt_SizeFP A `{Enum A} :
  SizeFP (@enum _ (enumOpt _)).
Proof.
  destruct H. destruct enum. simpl in *.

  intros s1 s2 Hleq Hnin. simpl.
  unfold semEnumSize in *. simpl in *. firstorder.
Qed.

#[global] Instance enumNatSized_CorrectSized :
  CorrectSized (@enumSized _ enumNatSized).
Proof.
  constructor.
  intros t; split; eauto.
  - intros. exact I.
  - intros _.

      assert (Hsize := @Enumerators.semChooseSize nat _).
      simpl in *.

      exists t. exists t. split. exact I. eapply Hsize.
      reflexivity. ssromega.
Qed.

#[global] Instance enumNatSized_SizedMonotonic :
  SizedMonotonic (@enumSized _ enumNatSized).
Proof.
  intros s s1 s2 Hleq. simpl.
  intros x Hin.

  assert (Hsize := @Enumerators.semChooseSize nat _).
  eapply Hsize in Hin; eauto.
  simpl in Hin.
  eapply Hsize.
  reflexivity.
  simpl.
  ssromega.
Qed.

#[global] Instance enumNatSized_SizeMonotonic s:
  SizeMonotonic (@enumSized _ enumNatSized s).
Proof.
  intros s1 s2 Hleq. simpl.
  intros x Hin.

  assert (Hsize := @Enumerators.semChooseSize nat _).
  eapply Hsize in Hin; eauto.
  simpl in Hin.
  eapply Hsize. reflexivity. simpl.
  ssromega.
Qed.

(* TODO. These case be derived automatically. Change the default definitions *)

#[global] Instance enumListSized_SizedMonotonic A `{EnumMonotonic A} :
  SizedMonotonic (@enumSized (list A) enumListSized).
Proof.
  intros s s1 s2 Hleq x Hin.
  eapply semBindSizeEnum in Hin. destruct Hin as [a [Hin He]].
  assert (Hvec := @semVectorOfSize E _ _). eapply Hvec in He. destruct He as [Heq Hin'].
  eapply semBindSizeEnum. exists a. split.
  eapply Enumerators.semChooseSize in Hin. simpl in *.
  eapply Enumerators.semChooseSize. now eauto.
  simpl. now ssromega. now eauto.
  eapply Hvec. split; eauto.
Qed.

#[global] Instance enumListSized_SizeMonotonic A `{EnumMonotonic A} s :
  SizeMonotonic (@enumSized (list A) enumListSized s).
Proof.
  eapply bindMonotonic; eauto with typeclass_instances.
Qed.

#[global] Instance enumListSized_CorrectSized A `{EnumMonotonicCorrect A} :
  CorrectSized (@enumSized (list A) enumListSized).
Proof.
  assert (Hvec := @semVectorOfSize E _ _).
  constructor. intros l; induction l; simpl.
  - split; intros Hin; simpl in *. now constructor.
    eexists 0. eexists 0. split; eauto.
    eapply semBindSizeEnum. eexists. split.
    eapply Enumerators.semChooseSize. now eauto.
    2:{ eapply Hvec. split. reflexivity. eapply sub0set. }
    now eauto.
  - split; intros Hin. now constructor.
    destruct IHl as [_ IHl].
    edestruct IHl as [x [s1 [Hin1 He]]]. now constructor.
    eapply semBindSizeEnum in He.
    destruct He as [y [Hen Hv]].
    eapply Hvec in Hv; eauto with typeclass_instances. destruct Hv as [Heq Hinl].
    subst.
    eapply Enumerators.semChooseSize in Hen; eauto. simpl in *.

    destruct H2. destruct H1. edestruct prodCorrect with (a := a).
    edestruct H2 as [s2 [ _ Hin'] ]. reflexivity.

    eexists (x + 1). eexists (s1 + s2). split. reflexivity.
    eapply semBindSizeEnum. exists (length l+1). split.
    eapply Enumerators.semChooseSize; eauto. simpl in *. ssromega.
    eapply Hvec. split. simpl. now ssromega.
    eapply cons_subset.

    eapply H0; [| eassumption ].  now ssromega.

    eapply subset_trans. eassumption.
    eapply H0. now ssromega.
Qed.

#[global] Instance enumPairSized_SizedMonotonic A {_ : EnumSized A} { _ : SizedMonotonic (@enumSized A _)}
  B {_ : EnumSized B} { _ : SizedMonotonic (@enumSized B _)}:
  SizedMonotonic (@enumSized (A * B) enumPairSized).
Proof.
  intros s s1 s2 Hleq.
  simpl. rewrite !semBindSizeEnum.
  eapply incl_bigcup_compat; eauto.
  intros x.
  simpl. rewrite !semBindSizeEnum.
  eapply incl_bigcup_compat; eauto.
  intros y. eapply subset_refl.
Qed.

#[global] Instance enumPairSized_SizeMonotonic A {_ : EnumSized A} { _ : forall s, SizeMonotonic (@enumSized A _ s)}
         B {_ : EnumSized B} { _ : forall s, SizeMonotonic (@enumSized B _ s)} s :
  SizeMonotonic (@enumSized (A * B) enumPairSized s).
Proof.
  do 2 (eapply bindMonotonic; [ eauto with typeclass_instances .. | intros ? ]).
  eapply returnGenSizeMonotonic; eauto with typeclass_instances.
Qed.

#[global] Instance enumPairSized_CorrectSized
         A {_ : EnumSized A} { _ : forall s, SizeMonotonic (@enumSized A _ s)}
         { _ : SizedMonotonic (@enumSized A _)} { _ : CorrectSized (@enumSized A _)}
         B {_ : EnumSized B} { _ : forall s, SizeMonotonic (@enumSized B _ s)}
         { _ : SizedMonotonic (@enumSized B _)} { _ : CorrectSized (@enumSized B _)}:
  CorrectSized (@enumSized (A * B) enumPairSized).
Proof.
  constructor. split.
  { intros. reflexivity. }
  destruct a.
  intros _.
  destruct H1 as [[_ Hca]].
  destruct H4 as [[_ Hcb]].
  destruct Hca as [x1 [s1 [_ Hin1]]]. reflexivity.
  destruct Hcb as [x2 [s2 [_ Hin2]]]. reflexivity.
  eexists (x1 + x2). simpl. eexists (s1 + s2). split. reflexivity.
  simpl. eapply semBindSizeEnum.
  eexists. split.
  eapply H0. 2:{ eapply H; [| eassumption ]. ssromega. }
  ssromega.
  eapply semBindSizeEnum.
  eexists. split.
  eapply H2. 2:{ eapply H3; [| eassumption ]. ssromega. }
  ssromega.
  eapply semReturnSizeEnum. reflexivity.
Qed.

#[global] Instance enumOption_SizeMonotonic A {_ : Enum A} { _ : SizeMonotonic (@enum A _)} :
  SizeMonotonic (@enum (option A) enumOption).
Proof.
  simpl. eapply oneofMonotonic.
  - eauto with typeclass_instances.
  - eapply returnGenSizeMonotonic; eauto with typeclass_instances.
  - eapply cons_subset.
    eapply returnGenSizeMonotonic; eauto with typeclass_instances.
    eapply cons_subset.
    + eapply bindMonotonic; [ eauto with typeclass_instances .. | intros y ].
      eapply returnGenSizeMonotonic; eauto with typeclass_instances.
    + eapply sub0set.
Qed.

#[global] Instance enumOption_Correct A {_ : Enum A} { _ : Correct A (@enum A _)}:
  Correct _ (@enum (option A) enumOption).
Proof.
  constructor. split. intros. reflexivity.
  intros _.
  simpl. destruct a.
  - destruct H as [ [ _ Hc ] ]. destruct Hc as [x [H1 H2]]. reflexivity.
    eexists x. split. reflexivity.
    eapply semOneofSize. eauto with typeclass_instances.
    eexists. split. right. left.
    eexists. eapply semBindSizeEnum. eexists. split. eassumption.
    eapply semReturnSizeEnum. reflexivity.
  - exists 0. split. reflexivity.
    eapply semOneofSize. eauto with typeclass_instances.
    eexists. split. left. reflexivity.
    eapply semReturnSizeEnum. reflexivity.
Qed.

Lemma andb_len x1 x2 x3 x4 :
  (x1 <=? x2)%num && (x3 <=? x4)%num <-> (x1 <= x2)%num /\ (x3 <= x4)%num.
Proof.
  destruct (x1 <=? x2)%num eqn:Heq1; simpl; split; try easy;
    destruct (x3 <=? x4)%num eqn:Heq2; simpl; try easy.
  - eapply N.leb_le in Heq1. eapply N.leb_le in Heq2.
    easy.
  - intros [H1 H2]. eapply N.leb_nle in Heq2.
    eauto.
  - intros [H1 H2]. eapply N.leb_nle in Heq1. eauto.
  - intros [H1 H2]. eapply N.leb_nle in Heq1. eauto.
Qed.

#[global] Instance enumNSized_SizedMonotonic :
  SizedMonotonic (@enumSized _ enumNSized).
Proof.
  intros s s1 s2 Hleq. simpl.
  intros x Hin.
  assert (Hsize := @Enumerators.semChooseSize N _).
  eapply Hsize in Hin; eauto.
  simpl in Hin.
  eapply Hsize. simpl in *.
  eapply N.leb_le. now lia.
  eapply andb_len in Hin. eapply andb_len. ssromega.
  simpl. eapply N.leb_le. ssromega.
Qed.

#[global] Instance enumNSized_SizeMonotonic s:
  SizeMonotonic (@enumSized _ enumNSized s).
Proof.
  intros s1 s2 Hleq. simpl.
  intros x Hin.

  assert (Hsize := @Enumerators.semChooseSize N _).

  eapply Hsize in Hin; eauto.
  simpl in Hin.
  eapply Hsize. simpl. eapply N.leb_le. ssromega.
  eapply andb_len in Hin. eapply andb_len. split; ssromega.
  eapply N.leb_le. ssromega.
Qed.

(* Lemma of_nat_bin t : *)
(*   (N.of_nat (nat_of_bin t)) = t. *)
(* Proof. *)
(*   destruct t. reflexivity. *)
(*   simpl. *)
(*   induction p; simpl. *)
(*   - admit. *)
(*   -  *)

#[global] Instance enumNSized_CorrectSized :
  CorrectSized (@enumSized _ enumNSized).
Proof.
  constructor.
  intros t; split; eauto.
  - intros. exact I.
  - intros _.

      assert (Hsize := @Enumerators.semChooseSize N _).
      simpl in *.

      exists (N.to_nat t). exists 0 . split. exact I. eapply Hsize.
      eapply N.leb_le. ssromega.
      eapply andb_len. split; ssromega.
Qed.

#[global] Instance enumBoolSized_SizeMonotonic s:
  SizeMonotonic (@enumSized _ enumBoolSized s).
Proof.
  intros s1 s2 Hleq.
  assert ( Heq := @semElementsSize E _ _).
  simpl in *. rewrite Heq.
  eapply subset_refl.
Qed.

#[global] Instance enumBoolSized_CorrectSized :
  CorrectSized (@enumSized _ enumBoolSized).
Proof.
  constructor.
  intros t; split; eauto.
  - intros. exact I.
  - intros _.
    destruct t; exists 0; simpl;
    eapply semElements; eauto with typeclass_instances.
    now left.
    right. now left.
Qed.

#[global] Instance enumBoolSized_SizedMonotonic :
  SizedMonotonic (@enumSized _ enumBoolSized).
Proof.
  intros s s1 s2 Hleq. simpl.
  assert ( Heq := @semElementsSize E _ _).
  simpl in *. rewrite Heq.
  eapply subset_refl.
Qed.

(** Shrinking of nat starts to become annoying *)
Function shrinkNatAux (x : nat) {measure (fun x => x) x} : list nat :=
  match x with
    | O => nil
    | S n =>
      let x' := Nat.div x 2 in
      x' :: shrinkNatAux x'
  end.
Proof.
  move => x n Eq;
  pose proof (Nat.divmod_spec n 1 0 0) as H.
  assert (H' : (0 <= 1)%coq_nat) by lia; apply H in H';
  subst; simpl in *; clear H.
  destruct (Nat.divmod n 1 0 0) as [q u];  destruct u; simpl in *; lia.
Defined.

#[global] Instance shrinkNat : Shrink nat :=
  {| shrink := shrinkNatAux |}.

(** Shrinking of Z is even more so *)
Lemma abs_div2_pos : forall p, Z.abs_nat (Z.div2 (Z.pos p)) = Nat.div2 (Pos.to_nat p).
Proof.
  intros. destruct p.
    rewrite /Z.div2 /Pos.div2.
      rewrite /Z.abs_nat. rewrite Pos2Nat.inj_xI.
      rewrite <- Nat.add_1_r. rewrite Nat.mul_comm.
      rewrite Nat.div2_div. rewrite Nat.div_add_l; simpl; lia.
    rewrite /Z.div2 /Pos.div2.
      rewrite /Z.abs_nat. rewrite Pos2Nat.inj_xO.
      rewrite Nat.mul_comm. rewrite Nat.div2_div. rewrite Nat.div_mul. reflexivity. lia.
  reflexivity.
Qed.

Lemma neg_succ : forall p,
  Z.neg (Pos.succ p) = Z.pred (Z.neg p).
Proof.
  move => p. rewrite <- Pos.add_1_r.
  rewrite <- Pos2Z.add_neg_neg.
  rewrite <- Z.sub_1_r.
  reflexivity.
Qed.

Lemma neg_pred : forall p, (p > 1)%positive ->
  Z.neg (Pos.pred p) = Z.succ (Z.neg p).
Proof.
  move => p Hp. destruct p using Pos.peano_ind. by inversion Hp.
  rewrite Pos.pred_succ. rewrite neg_succ. rewrite Z.succ_pred.
  reflexivity.
Qed.

Lemma abs_succ_neg : forall p,
  Z.abs_nat (Z.succ (Z.neg p)) = Nat.pred (Pos.to_nat p).
Proof.
  move => p. destruct p using Pos.peano_ind. reflexivity.
  rewrite -neg_pred /Z.abs_nat. rewrite Pos2Nat.inj_pred. reflexivity.
  apply Pos.lt_1_succ. apply Pos.lt_gt; apply Pos.lt_1_succ.
Qed.

Lemma abs_succ_div2_neg : forall p,
  Z.abs_nat (Z.succ (Z.div2 (Z.neg p))) = Nat.div2 (Pos.to_nat p) \/
  Z.abs_nat (Z.succ (Z.div2 (Z.neg p))) = Nat.pred (Nat.div2 (Pos.to_nat p)).
Proof.
  intros. destruct p.
    left. rewrite /Z.div2 /Pos.div2.
      rewrite neg_succ. rewrite <- Zsucc_pred. rewrite /Z.abs_nat. rewrite Pos2Nat.inj_xI.
      rewrite <- Nat.add_1_r. rewrite Nat.mul_comm.
      rewrite Nat.div2_div. rewrite Nat.div_add_l; simpl; lia.
    right. rewrite /Z.div2 /Pos.div2.
      rewrite Pos2Nat.inj_xO. rewrite Nat.mul_comm.
      rewrite Nat.div2_div. rewrite Nat.div_mul. simpl.
      apply abs_succ_neg. lia.
  left. simpl. reflexivity.
Qed.

Function shrinkZAux (x : Z) {measure (fun x => Z.abs_nat x) x}: list Z :=
  match x with
    | Z0 => nil
    | Zpos _ => rev (cons (Z.pred x) (cons (Z.div2 x) (shrinkZAux (Z.div2 x))))
    | Zneg _ => rev (cons (Z.succ x) (cons (Z.succ (Z.div2 x)) (shrinkZAux (Z.succ (Z.div2 x)))))
  end.
Proof.
  move => ? p ?. subst. rewrite abs_div2_pos. rewrite Zabs2Nat.inj_pos.
    rewrite Nat.div2_div. apply Nat.div_lt. apply Pos2Nat.is_pos. lia.
  move => ? p ?. subst. destruct (abs_succ_div2_neg p) as [H | H].
    rewrite {}H /Z.abs_nat. rewrite Nat.div2_div.
      apply Nat.div_lt. apply Pos2Nat.is_pos. lia.
    rewrite {}H /Z.abs_nat. eapply Nat.le_lt_trans. apply Nat.le_pred_l. rewrite Nat.div2_div.
      apply Nat.div_lt. apply Pos2Nat.is_pos. lia.
Qed.

#[global] Instance shrinkZ : Shrink Z :=
  {| shrink := shrinkZAux |}.

Open Scope program_scope.

#[global] Instance shrinkN : Shrink N :=
  {| shrink := map Z.to_N ∘ shrink ∘ Z.of_N |}.

Definition shrinkListAux {A : Type} (shr : A -> list A) : list A -> list (list A) :=
  fix shrinkListAux_ (l : list A) : list (list A) :=
    match l with
    | nil => nil
    | cons x xs =>
      xs :: map (fun xs' => cons x xs') (shrinkListAux_ xs)
         ++ map (fun x'  => cons x' xs) (shr x )
    end.

#[global] Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A) :=
  {| shrink := shrinkListAux shrink |}.

#[global] Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B) :=
  {|
    shrink := fun (p : A * B) =>
      let (a,b) := p in
      map (fun a' => (a',b)) (shrink a) ++ map (fun b' => (a,b')) (shrink b)
  |}.

#[global] Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A) :=
  {| shrink m :=
       match m with
         | None => []
         | Some x => None :: (map Some (shrink x))
       end
  |}.

(** Arbitraries are derived automatically! *)

(**#[global] Instance correctness *)

(* Needed to add this! *)
Opaque semProdSize.

#[global]
Program Instance arbNatMon :
  @SizeMonotonic nat G ProducerGen (@arbitrary nat _).
Next Obligation.
  rewrite !semSizedSize !semChooseSize // => n /andP [/leP H1 /leP H2].
  move : H => /leP => Hle. apply/andP.
  split; apply/leP; ssromega.
Qed.

(** Correctness proof about built-in generators *)

#[global]
Instance boolSizeMonotonic : SizeMonotonic (@arbitrary bool _).
Proof.
  unfold arbitrary, GenOfGenSized.
  eapply sizedSizeMonotonic; unfold arbitrarySized, genBoolSized.
  - eauto with typeclass_instances.
  - intros; eauto with typeclass_instances.
  - intros n s1 s2 Hs. eapply subset_refl.
Qed.

#[global]
Instance boolSizedMonotonic : SizedMonotonic (@arbitrarySized bool _).
Proof.
  intros n s1 s2 Hs. eapply subset_refl.
Qed.

#[global]
Instance boolCorrect : Correct bool arbitrary.
Proof.
  constructor. unfold arbitrary, GenOfGenSized.
  rewrite semSized.
  unfold arbitrarySized, genBoolSized.
  intros x. split; intros H; try now constructor.
  exists 0. split. constructor.
  eapply semElementsSize; eauto with typeclass_instances.
  destruct x; try solve [left; auto]; right; left; auto.
Qed.

Local Open Scope set_scope.

Lemma arbBool_correct:
  semProd arbitrary <--> [set: bool].
Proof.
rewrite /arbitrary /arbitrarySized /genBoolSized /=.
rewrite semSized => n; split=> // _.
exists n; split=> //.
apply semElementsSize => //=;
                           eauto with typeclass_instances.
destruct n; repeat (try solve [left; auto]; right).
Qed.

Lemma arbNat_correct:
  semProd arbitrary <--> [set: nat].
Proof.
rewrite /arbitrary /=.
rewrite semSized => n; split=> // _; exists n; split=> //.
by rewrite (semChooseSize _ _ _) /RandomQC.leq /=.
Qed.

#[global]
Instance ArbNatGenCorrect : Correct nat arbitrary.
Proof.
  constructor. now apply arbNat_correct.
Qed.

Lemma arbInt_correct s :
  semProdSize arbitrary s <-->
  [set z | (- Z.of_nat s <= z <= Z.of_nat s)%Z].
Proof.
rewrite semSizedSize semChooseSize.
  by move=> n; split=> [/andP|] [? ?]; [|apply/andP]; split; apply/Zle_is_le_bool.
apply/(Zle_bool_trans _ 0%Z); apply/Zle_is_le_bool.
  exact/Z.opp_nonpos_nonneg/Zle_0_nat.
exact/Zle_0_nat.
Qed.

Lemma arbBool_correctSize s :
  semProdSize arbitrary s <--> [set: bool].
Proof.
rewrite /arbitrary //=.
rewrite semSizedSize semElementsSize //; split=> /RandomQC.leq _ //=; case a=> //=.
repeat (try solve [left; auto]; right).
repeat (try solve [left; auto]; right).
Qed.

Lemma arbNat_correctSize s :
  semProdSize arbitrary s <--> [set n : nat | (n <= s)%coq_nat].
Proof.
by rewrite semSizedSize semChooseSize // => n /=; case: leP.
Qed.

Lemma arbInt_correctSize : semProd arbitrary <--> [set: Z].
Proof.
rewrite /arbitrarySized semSized => n; split=> // _; exists (Z.abs_nat n); split=> //.
simpl.
rewrite Nat2Z.inj_abs_nat (semChooseSize _ _ _).
  by case: n => //= p; rewrite !Z.leb_refl.
apply/(Zle_bool_trans _ 0%Z); apply/Zle_is_le_bool.
  exact/Z.opp_nonpos_nonneg/Z.abs_nonneg.
exact/Z.abs_nonneg.
Qed.

Lemma arbList_correct:
  forall {A} `{H : Arbitrary A} (P : nat -> A -> Prop) s,
    (semProdSize arbitrary s <--> P s) ->
    (semProdSize arbitrary s <-->
     (fun (l : list A) => length l <= s /\ (forall x, List.In x l -> P s x))).
Proof.
  move => A G S H P s Hgen l.
  rewrite !/arbitrary /genList.
  split.
  - move => /semListOfSize [Hl Hsize]. split => // x HIn //=. apply Hgen. auto.
  - move => [Hl HP].
    apply semListOfSize; eauto with typeclass_instances.
    split => // x HIn.
    apply Hgen. auto.
Qed.

Opaque ret.
Opaque liftM.
Lemma arbOpt_correct:
  forall {A} `{H : Arbitrary A} (P : nat -> A -> Prop) s,
    (semProdSize arbitrary s <--> P s) ->
    (semProdSize arbitrary s <-->
     (fun (m : option A) =>
        match m with
          | None => true
          | Some x => P s x
        end)).
Proof.
  move => A G S Arb P s Hgen m. rewrite !/arbitrary /genOption; split.
  - move => /semFrequencySize [[w g] H2].
    move: H2 => [[H2 | [H2 | H2]] H3];
    destruct m => //=; apply Hgen => //=;
    inversion H2; subst; auto; simpl in *.
    + apply (@semReturnSize Generators.G ProducerGen ProducerSemanticsGen (option A) _) in H3; inversion H3.
    + apply semLiftProdSize in H3; eauto with typeclass_instances. inversion H3 as [x [H0 H1]].
      inversion H1; subst; auto.
  - destruct m eqn:Hm; simpl in *; move => HP; subst.
    + apply semFrequencySize; simpl.
      exists (7, liftM Some arbitrary); split; auto.
      * right; left; auto.
      * simpl. apply semLiftProdSize; simpl;
                 eauto with typeclass_instances.
        apply imset_in; apply Hgen; auto.
    + apply semFrequencySize; simpl.
      exists (1, ret None); split; auto.
      * left; auto.
      * simpl.
        apply (@semReturnSize Generators.G ProducerGen ProducerSemanticsGen). constructor.
Qed.

Lemma arbPair_correctSize
      {A B} `{Arbitrary A} `{Arbitrary B} (Sa : nat -> set A)
      (Sb : nat -> set B) s:
    (semProdSize arbitrary s <--> Sa s) ->
    (semProdSize arbitrary s <--> Sb s) ->
    (semProdSize arbitrary s <--> setX (Sa s) (Sb s)).
Proof.
  move => Hyp1 Hyp2 .
  Opaque liftM2.
  simpl.
  rewrite semLiftProd2Size; move => [a b].
  split.
  by move => [[a' b'] [[/= /Hyp1 Ha /Hyp2 Hb] [Heq1 Heq2]]]; subst; split.
  move => [/Hyp1 Ha /Hyp2 Hb]. eexists; split; first by split; eauto.
  reflexivity.
Qed.


Require Import Morphisms Setoid.
Require Import Utf8.

Add LoadPath "../../theories" as CatQ.
From CatQ.Structures Require Import Structures.
From CatQ.Categories Require Import Concrete.

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

Set Universe Polymorphism.

Definition Bifunctor (C D E : Category) := Functor (Product C D) E.

Program Definition homFunctor {C : Category} : Bifunctor (opposite C) C Setoids :=
  [fmap: fun a b ab => [mapoid: fun f => snd ab ∘ f ∘ fst ab]
   with fun a => @morphism C (fst a) (snd a) as (opposite C) × C to Setoids].
Next Obligation.
  simpl.
  unfold Proper, respectful.
  intros.
  destruct ab.
  simpl.
  simpl in c, c0.
  unfold Func.flip in c.
  rewrite H.
  reflexivity.
Defined.
Next Obligation.
  unfold Proper, respectful, Func.flip.
  simpl.
  intros.
  destruct x, y.
  destruct H.
  simpl in H, H0.
  simpl.
  rewrite H, H0.
  reflexivity.
Defined.
Next Obligation.
  rewrite left_id_of.
  rewrite right_id_of.
  reflexivity.
Defined.
Next Obligation.
  repeat rewrite assoc_of.
  reflexivity.
Defined.

Definition bimap {C D E} (G : Bifunctor C D E) {a b} (f : fst a ⟶ fst b) (g : snd a ⟶ snd b) : G a ⟶ G b
  := fmap G (Spair f g).

Instance bimap_proper {C D E} {G : Bifunctor C D E} {a b} :
  Proper (@equality _ ==> @equality _ ==> @equality _) (fun f g => bimap G (a:=a) (b:=b) f g).
Proof.
  unfold bimap.
  unfold Proper, respectful.
  intros.
  apply fmap_proper.
  simpl.
  auto.
Qed.

Lemma bimap_identity {C D E} (G : Bifunctor C D E) {a} : bimap G (a:=a) identity identity == identity.
Proof.
  unfold bimap.
  rewrite fmap_identity.
  reflexivity.
Qed.

Lemma bimap_compose {C D E} (G : Bifunctor C D E) {a b c}
      (f : fst a ⟶ fst b) (f' : fst b ⟶ fst c) (g : snd a ⟶ snd b) (g' : snd b ⟶ snd c) :
  bimap G (f' ∘ f) (g' ∘ g) == bimap G f' g' ∘ bimap G f g.
Proof.
  unfold bimap.
  rewrite <- fmap_compose.
  reflexivity.
Qed.

Program Definition Bifunctor_at_L {C D E} (G : Bifunctor C D E) (c : C) : Functor D E
  := [fmap: fun a b f => bimap G (a:=(c,a)) (b:=(c,b)) identity f with fun d => G (c,d) ].
Next Obligation.
  solve_proper.
Defined.
Next Obligation.
  apply bimap_identity.
Defined.
Next Obligation.
  rewrite <- bimap_compose.
  rewrite right_id_of.
  reflexivity.
Defined.

Notation "F [ a ,-]" := (Bifunctor_at_L F a) (at level 0).

Program Definition Bifunctor_at_R {C D E} (G : Bifunctor C D E) (d : D) : Functor C E
  := [fmap: fun a b f => bimap G (a:=(a,d)) (b:=(b,d)) f identity with fun c => G (c,d) ].
Next Obligation.
  solve_proper.
Defined.
Next Obligation.
  apply bimap_identity.
Defined.
Next Obligation.
  rewrite <- bimap_compose.
  rewrite right_id_of.
  reflexivity.
Defined.

Notation "F [-, a ]" := (Bifunctor_at_R F a) (at level 0).

Program Definition Bifunctor_apply_L {C D E} (G : Bifunctor C D E) {c c'} (k : c ⟶ c' in C) : Nat G[c,-] G[c',-]
  := [Nat: fun a => bimap G (a:=(c,a)) (b:=(c',a)) k identity ].
Next Obligation.
  constructor.
  intros.

  refine
    (`begin
      fmap G[c',-] f ∘ bimap G (a:=(c,a)) (b:=(c',a)) k identity
     =⟨ hom_refl ⟩
      bimap G (a:=(c',a)) (b:=(c',b)) identity f ∘ bimap G (a:=(c,a)) (b:=(c',a)) k identity
     =⟨ ltac: (rewrite <- bimap_compose; reflexivity) ⟩
      bimap G (a:=(c,a)) (b:=(c',b)) (identity ∘ k) (f ∘ identity)
     =⟨ ltac: (rewrite right_id_of, left_id_of; reflexivity) ⟩
      bimap G (a:=(c,a)) (b:=(c',b)) k f
     ↑⟨ ltac: (rewrite right_id_of, left_id_of; reflexivity) ⟩
      bimap G (a:=(c,a)) (b:=(c',b)) (k ∘ identity) (identity ∘ f)
     =⟨ ltac: (rewrite <- bimap_compose; reflexivity) ⟩
      bimap G (a:=(c,b)) (b:=(c',b)) k identity ∘ bimap G (a:=(c,a)) (b:=(c,b)) identity f
     =⟨ hom_refl ⟩
      bimap G (a:=(c,b)) (b:=(c',b)) k identity ∘ fmap G[c,-] f
     `end).
Defined.

Notation "F [ f ,-]n" := (Bifunctor_apply_L F f) (at level 0).

Program Definition Bifunctor_apply_R {C D E} (G : Bifunctor C D E) {d d'} (k : d ⟶ d' in D) : Nat G[-,d] G[-,d']
  := [Nat: fun a => bimap G (a:=(a,d)) (b:=(a,d')) identity k].
Next Obligation.
  constructor.
  intros.

  refine
    (`begin
      fmap G[-,d'] f ∘ bimap G (a:=(a,d)) (b:=(a,d')) identity k
     =⟨ hom_refl ⟩
      bimap (a:=(a,d')) (b:=(b,d')) G f identity ∘ bimap G (a:=(a,d)) (b:=(a,d')) identity k
     =⟨ ltac: (rewrite <- bimap_compose; reflexivity) ⟩
      bimap (a:=(a,d)) (b:=(b,d')) G (f ∘ identity) (identity ∘ k)
     =⟨ ltac: (rewrite right_id_of, left_id_of; reflexivity) ⟩
      bimap (a:=(a,d)) (b:=(b,d')) G f k
     ↑⟨ ltac: (rewrite right_id_of, left_id_of; reflexivity) ⟩
      bimap G (a:=(a,d)) (b:=(b,d')) (identity ∘ f) (k ∘ identity)
     =⟨ ltac: (rewrite <- bimap_compose; reflexivity) ⟩
      bimap G (a:=(b,d)) (b:=(b,d')) identity k ∘ bimap G (a:=(a,d)) (b:=(b,d)) f identity
     =⟨ hom_refl ⟩
      bimap G (a:=(b,d)) (b:=(b,d')) identity k ∘ fmap G[-,d] f
     `end).
Defined.

Notation "F [-, f ]n" := (Bifunctor_apply_R F f) (at level 0).


(** * Constructors and Deconstructors for Finite Types *)

Require Import ProgrammingTools.

Section CaseFin.

  Variable sig : finType.
  Hypothesis defSig : inhabitedC sig.

  Definition CaseFin : pTM sig^+ sig 1 :=
    Move R;;
    Switch (ReadChar)
    (fun s => match s with
           | Some (inr x) => Return (Move R) x
           | _ => Return (Nop) default
           end).

  (** Note that [Encode_Finite] is not globally declared as an instance, because that would cause ambiguity. For example, [bool+bool] is finite, but we might want to encode it with [Encode_sum Encode_bool Encode_bool]. *)
  Local Existing Instance Encode_Finite.

  Definition CaseFin_Rel : pRel sig^+ sig 1 :=
    fun tin '(yout, tout) => forall x : sig, tin[@Fin0] ≃ x -> isRight tout[@Fin0] /\ yout = x.

  Lemma CaseFin_Sem : CaseFin ⊨c(5) CaseFin_Rel.
  Proof.
    eapply RealiseIn_monotone.
    { unfold CaseFin. TM_Correct. }
    { Unshelve. 4,8:reflexivity. all:omega. }
    {
      intros tin (yout, tout) H. intros x HEncX.
      destruct HEncX as (ls&HEncX).
      TMSimp. repeat econstructor.
    }
  Qed.

  (** There is no need for a constructor, just use [WriteValue] *)

End CaseFin.

Arguments CaseFin : simpl never.
Arguments CaseFin sig {_}. (** Default element is infered and inserted automatically *)

Ltac smpl_TM_CaseFin :=
  lazymatch goal with
  | [ |- CaseFin _ ⊨ _ ] => eapply RealiseIn_Realise; apply CaseFin_Sem
  | [ |- CaseFin _ ⊨c(_) _ ] => apply CaseFin_Sem
  | [ |- projT1 (CaseFin _) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply CaseFin_Sem
  end.

Smpl Add smpl_TM_CaseFin : TM_Correct.


From Coq Require Import ZArith Psatz Bool String List FMaps.
From Coq Require Import FunctionalExtensionality.
From CDF Require Import Sequences IMP.
From CDF Require AbstrInterp.

Local Open Scope string_scope.
Local Open Scope Z_scope.

(** * 5.  Static analysis by abstract interpretation, improved version *)

(** ** 5.5.  Improved interface of abstract domains *)

(** We enrich the interface of abstract domains for values with
    operations for inverse analysis of conditionals and for widening. *)

Module Type VALUE_ABSTRACTION.

(** We reuse all the declarations of the simplified interface. *)

  Include AbstrInterp.VALUE_ABSTRACTION.

(** [meet] computes a lower bound of its two arguments. *)
  Parameter meet: t -> t -> t.
  Axiom meet_1: forall n N1 N2, In n N1 -> In n N2 -> In n (meet N1 N2).

(** [isIn] tests whether a concrete value belongs to an abstract value. *)
  Parameter isIn: Z -> t -> bool.
  Axiom isIn_1: forall n N, In n N -> isIn n N = true.

(** Abstract operators for inverse analysis of comparisons. *)

(** Consider a test [a1 = a2] that evaluates to true at run-time.
    Let [N1] be an abstraction of [a1] and [N2] be an abstraction of [a2].
    [eq_inv N1 N2] produces a pair of abstract values [N1', N2'].
    [N1'] is a possibly more precise abstraction for [a1]
    taking into account the fact that [a1 = a2].
    [N2'] is a possibly more precise abstraction for [a2]
    taking into account the fact that [a1 = a2]. *)

  Parameter eq_inv: t -> t -> t * t.
  Axiom eq_inv_1:
    forall n1 n2 N1 N2,
    In n1 N1 -> In n2 N2 -> n1 = n2 ->
    In n1 (fst (eq_inv N1 N2)) /\ In n2 (snd (eq_inv N1 N2)).

(** [ne_inv], [le_inv] and [gt_inv] are similar but apply to the other
    three basic comparisons: "different", "less than or equal", and
    "greater than". *)

  Parameter ne_inv: t -> t -> t * t.
  Axiom ne_inv_1:
    forall n1 n2 N1 N2,
    In n1 N1 -> In n2 N2 -> n1 <> n2 ->
    In n1 (fst (ne_inv N1 N2)) /\ In n2 (snd (ne_inv N1 N2)).

  Parameter le_inv: t -> t -> t * t.
  Axiom le_inv_1:
    forall n1 n2 N1 N2,
    In n1 N1 -> In n2 N2 -> n1 <= n2 ->
    In n1 (fst (le_inv N1 N2)) /\ In n2 (snd (le_inv N1 N2)).

  Parameter gt_inv: t -> t -> t * t.
  Axiom gt_inv_1:
    forall n1 n2 N1 N2,
    In n1 N1 -> In n2 N2 -> n1 > n2 ->
    In n1 (fst (gt_inv N1 N2)) /\ In n2 (snd (gt_inv N1 N2)).

(** [widen N1 N2] computes an upper bound of its first argument, chosen
    so as to guarantee and accelerate the convergence of fixed point
    iteration. *)

  Parameter widen: t -> t -> t.
  Axiom widen_1: forall N1 N2, le N1 (widen N1 N2).

(** To guarantee convergence, we provide a measure with nonnegative
    integer values that decreases strictly along the fixed point
    iteration with widening. *)
  Parameter measure: t -> nat.
  Axiom measure_top: measure top = 0%nat.
  Axiom widen_2: forall N1 N2, (measure (widen N1 N2) <= measure N1)%nat.
  Axiom widen_3:
    forall N1 N2, ble N2 N1 = false -> (measure (widen N1 N2) < measure N1)%nat.

End VALUE_ABSTRACTION.

(** We enrich the interface of abstract stores with a widening operation. *)

Module Type STORE_ABSTRACTION.

  Declare Module V: VALUE_ABSTRACTION.
  Parameter t: Type.
  Parameter get: ident -> t -> V.t.
  Definition In (s: store) (S: t) : Prop := forall x, V.In (s x) (get x S).
  Parameter set: ident -> V.t -> t -> t.
  Axiom set_1: forall x n N s S, V.In n N -> In s S -> In (update x n s) (set x N S).
  Definition le (S1 S2: t) : Prop :=
    forall s, In s S1 -> In s S2.
  Parameter ble: t -> t -> bool.
  Axiom ble_1: forall S1 S2, ble S1 S2 = true -> le S1 S2.
  Parameter bot: t.
  Axiom bot_1: forall s, ~(In s bot).
  Parameter top: t.
  Parameter top_1: forall s, In s top.
  Parameter join: t -> t -> t.
  Axiom join_1: forall s S1 S2, In s S1 -> In s (join S1 S2).
  Axiom join_2: forall s S1 S2, In s S2 -> In s (join S1 S2).

(** This is the new widening operator. *)

  Parameter widen: t -> t -> t.
  Axiom widen_1: forall S1 S2, le S1 (widen S1 S2).

(** The order below corresponds to consecutive rounds of the fixed point
    iteration with widening.  We require it to be well founded,
    so as to guarantee termination. *)

  Definition widen_order (S S1: t) :=
    exists S2, S = widen S1 S2 /\ ble S2 S1 = false.

  Axiom widen_order_wf: well_founded widen_order.

End STORE_ABSTRACTION.

(** ** 5.6.  The improved generic analyzer. *)

Module Analysis (ST: STORE_ABSTRACTION).

Module V := ST.V.

(** *** Computing post-fixed points with widening and narrowing. *)

Section FIXPOINT.

Variable F: ST.t -> ST.t.

Program Definition is_true (b: bool) : { b = true } + { b = false } :=
  match b with true => left _ | false => right _ end.

Lemma iter_up_acc:
  forall (S: ST.t) (acc: Acc ST.widen_order S) (S': ST.t),
  ST.ble S' S = false ->
  Acc ST.widen_order (ST.widen S S').
Proof.
  intros. eapply Acc_inv; eauto. exists S'. auto.
Defined.

Fixpoint iter_up (S: ST.t) (acc: Acc ST.widen_order S) : ST.t :=
  let S' := F S in
  match is_true (ST.ble S' S) with
  | left LE => S
  | right NOTLE => iter_up (ST.widen S S') (iter_up_acc S acc S' NOTLE)
  end.

Fixpoint iter_down (n: nat) (S: ST.t) : ST.t :=
  match n with
  | O => S
  | S n => let S' := F S in
           if ST.ble (F S') S' then iter_down n S' else S
  end.

Definition niter_down := 3%nat.

Definition postfixpoint : ST.t :=
  iter_down niter_down (iter_up ST.bot (ST.widen_order_wf ST.bot)).

Lemma iter_up_sound:
  forall S acc, ST.le (F (iter_up S acc)) (iter_up S acc).
Proof.
  induction S using (well_founded_induction ST.widen_order_wf).
  intros acc. destruct acc. cbn. destruct (is_true (ST.ble (F S) S)).
- apply ST.ble_1; auto.
- apply H. exists (F S); auto.
Qed.

Lemma iter_down_sound:
  forall n S, ST.le (F S) S -> ST.le (F (iter_down n S)) (iter_down n S).
Proof.
  induction n; intros; cbn.
- auto.
- destruct (ST.ble (F (F S)) (F S)) eqn:BLE.
  + apply IHn. apply ST.ble_1; auto.
  + auto.
Qed.

Lemma postfixpoint_sound: ST.le (F postfixpoint) postfixpoint.
Proof.
  apply iter_down_sound. apply iter_up_sound.
Qed.

End FIXPOINT.

(** *** Abstract interpretation of arithmetic expressions *)

(** Same definition as in the simplified version. *)

Fixpoint Aeval (a: aexp) (S: ST.t) : V.t :=
  match a with
  | CONST n => V.const n
  | VAR x => ST.get x S
  | PLUS a1 a2 => V.add (Aeval a1 S) (Aeval a2 S)
  | MINUS a1 a2 => V.sub (Aeval a1 S) (Aeval a2 S)
  end.

Lemma Aeval_sound:
  forall s S a,
  ST.In s S -> V.In (aeval a s) (Aeval a S).
Proof.
  induction a; cbn; intros.
- apply V.const_1.
- apply H.
- apply V.add_1; auto.
- apply V.sub_1; auto.
Qed.

(** *** Inverse analysis of arithmetic and Boolean expressions *)

(** Assuming that the concrete value of [a] belongs to the abstract
    value [Res], what do we learn about the values of the variables
    that occur in [a]?  The facts that we learn are used to refine
    the abstract values of these variables in the abstract store [S]. *)

Fixpoint assume_eval (a: aexp) (Res: V.t) (S: ST.t) : ST.t :=
  match a with
  | CONST n =>
      if V.isIn n Res then S else ST.bot
  | VAR x =>
      ST.set x (V.meet Res (ST.get x S)) S
  | PLUS a1 a2 =>
      let N1 := Aeval a1 S in
      let N2 := Aeval a2 S in
      let Res1 := V.meet N1 (V.sub Res N2) in
      let Res2 := V.meet N2 (V.sub Res N1) in
      assume_eval a1 Res1 (assume_eval a2 Res2 S)
  | MINUS a1 a2 =>
      let N1 := Aeval a1 S in
      let N2 := Aeval a2 S in
      let Res1 := V.meet N1 (V.add Res N2) in
      let Res2 := V.meet N2 (V.sub N1 Res) in
      assume_eval a1 Res1 (assume_eval a2 Res2 S)
  end.

Lemma assume_eval_sound:
  forall a Res S s,
  V.In (aeval a s) Res -> ST.In s S -> ST.In s (assume_eval a Res S).
Proof.
  induction a; cbn; intros.
- (* CONST *)
  rewrite V.isIn_1 by auto. auto.
- (* VAR *)
  replace s with (update x (s x) s).
  apply ST.set_1; auto.
  apply V.meet_1; auto.
  apply functional_extensionality; intros y.
  unfold update; destruct (string_dec x y); congruence.
- (* PLUS *)
  set (n1 := aeval a1 s) in *. set (n2 := aeval a2 s) in *.
  set (N1 := Aeval a1 S). set (N2 := Aeval a2 S).
  assert (V.In n1 N1) by (apply Aeval_sound; auto).
  assert (V.In n2 N2) by (apply Aeval_sound; auto).
  apply IHa1; fold n1.
  apply V.meet_1. auto. replace n1 with ((n1 + n2) - n2) by lia. apply V.sub_1; auto.
  apply IHa2; fold n2.
  apply V.meet_1. auto. replace n2 with ((n1 + n2) - n1) by lia. apply V.sub_1; auto.
  auto.
- (* MINUS *)
  set (n1 := aeval a1 s) in *. set (n2 := aeval a2 s) in *.
  set (N1 := Aeval a1 S). set (N2 := Aeval a2 S).
  assert (V.In n1 N1) by (apply Aeval_sound; auto).
  assert (V.In n2 N2) by (apply Aeval_sound; auto).
  apply IHa1; fold n1.
  apply V.meet_1. auto. replace n1 with ((n1 - n2) + n2) by lia. apply V.add_1; auto.
  apply IHa2; fold n2.
  apply V.meet_1. auto. replace n2 with (n1 - (n1 - n2)) by lia. apply V.sub_1; auto.
  auto.
Qed.

(** Assuming that the Boolean expression [b] evaluates concretely to
    the Boolean value [res], what do we learn about the values of the
    variables that occur in [b]?  The facts that we learn are used to
    refine the abstract values of these variables in the abstract
    store [S]. *)

Fixpoint assume_test (b: bexp) (res: bool) (S: ST.t): ST.t :=
  match b with
  | TRUE => if res then S else ST.bot
  | FALSE => if res then ST.bot else S
  | EQUAL a1 a2 =>
      let (Res1, Res2) :=
        if res
        then V.eq_inv (Aeval a1 S) (Aeval a2 S)
        else V.ne_inv (Aeval a1 S) (Aeval a2 S) in
      assume_eval a1 Res1 (assume_eval a2 Res2 S)
  | LESSEQUAL a1 a2 =>
      let (Res1, Res2) :=
        if res
        then V.le_inv (Aeval a1 S) (Aeval a2 S)
        else V.gt_inv (Aeval a1 S) (Aeval a2 S) in
      assume_eval a1 Res1 (assume_eval a2 Res2 S)
  | NOT b1 =>
      assume_test b1 (negb res) S
  | AND b1 b2 =>
      if res
      then assume_test b1 true (assume_test b2 true S)
      else ST.join (assume_test b1 false S) (assume_test b2 false S)
  end.

Lemma assume_test_sound:
  forall b res S s,
  beval b s = res -> ST.In s S -> ST.In s (assume_test b res S).
Proof.
  induction b; cbn; intros.
- (* TRUE *)
  subst res; auto.
- (* FALSE *)
  subst res; auto.
- (* EQUAL *)
  set (Res := if res
              then V.eq_inv (Aeval a1 S) (Aeval a2 S)
              else V.ne_inv (Aeval a1 S) (Aeval a2 S)).
  assert (A: V.In (aeval a1 s) (fst Res) /\ V.In (aeval a2 s) (snd Res)).
  { unfold Res; destruct res;
    [ apply V.eq_inv_1 | apply V.ne_inv_1 ]; auto using Aeval_sound.
  - apply Z.eqb_eq; auto.
  - apply Z.eqb_neq; auto.
  }
  destruct A as [A1 A2]. destruct Res as [Res1 Res2]. auto using assume_eval_sound.
- (* LESSEQUAL *)
  set (Res := if res
              then V.le_inv (Aeval a1 S) (Aeval a2 S)
              else V.gt_inv (Aeval a1 S) (Aeval a2 S)).
  assert (A: V.In (aeval a1 s) (fst Res) /\ V.In (aeval a2 s) (snd Res)).
  { unfold Res; destruct res;
    [ apply V.le_inv_1 | apply V.gt_inv_1 ]; auto using Aeval_sound.
  - apply Z.leb_le; auto.
  - apply Z.leb_nle in H. lia.
  }
  destruct A as [A1 A2]. destruct Res as [Res1 Res2]. auto using assume_eval_sound.
- (* NOT *)
  apply IHb; auto. rewrite <- H. rewrite negb_involutive; auto.
- (* AND *)
  destruct res.
  + (* AND, true *)
    destruct (andb_prop _ _ H).
    auto.
  + (* AND, false *)
    destruct (andb_false_elim _ _ H); [apply ST.join_1 | apply ST.join_2]; auto.
Qed.

(** *** Improved abstract interpretation of commands *)

(** We add calls to [assume_test] every time a Boolean condition
    is known to be true or to be false. *)

Fixpoint Cexec (c: com) (S: ST.t) : ST.t :=
  match c with
  | SKIP => S
  | ASSIGN x a => ST.set x (Aeval a S) S
  | SEQ c1 c2 => Cexec c2 (Cexec c1 S)
  | IFTHENELSE b c1 c2 =>
      ST.join (Cexec c1 (assume_test b true S))
              (Cexec c2 (assume_test b false S))
  | WHILE b c =>
      assume_test b false
        (postfixpoint (fun X => ST.join S (Cexec c (assume_test b true X))))
  end.

Theorem Cexec_sound:
  forall c s s' S,
  ST.In s S -> cexec s c s' -> ST.In s' (Cexec c S).
Proof.
Opaque niter_down.
  induction c; intros s s' S PRE EXEC; cbn.
- (* SKIP *)
  inversion EXEC; subst. auto.
- (* ASSIGN *)
  inversion EXEC; subst. apply ST.set_1; auto. apply Aeval_sound; auto.
- (* SEQ *)
  inversion EXEC; subst. eauto.
- (* IFTHENELSE *)
  inversion EXEC; subst. destruct (beval b s) eqn:B.
  apply ST.join_1. eapply IHc1; eauto. apply assume_test_sound; auto.
  apply ST.join_2. eapply IHc2; eauto. apply assume_test_sound; auto.
- (* WHILE *)
  set (F := fun X => ST.join S (Cexec c (assume_test b true X))).
  set (X := postfixpoint F).
  assert (L : ST.le (F X) X) by (apply postfixpoint_sound).
  assert (REC: forall s1 c1 s2,
               cexec s1 c1 s2 ->
               c1 = WHILE b c ->
               ST.In s1 X ->
               ST.In s2 (assume_test b false X)).
  { induction 1; intro EQ; inversion EQ; subst; intros.
  - (* WHILE done *)
    apply assume_test_sound; auto.
  - (* WHILE loop *)
    apply IHcexec2; auto. apply L. unfold F. apply ST.join_2.
    eapply IHc; eauto. apply assume_test_sound; auto.
  }
  eapply REC; eauto. apply L. unfold F. apply ST.join_1. auto.
Qed.

End Analysis.

(** ** 5.7.  An improved abstract domain for stores *)

(** We start from the abstract domain in module [AbstrInterp], section 5.3,
    and add the widening operator and its properties. *)

Module IdentMap := AbstrInterp.IdentMap.
Module IMFact := AbstrInterp.IMFact.
Module IMProp := AbstrInterp.IMProp.

Module StoreAbstr (VA: VALUE_ABSTRACTION) <: STORE_ABSTRACTION.

Module V := VA.

Inductive abstr_state : Type :=
  | Bot
  | Top_except (m: IdentMap.t V.t).

Definition t := abstr_state.

Definition get (x: ident) (S: t) : V.t :=
  match S with
  | Bot => V.bot
  | Top_except m =>
      match IdentMap.find x m with
      | None => V.top
      | Some v => v
      end
  end.

Definition In (s: store) (S: t) : Prop :=
  forall x, V.In (s x) (get x S).

Definition set (x: ident) (N: V.t) (S: t): t :=
  if V.ble N V.bot then Bot else
  match S with
  | Bot => Bot
  | Top_except m => Top_except (IdentMap.add x N m)
  end.

Lemma set_1:
  forall x n N s S,
  V.In n N -> In s S -> In (update x n s) (set x N S).
Proof.
  unfold In, get, set; intros.
  destruct (V.ble N V.bot) eqn:BLE; [ | destruct S ].
- apply V.ble_1 in BLE. apply BLE in H. elim (V.bot_1 n); auto.
- elim (V.bot_1 (s "")). auto.
- rewrite IMFact.add_o. change IdentMap.E.eq_dec with string_dec. unfold update.
  destruct (string_dec x x0); auto.
Qed.

(** The order between abstract states. *)

Definition le (S1 S2: t) : Prop :=
  forall s, In s S1 -> In s S2.

Definition ble (S1 S2: t) : bool :=
  match S1, S2 with
  | Bot, _ => true
  | _, Bot => false
  | Top_except m1, Top_except m2 =>
      IMProp.for_all (fun x v => V.ble (get x S1) v) m2
  end.

Lemma ble_1: forall S1 S2, ble S1 S2 = true -> le S1 S2.
Proof.
  unfold ble, le; intros.
  destruct S1 as [ | m1].
- elim (V.bot_1 (s "")). apply H0.
- destruct S2 as [ | m2]. discriminate.
  red; cbn; intros. destruct (IdentMap.find x m2) as [N2|] eqn:F2.
  + apply IdentMap.find_2 in F2. eapply IMProp.for_all_iff in H; eauto.
    apply V.ble_1 in H. apply H. apply H0.
    hnf. intros; subst x0. hnf; intros. subst x0. auto.
  + apply V.top_1.
Qed.

Lemma ble_false: forall s1 s2,
  s2 <> Bot -> ble s1 s2 = false -> exists x, V.ble (get x s1) (get x s2) = false.
Proof.
  unfold ble; intros.
  destruct s1 as [ | m1]. discriminate. destruct s2 as [ | m2]. congruence.
- set (p := fun (x: IdentMap.key) v => V.ble (get x (Top_except m1)) v) in *.
  set (m' := IMProp.filter (fun x v => negb (p x v)) m2).
  destruct (IdentMap.elements m') as [ | [x1 v1] l1] eqn:ELT.
+ assert (IMProp.for_all p m2 = true).
  { apply IMProp.for_all_iff.
    repeat (hnf; intros). congruence.
    intros. destruct (p k e) eqn:P; auto.
    assert (M: IdentMap.MapsTo k e m').
    { apply IMProp.filter_iff.
      repeat (hnf; intros). congruence.
      rewrite P; auto. }
    apply IdentMap.elements_1 in M. rewrite ELT in M. inversion M.
  }
  congruence.
+ assert (M: IdentMap.MapsTo x1 v1 m').
  { apply IdentMap.elements_2. rewrite ELT. constructor. hnf; auto. }
  apply IMProp.filter_iff in M. destruct M as [M N]. apply negb_true_iff in N.
  exists x1. unfold get at 2. erewrite IdentMap.find_1 by eauto. exact N.
  repeat (hnf; intros). congruence.
Qed.

(** The lattice operations. *)

Definition bot: t := Bot.

Lemma bot_1: forall s, ~(In s bot).
Proof.
  unfold In; cbn. intros s IN. apply (V.bot_1 (s "")). apply IN.
Qed.

Definition top: t := Top_except (IdentMap.empty V.t).

Lemma top_1: forall s, In s top.
Proof.
  unfold In, top, get; cbn. intros. apply V.top_1.
Qed.

Definition join_aux (ov1 ov2: option V.t) : option V.t :=
  match ov1, ov2 with
  | Some v1, Some v2 => Some (V.join v1 v2)
  | _, _ => None
  end.

Definition join (S1 S2: t) : t :=
  match S1, S2 with
  | Bot, _ => S2
  | _, Bot => S1
  | Top_except m1, Top_except m2 =>
      Top_except (IdentMap.map2 join_aux m1 m2)
  end.

Lemma join_1:
  forall s S1 S2, In s S1 -> In s (join S1 S2).
Proof.
  unfold join; intros.
  destruct S1 as [ | m1]. elim (bot_1 s); auto.
  destruct S2 as [ | m2]. auto.
- red; unfold get; intros. rewrite IMFact.map2_1bis; auto.
  unfold join_aux. specialize (H x). unfold get in H.
  destruct (IdentMap.find x m1).
  + destruct (IdentMap.find x m2).
    * apply V.join_1; auto.
    * apply V.top_1.
  + apply V.top_1.
Qed.

Lemma join_2:
  forall s S1 S2, In s S2 -> In s (join S1 S2).
Proof.
  unfold join; intros.
  destruct S1 as [ | m1]. auto.
  destruct S2 as [ | m2]. elim (bot_1 s); auto.
- red; unfold get; intros. rewrite IMFact.map2_1bis; auto.
  unfold join_aux. specialize (H x). unfold get in H.
  destruct (IdentMap.find x m1).
  + destruct (IdentMap.find x m2).
    * apply V.join_2; auto.
    * apply V.top_1.
  + apply V.top_1.
Qed.

(** The widening operator.  We apply pointwise the [V.widen] widening
    provided by the value domain, with default cases for variables
    not described in the map, which are implicitly set to [V.top]. *)

Definition widen_aux (ov1 ov2: option V.t) : option V.t :=
  match ov1, ov2 with
  | Some v1, Some v2 => Some (V.widen v1 v2)
  | None, _ => None
  | _, None => None
  end.

Definition widen (s1 s2: t) : t :=
  match s1, s2 with
  | Bot, _ => s2
  | _, Bot => s1
  | Top_except m1, Top_except m2 => Top_except (IdentMap.map2 widen_aux m1 m2)
  end.

Lemma widen_1: forall s1 s2, le s1 (widen s1 s2).
Proof.
  unfold le, widen; intros.
  destruct s1 as [ | m1]. elim (bot_1 _ H).
  destruct s2 as [ | m2]. auto.
  red; unfold get; intros. specialize (H x); cbn in H.
  rewrite IMFact.map2_1bis; auto. unfold widen_aux.
  destruct (IdentMap.find x m1); destruct (IdentMap.find x m2);
  auto using V.top_1.
  apply V.widen_1; auto.
Qed.

(** Constructing a well-founded order that guarantees termination is difficult.
    We start by defining a measure with nonnegative integer values
    for a finite map [IdentMap.t V.t].  This measure is the sum
    of the measures of the abstract values in the codomain of this
    finite map. *)

Definition measure_map (m: IdentMap.t V.t) : nat :=
  IdentMap.fold (fun x v n => (V.measure v + n)%nat) m 0%nat.

Remark measure_map_empty:
  forall m, IdentMap.Empty m -> measure_map m = 0%nat.
Proof.
  intros. apply IMProp.fold_Empty; auto.
Qed.

Remark measure_map_add:
  forall m x v m', ~IdentMap.In x m -> IMProp.Add x v m m' ->
  measure_map m' = (V.measure v + measure_map m)%nat.
Proof.
  intros. unfold measure_map; eapply IMProp.fold_Add with (f := fun x v n => (V.measure v + n)%nat); eauto.
  repeat (hnf; intros). congruence.
  hnf; intros. lia.
Qed.

Remark measure_map_remove:
  forall m x,
  measure_map m = (V.measure (get x (Top_except m)) + measure_map (IdentMap.remove x m))%nat.
Proof.
  intros. unfold get. destruct (IdentMap.find x m) as [v|] eqn:F.
- apply measure_map_add with x.
  apply IMFact.not_find_in_iff. rewrite IMFact.remove_eq_o; auto.
  red; intros. rewrite IMFact.add_o, IMFact.remove_o.
  destruct (AbstrInterp.IdentMap.E.eq_dec x y); congruence.
- rewrite V.measure_top. unfold measure_map. eapply IMProp.fold_Equal. auto.
  repeat (hnf; intros). congruence.
  hnf; intros; lia.
  red; intros. rewrite IMFact.remove_o.
  destruct (AbstrInterp.IdentMap.E.eq_dec x y); congruence.
Qed.

Lemma measure_map_le: forall m1 m2,
  (forall x, V.measure (get x (Top_except m1)) <= V.measure (get x (Top_except m2)))%nat ->
  (measure_map m1 <= measure_map m2)%nat.
Proof.
  intros m0. pattern m0. unfold measure_map at 1; apply IMProp.fold_rec.
- intros m EMPTY m2 LE. lia.
- intros x v1 n m' m'' MAP NOTIN ADD REC m2 LE.
  set (m2' := IdentMap.remove x m2).
  assert (LE': forall x, (V.measure (get x (Top_except m')) <= V.measure (get x (Top_except m2')))%nat).
  { intros y. generalize (LE y). unfold get, m2'. rewrite ADD, IMFact.add_o, IMFact.remove_o.
    destruct (AbstrInterp.IdentMap.E.eq_dec x y).
    + subst y. apply IMFact.not_find_in_iff in NOTIN. rewrite NOTIN. rewrite ! V.measure_top. lia.
    + auto. }
  apply REC in LE'.
  rewrite (measure_map_remove m2 x). fold m2'.
  specialize (LE x). unfold get at 1 in LE. rewrite ADD, IMFact.add_eq_o in LE by auto.
  lia.
Qed.

Lemma measure_map_lt: forall m1 m2,
  (forall x, V.measure (get x (Top_except m1)) <= V.measure (get x (Top_except m2)))%nat ->
  (exists x, V.measure (get x (Top_except m1)) < V.measure (get x (Top_except m2)))%nat ->
  (measure_map m1 < measure_map m2)%nat.
Proof.
  intros m1 m2 LE (x & LT).
  rewrite (measure_map_remove m1 x), (measure_map_remove m2 x).
  assert ((measure_map (IdentMap.remove x m1) <= measure_map (IdentMap.remove x m2))%nat).
  { apply measure_map_le.
    intros y; unfold get. rewrite ! IMFact.remove_o.
    destruct (AbstrInterp.IdentMap.E.eq_dec x y).
    lia.
    apply LE. }
  lia.
Qed.

(** We then show that this measure strictly decreases during a widening
    step that does not mention [Bot]. *)

Lemma measure_widen_lt: forall m1 m2,
  ble (Top_except m2) (Top_except m1) = false ->
  (measure_map (IdentMap.map2 widen_aux m1 m2) < measure_map m1)%nat.
Proof.
  intros. apply ble_false in H. 2: congruence. destruct H as (x & BL).
  apply measure_map_lt.
- intros y. unfold get. rewrite IMFact.map2_1bis by auto. unfold widen_aux.
  destruct (IdentMap.find y m1) as [ v1 |].
  destruct (IdentMap.find y m2) as [ v2 |].
  apply V.widen_2.
  rewrite V.measure_top; lia.
  rewrite V.measure_top; lia.
- exists x. unfold get in *. rewrite IMFact.map2_1bis by auto. unfold widen_aux.
  destruct (IdentMap.find x m1) as [ v1 |].
  destruct (IdentMap.find x m2) as [ v2 |].
  apply V.widen_3 in BL; auto.
  apply V.widen_3 in BL; rewrite V.measure_top; lia.
  assert (T: forall z, V.ble z V.top = true).
  { intros. apply V.ble_2. red; intros. apply V.top_1. }
  rewrite T in BL. congruence.
Qed.

(** We conclude that the widening order is well founded. *)

Definition widen_order (S S1: t) := exists S2, S = widen S1 S2 /\ ble S2 S1 = false.

Lemma widen_order_wf: well_founded widen_order.
Proof.
  assert (A: forall m, Acc widen_order (Top_except m)).
  { induction m using (well_founded_ind (well_founded_ltof _ measure_map)).
    constructor. intros S (S2 & EQ & BLE). subst S.
    destruct S2. discriminate. apply H. apply measure_widen_lt. auto. }
  assert (B: Acc widen_order Bot).
  { constructor. intros S (S2 & EQ & BLE). subst S.
    unfold ble in BLE. destruct S2. discriminate. apply A. }
  red. destruct a; auto.
Defined.

End StoreAbstr.

(** ** 5.8.  The abstract domain of intervals *)

(** We first define the type [zinf] of integers complemented with a
    "plus infinity" value. *)

Inductive zinf : Type := Fin (h: Z) | Inf.

Coercion Fin : Z >-> zinf.

Module Zinf.
  Definition In (n: Z) (N: zinf) : Prop :=
    match N with Fin h => n <= h | Inf => True end.

  Lemma In_mono: forall n1 n2 N, n1 <= n2 -> In n2 N -> In n1 N.
  Proof.
    unfold In; destruct N; intros. lia. auto.
  Qed.

  Definition le (N1 N2: zinf) : Prop :=
    forall n, In n N1 -> In n N2.

  Lemma le_Fin: forall n1 N2, le (Fin n1) N2 <-> In n1 N2.
  Proof.
    unfold le; cbn; intros; split; intros.
  - apply H. lia.
  - destruct N2; cbn in *; auto. lia.
  Qed.

  Lemma le_is_Inf: forall N h, (forall n, h <= n -> In n N) -> N = Inf.
  Proof.
    destruct N; cbn; intros; auto.
    specialize (H (Z.max h0 (h + 1))). lia.
  Qed.

  Lemma le_Inf: forall N, le Inf N <-> N = Inf.
  Proof.
    unfold le; intros; split; intros.
  - apply le_is_Inf with 0. intros; apply H; exact I.
  - subst N; exact I.
  Qed.

  Definition ble (N1 N2: zinf) : bool :=
    match N1, N2 with _, Inf => true | Inf, _ => false | Fin h1, Fin h2 => h1 <=? h2 end.

  Lemma ble_1: forall N1 N2, ble N1 N2 = true -> le N1 N2.
  Proof.
    unfold ble, le, In; intros.
    destruct N1, N2; auto.
    apply Z.leb_le in H. lia.
    discriminate.
  Qed.

  Lemma ble_2: forall N1 N2, le N1 N2 -> ble N1 N2 = true.
  Proof.
    unfold ble; intros. destruct N1.
  - apply le_Fin in H. destruct N2; auto. apply Z.leb_le; auto.
  - apply le_Inf in H. rewrite H. auto.
  Qed.

  Definition max (N1 N2: zinf) : zinf :=
    match N1, N2 with Inf, _ => Inf | _, Inf => Inf | Fin h1, Fin h2 => Fin (Z.max h1 h2) end.

  Lemma max_1: forall n N1 N2, In n N1 -> In n (max N1 N2).
  Proof.
    unfold In, max; intros. destruct N1; auto. destruct N2; auto. lia.
  Qed.

  Lemma max_2: forall n N1 N2, In n N2 -> In n (max N1 N2).
  Proof.
    unfold In, max; intros. destruct N1; auto. destruct N2; auto. lia.
  Qed.

  Definition min (N1 N2: zinf) : zinf :=
    match N1, N2 with Inf, _ => N2 | _, Inf => N1 | Fin h1, Fin h2 => Fin (Z.min h1 h2) end.

  Lemma min_1: forall n N1 N2, In n N1 -> In n N2 -> In n (min N1 N2).
  Proof.
    unfold In, min; intros. destruct N1; auto. destruct N2; auto. lia.
  Qed.

  Definition add (N1 N2: zinf) : zinf :=
    match N1, N2 with Inf, _ => Inf | _, Inf => Inf | Fin h1, Fin h2 => Fin (h1 + h2) end.

  Lemma add_1: forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1 + n2) (add N1 N2).
  Proof.
    unfold In, add; intros. destruct N1; auto. destruct N2; auto. lia.
  Qed.

  Definition isIn (n: Z) (N: zinf) : bool :=
    match N with Fin h => n <=? h | Inf => true end.

  Lemma isIn_1:
    forall n N, In n N -> isIn n N = true.
  Proof.
    unfold In, isIn; intros. destruct N; auto. apply Z.leb_le; auto.
  Qed.

  Definition pred (N: zinf) : zinf :=
    match N with Inf => Inf | Fin n => Fin (n - 1) end.

  Lemma pred_1: forall n N, In n N -> In (n - 1) (pred N).
  Proof.
    unfold pred, In; intros; destruct N; auto. lia.
  Qed.

(** We define widening between two possibly infinite integers as follows:
    if the integer increases strictly, we jump to infinity, otherwise
    we keep the first integer. *)

  Definition widen (N1 N2: zinf) : zinf :=
     if ble N2 N1 then N1 else Inf.

  Lemma widen_1: forall N1 N2, le N1 (widen N1 N2).
  Proof.
    unfold widen; intros. destruct (ble N2 N1) eqn:LE.
    red; auto.
    red; unfold In; auto.
  Qed.

  Definition measure (N: zinf) : nat :=
    match N with Inf => 0%nat | Fin _ => 1%nat end.

  Lemma measure_1: forall N, (measure N <= 1)%nat.
  Proof.
    destruct N; cbn; lia.
  Qed.

  Lemma widen_2:
    forall N1 N2, (measure (widen N1 N2) <= measure N1)%nat.
  Proof.
    intros. unfold widen. destruct (ble N2 N1) eqn:BLE.
  - lia.
  - destruct N1. cbn; lia. destruct N2; discriminate.
  Qed.

  Lemma widen_3:
    forall N1 N2, ble N2 N1 = false -> (measure (widen N1 N2) < measure N1)%nat.
  Proof.
    destruct N1, N2; cbn; intros; auto; try discriminate.
    unfold widen. cbn. rewrite H. cbn. lia.
  Qed.

End Zinf.

(** An interval is encoded as a pair of two [zinf].
    The second [zinf] is the upper bound.
    The first [zinf] is the opposite of the lower bound.
    This representation trick makes it possible to have only one
    infinity [Inf], instead of a negative infinity for lower bounds
    and a positive infinity for upper bounds. *)

Module Intervals <: VALUE_ABSTRACTION.

(** The type of abstract values. *)
  Record interval : Type := intv { low: zinf; high: zinf }.
  Definition t := interval.

(** Membership: [n] must be below the upper bound, and the opposite of [n]
    must be below the opposite of the lower bound. *)

  Definition In (n: Z) (N: t) : Prop :=
    Zinf.In n (high N) /\ Zinf.In (-n) (low N).

  Definition le (N1 N2: t) : Prop :=
    forall n, In n N1 -> In n N2.

(** Test whether an interval is empty. *)

  Definition isempty (N: t) : bool :=
    match N with
    | {| low := Fin l; high := Fin h |} => h <? (-l)
    | _ => false
    end.

  Lemma isempty_1: forall n N, isempty N = true -> In n N -> False.
  Proof.
    unfold isempty, In; intros. destruct N as [[l|] [h|]]; try discriminate.
    apply Z.ltb_lt in H. cbn in H0. lia.
  Qed.

  Lemma isempty_2: forall N, isempty N = false -> exists n, In n N.
  Proof.
    unfold isempty, In; intros. destruct N as [[l|] [h|]]; cbn.
  - apply Z.ltb_ge in H. exists h; lia.
  - exists (- l); lia.
  - exists h; lia.
  - exists 0; auto.
  Qed.

  Lemma nonempty_le: forall N1 N2,
    le N1 N2 -> isempty N1 = false -> (Zinf.le (high N1) (high N2) /\ Zinf.le (low N1) (low N2)).
  Proof.
    unfold le, In, isempty; intros.
    destruct N1 as [[l1 |] [h1|]]; cbn in *; rewrite ? Zinf.le_Fin, ? Zinf.le_Inf.
  - apply Z.ltb_ge in H0. split.
    + apply H; lia.
    + replace l1 with (- - l1) by lia. apply H. lia.
  - split.
    + apply Zinf.le_is_Inf with (-l1). intros; apply H. intuition lia.
    + replace l1 with (- - l1) by lia. apply H. intuition lia.
  - split.
    + apply H. intuition lia.
    + apply Zinf.le_is_Inf with(- h1).
      intros. replace n with (- - n) by lia. apply H. intuition lia.
  - split; apply Zinf.le_is_Inf with 0; intros.
    + apply H; auto.
    + replace n with (- - n) by lia. apply H. auto.
  Qed.

(** [ble] is a Boolean-valued function that decides the [le] relation. *)

  Definition ble (N1 N2: t) : bool :=
    isempty N1 || (Zinf.ble (high N1) (high N2) && Zinf.ble (low N1) (low N2)).

  Lemma ble_1: forall N1 N2, ble N1 N2 = true -> le N1 N2.
  Proof.
    unfold ble, le, In; intros.
    destruct (isempty N1) eqn:E.
    elim (isempty_1 _ _ E H0).
    apply andb_prop in H. destruct H as [B1 B2].
    apply Zinf.ble_1 in B1. apply Zinf.ble_1 in B2.
    intuition.
  Qed.

  Lemma ble_2: forall N1 N2, le N1 N2 -> ble N1 N2 = true.
  Proof.
    unfold ble; intros. destruct (isempty N1) eqn:E; auto.
    destruct (nonempty_le N1 N2) as [P Q]; auto.
    apply andb_true_intro; split; apply Zinf.ble_2; auto.
  Qed.

(** [const n] is the abstract value for the singleton set [{n}]. *)
  Definition const (n: Z) : t := {| low := Fin (-n); high := Fin n |}.

  Lemma const_1: forall n, In n (const n).
  Proof.
    unfold const, In, Zinf.In; intros; cbn. lia.
  Qed.

(** [bot] represents the empty set. *)
  Definition bot: t := {| low := Fin 0; high := Fin (-1) |}.

  Lemma bot_1: forall n, ~(In n bot).
  Proof.
    unfold bot, In, Zinf.In; intros; cbn. lia.
  Qed.

(** [top] represents the set of all integers. *)
  Definition top: t := {| low := Inf; high := Inf |}.

  Lemma top_1: forall n, In n top.
  Proof.
    intros. split; exact I.
  Qed.

(** [join] computes an upper bound of its two arguments. *)
  Definition join (N1 N2: t) : t :=
    {| low := Zinf.max (low N1) (low N2);
       high := Zinf.max (high N1) (high N2) |}.

  Lemma join_1:
    forall n N1 N2, In n N1 -> In n (join N1 N2).
  Proof.
    unfold In, join; intros; cbn. split; apply Zinf.max_1; tauto.
  Qed.

  Lemma join_2:
    forall n N1 N2, In n N2 -> In n (join N1 N2).
  Proof.
    unfold In, join; intros; cbn. split; apply Zinf.max_2; tauto.
  Qed.

(** The abstract operators for addition and subtraction. *)

  Definition add (N1 N2: t) : t :=
    if isempty N1 || isempty N2 then bot else
    {| low := Zinf.add (low N1) (low N2);
       high := Zinf.add (high N1) (high N2) |}.

  Lemma add_1:
    forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1 + n2) (add N1 N2).
  Proof.
    unfold add; intros.
    destruct (isempty N1) eqn:E1. elim (isempty_1 n1 N1); auto.
    destruct (isempty N2) eqn:E2. elim (isempty_1 n2 N2); auto.
    destruct H; destruct H0; split; cbn.
    apply Zinf.add_1; auto.
    replace (- (n1 + n2)) with ((-n1) + (-n2)) by lia. apply Zinf.add_1; auto.
  Qed.

  Definition opp (v: t) : t := {| low := high v; high := low v |}.

  Lemma opp_1:
    forall n v, In n v -> In (-n) (opp v).
  Proof.
    unfold In, opp; intros; cbn. replace (- - n) with n by lia. tauto.
  Qed.

  Definition sub (N1 N2: t) : t := add N1 (opp N2).

  Lemma sub_1:
    forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1 - n2) (sub N1 N2).
  Proof.
    intros. apply add_1; auto. apply opp_1; auto.
  Qed.

(** [meet] computes a lower bound for its two arguments.*)
  Definition meet (N1 N2: t) : t :=
    {| low := Zinf.min (low N1) (low N2);
       high := Zinf.min (high N1) (high N2) |}.

  Lemma meet_1:
    forall n N1 N2, In n N1 -> In n N2 -> In n (meet N1 N2).
  Proof.
    unfold In, meet; intros; cbn. split; apply Zinf.min_1; tauto.
  Qed.

(** [isIn] tests whether a concrete value belongs to an abstract value. *)
  Definition isIn (n: Z) (v: t) : bool :=
    Zinf.isIn n (high v) && Zinf.isIn (-n) (low v).

  Lemma isIn_1:
    forall n v, In n v -> isIn n v = true.
  Proof.
    unfold In, isIn; intros.
    apply andb_true_intro; split; apply Zinf.isIn_1; tauto.
  Qed.

(** Abstract operators for inverse analysis of comparisons. *)

  Definition eq_inv (N1 N2: t) : t * t := (meet N1 N2, meet N1 N2).

  Lemma eq_inv_1:
    forall n1 n2 a1 a2,
    In n1 a1 -> In n2 a2 -> n1 = n2 ->
    In n1 (fst (eq_inv a1 a2)) /\ In n2 (snd (eq_inv a1 a2)).
  Proof.
    intros; cbn. subst n2. split; apply meet_1; auto.
  Qed.

  Definition ne_inv (N1 N2: t) : t * t := (N1, N2).

  Lemma ne_inv_1:
    forall n1 n2 a1 a2,
    In n1 a1 -> In n2 a2 -> n1 <> n2 ->
    In n1 (fst (ne_inv a1 a2)) /\ In n2 (snd (ne_inv a1 a2)).
  Proof.
    intros; cbn; auto.
  Qed.

(** For the [<=] comparison, the upper bound of [N1] is at most that of [N2],
    and the lower bound of [N2] is at least that of [N1]. *)

  Definition le_inv (N1 N2: t) : t * t :=
    ( {| low := low N1; high := Zinf.min (high N1) (high N2) |},
      {| low := Zinf.min (low N1) (low N2); high := high N2 |} ).

  Lemma le_inv_1:
    forall n1 n2 a1 a2,
    In n1 a1 -> In n2 a2 -> n1 <= n2 ->
    In n1 (fst (le_inv a1 a2)) /\ In n2 (snd (le_inv a1 a2)).
  Proof.
    unfold In, le_inv; intros; cbn.
    intuition auto; apply Zinf.min_1; auto.
    apply Zinf.In_mono with n2; auto.
    apply Zinf.In_mono with (-n1); auto. lia.
  Qed.

(** For the [>] comparison, the upper bound of [N1] is at least that of [N2],
    and the lower bound of [N2] is at most that of [N1] - 1. *)

  Definition gt_inv (N1 N2: t) : t * t :=
    ( {| low := Zinf.min (low N1) (Zinf.pred (low N2)); high := high N1 |},
      {| low := low N2; high := Zinf.min (high N2) (Zinf.pred (high N1)) |} ).

  Lemma gt_inv_1:
    forall n1 n2 a1 a2,
    In n1 a1 -> In n2 a2 -> n1 > n2 ->
    In n1 (fst (gt_inv a1 a2)) /\ In n2 (snd (gt_inv a1 a2)).
  Proof.
    unfold In, gt_inv; intros; cbn.
    intuition auto; apply Zinf.min_1; auto.
    apply Zinf.In_mono with ((-n2) - 1). lia. apply Zinf.pred_1; auto.
    apply Zinf.In_mono with (n1 - 1). lia. apply Zinf.pred_1; auto.
  Qed.

(** The widening operator. *)

  Definition widen (N1 N2: t) : t :=
    if isempty N1 then N2 else
    if isempty N2 then N1 else
    {| low := Zinf.widen (low N1) (low N2); high := Zinf.widen (high N1) (high N2) |}.

  Lemma widen_1: forall N1 N2, le N1 (widen N1 N2).
  Proof.
    unfold le, widen; intros.
    destruct (isempty N1) eqn:E1. elim (isempty_1 n N1); auto.
    destruct (isempty N2) eqn:E2. auto.
    destruct H. split; apply Zinf.widen_1; auto.
  Qed.

  Definition measure (v: t) : nat :=
    if isempty v then 3%nat else (Zinf.measure (low v) + Zinf.measure (high v))%nat.

  Lemma measure_top: measure top = 0%nat.
  Proof.
    auto.
  Qed.

  Remark isempty_widen: forall N1 N2,
    isempty N1 = false -> isempty N2 = false -> isempty (widen N1 N2) = false.
  Proof.
    intros. destruct (isempty (widen N1 N2)) eqn:E; auto.
    destruct (isempty_2 _ H) as (n1 & IN1).
    elim (isempty_1 n1 _ E). apply widen_1; auto.
  Qed.

  Lemma widen_2:
    forall N1 N2, (measure (widen N1 N2) <= (measure N1))%nat.
  Proof.
    unfold measure; intros.
    destruct (isempty N1) eqn:E1. unfold widen; rewrite E1.
    generalize (Zinf.measure_1 (low N2)) (Zinf.measure_1 (high N2)); intros.
    destruct (isempty N2); lia.
    destruct (isempty N2) eqn:E2. unfold widen; rewrite E1, E2, E1. lia.
    rewrite isempty_widen by auto.
    unfold widen; rewrite E1, E2; cbn.
    generalize (Zinf.widen_2 (low N1) (low N2)) (Zinf.widen_2 (high N1) (high N2)). lia.
  Qed.

  Lemma widen_3:
    forall N1 N2, ble N2 N1 = false -> (measure (widen N1 N2) < measure N1)%nat.
  Proof.
    unfold ble, measure; intros.
    destruct (isempty N2) eqn:E2. discriminate.
    destruct (isempty N1) eqn:E1.
  - unfold widen; rewrite E1, E2.
    generalize (Zinf.measure_1 (low N2)) (Zinf.measure_1 (high N2)). lia.
  - rewrite isempty_widen by auto.
    unfold widen; rewrite E1, E2. cbn.
    generalize (Zinf.widen_2 (low N1) (low N2)) (Zinf.widen_2 (high N1) (high N2)); intros.
    destruct (Zinf.ble (high N2) (high N1)) eqn:LE.
    + cbn in H. apply Zinf.widen_3 in H. lia.
    + apply Zinf.widen_3 in LE. lia.
  Qed.

End Intervals.

(** ** 5.9.  Application: an interval analysis for IMP *)

(** We instantiate the generic analyzer with the domain of intervals. *)

Module SIntervals := StoreAbstr(Intervals).
Module AIntervals := Analysis(SIntervals).

(** First program:
<<
    x := 0; y := 100; z := x + y;
    while x <= 10 do x := x + 1; y := y - 1 end
>>
*)

Definition prog1 :=
  ASSIGN "x" (CONST 0) ;;
  ASSIGN "y" (CONST 100) ;;
  ASSIGN "z" (PLUS (VAR "x") (VAR "y")) ;;
  WHILE (LESSEQUAL (VAR "x") (CONST 10))
        (ASSIGN "x" (PLUS (VAR "x") (CONST 1)) ;;
         ASSIGN "y" (MINUS (VAR "y") (CONST 1))).

Compute (let S := AIntervals.Cexec prog1 SIntervals.top in
           (SIntervals.get "x" S, SIntervals.get "y" S, SIntervals.get "z" S)).

(** Analysis result:
<<
      ({| Intervals.low := -11; Intervals.high := 11 |},
       {| Intervals.low := Inf; Intervals.high := 100 |},
       {| Intervals.low := -100; Intervals.high := 100 |})
>>
In other words: [x] is in [[11,11]], [y] in [[-inf,100]], and [z] in [[100,100]].
*)

(** Second program:
<<
    x := 0; y := 0;
    while x <= 1000 do y := x; x := x + 1 end
>>
*)

Definition prog2 :=
  ASSIGN "x" (CONST 0) ;;
  ASSIGN "y" (CONST 0) ;;
  WHILE (LESSEQUAL (VAR "x") (CONST 1000))
    (ASSIGN "y" (VAR "x") ;;
     ASSIGN "x" (PLUS (VAR "x") (CONST 1))).

Compute (let S := AIntervals.Cexec prog2 SIntervals.top in
           (SIntervals.get "x" S, SIntervals.get "y" S)).

(** Analysis result:
<<
      ({| Intervals.low := -1001; Intervals.high := 1001 |},
       {| Intervals.low := 0; Intervals.high := 1000 |})
>>
In other words: [x] is in [[1001,1001]], and [y] in [[0,1000]].
*)


From Undecidability.L Require Import L Tactics.LTactics LBool.
(*From Undecidability.L.Complexity Require Import Monotonic UpToC.*)

Class eqbClass X (eqb : X -> X -> bool): Type :=
  _eqb_spec : forall (x y:X), reflect (x=y) (eqb x y).

Hint Mode eqbClass + -: typeclass_instances. (* treat argument as input and force evar-freeness*)

Definition eqb X eqb `{H:eqbClass (X:=X) eqb} := eqb.

Arguments eqb {_ _ _}: simpl never.

Lemma eqb_spec {X} {f : X -> X -> bool} {_:eqbClass f}:
  forall (x y:X), reflect (x=y) (eqb x y).
Proof.
  intros. eapply _eqb_spec.
Qed.

Instance eqbBool_inst : eqbClass Bool.eqb.
Proof.
  intros ? ?. eapply iff_reflect. rewrite eqb_true_iff. reflexivity.
Qed.

Lemma dec_reflect_remove {P Y} (d:dec P) b (H:reflect P b) (y y' : Y):
  (if d then y else y') = (if b then y else y').
Proof.
  destruct H,d;easy.
Qed.

Lemma eqDec_remove {X Y eqb} {H:eqbClass (X:=X) eqb} x x' (d:dec (x=x')) (a b : Y):
  (if d then a else b) = (if eqb x x' then a else b).
Proof.
  apply dec_reflect_remove. eapply eqb_spec.
Qed.

Class eqbCompT X {R:registered X} eqb {H:eqbClass (X:=X) eqb} :=
  { c__eqbComp :nat;
    eqbTime x y:= min x y* c__eqbComp;
    comp_eqb : computableTime' eqb (fun x _ =>(5,fun y _ => (eqbTime (size (enc x)) (size (enc y)),tt)))
  }.
Arguments eqbCompT _ {_ _ _}.
Arguments c__eqbComp _ {_ _ _ _}.

Hint Mode eqbCompT + - - -: typeclass_instances.

Existing Instance comp_eqb.

Instance eqbComp_bool : eqbCompT bool.
Proof.
  evar (c:nat). exists c. unfold Bool.eqb.
  unfold enc;cbn.
  extract.
  solverec.
  [c]:exact 3.
  all:unfold c;try lia.
Qed.

Lemma eqbTime_le_l X {R : registered X} (eqb : X -> X -> bool) {H : eqbClass eqb}
      {H' : eqbCompT X} x n':
  eqbTime (X:=X) x n' <= x * c__eqbComp X.
Proof.
  unfold eqbTime. rewrite Nat.le_min_l. easy.
Qed.

Lemma eqbTime_le_r X (R : registered X) (eqb : X -> X -> bool) (H : eqbClass eqb)
      (eqbCompT : eqbCompT X) x n':
  eqbTime (X:=X) n' x <= x * c__eqbComp X.
Proof.
  unfold eqbTime. rewrite Nat.le_min_r. easy.
Qed.

(*
Lemma eqbTime_upToC X {R:registered X} eqb {H:eqbClass (X:=X) eqb} {_:eqbCompT X}:
  eqbTime (X:=X) <=c (fun (x y:nat) => min x y).
Proof.
  unfold eqbTime. hnf.
  exists (c__eqbComp X). unfold leHO;repeat intro; cbn;nia.
Qed.
*)


Add LoadPath "..".
Require Import Setoid.
Require Export Shared.
Require Export PermutLib.
Require Export Hyb_PPermutLib.
Require Export ListLib.

Open Scope permut_scope.

(*** Definitions ***)

Set Implicit Arguments.

Section Definitions.

Variables A B : Type.

Inductive ok_Hyb: list (var * A) -> list var -> Prop :=
| ok_Hyb_nil: forall U, ok_Hyb nil U
| ok_Hyb_step: forall w C G U,
  ~ Mem w U -> ok_Hyb G (w::U) -> ok_Hyb ((w, C)::G) U
.

End Definitions.

Definition ok_Bg_Hyb (G: bg_Hyb) : Prop :=
ok_Hyb G nil /\
ok_Hyb (flat_map snd_ G) nil.

Fixpoint used_t_vars_Hyb (G: bg_Hyb) :=
match G with
| nil => from_list nil
| (w, Gamma) :: G => from_list (map fst_ Gamma) \u used_t_vars_Hyb G
end.

Fixpoint used_w_vars_Hyb (G: bg_Hyb) :=
match G with
| nil => from_list nil
| (w, Gamma) :: G => \{w} \u used_w_vars_Hyb G
end.

(*** Lemmas ***)

Lemma flat_map_PPermut_Hyb:
forall G G',
  G ~=~ G' -> flat_map snd_ G *=* flat_map snd_ G'.
induction G; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
assert (a::G ~=~ G') by auto;
destruct a; apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))).
subst; simpl in *.
specialize IHG with (hd ++ tl).
rew_flat_map; simpl.
transitivity (l' ++ flat_map snd_ G); permut_simpl; auto.
transitivity (flat_map snd_ (hd++tl)).
apply IHG; apply PPermut_Hyb_last_rev with (w:=v) (Gamma:=l) (Gamma':=l');
auto; transitivity ((v,l)::G); PPermut_Hyb_simpl; rewrite H0; PPermut_Hyb_simpl.
rew_flat_map; auto.
Qed.

(* used_*_vars *)

Lemma used_t_vars_Hyb_app:
forall x y,
  used_t_vars_Hyb (x ++ y) = used_t_vars_Hyb x \u used_t_vars_Hyb y.
induction x; intros.
rew_app; simpl; rewrite from_list_nil; rewrite union_empty_l; auto.
rew_app; destruct a; simpl; rewrite IHx; rewrite union_assoc; auto.
Qed.

Lemma used_w_vars_Hyb_app:
forall x y,
  used_w_vars_Hyb (x ++ y) = used_w_vars_Hyb x \u used_w_vars_Hyb y.
induction x; intros.
rew_app; simpl; rewrite from_list_nil; rewrite union_empty_l; auto.
rew_app; destruct a; simpl; rewrite IHx; rewrite union_assoc; auto.
Qed.

Add Morphism used_t_vars_Hyb: PPermut_Hyb_used_t.
induction x; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
destruct a; simpl.
assert ((v, l) :: x ~=~ y) by auto.
apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))).
subst.
assert (x & (v,l) ~=~  (hd ++ tl) & (v, l')).
  transitivity ((v,l)::x); [ | rewrite H0];
  PPermut_Hyb_simpl.
apply PPermut_Hyb_last_rev in H; auto.
rewrite IHx with (y:=hd ++ tl); auto.
repeat rewrite used_t_vars_Hyb_app.
simpl; repeat rewrite <- union_assoc.
rewrite from_list_nil; rewrite union_empty_l.
assert (from_list (map fst_ l) = from_list (map fst_ l')).
  apply from_list_map; auto.
rewrite union_comm_assoc; rewrite H1; auto.
Qed.

Add Morphism used_w_vars_Hyb: PPermut_Hyb_used_w.
induction x; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
destruct a; simpl.
assert ((v, l) :: x ~=~ y) by auto.
apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))).
subst.
assert (x & (v,l) ~=~  (hd ++ tl) & (v, l')).
  transitivity ((v,l)::x); [ | rewrite H0];
  PPermut_Hyb_simpl.
apply PPermut_Hyb_last_rev in H; auto.
rewrite IHx with (y:=hd ++ tl); auto.
repeat rewrite used_w_vars_Hyb_app.
simpl; repeat rewrite <- union_assoc.
rewrite union_comm_assoc;
rewrite from_list_nil; rewrite union_empty_l.
auto.
Qed.

(* ok_Hyb for a generic type *)

Lemma ok_Hyb_used_permut:
forall A G U U',
  U *=* U' ->
  (@ok_Hyb A G U) ->
  (@ok_Hyb A G U').
induction G; intros.
destruct U'; econstructor; eauto.
destruct a; inversion H0; subst;
constructor; [ intro | apply IHG with (U:=v::U)]; auto;
apply Mem_permut with (l':=U) in H1; [ elim H5 | symmetry]; auto.
Qed.

Lemma ok_Hyb_used_weakening:
forall A G x U,
  (@ok_Hyb A G (x::U)) ->
  (@ok_Hyb A G U).
induction G; intros; try constructor;
destruct a; inversion H; subst;
constructor.
intro; apply Mem_permut with (l':=U) in H0; auto; elim H4;
rewrite Mem_cons_eq; right; auto.
apply ok_Hyb_used_permut with (U' := (x::v::U)) in H5;
[ | permut_simpl]; apply IHG with (x:=x); auto.
Qed.

Lemma ok_Hyb_split:
forall A G1 G2 U,
  (@ok_Hyb A (G1++G2) U) ->
  ok_Hyb G1 U /\ ok_Hyb G2 U.
induction G1; intros; split; try destruct a; auto using ok_Hyb.
rew_app in *; inversion H; subst; constructor; auto;
eapply IHG1 with (G2:=G2); auto.
rew_app in *; inversion H; subst; eapply IHG1 with (G2:=G2); auto;
eapply ok_Hyb_used_weakening in H5; eauto.
Qed.

(* ok_Hyb for a specific type -- would be nice to make it more general btw *)

Add Morphism (@ok_Hyb (list (var*ty))) : ok_Hyb_PPermut_Hyb_lst_var_ty.
split; intros;
[apply ok_Hyb_used_permut with (U:=x0); auto |
 apply ok_Hyb_used_permut with (U:=y0); [symmetry | ]; auto];
generalize dependent y0; generalize dependent x0;
induction H; intros; auto using ok_Hyb.
inversion H1; subst; constructor; auto;
eapply IHPPermut_Hyb; auto.
inversion H1; subst; inversion H8; subst;
constructor;
[intro; elim H9; rewrite Mem_cons_eq; right; auto | ];
constructor.
intro; rewrite Mem_cons_eq in H3; elim H9; destruct H3; subst.
  elim H9; rewrite Mem_cons_eq; left; auto. contradiction.
  apply ok_Hyb_used_permut with (U:=w'::w::y0); auto.
  permut_simpl; symmetry; auto.
  apply ok_Hyb_used_permut with (U:=(w'::w::x0)); auto.
eapply IHPPermut_Hyb2; eauto; eapply IHPPermut_Hyb1; auto.
inversion H2; subst; constructor; auto;
eapply IHPPermut_Hyb; auto.
inversion H2; subst; inversion H8; subst;
constructor;
[intro; elim H9; rewrite Mem_cons_eq; right; auto | ];
constructor.
intro; rewrite Mem_cons_eq in H3; elim H9; destruct H3; subst.
  elim H9; rewrite Mem_cons_eq; left; auto. contradiction.
  apply ok_Hyb_used_permut with (U:=w::w'::y0); auto.
  permut_simpl; symmetry; auto.
eapply IHPPermut_Hyb1; eauto; eapply IHPPermut_Hyb2; auto.
Qed.

Lemma ok_Hyb_permut_any0:
forall X (G1: list (var * X)) G2 U,
  G1 *=* G2 ->
  ok_Hyb G1 U ->
  ok_Hyb G2 U.
intro A.
induction G1; intros.
apply permut_nil_eq in H; subst; auto.
destruct a. inversion H0; subst.
assert ((v, a)::G1 *=* G2) by auto.
apply permut_split_head in H.
destruct H as (hd, (tl, H)).
assert (G1 *=* hd ++ tl).
  apply permut_cons_inv with (a:=(v, a)); rewrite H1; subst; permut_simpl.
specialize IHG1 with (G2:=hd++tl).
apply IHG1 in H6; auto.
subst; generalize dependent G1; generalize dependent U;
induction hd; intros; rew_app in *.
constructor; auto.
destruct a0. inversion H6; subst. constructor.
intro; elim H8; rewrite Mem_cons_eq; right; auto.
apply IHhd with (G1:=hd++tl); try permut_simpl.
intro n; elim H8; rewrite Mem_cons_eq in n; destruct n; rewrite Mem_cons_eq;
[left; subst; auto | contradiction].
apply ok_Hyb_used_permut with (U:=v0::v::U); [permut_simpl | auto].
intros; auto.
constructor.
intro; elim H8; rewrite Mem_cons_eq; rewrite Mem_cons_eq in H; destruct H;
subst. left; auto. contradiction.
apply ok_Hyb_used_permut with (U:=v0::v::U); [permut_simpl | auto].
Qed.

Lemma ok_Hyb_permut_any:
forall X (G: list (var * X)) G',
  G *=* G' ->
  forall U, ok_Hyb G U <-> ok_Hyb G' U.
split; intros; [ | symmetry in H]; eapply ok_Hyb_permut_any0; eauto.
Qed.

Lemma ok_Hyb_PPermut_Hyb_ty:
forall G G'
  (H: G ~=~ G'),
  forall U, ok_Hyb (flat_map snd_ G) U <->
  ok_Hyb (flat_map snd_ G') U.
intros; eapply ok_Hyb_permut_any; apply flat_map_PPermut_Hyb; auto.
Qed.

Lemma ok_Hyb_fresh_te_list:
forall G Gamma v A w U,
 ok_Hyb ((w, Gamma) :: G) U ->
 v \notin (used_t_vars_Hyb ((w,Gamma)::G)) ->
 ok_Hyb ((w, (v,A)::Gamma) :: G) U.
intros; inversion H; subst; constructor; auto.
Qed.

Lemma ok_Hyb_merge_contexts:
forall (G: list (var * list (var * ty))) U l1 l2 (w: var) w' w'',
  ok_Hyb (flat_map snd_ ((w,l1)::(w',l2)::G)) U <->
  ok_Hyb (flat_map snd_ ((w'', l1++l2)::G)) U.
split; intros; simpl in *; rew_app in *; auto.
Qed.

Lemma ok_Hyb_fresh_te_ty0:
forall G U w v A,
  ok_Hyb (flat_map snd_ G) U ->
  v \notin (used_t_vars_Hyb G \u from_list U) ->
  ok_Hyb (flat_map snd_ ((w, (v, A)::nil) :: G)) U.
induction G; intros.
simpl in *; constructor; [apply notin_Mem | constructor]; auto.
eapply ok_Hyb_PPermut_Hyb_ty with (G':=a:: (w, (v,A)::nil)::G).
PPermut_Hyb_simpl. destruct a; simpl in *; rew_app in *.
generalize dependent U.
induction l; intros; simpl in *.
rew_app in *; apply IHG; eauto.
destruct a.
rew_app in *; inversion H; subst.
constructor; auto.
apply IHl; auto.
simpl in *; rew_map in *; simpl in *; rewrite from_list_cons in *;
repeat rewrite notin_union in *; destruct H0; destruct H0; destruct H0;
repeat split; auto.
Qed.

Lemma ok_Hyb_fresh_te_ty:
forall Gamma G U v A w,
 ok_Hyb (flat_map snd_ ((w, Gamma) :: G)) U ->
 v \notin (used_t_vars_Hyb ((w, Gamma)::G) \u from_list U) ->
 ok_Hyb (flat_map snd_ ((w, (v, A)::Gamma) :: G)) U.
intros; simpl in *.
replace (((v,A) :: Gamma) ++ flat_map snd_ G) with
  ((flat_map snd_ ((w,(v,A)::nil)::((w,Gamma)::G)))) by (simpl; auto).
apply ok_Hyb_fresh_te_ty0; auto.
Qed.

Lemma ok_Hyb_fresh_wo_list:
forall G w U l,
 ok_Hyb G U ->
 w \notin (used_w_vars_Hyb G)  \u from_list U ->
 ok_Hyb ((w, l) :: G) U.
induction G; intros.
constructor.
  apply notin_Mem; auto.
  constructor.
destruct a; inversion H; subst; constructor.
  apply notin_Mem;
  rewrite notin_union in H0; destruct H0; auto.
  constructor.
  rewrite Mem_cons_eq; intro; destruct H1; subst.
  simpl in H0; repeat rewrite notin_union in H0; destruct H0;
  destruct H0; rewrite notin_singleton in H0; elim H0; auto.
  contradiction.
apply ok_Hyb_used_permut with (U:=w::v::U).
permut_simpl.
assert (ok_Hyb ((w, l) :: G) (v::U)).
apply IHG; auto.
simpl in *; repeat rewrite notin_union in H0;
rewrite from_list_cons; repeat rewrite notin_union;
destruct H0; destruct H0; split; auto; split; auto.
inversion H1; subst; auto.
Qed.

Lemma ok_Hyb_fresh_wo_ty:
forall G w U,
 ok_Hyb (flat_map snd_ G) U ->
 w \notin (used_w_vars_Hyb G) \u from_list U ->
 ok_Hyb (flat_map snd_ ((w, nil) :: G)) U.
intros; inversion H; subst; simpl in *; rew_app in *; auto.
Qed.

Lemma ok_Hyb_fresh_wo_te_list:
forall U G v A w,
 ok_Hyb G U ->
 w \notin (used_w_vars_Hyb G) \u from_list U ->
 v \notin (used_t_vars_Hyb G) ->
 ok_Hyb ((w, (v,A)::nil) :: G) U.
intros; apply ok_Hyb_fresh_te_list;
[ apply ok_Hyb_fresh_wo_list | ]; auto.
simpl; rewrite map_nil; rewrite from_list_nil; rewrite union_empty_l; auto.
Qed.

Lemma ok_Hyb_fresh_wo_te_ty:
forall U G v A w,
 ok_Hyb (flat_map snd_ G) U ->
 w \notin (used_w_vars_Hyb G) \u from_list U ->
 v \notin (used_t_vars_Hyb G) \u from_list U ->
 ok_Hyb (flat_map snd_ ((w, (v,A) :: nil) :: G)) U.
intros; apply ok_Hyb_fresh_te_ty.
apply ok_Hyb_fresh_wo_ty; auto.
simpl; rewrite map_nil; rewrite from_list_nil; rewrite union_empty_l; auto.
Qed.

Lemma ok_Hyb_empty_first_list:
forall w G Gamma U,
  ok_Hyb ((w,Gamma) :: G) U ->
  ok_Hyb ((w, (@nil (prod var ty))) :: G) U.
intros; simpl in *; inversion H; subst; constructor; auto.
Qed.

Lemma ok_Hyb_empty_first_ty:
forall Gamma (w: var) G U,
  (@ok_Hyb ty (flat_map snd_ ((w,Gamma) :: G)) U) ->
  (@ok_Hyb ty (flat_map snd_ ((w, nil) :: G)) U).
induction Gamma; intros; simpl in *; auto; destruct a;
rew_app in H; inversion H; subst.
apply IHGamma; auto.
apply ok_Hyb_used_weakening with (x:=v); auto.
Qed.

(* ok_Bg_Hyb *)

Add Morphism ok_Bg_Hyb : ok_Bg_Hyb_PPermut_Hyb.
intros; unfold ok_Bg_Hyb; split; intros;
destruct H0; split;
[ rewrite <- H | |
  rewrite H | eapply ok_Hyb_PPermut_Hyb_ty; try symmetry ]; eauto.
assert (x ~=~y) by auto; eapply flat_map_PPermut_Hyb in H;
eapply ok_Hyb_PPermut_Hyb_ty;
try symmetry; eauto.
assert (x ~=~ y) by auto; eapply flat_map_PPermut_Hyb in H;
eapply ok_Hyb_PPermut_Hyb_ty;
eauto.
Qed.

Lemma ok_Bg_Hyb_ppermut:
forall G G',
  G ~=~ G' ->
  ok_Bg_Hyb G ->
  ok_Bg_Hyb G'.
intros; rewrite <- H; auto.
Qed.

Lemma ok_Bg_Hyb_permut:
forall G Ctx Ctx' w,
  Ctx *=* Ctx' ->
  ok_Bg_Hyb ((w, Ctx) :: G) ->
  ok_Bg_Hyb ((w, Ctx') :: G).
intros;
assert ((w, Ctx) :: G ~=~ (w, Ctx') :: G) by PPermut_Hyb_simpl;
rewrite <- H1; auto.
Qed.

Lemma ok_Bg_Hyb_permut_last:
forall G Ctx Ctx' w,
  Ctx *=* Ctx' ->
  ok_Bg_Hyb (G ++ (w, Ctx) :: nil) ->
  ok_Bg_Hyb (G ++ (w, Ctx') :: nil).
intros;
assert (G & (w, Ctx) ~=~ G & (w, Ctx')) by PPermut_Hyb_simpl;
rewrite <- H1; auto.
Qed.

Lemma ok_Bg_Hyb_fresh_te:
forall G Gamma v A w,
 ok_Bg_Hyb ((w, Gamma) :: G) ->
 v \notin (used_t_vars_Hyb ((w,Gamma)::G)) ->
 ok_Bg_Hyb ((w, (v,A)::Gamma) :: G).
intros; unfold ok_Bg_Hyb in *;  destruct H; split;
[ apply ok_Hyb_fresh_te_list |
  apply ok_Hyb_fresh_te_ty]; auto.
rewrite from_list_nil. rewrite notin_union; split; auto; rewrite notin_empty.
Qed.

Lemma ok_Bg_Hyb_fresh_wo:
forall G w,
 ok_Bg_Hyb G ->
 w \notin (used_w_vars_Hyb G) ->
 ok_Bg_Hyb ((w, nil) :: G).
intros; unfold ok_Bg_Hyb in *;  destruct H; split;
[ eapply ok_Hyb_fresh_wo_list |
  eapply ok_Hyb_fresh_wo_ty]; eauto;
rewrite from_list_nil; rewrite union_empty_r; auto.
Qed.

Lemma ok_Bg_Hyb_fresh_wo_te:
forall G w v A,
 ok_Bg_Hyb G ->
 w \notin (used_w_vars_Hyb G) ->
 v \notin (used_t_vars_Hyb G) ->
 ok_Bg_Hyb ((w, (v, A) :: nil) :: G).
intros; unfold ok_Bg_Hyb in *;  destruct H; split;
[ apply ok_Hyb_fresh_wo_te_list |
  apply ok_Hyb_fresh_wo_te_ty]; eauto;
rewrite from_list_nil; rewrite union_empty_r; auto.
Qed.

Lemma ok_Bg_Hyb_cons_last:
forall G a,
  ok_Bg_Hyb (G & a) <-> ok_Bg_Hyb (a :: G).
intros; assert (G & a ~=~ a :: G) by PPermut_Hyb_simpl;
rewrite H; split; auto.
Qed.

Lemma ok_Bg_Hyb_swap:
forall C C' G,
  ok_Bg_Hyb (C :: G & C') ->
  ok_Bg_Hyb (C' :: G & C).
intros; assert (C:: G & C' ~=~ C' :: G & C) by PPermut_Hyb_simpl;
rewrite <- H0; auto.
Qed.

Hint Resolve ok_Bg_Hyb_cons_last ok_Bg_Hyb_swap.
Hint Resolve ok_Bg_Hyb_permut_last: ok_bg_hyb_rew.
Hint Resolve ok_Bg_Hyb_fresh_te ok_Bg_Hyb_fresh_wo ok_Bg_Hyb_fresh_wo_te.

Lemma ok_Bg_Hyb_permut_first_tail:
forall G C C' w x A,
  ok_Bg_Hyb ((w, C) :: G) ->
  C *=* (x,A)::C' ->
  ok_Bg_Hyb ((w, C') :: G).
intros;
assert ((w,(x, A) :: C') :: G ~=~ (w, C) :: G) by PPermut_Hyb_simpl;
rewrite <- H1 in H; unfold ok_Bg_Hyb in *; destruct H; split; simpl in *.
inversion H; subst; constructor; auto.
rew_app in *; inversion H2; subst; simpl in *.
apply ok_Hyb_used_weakening with (x:=x); auto.
Qed.
Hint Resolve ok_Bg_Hyb_permut_first_tail : ok_bg_hyb_rew.

Lemma ok_Bg_Hyb_empty_first:
forall w G Gamma,
  ok_Bg_Hyb ((w,Gamma) :: G) ->
  ok_Bg_Hyb ((w, nil) :: G).
intros; unfold ok_Bg_Hyb; destruct H; split;
[eapply ok_Hyb_empty_first_list |
 eapply ok_Hyb_empty_first_ty]; eauto.
Qed.

Hint Resolve ok_Bg_Hyb_empty_first : ok_bg_hyb_rew.

Lemma ok_Bg_Hyb_Mem_eq:
forall w C C' v A A0 G,
  ok_Bg_Hyb ((w, C) :: G) ->
  C *=* (v, A) :: C' ->
  Mem (v, A0) C ->
  A0 = A.
intros; destruct (eq_ty_dec A0 A); auto;
assert (exists gh, exists gt, C' = gh & (v, A0) ++ gt) by
  ( apply permut_neq_split with (b := (v, A)) (l1 := C); auto;
    intro HH; inversion HH; subst; elim n; auto);
destruct H2 as (gh); destruct H2 as (gt); subst;
assert (C *=* (v, A) :: (v, A0) :: gh ++ gt) by (rewrite H0; permut_simpl);
unfold ok_Bg_Hyb in *; destruct H.
assert (ok_Hyb (flat_map snd_ ((w, (v, A) :: (v, A0) :: gh ++ gt ) :: G )) nil)
by
  (apply ok_Hyb_PPermut_Hyb_ty with (G := ((w, C) :: G));
   [PPermut_Hyb_simpl | auto]).
simpl in *. rew_app in *; inversion H4; subst.
inversion H10; subst;
elim H11; apply Mem_here.
Qed.

Lemma ok_Bg_Hyb_Mem_contradict:
forall A A' w w' v C C' G G',
 ok_Bg_Hyb ((w, C) :: G) ->
 Mem (v, A) C ->
 G ~=~ G' & (w', (v, A') :: C') ->
 False.
intros.
rewrite H1 in H.
apply permut_Mem_split_head with (l2 := C) in H0; auto;
destruct H0 as (gh); destruct H0 as (gt); subst.
assert ((w, gh & (v, A) ++ gt) :: G' & (w', (v, A') :: C') ~=~
        (w, (v, A) :: gh ++ gt) :: (w', (v, A') :: C') :: G') by
(PPermut_Hyb_simpl; apply PPermut_Hyb_skip; [permut_simpl | auto]).
rewrite H0 in H; unfold ok_Bg_Hyb in H; destruct H.
rew_flat_map in *. simpl ok_Hyb in H2.
rew_app in *. inversion H2; subst.
assert (ok_Hyb ((v, A') :: C' ++ flat_map snd_ G') (v :: nil)).
  eapply ok_Hyb_split with (G1:=flat_map snd_ ((w, gh++gt)::nil)); simpl;
  rew_app; auto.
inversion H3; subst; elim H10; apply Mem_here.
Qed.

Lemma ok_Bg_Hyb_permut_no_last:
forall G w C v A,
  ok_Bg_Hyb (G & (w, (v,A) :: C)) ->
  ok_Bg_Hyb (G & (w, C)).
intros;
assert (G & (w, C) ~=~ (w,C) :: G) by PPermut_Hyb_simpl;
assert (G & (w, (v, A) :: C) ~=~ (w, (v,A) :: C) :: G) by PPermut_Hyb_simpl;
rewrite H1 in H; destruct H; simpl in *; split; rew_app in *.
inversion H; subst; rewrite H0; constructor; auto.
inversion H2; subst;
apply ok_Hyb_PPermut_Hyb_ty with (U:=nil) in H0;
apply H0; simpl;
apply ok_Hyb_used_weakening in H8;
auto.
Qed.

Lemma ok_Bg_Hyb_permut_no_last_spec:
forall G w C C0 v A,
  ok_Bg_Hyb (C0::G & (w, (v,A) :: C)) ->
  ok_Bg_Hyb (C0::G & (w, C)).
intros;
assert (C0 :: G & (w, C)  ~=~ (C0 :: G) & (w, C))
  by (rew_app; PPermut_Hyb_simpl);
rewrite H0; eapply ok_Bg_Hyb_permut_no_last; rew_app; eauto.
Qed.

Lemma ok_Bg_Hyb_no_last:
forall G C,
  ok_Bg_Hyb (G & C) -> ok_Bg_Hyb G.
intros;
assert (G & C ~=~ (C :: nil) ++ G) by PPermut_Hyb_simpl; rewrite H0 in H;
destruct H; split.
eapply ok_Hyb_split with (G1:=C::nil) (G2:=G); eauto.
destruct C; rew_app in *; simpl in *.
eapply ok_Hyb_split with (G1:=l) (G2:=flat_map snd_  G); auto.
Qed.
Hint Resolve ok_Bg_Hyb_no_last.

Lemma ok_Bg_Hyb_permut_no_last_spec2:
forall G w C C0 v A,
  ok_Bg_Hyb (G & (w, (v,A) :: C) & C0) ->
  ok_Bg_Hyb (G & (w, C) & C0).
intros.
assert (G & (w, C) & C0 ~=~ G & C0 & (w, C)) by PPermut_Hyb_simpl;
rewrite H0;
apply ok_Bg_Hyb_permut_no_last with (v:=v) (A:=A).
assert (G & C0 & (w, (v, A) :: C) ~=~ G & (w, (v, A) :: C) & C0)
  by PPermut_Hyb_simpl;
rewrite H1; auto.
Qed.

Lemma ok_Bg_Hyb_first_last_neq:
forall w w' C C' G,
  ok_Bg_Hyb ((w, C) :: G & (w', C')) ->
  w <> w'.
intros.
assert ((w, C) :: G & (w', C') ~=~ (w, C) :: (w', C') :: G)
  by PPermut_Hyb_simpl;
rewrite H0 in H;
destruct H; simpl in *. inversion H; subst; inversion H7; subst.
rewrite Mem_cons_eq in H8. rewrite Mem_nil_eq in H8. auto.
Qed.

Lemma ok_Bg_Hyb_last_last2_neq:
forall w w' C C' G,
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  w <> w'.
intros;
assert (G & (w, C) & (w', C') ~=~ (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl;
rewrite H0 in H;
destruct H; simpl in *; inversion H; subst; inversion H7; subst.
rewrite Mem_cons_eq in H8. rewrite Mem_nil_eq in H8; auto.
Qed.

Lemma ok_Bg_Hyb_swap_worlds:
forall G w w' C C',
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  ok_Bg_Hyb (G & (w', C) & (w, C')).
intros.
assert (G & (w, C) & (w', C') ~=~ (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl.
rewrite H0 in H.
assert (G & (w', C) & (w, C') ~=~ (w', C) :: (w, C') :: G) by PPermut_Hyb_simpl.
rewrite H1.
destruct H; split; simpl in *.
inversion H; subst; constructor. rewrite Mem_nil_eq; tauto.
inversion H8; subst; constructor.
rewrite Mem_cons_eq in *; intro; destruct H3; subst;
[ elim H9; left | rewrite Mem_nil_eq in H3 ]; auto.
apply ok_Hyb_used_permut with (U := w'::w::nil); [permut_simpl | ]; auto.
auto.
Qed.

Lemma ok_Bg_Hyb_impl_ppermut:
forall G G' w C C',
  ok_Bg_Hyb ((w, C) :: G) ->
  G & (w, C) ~=~ G' & (w, C') ->
  G ~=~ G' /\ C *=* C'.
unfold ok_Bg_Hyb.
intros. destruct H.
assert ((w,C) :: G ~=~ (w, C') :: G').
  transitivity (G & (w,C)); [ | rewrite H0]; PPermut_Hyb_simpl.
apply PPermut_Hyb_split_head in H2.
destruct H2 as (C'', (hd, (tl, (H2, H3)))).
assert ((w, C') :: G' = hd & (w, C'') ++ tl) by auto.
apply cons_eq_last_val_app_inv in H4; destruct H4.
(* case 1: positive - hd = nil and C *=* C'' *)
destruct H4; destruct H5; subst; rew_app in *;
inversion H3; subst; split; auto;
apply PPermut_Hyb_last_rev with (Gamma:=C)(Gamma':=C'')(w:=w); auto.
(* case 2: negative *)
destruct H4 as (hd', H4); subst.
assert ((w, C) :: G ~=~ (w, C') :: (w, C'') :: hd' ++ tl).
  transitivity (G & (w,C)). PPermut_Hyb_simpl.
  rewrite H0; transitivity ((w, C') :: G'); [ | rewrite H3];
  PPermut_Hyb_simpl.
rewrite H4 in H; inversion H; subst; inversion H10; subst.
elim H11; apply Mem_here.
Qed.

Lemma ok_Bg_Hyb_split1:
forall G w w' C C',
  ok_Bg_Hyb ((w,C)::G & (w',C')) ->
  ok_Bg_Hyb ((w, C ++ C') :: G).
intros.
assert ((w, C) :: G & (w', C') ~=~ (w,C) :: (w', C')::G) by PPermut_Hyb_simpl.
rewrite H0 in H; destruct H; split; simpl in *.
inversion H; subst; inversion H7; subst; constructor; auto;
apply ok_Hyb_used_weakening with (x:=w'); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split2:
forall G w w' C C',
  ok_Bg_Hyb ((w,C)::G & (w',C')) ->
  ok_Bg_Hyb ((w', C' ++ C) :: G).
intros.
assert ((w, C) :: G & (w', C') ~=~ (w', C') :: (w, C)::G) by PPermut_Hyb_simpl.
rewrite H0 in H; destruct H; split; simpl in *.
inversion H; subst; inversion H7; subst;
constructor; auto.
apply ok_Hyb_used_weakening with (x:=w); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split3:
forall G w w' w'' C C' C'',
  ok_Bg_Hyb ((w,C)::G & (w',C') & (w'',C'')) ->
  ok_Bg_Hyb ((w, C) :: G & (w', C' ++ C'')).
intros.
assert ((w, C) :: G & (w', C') & (w'',C'') ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G) by PPermut_Hyb_simpl.
assert ((w,C) :: G & (w', C'++C'') ~=~ (w,C) :: (w', C'++C'') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst;
constructor; auto; constructor; auto.
apply ok_Hyb_used_weakening with (x:=w''); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split4:
forall G w w' C C',
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  ok_Bg_Hyb (G & (w', C' ++ C)).
intros.
assert (G & (w, C) & (w', C') ~=~
  (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl.
assert (G & (w', C'++C) ~=~ (w', C'++C) :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split.
simpl in *; inversion H; subst; inversion H8; subst; constructor; auto.
rewrite Mem_nil_eq; tauto.
apply ok_Hyb_used_weakening with (x:=w);
apply ok_Hyb_used_permut with (U:= w'::w::nil);
try permut_simpl; auto.
assert ((w', C'++C)::G ~=~ (w',C++C')::G) by PPermut_Hyb_simpl.
apply ok_Hyb_PPermut_Hyb_ty with (U:=nil) in H3.
simpl in *; rew_app in *.
apply H3. auto.
Qed.

Lemma ok_Bg_Hyb_split5:
forall G w w' C C',
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  ok_Bg_Hyb (G & (w, C ++ C')).
intros.
assert (G & (w, C) & (w', C') ~=~
  (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl.
assert (G & (w, C++C') ~=~ (w, C++C') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst.
constructor; auto;
apply ok_Hyb_used_weakening with (x:=w'); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split6:
forall G w C C' C'' w' w'',
  ok_Bg_Hyb (G & (w, C) & (w', C') & (w'', C'')) ->
  ok_Bg_Hyb (G & (w, C ++ C') & (w'', C'')).
intros.
assert (G & (w,C) & (w', C') & (w'',C'') ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G) by PPermut_Hyb_simpl.
assert (G & (w, C++C') & (w'', C'') ~=~ (w, C ++ C') :: (w'', C'') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst.
constructor; auto.
apply ok_Hyb_used_weakening with (x:=w'); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split8:
forall G G' w w' w'' C C' C'',
  ok_Bg_Hyb (G ++ G' ++ (w, C) :: (w', C') :: (w'', C'') :: nil) ->
  ok_Bg_Hyb (G ++ G' ++ (w', C') :: (w'', C'' ++ C)::nil) .
intros.
assert (G++G' ++ (w, C) :: (w', C') :: (w'',C'') :: nil ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G ++ G') by PPermut_Hyb_simpl.
assert (G ++ G' ++ (w', C') :: (w'', C'' ++ C) :: nil ~=~
  (w', C') :: (w'', C''++C) :: G ++ G')
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split.
simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst.
constructor.
intro; rewrite Mem_nil_eq in H3; auto.
constructor.
intro; elim H11; rewrite Mem_cons_eq in *; destruct H3.
left; auto.
rewrite Mem_nil_eq in H3; auto.
contradiction.
apply ok_Hyb_used_weakening with (x:=w);
apply ok_Hyb_used_permut with (U:=w'' :: w' :: w :: nil);
auto; permut_simpl.
apply ok_Hyb_PPermut_Hyb_ty with
  (G':=(w',C') :: (w'', C'')::(w,C) :: G ++ G') in H2.
simpl in *.
rew_app. auto.
PPermut_Hyb_simpl.
Qed.

Lemma ok_Bg_Hyb_split9:
forall G w w' w'' C C' C'',
  ok_Bg_Hyb ((w,C)::G & (w',C') & (w'',C'')) ->
  ok_Bg_Hyb ((w, C++C') :: G & (w'', C'')).
intros.
assert ((w, C) :: G & (w', C') & (w'',C'') ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G) by PPermut_Hyb_simpl.
assert ((w, C++C') :: G & (w'', C'')  ~=~
  (w, C++C') :: (w'', C'') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst.
constructor; auto; constructor.
intro; rewrite Mem_cons_eq in *. destruct H3; subst.
elim H11;right; apply Mem_here.
rewrite Mem_nil_eq in H3; auto.
apply ok_Hyb_used_weakening with (x:=w');
apply ok_Hyb_used_permut with (U:=w'' :: w' :: w :: nil);
auto; permut_simpl.
rew_app. auto.
Qed.

Lemma ok_Bg_Hyb_split10:
forall G G' w1 w2 w3 w4 c1 c2 c3 c4,
  ok_Bg_Hyb (G ++ (w1, c1)::G' ++ (w2, c2) :: (w3, c3) :: (w4, c4) :: nil) ->
  ok_Bg_Hyb (G ++ (w1, c1)::G' ++ (w2, c2 ++ c3) :: (w4, c4) :: nil).
intros.
assert (G ++ (w1,c1) :: G' ++ (w2, c2) :: (w3, c3) :: (w4,c4) :: nil ~=~
   (w1,c1) :: (w2, c2) :: (w3, c3) :: (w4,c4) :: G ++ G') by PPermut_Hyb_simpl.
assert (G ++ (w1, c1) :: G' ++ (w2, c2 ++ c3) :: (w4, c4) :: nil~=~
   (w1,c1) :: (w2, c2 ++ c3) :: (w4,c4) :: G ++ G') by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst;
inversion H12; subst.
constructor; auto; constructor; auto; constructor.
intro; rewrite Mem_cons_eq in *. destruct H3; subst.
elim H13; right; left; auto.
rewrite Mem_cons_eq in H3; destruct H3; subst.
elim H13; right; rewrite Mem_cons_eq; right; rewrite Mem_cons_eq; left; auto.
rewrite Mem_nil_eq in H3; auto.
apply ok_Hyb_used_weakening with (x:=w3);
apply ok_Hyb_used_permut with (U:=w4 :: w3 :: w2 :: w1 :: nil);
auto; permut_simpl.
rew_app; auto.
Qed.

Hint Resolve ok_Bg_Hyb_split1 ok_Bg_Hyb_split2 ok_Bg_Hyb_split3 ok_Bg_Hyb_split4
  ok_Bg_Hyb_split5 ok_Bg_Hyb_split6 ok_Bg_Hyb_split8
  ok_Bg_Hyb_split9 ok_Bg_Hyb_split10 : ok_bg_hyb_rew.
Hint Resolve ok_Bg_Hyb_permut_no_last ok_Bg_Hyb_permut_no_last_spec2
  ok_Bg_Hyb_permut_no_last_spec ok_Bg_Hyb_first_last_neq
  ok_Bg_Hyb_last_last2_neq : ok_bg_hyb_rew.
Hint Resolve ok_Bg_Hyb_swap_worlds.

Lemma ok_Hyb_not_Mem_fst:
forall (G: bg_Hyb) U w,
  ok_Hyb G U -> Mem w U ->
  ~ Mem w (map fst_ G) .
induction G; intros; simpl in *.
rewrite Mem_nil_eq; auto.
destruct a; rew_map; simpl; rewrite Mem_cons_eq; intro; destruct H1; subst.
inversion H; subst; auto; inversion H; subst. apply IHG in H0;
[ contradiction | ]; inversion H; subst; apply ok_Hyb_used_weakening in H7;
auto.
Qed.

Close Scope permut_scope.