Require Import Coq.ZArith.ZArith.
Require Import Coq.Structures.OrderedType.

Require Import compcert.lib.Axioms.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Memtype.

Require Import msl.eq_dec.
Require Import msl.Coqlib2.
Require Import sepcomp.semantics_lemmas.
Require Import concurrency.sepcomp. Import SepComp.
Require Import concurrency.permissions.
Require Import concurrency.lksize.
Set Bullet Behavior "Strict Subproofs".

  Module MiniAddressOrdered <: MiniOrderedType.

    Definition t:= address.
    Definition eq:= @eq t.
    Definition lt' (x y:t): bool :=
      (match x, y with (x1,x2),(y1,y2) =>
        if peq x1 y1 then zlt x2 y2 else plt x1 y1
      end).
    Definition lt x y:= is_true (lt' x y).

    Lemma eq_refl : forall x : t, eq x x. Proof. reflexivity. Qed.
    Lemma eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. intros; symmetry; assumption. Qed.
    Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros. rewrite H, H0; reflexivity. Qed.
    Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
    Proof. intros x y z; destruct x, y, z.
           unfold lt; simpl.
           destruct (peq b b0), (peq b0 b1), (peq b b1),
           (plt b b0), (plt b0 b1), (plt b b1),
           (zlt z0 z1), (zlt z1 z), (zlt z0 z); subst;
             simpl; intros; auto; try omega; (*Solves most*)
             exfalso;
           (* solves al Plt x y /\ Plt y x *)
           try match goal with
             [H1:Plt ?x ?y, H2:Plt ?y ?x |- _ ]=>
             pose (Plt_trans x y x H1 H2)
               end;
           (* solves Plt x x*)
           try match goal with
             [H1:Plt ?x ?x  |- _ ]=>
             apply (Plt_strict x); assumption
               end;
           (* solves al Plt x y /\ Plt y z /\ ~ Plt x z *)
           match goal with
             [H1:Plt ?x ?y, H2:Plt ?y ?z |- _ ]=>
             pose (Plt_trans x y z H1 H2)
           end; auto.
    Qed.
    Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
    Proof. unfold lt, lt'.
           destruct x, y.
           unfold not; intros.
           inversion H0; subst.
           rewrite peq_true in H.
           assert (HH: z0 >= z0) by omega.
           destruct zlt as [a|b]; auto.
    Qed.
   Lemma compare : forall x y : t, Compare lt eq x y.
          destruct x as [x1 x2].
          destruct y as [y1 y2].
          destruct (peq x1 y1) eqn:H0.
          - destruct (Z_dec x2 y2) eqn:H1; [destruct s|].
            + constructor 1.
              unfold lt, lt'.
              rewrite H0; simpl.
              unfold is_true.
              destruct (zlt x2 y2); auto; omega.
            + constructor 3.
              unfold lt, lt'.
              destruct (peq x1 y1); try solve[inversion H0]; subst.
              destruct (peq y1 y1); simpl. clear e e0 H0.
              destruct (zlt y2 x2); auto; omega.
              destruct (zlt x2 y2); auto; omega.
            + constructor 2.
              subst; reflexivity.
          - destruct (plt x1 y1).
            + constructor 1.
              unfold lt, lt'; rewrite H0; simpl.
              destruct (plt x1 y1); auto.
            + constructor 3.
              unfold lt, lt'.
              destruct (peq x1 y1); try solve[inversion H0]; subst.
              destruct (peq y1 x1); simpl.
              exfalso; apply n; symmetry; assumption.
              destruct (plt y1 x1); auto.
              unfold Plt in *.
              destruct (x1 <? y1)%positive eqn:AAA.
              apply Pos.ltb_lt in AAA. auto.
              apply Pos.ltb_ge in AAA.
              apply Pos.le_lteq in AAA; destruct AAA; auto.
   Qed.
  End MiniAddressOrdered.

  Module AddressOrdered <: OrderedType.
     Include MiniAddressOrdered.

     Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }.
     Proof. unfold eq; destruct x, y. simpl.
            destruct (peq b b0);
              destruct (zeq z z0); subst; try solve[left; reflexivity];
              right; unfold not; intros H; inversion H; apply n; auto.
     Qed.
  End AddressOrdered.

  (*This is my map!*)
  Require Import FMaps.
  Module AMap:= Make AddressOrdered.

  Section AMap2PMap.
    (*Need to build a permission map from a finite map*)
    (*The pmap is used in the compcert memory. *)
    Context {lock_info: Type}.
    Variable am: AMap.t lock_info.

    Definition A2PMap (*: Map.PMap*) :=
      fold_left
        (fun (pmap:access_map) (a:address * lock_info)=>
           match a with
           | ((b, ofs), _) => setPermBlock (Some Memtype.Writable) b ofs pmap LKSIZE_nat
           end)
        (AMap.elements am)
        (PMap.init (fun _ => None)).
    End AMap2PMap.

Lemma AMap_find_map {A B} m (f : A -> B) k (x : A) :
  AMap.find k m = Some x ->
  AMap.find k (AMap.map f m) = Some (f x).
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl.
  - intro. discriminate.
  - destruct (AddressOrdered.compare k addr); intros E.
    + discriminate.
    + injection E as <-. eauto.
    + eauto.
Qed.

Lemma AMap_find_map_None {A B} m (f : A -> B) k :
  AMap.find k m = None ->
  AMap.find k (AMap.map f m) = None.
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl.
  - auto.
  - destruct (AddressOrdered.compare k addr); intros E; auto.
    discriminate.
Qed.

Lemma AMap_find_map_inv {A B} m (f : A -> B) k (y : B) :
  AMap.find k (AMap.map f m) = Some y ->
  exists x,
    AMap.find k m = Some x /\
    y = f x.
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl.
  - intro. discriminate.
  - destruct (AddressOrdered.compare k addr); intros E.
    + discriminate.
    + injection E as <-. eauto.
    + eauto.
Qed.

Lemma AMap_map {A B} (f : A -> B) m :
  map snd (AMap.elements (AMap.map f m)) =
  map f (map snd (AMap.elements m)).
Proof.
  destruct m as [l sorted].
  unfold AMap.Raw.t, AMap.find in *.
  simpl.
  clear sorted.
  induction l as [| [addr a] l IHl]; simpl; auto.
  rewrite IHl; auto.
Qed.

Lemma AMap_find_map_option_map {A B} m (f : A -> B) k :
  AMap.find k (AMap.map f m) =
  option_map f (AMap.find k m).
Proof.
  destruct (AMap.find k m) eqn:E.
  - apply AMap_find_map, E.
  - apply AMap_find_map_None, E.
Qed.

Instance EqDec_AMap_key : EqDec AMap.key.
Proof.
  compute.
  change (forall a a' : positive * Z, {a = a'} + {a <> a'}).
  repeat decide equality.
Qed.

Lemma AMap_find_add {A} m x (y : A) x' :
  AMap.find x' (AMap.add x y m) =
  if eq_dec x x' then Some y else AMap.find x' m.
Proof.
  pose proof AMap.add_1.
  pose proof AMap.add_2.
  pose proof AMap.add_3.
  pose proof AMap.find_1.
  pose proof AMap.find_2.
  assert (SN : forall A, forall o : option A, (forall x, o <> Some x) <-> o = None).
  { intros ? []; split; congruence. }

  destruct (eq_dec x x') as [d|d].
  - eauto.
  - destruct (AMap.find (elt:=A) x' m) eqn:E.
    + eauto.
    + rewrite <-SN in E |- *.
      intros y' Ey'; eapply E.
      eauto.
Qed.

Lemma AMap_find_remove {A} (m : AMap.t A) x x' :
  AMap.find x' (AMap.remove x m) =
  if eq_dec x x' then None else AMap.find x' m.
Proof.
  pose proof AMap.add_1.
  pose proof AMap.add_2.
  pose proof AMap.add_3.
  pose proof AMap.find_1.
  pose proof AMap.find_2.
  pose proof AMap.remove_1.
  pose proof AMap.remove_2.
  pose proof AMap.remove_3.
  assert (SN : forall A, forall o : option A, (forall x, o <> Some x) <-> o = None).
  { intros ? []; split; congruence. }

  destruct (eq_dec x x') as [d|d].
  - destruct (AMap.find _ _) as [o|] eqn:Eo; auto; exfalso.
    apply AMap.find_2 in Eo.
    eapply H4; eauto.
    exists o. apply Eo.
  - destruct (AMap.find (elt:=A) x' m) eqn:E.
    + eauto.
    + rewrite <-SN in E |- *.
      intros y' Ey'; eapply E.
      eauto.
Qed.

Lemma AMap_Raw_map_app {A} (f : A -> A) l1 l2 :
  AMap.Raw.map (option_map f) (app l1 l2) =
  app (AMap.Raw.map (option_map f) l1)
      (AMap.Raw.map (option_map f) l2).
Proof.
  induction l1; simpl; auto.
  rewrite IHl1. destruct a; auto.
Qed.

Lemma AMap_Raw_map_rev {A} (f : A -> A) l :
  AMap.Raw.map (option_map f) (rev l) =
  rev (AMap.Raw.map (option_map f) l).
Proof.
  induction l; simpl; auto.
  rewrite AMap_Raw_map_app. simpl. destruct a.
  rewrite IHl. auto.
Qed.

Lemma A2PMap_option_map {A} (m : AMap.t (option A)) (f : A -> A) :
  A2PMap (AMap.map (option_map f) m) = A2PMap m.
Proof.
  destruct m as [l sorted].
  unfold A2PMap in *.
  do 2 rewrite <-fold_left_rev_right.
  unfold AMap.elements in *.
  unfold AMap.map in *.
  unfold AMap.Raw.elements in *.
  simpl AMap.this.
  clear sorted.
  unfold AMap.Raw.t in *.
  rewrite <-AMap_Raw_map_rev.
  induction (rev l). reflexivity.
  simpl in *. rewrite <-IHl0.
  destruct a. reflexivity.
Qed.

Lemma AMap_map_add {A B} (f : A -> B) m x y :
  AMap.Equal
    (AMap.map f (AMap.add x y m))
    (AMap.add x (f y) (AMap.map f m)).
Proof.
  intros k.
  rewrite AMap_find_map_option_map.
  rewrite AMap_find_add.
  rewrite AMap_find_add.
  rewrite AMap_find_map_option_map.
  destruct (AMap.find (elt:=A) k m); destruct (eq_dec x k); auto.
Qed.

Lemma AMap_Raw_add_fold_left A (EQ : A -> A -> Prop) B f k (x : B) l (e : A) :
  (forall e, EQ e e) ->
  (forall e e', EQ e e' -> EQ e' e) ->
  (forall e e' e'', EQ e e' -> EQ e' e'' -> EQ e e'') ->
  (forall a e e', EQ e e' -> EQ (f e a) (f e' a)) ->
  (forall a b e, fst a = fst b -> EQ (f (f e a) b) (f e a)) ->
  (forall a b e, EQ (f (f e a) b) (f (f e b) a)) ->
  EQ
    (fold_left f (AMap.Raw.add k x l) e)
    (fold_left f ((k, x) :: l) e).
Proof.
  intros re sy tr congr idem comm.
  assert (congr' : forall l e e', EQ e e' -> EQ (fold_left f l e) (fold_left f l e')). {
    clear -congr; intros l; induction l; intros e e' E.
    - apply E.
    - apply IHl, congr, E.
  }
  revert e. induction l; intros e. apply re. simpl.
  destruct a as (k', y).
  destruct (AddressOrdered.compare k k').
  - apply re.
  - simpl. apply congr'. apply sy. apply idem. assumption.
  - simpl. eapply tr. apply IHl. simpl. apply congr'. apply comm.
Qed.

Require Import Coq.Sorting.Permutation.

Lemma AMap_Raw_add_fold_left_permut A (EQ : A -> A -> Prop) B f (l l' : list B) (e : A) :
  (forall e, EQ e e) ->
  (forall e e', EQ e e' -> EQ e' e) ->
  (forall e e' e'', EQ e e' -> EQ e' e'' -> EQ e e'') ->
  (forall a e e', EQ e e' -> EQ (f e a) (f e' a)) ->
  (forall a b e, EQ (f (f e a) b) (f (f e b) a)) ->
  Permutation l l' ->
  EQ
    (fold_left f l e)
    (fold_left f l' e).
Proof.
  intros re sy tr congr comm permut.
  assert (congr' : forall l e e', EQ e e' -> EQ (fold_left f l e) (fold_left f l e')). {
    clear -congr; intros l; induction l; intros e e' E.
    - apply E.
    - apply IHl, congr, E.
  }
  revert e. induction permut; intros e.
  - apply re.
  - apply IHpermut.
  - simpl. eapply tr. apply congr'. 2:apply re. apply comm.
  - eapply tr. apply IHpermut1. apply IHpermut2.
Qed.

Lemma AMap_Raw_add_fold_left_right A (EQ : A -> A -> Prop) B f (l : list B) (e : A) :
  (forall e, EQ e e) ->
  (forall e e', EQ e e' -> EQ e' e) ->
  (forall e e' e'', EQ e e' -> EQ e' e'' -> EQ e e'') ->
  (forall a e e', EQ e e' -> EQ (f e a) (f e' a)) ->
  (forall a b e, EQ (f (f e a) b) (f (f e b) a)) ->
  EQ
    (fold_left f l e)
    (fold_right (fun x y => f y x) e l).
Proof.
  intros re sy tr congr comm.
  replace l with (rev (rev l)) at 2. 2:apply rev_involutive.
  rewrite fold_left_rev_right.
  apply AMap_Raw_add_fold_left_permut; auto.
  apply Permutation_rev.
Qed.

Lemma setPerm_b_comm o b ofs1 ofs2 t :
  setPerm o b ofs1 (setPerm o b ofs2 t) =
  setPerm o b ofs2 (setPerm o b ofs1 t).
Proof.
  unfold setPerm. do 2 rewrite PMap.set2. f_equal.
  extensionality z. do 2 rewrite PMap.gsspec.
  destruct (zeq ofs1 z); destruct (zeq ofs2 z); simpl.
  - auto.
  - if_tac. 2:tauto. destruct (zeq ofs1 z); simpl; auto. tauto.
  - if_tac. 2:tauto. destruct (zeq ofs2 z); simpl; auto. tauto.
  - if_tac. 2:tauto. destruct (zeq ofs2 z); simpl; auto. tauto.
    destruct (zeq ofs1 z); simpl; auto. tauto.
Qed.

Lemma setPerm_b_idem o b ofs t :
  setPerm o b ofs (setPerm o b ofs t) =
  setPerm o b ofs t.
Proof.
  unfold setPerm. rewrite PMap.set2. f_equal.
  extensionality z. rewrite PMap.gsspec.
  destruct (zeq ofs z); simpl; auto. if_tac. 2:tauto. destruct (zeq ofs z); auto. tauto.
Qed.

Definition PMap_eq {A} (m m' : PMap.t (Z -> A)) := forall b' ofs', m !! b' ofs' = m' !! b' ofs'.

Lemma PMap_eq_refl {A} : reflexive _ (@PMap_eq A). intros f g. reflexivity. Qed.
Lemma PMap_eq_sym {A} : symmetric _ (@PMap_eq A). intros f g. unfold PMap_eq; symmetry; auto. Qed.
Lemma PMap_eq_trans {A} : transitive _ (@PMap_eq A). intros ? ? ? E E' ? ?. rewrite E, E'. auto. Qed.

Definition A2P {A} :=
 (fun (pmap : access_map) (a : address * A) =>
      let (a0, _) := a in let (b0, ofs0) := a0 in setPermBlock (Some Writable) b0 ofs0 pmap LKSIZE_nat).

Lemma A2P_congr A e e' a : PMap_eq e e' -> PMap_eq (A2P e a) (@A2P A e' a).
Proof.
  destruct a as ((b_, ofs_), a). intros E b'' ofs''. simpl. unfold setPerm.
  repeat rewrite PMap.gsspec.
  destruct (peq b'' b_) as [-> | ne]. destruct (peq b_ b_); [ | tauto]. 2:now auto.
  destruct (zeq (ofs_ + 3) ofs''); simpl; auto.
  destruct (zeq (ofs_ + 2) ofs''); simpl; auto.
  destruct (zeq (ofs_ + 1) ofs''); simpl; auto.
  destruct (zeq (ofs_ + 0) ofs''); simpl; auto.
Qed.

Lemma A2P_overwrite A : forall a b e, fst a = fst b -> PMap_eq (@A2P A (A2P e a) b) (@A2P A e a).
Proof.
  intros ((b1, ofs1), x1) (k2, x2) e; simpl. intros <- b'' ofs''.
  f_equal.
  repeat rewrite (setPerm_b_comm _ _ _ (ofs1 + 3)). rewrite setPerm_b_idem. f_equal.
  repeat rewrite (setPerm_b_comm _ _ _ (ofs1 + 2)). rewrite setPerm_b_idem. f_equal.
  repeat rewrite (setPerm_b_comm _ _ _ (ofs1 + 1)). rewrite setPerm_b_idem. f_equal.
  repeat rewrite (setPerm_b_comm _ _ _ (ofs1 + 0)). rewrite setPerm_b_idem. f_equal.
Qed.

Lemma setPerm_comm b1 o1 b2 o2 e:
  PMap_eq (setPerm (Some Writable) b1 o1 (setPerm (Some Writable) b2 o2 e))
          (setPerm (Some Writable) b2 o2 (setPerm (Some Writable) b1 o1 e)).
Proof.
  intros b' o'.
  unfold setPerm in *.
  repeat rewrite PMap.gsspec.
  destruct (peq b1 b2) as [B|B];
  destruct (peq b2 b1) as [B'|B']; try tauto;
  destruct (peq b' b1) as [B1|B1];
  destruct (peq b' b2) as [B2|B2];
  destruct (zeq o1 o') as [O1|O1];
  destruct (zeq o2 o') as [O2|O2]; simpl; auto; congruence.
Qed.

Lemma setPerm_congr b o e e':
  PMap_eq e e' ->
  PMap_eq (setPerm (Some Writable) b o e)
          (setPerm (Some Writable) b o e').
Proof.
  intros E b' o'; simpl.
  unfold setPerm in *.
  repeat rewrite PMap.gsspec.
  if_tac; destruct (zeq o o'); simpl. auto.
  all: rewrite E; auto.
Qed.

Lemma A2P_comm A e a b : PMap_eq (@A2P A (A2P e a) b) (@A2P A (A2P e b) a).
Proof.
  destruct a as ((b1, o1), a1), b as ((b2, o2), a2); simpl.
  eapply PMap_eq_trans; [ do 3 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 2 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 1 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 0 apply setPerm_congr; apply setPerm_comm | ].
  apply setPerm_congr.
  eapply PMap_eq_trans; [ do 3 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 2 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 1 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 0 apply setPerm_congr; apply setPerm_comm | ].
  apply setPerm_congr.
  eapply PMap_eq_trans; [ do 3 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 2 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 1 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 0 apply setPerm_congr; apply setPerm_comm | ].
  apply setPerm_congr.
  eapply PMap_eq_trans; [ do 3 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 2 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 1 apply setPerm_congr; apply setPerm_comm | ].
  eapply PMap_eq_trans; [ do 0 apply setPerm_congr; apply setPerm_comm | ].
  apply PMap_eq_refl.
Qed.

Lemma fold_right_cons : forall A B (f : A -> B -> B) (z : B) (x : A) (y : list A),
    fold_right f z (x :: y) = f x (fold_right f z y).
Proof. reflexivity. Qed.

Lemma setPerm_spec perm m b ofs b' ofs' :
  (setPerm perm b ofs m) !! b' ofs' =
  if eq_dec (b, ofs) (b', ofs') then
    perm
  else
    m !! b' ofs'.
Proof.
  unfold setPerm. rewrite PMap.gsspec.
  if_tac; destruct (zeq ofs ofs'); simpl; if_tac [?|ne]; try congruence.
  destruct ne; auto.
Qed.

Lemma A2PMap_found A m b ofs ofs' o :
  AMap.find (elt:=A) (b, ofs) m = Some o ->
  (ofs <= ofs' < ofs + 4)%Z ->
  (A2PMap m) !! b ofs' = Some Writable.
Proof.
  unfold AMap.find, A2PMap, AMap.elements, AMap.Raw.elements.
  rewrite (AMap_Raw_add_fold_left_right (PMap.t (Z -> option permission)) PMap_eq).
  2: now apply PMap_eq_refl.
  2: now apply PMap_eq_sym.
  2: now apply PMap_eq_trans.
  2: now intros; eapply A2P_congr; auto.
  2: now intros; eapply A2P_comm; auto.

  induction (@AMap.this A m) as [ | ((b0, ofs0), a) ]; [ discriminate | ].
  simpl (AMap.Raw.find _ _).
  destruct (AddressOrdered.compare (b, ofs) (b0, ofs0)) as [C|C|C].
  - discriminate.
  - injection 1 as <-.
    rewrite fold_right_cons.
    simpl.
    repeat rewrite setPerm_spec.
    repeat (if_tac; auto).
    injection C as <- <- .
    intros r.
    exfalso.
    do 4 match goal with H : (b, ?x) <> (b, ?y) |- _ => assert (x <> y) by (intros <-; tauto); clear H end.
    omega.
  - rewrite fold_right_cons.
    simpl.
    repeat rewrite setPerm_spec.
    repeat (if_tac; auto).
Qed.

Lemma fold_right_rev_left:
  forall (A B: Type) (f: A -> B -> A) (l: list B) (i: A),
  fold_left f l i = fold_right (fun x y => f y x) i (rev l).
Proof.
intros. rewrite fold_left_rev_right.
f_equal; extensionality x y; auto.
Qed.

Lemma A2PMap_add_outside T b b' ofs ofs' set o :
  (@A2PMap T (AMap.add (b, ofs) o set)) !! b' ofs' =
  if adr_range_dec (b, ofs) LKSIZE (b', ofs') then
    Some Writable
  else
    (@A2PMap T set) !! b' ofs'.
Proof.
  unfold A2PMap in *.
  unfold AMap.elements in *.
  unfold AMap.Raw.elements in *.
  unfold AMap.add in *.
  simpl (AMap.this _).

  etransitivity.
  {
    apply (AMap_Raw_add_fold_left _ (fun t t' => forall b' ofs', t !! b' ofs' = t' !! b' ofs')).
    - apply PMap_eq_refl.
    - apply PMap_eq_sym.
    - apply PMap_eq_trans.
    - intros; eapply A2P_congr; auto.
    - intros; eapply A2P_overwrite; auto.
    - intros; eapply A2P_comm; auto.
  }
  assert (P : Permutation ((b, ofs, o) :: AMap.this set) (AMap.this set ++ (b, ofs, o) :: nil)).
  { apply Permutation_cons_append. }
  etransitivity.
  {
    eapply (AMap_Raw_add_fold_left_permut _ (fun t t' => forall b' ofs', t !! b' ofs' = t' !! b' ofs')).
    - apply PMap_eq_refl.
    - apply PMap_eq_sym.
    - apply PMap_eq_trans.
    - intros; eapply A2P_congr; auto.
    - intros; eapply A2P_comm; auto.
    - apply P.
  }
  remember (AMap.this set) as l. clear set Heql.
  do 2 rewrite fold_right_rev_left.
  rewrite rev_app_distr. simpl (app _ _).
  remember (rev l) as l'; clear l Heql' P.
  rewrite (* canon. *)fold_right_cons.
  set (fold_right _ _ _) as m; clearbody m; clear.
  simpl.
  unfold setPerm in *.
  do 7 rewrite PMap.gsspec.
  if_tac [->|ne]; swap 1 2.
  { if_tac. destruct H. congruence. reflexivity. }
  destruct (peq b b). 2:tauto.
  destruct (zeq (ofs + 3) ofs') as [<- | ne3]; simpl.
  { if_tac [r|nr]; auto. destruct nr. split; auto; unfold LKSIZE; omega. }
  destruct (zeq (ofs + 2) ofs') as [<- | ne2]; simpl.
  { if_tac [r|nr]; auto. destruct nr. split; auto; unfold LKSIZE; omega. }
  destruct (zeq (ofs + 1) ofs') as [<- | ne1]; simpl.
  { if_tac [r|nr]; auto. destruct nr. split; auto; unfold LKSIZE; omega. }
  destruct (zeq (ofs + 0) ofs') as [<- | ne0]; simpl.
  { if_tac [r|nr]; auto. destruct nr. split; auto; unfold LKSIZE; omega. }
  if_tac [r|nr]; auto.
  destruct r. unfold LKSIZE in *; omega.
Qed.

Lemma find_too_small A y a x l :
  (AddressOrdered.lt y a \/ AddressOrdered.eq y a) ->
  Sorted (AMap.Raw.PX.ltk (elt:=A)) l ->
  HdRel (AMap.Raw.PX.ltk (elt:=A)) (a, x) l ->
  AMap.Raw.find (elt:=A) y l = None.
Proof.
  intros toosmall.
  induction l as [ | [b z] l]; auto.
  intros sorted below.
  inversion below as [ | b0 l0 Hab H ]; subst.
  change (AddressOrdered.lt a b) in Hab.
  simpl.
  destruct (AddressOrdered.compare y b).
  - reflexivity.
  - exfalso.
    destruct toosmall as [t|t].
    + pose proof AddressOrdered.lt_trans t Hab.
      eapply AddressOrdered.lt_not_eq; eauto.
    + hnf in t. subst.
      eapply AddressOrdered.lt_not_eq; eauto.
  - apply IHl; auto.
    inv sorted; eauto.
    inv sorted; eauto.
    eapply AMap.Raw.PX.Inf_lt; eauto.
    simpl; auto.
Qed.

Lemma sorted_find A a x l l'
      (sorted : Sorted (AMap.Raw.PX.ltk (elt:=A)) ((a, x) :: l))
      (sorted' : Sorted (AMap.Raw.PX.ltk (elt:=A)) ((a, x) :: l')) :
  (forall y : AMap.key,
      AMap.Raw.find (elt:=A) y ((a, x) :: l) =
      AMap.Raw.find (elt:=A) y ((a, x) :: l')) ->
  forall y : AMap.key,
    AMap.Raw.find (elt:=A) y l =
    AMap.Raw.find (elt:=A) y l'.
Proof.
  intros E.
  inversion sorted as [ | a0 l0 S B ]; subst. clear sorted.
  inversion sorted' as [ | a0 l0 S' B' ]; subst. clear sorted'.
  intros y; specialize (E y).
  simpl in E.
  destruct (AddressOrdered.compare y a).
  - erewrite find_too_small; eauto.
    erewrite find_too_small; eauto.
  - erewrite find_too_small; eauto.
    erewrite find_too_small; eauto.
  - auto.
Qed.

Lemma AMap_Equal_PMap_eq {A} m m' : AMap.Equal m m' -> @A2PMap A m = @A2PMap A m'.
Proof.
  intros E.
  unfold A2PMap in *.
  f_equal.
  unfold AMap.elements in *.
  destruct m as [l sorted], m' as [l' sorted']; simpl in *.
  unfold AMap.Equal in *.
  unfold AMap.find in *.
  unfold AMap.Raw.elements in *.
  simpl in *.
  revert l' sorted' E.
  induction l as [ | [a x] l]; intros l' sorted' E.
  - destruct l' as [ | [a' x] l']; auto. exfalso.
    specialize (E a'). simpl in E.
    destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a')) as [p R]. rewrite R in E.
    discriminate.
  - destruct l' as [ | [a' x'] l'].
    + specialize (E a). simpl in E.
      destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a)) as [p R]. rewrite R in E.
      discriminate.
    + assert (Ea : a = a' /\ x = x'). {
        pose (E a) as Ea. simpl in Ea.
        destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a)) as [p R]. rewrite R in Ea.
        pose (E a') as Ea'. simpl in Ea'.
        destruct (AMap.Raw.MX.elim_compare_eq (eq_refl a')) as [p' R']. rewrite R' in Ea'.
        destruct (AddressOrdered.compare a a') eqn:Ec; try (split; congruence).
        destruct (AddressOrdered.compare a' a) eqn:Ec'; try (split; congruence).
        exfalso. eapply (@AddressOrdered.lt_not_eq a' a); eauto.
        exfalso. eapply (@AddressOrdered.lt_not_eq a a); auto.
        eapply AddressOrdered.lt_trans; eauto.
      }
      destruct Ea as [<- <-].
      f_equal.
      apply IHl.
      * inv sorted; auto.
      * inv sorted'; auto.
      * eapply sorted_find; eauto.
Qed.

Lemma AMap_remove_add {A} (m : AMap.t A) x y :
  AMap.find x m = Some y ->
  AMap.Equal m (AMap.add x y (AMap.remove x m)).
Proof.
  intros find.
  intros x'.
  rewrite AMap_find_add, AMap_find_remove.
  if_tac.
  - subst x'. auto.
  - reflexivity.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_4.

Coq < Goal forall o m s:Prop, (((o \/ m) -> s) /\ ~s) -> ~m.
1 subgoal

  ============================
   forall o m s : Prop, (o \/ m -> s) /\ ~ s -> ~ m

Unnamed_thm < intros.
1 subgoal

  o : Prop
  m : Prop
  s : Prop
  H : (o \/ m -> s) /\ ~ s
  ============================
   ~ m

Unnamed_thm < elim H.
1 subgoal

  o : Prop
  m : Prop
  s : Prop
  H : (o \/ m -> s) /\ ~ s
  ============================
   (o \/ m -> s) -> ~ s -> ~ m

Unnamed_thm < intro.
1 subgoal

  o : Prop
  m : Prop
  s : Prop
  H : (o \/ m -> s) /\ ~ s
  H0 : o \/ m -> s
  ============================
   ~ s -> ~ m

Unnamed_thm < intro.
1 subgoal

  o : Prop
  m : Prop
  s : Prop
  H : (o \/ m -> s) /\ ~ s
  H0 : o \/ m -> s
  H1 : ~ s
  ============================
   ~ m

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <
*)

Section Exercise_4.
Goal forall o m s:Prop, (((o \/ m) -> s) /\ ~s) -> ~m.
intros.
elim H.
intro.
intro.
firstorder.
Qed.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms Derived_Pairs.
Set Implicit Arguments.

Module Make(Import M: Memory.T).
  Module Export Derived_ProductsExp := Derived_Pairs.Make(M).

 Definition lprod {X Y X' Y'} (f: term X X') (g: term Y Y'): term (X*Y) (X'*Y') := pair (f o pi1) (g o pi2).
 Definition rprod {X Y X' Y'} (f: term X X') (g: term Y Y') := permut o pair (g o pi2) (f o pi1).

 Lemma is_lprod: forall k X' X Y' Y (f1: term X X') (f2: term Y Y'), RO f1 -> is k f1 -> is k f2 ->  is k (lprod f1 f2). (* FIXED *)
 Proof. intros. induction k; decorate. Qed.

 Lemma is_rprod: forall k X' X Y' Y (f1: term X X') (f2: term Y Y'), is k f1 -> RO f2 -> is k f2 -> is k (rprod f1 f2).  (* FIXED *)
 Proof. intros k X' X Y' Y f1 f2 H1 H2 H3. induction k; decorate. Qed.

 Lemma w_lprod: forall X' X Y' Y (f: term X' X) (g: term Y' Y), RO f -> pi1 o (lprod f g) ~ f o pi1.
 Proof. intros X' X Y' Y f g H1. apply w_lpair_eq; decorate. Qed.

 Lemma s_lprod: forall X' X Y' Y (f: term X' X) (g: term Y' Y), RO f -> pi2 o (lprod f g) == g o pi2.
 Proof. intros intros X' X Y' Y f g. apply s_lpair_eq; decorate. Qed.

 Lemma w_prod: forall X' X Y' Y (f: term X' X) (g: term Y' Y), RO g -> pi2 o rprod f g ~ g o pi2.
 Proof. intros X' X Y' Y f g H1. apply w_rpair_eq; decorate. Qed.

 Lemma s_rprod: forall X' X Y' Y (f: term X' X) (g: term Y' Y), RO g -> pi1 o (rprod f g) == f o pi1.
 Proof. intros X' X Y' Y f g H1. apply s_rpair_eq; decorate. Qed.

 Lemma lprod_u: forall X X' Y Y'(f g: term (Y*Y') (X*X')), (pi1 o f ~ pi1 o g) /\ (pi2 o f == pi2 o g) -> f == g.
 Proof. intros X X' Y Y' f g (H0&H1). apply lpair_u. split; [exact H0| exact H1]. Qed.

 Lemma sprod_u: forall X X' Y Y'(f g: term (Y*Y') (X*X')), (pi1 o f == pi1 o g) /\ (pi2 o f ~ pi2 o g) -> f == g.
 Proof. intros X X' Y Y' f g (H0&H1). apply rpair_u. split; [exact H0| exact H1]. Qed.

End Make.


(** A library for finite sets with extensional equality.

    Author: Brian Aydemir. *)

Require Import FSets.
Require Import ListFacts.

(* *********************************************************************** *)
(** * Interface *)

(** The following interface wraps the standard library's finite set
    interface with an additional property: extensional equality. *)

Module Type S.

  Declare Module E : UsualOrderedType.
  Declare Module F : FSetInterface.S with Module E := E.

  Parameter eq_if_Equal :
    forall s s' : F.t, F.Equal s s' -> s = s'.

End S.

(* *********************************************************************** *)
(** * Implementation *)

(** For documentation purposes, we hide the implementation of a
    functor implementing the above interface.  We note only that the
    implementation here assumes (as an axiom) that proof irrelevance
    holds. *)

Module Make (X : UsualOrderedType) <: S with Module E := X.

  (* begin hide *)

  Module E := X.
  Module F := FSetList.Make E.
  Module OFacts := OrderedType.OrderedTypeFacts E.

  Axiom sort_F_E_lt_proof_irrel : forall xs (p q : sort F.E.lt xs), p = q.

  Lemma eq_if_Equal :
    forall s s' : F.t, F.Equal s s' -> s = s'.
  Proof.
    intros [s1 pf1] [s2 pf2] Eq.
    assert (s1 = s2).
      unfold F.Raw.t in *.
      eapply Sort_InA_eq_ext; eauto.
      intros; eapply E.lt_trans; eauto.
      intros; eapply OFacts.lt_eq; eauto.
      intros; eapply OFacts.eq_lt; eauto.
    subst s1.
    rewrite (sort_F_E_lt_proof_irrel _ pf1 pf2).
    reflexivity.
  Qed.

  (* end hide *)

End Make.


(** ** Typing, Context Morphism Lemmas, and Preservation *)

From Chapter9 Require Export reduction.

(** A context *)
Definition ctx n := fin n -> ty.

(** Typing predicate *)
Inductive has_type {n} (Gamma : ctx n) : tm n -> ty -> Prop :=
| ty_var_tm (x : fin n) :
    has_type Gamma (var_tm x) (Gamma x)
| ty_abs (S1 S2 : ty) (M : tm (S n)) :
    @has_type (S n) (S1 .: Gamma) M S2 ->
    has_type Gamma (lam S1 M) (Fun S1 S2)
| ty_app (T S : ty) (M N : tm n) :
    has_type Gamma M (Fun T S) ->
    has_type Gamma N T ->
    has_type Gamma (app M N) S.
Notation "Gamma |- M : T" := (has_type Gamma M T) (at level 20, M at level 99).

(** Context renaming *)
Definition ltc {k k'} (Gamma: ctx k) (Delta: ctx k') rho := forall x, Delta (rho x) = Gamma x.

(** Context renaming lemma *)
Lemma typing_ren n k (Gamma: ctx n) (Delta: ctx k) (rho: fin n -> fin k) (M: tm n) T :
  ltc Gamma Delta rho  -> Gamma |- M : T ->  Delta |- (M⟨rho⟩) : T.
Proof.
  intros C H. revert k Delta rho C. induction H; intros; cbn; eauto using has_type.
  - unfold ltc in C. rewrite <- C. constructor.
  - constructor. apply IHhas_type. asimpl. unfold ltc. auto_case.
  - econstructor; eauto.
Qed.

Lemma typing_inst n k (Gamma: ctx n) (Delta: ctx k) (sigma: fin n -> tm k) (M: tm n) T :
  (forall x, Delta |- sigma x : Gamma x) -> Gamma |- M : T ->  Delta |- (M[sigma]) : T.
Proof.
  intros C H. revert k Delta sigma C. induction H; intros; asimpl; eauto using has_type.
  - apply C.
  - constructor. apply IHhas_type. auto_case.
    + eapply typing_ren; eauto. intros. unfold ltc. now asimpl.
    + constructor.
  - econstructor; eauto.
Qed.

Lemma preservation k (Gamma: ctx k) M T :
  Gamma |- M : T -> forall M', step M M' -> Gamma |- M' : T.
Proof.
  induction 1 as [k Gamma x | k Gamma T S M A IHA | k Gamma T S M N A IHA B IHB]; intros M' H; cbn.
  - inv H.
  - inv H. econstructor. now apply IHA.
  - inv H.
    + inv A. eapply typing_inst; try eassumption.
      auto_case. constructor.
    + eapply ty_app; eauto.
    + eapply ty_app; eauto.
Qed.


Require Import Recdef FunInd List Bool Lia Arith.

From Equations Require Import Equations.

Inductive B:=
| B0 | B1 | B2.

Inductive A :=
| N : (B*nat) -> (list A) -> A.

Section some_context.

Variables b1 b2 b3 : A -> bool.

Inductive valid_internal_patterns : Type :=
| Case1 | Case2 (t1 t2 : A) | Case3 (t1 t2 : A) | Case4 (t1 t2 : A) | Default.

(* The function is_valid_cases computes in which case each of the tree
  will fall.  At the same time, it selects the subtrees that will be used
  in recursive calls. *)
Definition is_valid_cases (t : A) : valid_internal_patterns :=
  match t with
    N((B0 | B1), _) nil => Case1
  | N(B0, _) ((N (B2, _) _ as t1) :: (N (B2, _) _ as t2) :: nil) => Case2 t1 t2
  | N(B2, _) ((N (B1, _) _ as t1) :: (N (B1, _) _ as t2) :: nil) => Case3 t1 t2
  | N((B1 | B2), _) ((N(B0, _) _ as t1):: (N(B2, _) _ as t2) :: nil) => Case4 t1 t2
  | _ => Default
  end.

(* Now, Function will use a proof-based termination criterion instead of
  structural recursion.  Here, I choose to use size (number of N nodes) *)
Fixpoint size (t : A) :=
  match t with
    N _ l => 1 + fold_right (fun x n => Nat.add (size x) n) 0 l
  end.

Function is_valid3 (t : A) {measure size} : bool :=
  match is_valid_cases t with
    Case1 => true
  | Case2 t1 t2 => b1 t && is_valid3 t1 && is_valid3 t2
  | Case3 t1 t2 => b2 t && is_valid3 t1 && is_valid3 t2
  | Case4 t1 t2 => b3 t && is_valid3 t1 && is_valid3 t2
  | _ => false
  end.
(* Il y a 6 appels récursifs, donc 6 buts pour prouver que la mesure décroit,
  mais toutes ces preuves sont résolues automatiquement par la même tactique.
*)
all: destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(intros t1 t2 ceq; injection ceq; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Defined.

Scheme Equality for B.

Lemma andb_proj1 {b b' : bool} : b && b' = true -> b = true.
Proof. destruct b as [ | ]; destruct b' as [ | ]; auto. Qed.

Lemma andb_proj2 {b b' : bool} : b && b' = true -> b' = true.
Proof. destruct b as [ | ]; destruct b' as [ | ]; auto. Qed.

Lemma size_le1 {p l} : size (N p l) <= 1 -> l = nil.
Proof.
destruct l as [ | [ p' l'] tl]; auto; simpl; lia.
Qed.

Fixpoint at_path (t : A) (l : list nat) :=
  match t, l with
    t, nil => t
  | N _ ltree, i::tl =>
    if i <? length ltree then at_path (nth i ltree t) tl else t
  end.

Definition branches t := match t with N _ ts => ts end.

Lemma at_path_empty b n l : at_path (N (b, n) nil) l = N (b, n) nil.
Proof.
induction l as [ | [ | k ] l]; auto.
Qed.

Lemma example_proof t : is_valid3 t = true ->
  forall l, length (branches (at_path t l)) < 3.
Proof.
functional induction is_valid3 t; try discriminate.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    try discriminate; intros _ [ | [ | n] l]; simpl;
    rewrite ?at_path_empty; lia.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    simpl in e; try discriminate.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection e as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    simpl in e; try discriminate.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection e as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    simpl in e; try discriminate.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection e as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection e as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
Qed.

Equations is_valid6 (t : A) : bool by  wf (size t) lt :=
  is_valid6 t with (exist (fun v => is_valid_cases t = v)
                          (is_valid_cases t) eq_refl) => {
    | (exist _ Case1 h) := true;
    | (exist _ (Case2 t1 t2) h) :=
        b1 t && is_valid6 t1 && is_valid6 t2;
    | (exist _ (Case3 t1 t2) h) :=
        b2 t && is_valid6 t1 && is_valid6 t2;
    | (exist _ (Case4 t1 t2) h) :=
        b3 t && is_valid6 t1 && is_valid6 t2;
    | _ :=  false
  }.
Next Obligation.
destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(injection h; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Qed.
Next Obligation.
destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(injection h; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Qed.
Next Obligation.
destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(injection h; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Qed.
Next Obligation.
destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(injection h; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Qed.
Next Obligation.
destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(injection h; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Qed.
Next Obligation.
destruct t as [[[ | | ] ?] [ | [[[ | | ] ?] ?]
 [ | [[[ | | ] ?] ?] [ | [[[ | | ] ?] ?]]]]]; simpl; try discriminate;
(injection h; intros ceq1 ceq2; rewrite <- ?ceq1, <- ?ceq2; simpl; lia).
Qed.

Lemma example_proof6 t : is_valid6 t = true ->
  forall l, length (branches (at_path t l)) < 3.
Proof.
funelim (is_valid6 t).
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    try discriminate; intros _ [ | [ | n] l]; simpl;
    rewrite ?at_path_empty; lia.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    simpl in H1; try discriminate.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection H1 as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    simpl in H1; try discriminate.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection H1 as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
- destruct t as [[[ | | ] nh]
          [ | [[[ | | ] n1] l1][ |[[[ | | ] n2] l2] [ | lh] ]]];
    simpl in H1; try discriminate.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection H1 as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
  intros result.
  assert (r1 := andb_proj2 (andb_proj1 result)).
  assert (r2 := andb_proj2 result).
  injection H1 as vt1 vt2; rewrite vt1, vt2.
  intros [ | [ | [ | [ | k] ]] l]; simpl; auto.
- intros; discriminate.
Qed.

(*
Equations is_valid7 (t : A) : bool by  wf (size t) lt :=
  is_valid7 t with (is_valid_cases t) => {
    | Case1 := true;
    | (Case2 t1 t2) :=
        b1 t && is_valid7 t1 && is_valid7 t2;
    | (Case3 t1 t2) :=
        b2 t && is_valid7 t1 && is_valid7 t2;
    | (Case4 t1 t2) :=
        b3 t && is_valid7 t1 && is_valid7 t2;
    | _ :=  false
  }.
Next Obligation.
(* The goal that is displayed cannot be proved.
  b1, b2, b3 : A -> bool
  t, t1, t2 : A
  is_valid7 : forall x : A, size x < size t -> bool
  --------------------------
  size t1 < size t *)
Abort. *)

Lemma show_unprovability_first_obligation_is_valid7 :
   (forall (t t1 t2 : A),
       (forall x, size x < size t -> bool) -> size t1 < size t) -> False.
Proof.
intros abs.
set (t := N (B0, 0) nil).
set (f := fun (x : A) (h : size x < size t) => false).
assert (tmp:= abs t t t f); lia.
Qed.

End some_context.


From Coq Require Import Reals Psatz.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy.
From stdpp Require Import numbers.
From self.prelude Require Import base Reals_ext.
Import Hierarchy.

Local Open Scope R.

#[global] Instance Rbar_le_Transitive: Transitive Rbar_le.
Proof. intros ???. eapply Rbar_le_trans. Qed.
#[global] Instance Rbar_le_Reflexive: Reflexive Rbar_le.
Proof. intros ?. eapply Rbar_le_refl. Qed.
#[global] Instance Rbar_lt_Transitive: Transitive Rbar_lt.
Proof. intros ???. eapply Rbar_lt_trans. Qed.

Lemma Rbar_le_fin' x y: 0 <= y → Rbar_le x y → x <= real y.
Proof.
  rewrite /Rbar_le. destruct x => //=.
Qed.

Lemma norm_dist_mid x y z: norm (x - y) <= norm (x - z) + norm (z - y).
Proof.
  replace (x - y) with ((x - z) + (z - y)) by field.
  etransitivity; last eapply norm_triangle.
  apply Rle_refl.
Qed.

Lemma sum_n_m_filter (a: nat → R) (P: nat → Prop) `{∀ x, Decision (P x)} n m :
  sum_n_m (λ n, if bool_decide (P n) then Rabs (a n) else 0) n m <= sum_n_m (Rabs ∘ a) n m.
Proof.
  apply sum_n_m_le => k.
  destruct (bool_decide (P k)) => //=; try nra.
  apply Rabs_pos.
Qed.

Lemma is_series_0 a :
  (∀ n, a n = 0) → is_series a 0.
Proof.
  intros Ha. apply (is_series_ext (λ x, 0)); auto.
  rewrite /is_series.
  apply (filterlim_ext (λ x, 0)).
  - intros m. rewrite sum_n_const Rmult_0_r //.
  - apply filterlim_const.
Qed.

Lemma Series_0 a:
  (∀ n, a n = 0) → Series a = 0.
Proof.
  intros Heq. apply is_series_unique, is_series_0. done.
Qed.

Lemma Series_le' :
  ∀ a b : nat → R, (∀ n : nat, a n <= b n) → ex_series a → ex_series b → Series a <= Series b.
Proof.
  intros a b Hle [av Hav] [bv Hbv].
  erewrite is_series_unique; [|done].
  erewrite is_series_unique; [|done].
  cut (Rbar_le av bv); auto.
  eapply @filterlim_le; eauto.
  - apply Proper_StrongProper, eventually_filter.
  - exists O => n Hn. by apply sum_n_m_le.
Qed.

Lemma is_lim_seq_pos a (v: R):
  (∀ n, 0 <= a n) →
  is_lim_seq a v →
  0 <= v.
Proof.
  rewrite /is_lim_seq => Hn; intros.
  cut (Rbar_le 0 v); first by auto.
  apply (@filterlim_le _ eventually _ (λ x, 0) a); auto.
  - exists O; intros.  auto.
  - apply filterlim_const.
Qed.

Lemma is_lim_seq_unique_series a v:
  is_series a v → Lim_seq (sum_n a) = v.
Proof.
  intros. apply is_lim_seq_unique. rewrite //=.
Qed.

Lemma is_series_partial_pos a n v:
  (∀ n, 0 <= a n) →
  is_series a v →
  sum_n a n <= v.
Proof.
  intros Hpos His_series.
  assert (Hpos' : ∀ n : nat, 0 <= sum_n a n).
  { intros n'. induction n' => //=; rewrite ?sum_O ?sum_Sn; eauto.
    specialize (Hpos (S n')). rewrite /plus//=. nra. }
  replace (sum_n a n) with (real (sum_n a n)) by auto.
  rewrite -(is_series_unique _ _ His_series).
  eapply Rbar_le_fin'.
  - case_eq (Lim_seq (sum_n a)) => //=; try nra.
    intros r Heq.
    rewrite /is_series in His_series.
    assert (ex_lim_seq (sum_n a)).
    { exists v. eauto. }
    eapply is_lim_seq_pos; eauto.
    rewrite -Heq. apply Lim_seq_correct; eauto.
  -  rewrite -Lim_seq_const.
     case_eq (Lim_seq (sum_n a)) => //=; try nra.
     * intros r Heq. rewrite -Heq.
       apply Lim_seq_le_loc. exists n.
       intros m; induction 1.
       ** nra.
       ** rewrite sum_Sn /plus//=. specialize (Hpos (S m)). nra.
     * intros Heq_infty. apply is_lim_seq_unique_series in His_series. exfalso.
       rewrite Heq_infty in His_series. congruence.
     * intros Heq_infty. apply is_lim_seq_unique_series in His_series. exfalso.
       rewrite Heq_infty in His_series. congruence.
Qed.

Lemma is_series_singleton_hd v :
  is_series (λ n, if bool_decide (n = 0)%nat then v else 0) v.
Proof.
  apply is_series_decr_1=>/=.
  rewrite plus_opp_r.
  by apply is_series_0.
Qed.

Lemma is_series_singleton m v :
  is_series (λ n, if bool_decide (n = m) then v else 0) v.
Proof.
  induction m.
  - apply is_series_singleton_hd.
  - apply is_series_decr_1=>/=.
    rewrite opp_zero plus_zero_r.
    eapply is_series_ext; [|done].
    intros ? => //=.
    do 2 case_bool_decide; auto with lia.
Qed.

Lemma Series_bump m v :
  Series (λ n, if bool_decide (n = m) then v else 0) = v.
Proof.
  apply is_series_unique, is_series_singleton.
Qed.

Lemma sum_n_partial_pos a :
  (∀ n, 0 <= a n) →
   ∀ n : nat, 0 <= sum_n a n.
Proof.
  intros Hpos n'; induction n' => //=; rewrite ?sum_O ?sum_Sn; eauto.
  specialize (Hpos (S n')). rewrite /plus //=. nra.
Qed.

Lemma is_series_chain s1 s2 v :
  is_series s2 (Series s1) → is_series s1 v → is_series s2 v.
Proof.
  intros Hs2 Hs1. apply is_series_unique in Hs1. rewrite -Hs1. done.
Qed.

Lemma Series_correct' a v:
  Series a = v → ex_series a → is_series a v.
Proof. by intros <- ?; apply Series_correct. Qed.

#[global] Instance is_series_Proper:
  Proper (pointwise_relation nat (@eq R) ==> @eq R ==> iff) is_series.
Proof.
  intros ?? ? ?? ?; subst; split; eapply is_series_ext; eauto.
Qed.

#[global] Instance ex_series_Proper:
  Proper (pointwise_relation nat (@eq R) ==> iff) ex_series.
Proof.
  intros ?? ?; split; eapply ex_series_ext; eauto.
Qed.

#[global] Instance Series_Proper:
  Proper (pointwise_relation nat (@eq R) ==> eq) Series.
Proof.
  intros ?? ?; eapply Series_ext; eauto.
Qed.


(* File: Basics.v *)
(* Title: Basics - Functional Programming *)
(* Author: Peter Urbak <peteru@dragonwasrobot.com> *)
(* Version: 2012-09-24 *)

(*
   Notes to the reader:
   - Be aware that I may at times accidentally introduce notation not yet covered
     in the book, this mostly happens if I don't like their approach.
   - Most uses of simpl have been replaced with more atomic actions like unfold
     and rewrite to better understand what happens all the way through the
     proof, instead of relying on some magical tactic.
   - Likewise, a lot of these proofs could be done in way fewer lines but have
     been done this way in the hopes it will give a deeper understanding of the
     result.
*)

(* Days of the Week *)

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d : day) : day :=
  match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => monday
    | saturday => monday
    | sunday => monday
  end.

Eval simpl in (next_weekday friday).
(* ==> monday : day *)
Eval simpl in (next_weekday (next_weekday saturday)).
(* ==> tuesday : day *)

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof.
  unfold next_weekday.
  reflexivity.
Qed.

(* Booleans *)

Inductive bool : Type :=
  | true : bool
  | false : bool.

Definition negb (b : bool) : bool :=
  match b with
    | true => false
    | false => true
  end.

Definition andb (b1 b2 : bool) : bool :=
  match b1 with
    | true => b2
    | false => false
  end.

Definition orb (b1 b2 : bool) : bool :=
  match b1 with
    | true => true
    | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. unfold orb. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. unfold orb. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. unfold orb. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. unfold orb. reflexivity. Qed.

Definition admit {T : Type} : T. Admitted.

(* Exercise: 1 star (nandb) *)
Definition nandb (b1 b2 : bool) : bool :=
  match b1 with
    | true => negb(b2)
    | false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. unfold nandb. unfold negb. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. unfold nandb. unfold negb. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. unfold nandb. unfold negb. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. unfold nandb. unfold negb. reflexivity. Qed.

(* Exercise: 1 star (andb3) *)
Definition andb3 (b1 b2 b3 : bool) : bool :=
  match b1 with
    | false => false
    | true => match b2 with
                | false => false
                | true => b3
              end
    end.

Example test_andb31: (andb3 true true true) = true.
Proof. unfold andb3. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. unfold andb3. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. unfold andb3. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. unfold andb3. reflexivity. Qed.

(* Function Types *)

Check true.
(* ==> true : bool *)
Check (negb true).
(* ==> negb true : bool *)
Check negb.
(* ==> negb : bool -> bool *)

(* Numbers *)

Module Playground1.

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

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

End Playground1.

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Check (S (S (S (S O)))).
Eval simpl in (minustwo 4).

Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n : nat) : bool :=
  match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
  end.

Definition oddb (n : nat) : bool :=
  negb (evenb n).

Example test_oddb1: (oddb (S O)) = true.
Proof. unfold oddb. unfold evenb. unfold negb. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. unfold oddb. unfold evenb. unfold negb. reflexivity. Qed.

Module Playground2.

Fixpoint plus (n m : nat) : nat :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.

Eval simpl in (plus (S (S (S O))) (S (S O))).

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => plus m (mult n' m)
  end.

Fixpoint minus (n m : nat) : nat :=
  match n, m with
    | O, _ => O
    | S _,  O => n
    | S n', S m' => minus n' m'
  end.

End Playground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Example test_mult1: (mult 3 3) = 9.
Proof. unfold mult. unfold plus. reflexivity. Qed.

(* Exercise: 1 star (factorial) *)

Fixpoint factorial (n : nat) : nat :=
  match n with
    | O => S O
    | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. unfold factorial. unfold mult. unfold plus. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. unfold factorial. unfold mult. unfold plus. reflexivity. Qed.

Notation "x + y" := (plus x y)
  (at level 50, left associativity)
  : nat_scope.
Notation "x - y" := (minus x y)
  (at level 50, left associativity)
  : nat_scope.
Notation "x * y" := (mult x y)
  (at level 40, left associativity)
  : nat_scope.

Check ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
    | O => match m with
             | O => true
             | S m' => false
           end
    | S n' => match m with
                | O => false
                | S m' => beq_nat n' m'
              end
    end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
    | O => true
    | S n' => match m with
                | O => false
                | S m' => ble_nat n' m'
              end
    end.

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. unfold ble_nat. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. unfold ble_nat. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. unfold ble_nat. reflexivity. Qed.

(* Exercise: 2 stars (blt_nat) *)
Definition blt_nat (n m : nat) : bool :=
  andb (ble_nat n m) (negb (beq_nat n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. unfold blt_nat. unfold ble_nat. unfold negb.
unfold beq_nat. unfold andb. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. unfold blt_nat. unfold ble_nat. unfold negb.
unfold beq_nat. unfold andb. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. unfold blt_nat. unfold ble_nat. unfold negb.
unfold beq_nat. unfold andb. reflexivity. Qed.

(* Proof by Simplification *)

Theorem plus_O_n : forall n : nat, O + n = n.
Proof.
  simpl.
  reflexivity.
Qed.

Theorem plus_O_n' : forall n : nat, O + n = n.
Proof.
  reflexivity.
Qed.

(* Exercise: 1 star, optional (simpl_plus) *)

(* Eval simpl in (forall n : nat, n + O = n). *)
(* ==> forall n : nat, n + 0 = n : Prop *)

(* Eval simpl in (forall n : nat, O + n = n). *)
(* ==> forall n : nat, n = n : Prop *)

(* Since we have proven that O + n = n, the simplification tactic manages ton
   further simplify the second expression because it also examines the theorems
   we have proven so far, while it can't simplify the first one further because
   n + O = n hasn't been proved yet. *)

(* The [intros] Tactic *)

Theorem plus_O_n'' : forall n : nat, O + n = n.
Proof.
  intros n.
  unfold plus.
  reflexivity.
Qed.

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n.
  unfold plus.
  reflexivity.
Qed.

Theorem mult_O_l : forall n : nat, O * n = O.
Proof.
  intros n.
  unfold mult.
  reflexivity.
Qed.

(* Proof by Rewriting *)

Theorem plus_id_example : forall n m : nat,
  n = m -> n + n = m + m.
Proof.
  intros n m.
  intro H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_example' : forall n m : nat,
  n = m -> n + n = m + m.
Proof.
  intros n m.
  intro H.
  rewrite <- H.
  reflexivity.
Qed.

(* Exercise: 1 star (plus_id_exercise) *)
Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H_n_eq_m H_m_eq_o.
  rewrite -> H_n_eq_m.
  rewrite <- H_m_eq_o.
  reflexivity.
Qed.

Theorem mult_O_plus : forall n m : nat,
  (O + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

(* Exercise: 2 stars, recommended (mult_1_plus) *)
Theorem mult_1_plus : forall n m : nat,
  (1 + n) * m = m + (n * m).
Proof.
  intros n m.
  rewrite -> plus_1_l.
  unfold mult. fold mult.
  reflexivity.
Qed.

(* Case Analysis *)

Theorem plus_1_neg_O : forall n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  destruct n as [ | n' ].

  unfold plus.
  unfold beq_nat.
  reflexivity.

  unfold plus.
  unfold beq_nat.
  reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b.

  unfold negb.
  reflexivity.

  unfold negb.
  reflexivity.
Qed.

(* Exercise: 1 star (zero_nbeg_plus_1) *)
Theorem zero_nbeg_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intro n.
  destruct n.

  unfold plus.
  unfold beq_nat.
  reflexivity.

  unfold plus.
  unfold beq_nat.
  reflexivity.
Qed.

(* Naming Cases *)

Require Export Cases.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c.
  intro H.
  destruct b.

  Case "b = true".
  reflexivity.

  Case "b = false".
  rewrite <- H.
  unfold andb.
  reflexivity.
Qed.

(* Exercise: 2 stars (andb_true_elim2) *)
Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  intro H.
  destruct c.

  Case "c = true".
  reflexivity.

  Case "c = false".
  rewrite <- H.
  unfold andb.
  destruct b.

  SCase "b = true".
  reflexivity.

  SCase "b = false".
  reflexivity.
Qed.

(* Induction *)

Theorem plus_O_r : forall n : nat,
  n + O = n.
Proof.
  intros n.
  induction n as [ | n' ].

  Case "n = O".
  unfold plus.
  reflexivity.

  Case "n = S n'".
  unfold plus. fold plus.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem minus_diag : forall n : nat,
  minus n n = O.
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  unfold minus.
  reflexivity.

  Case "n = S n'".
  unfold minus. fold minus.
  rewrite -> IHn'.
  reflexivity.
Qed.

(* Exercise: 2 stars, recommended (basic_induction) *)
Theorem mult_O_r : forall n : nat,
  n * O = O.
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> mult_O_l.
  reflexivity.

  Case "n = S n'".
  unfold mult. fold mult.
  rewrite -> plus_O_n.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> plus_O_n.
  rewrite -> plus_O_n.
  reflexivity.

  Case "n = S n'".
  unfold plus. fold plus.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> plus_O_n.
  rewrite -> plus_O_r.
  reflexivity.

  Case "n = S n'".
  unfold plus. fold plus.
  rewrite -> IHn'.
  rewrite -> plus_n_Sm.
  reflexivity.
Qed.

Fixpoint double (n : nat) :=
  match n with
    | O => O
    | S n' => S (S (double n'))
  end.

(* Exercise: 2 stars (double_plus) *)
Lemma double_plus : forall n : nat,
  double n = n + n.
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  unfold double.
  rewrite -> plus_O_n.
  reflexivity.

  Case "n = S n'".
  unfold double. fold double.
  rewrite -> IHn'.
  rewrite -> plus_n_Sm.
  unfold plus. fold plus.
  reflexivity.
Qed.

(* Exercise: 1 star (destruct_induction) *)
(* Briefly explain the difference between the tactics destruct and induction:
   Induction gives you a hypothesis while destruct just expects you to prove
   each case without an induction hypothesis. *)

(* Formal vs. Informal Proof. *)

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> plus_O_n.
  rewrite -> plus_O_n.
  reflexivity.

  Case "n = S n'".
  unfold plus. fold plus.
  rewrite -> IHn'.
  reflexivity.
Qed.

(* Exercise: 2 stars (plus_comm_informal) *)

(* Translate your solution for plus_comm into an informal proof.

Theorem: Addition is commutative.

Proof: (* FILL IN HERE *)

*)

(* Exercise: 2 stars, optional (beq_nat_refl_informal) *)

(* Write an informal proof of the following theorem, using the informal proof of
   plus_assoc as a model. Don't just paraphrase the Coq tactics into English!

Theorem: true = beq_nat n n for any n.

Proof: (* FILL IN HERE *)

*)

(* Exercise: 1 star, optional (beq_nat_refl) *)
Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  unfold beq_nat.
  reflexivity.

  Case "n = S n'".
  unfold beq_nat. fold beq_nat.
  rewrite <- IHn'.
  reflexivity.
Qed.

(* Proofs within Proofs *)

Theorem mult_O_plus' : forall n m : nat,
  (O + n) * m = n * m.
Proof.
  intros n m.
  assert (H: O + n = n).

    Case "Proof of assertion".
    unfold plus.
    reflexivity.

  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).

    Case "Proof of assertion".
    rewrite -> plus_comm.
    reflexivity.

  rewrite -> H.
  reflexivity.
Qed.

(* We can avoid introducing H by being more specific in our rewrite *)
Theorem plus_rearrange' : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  rewrite -> (plus_comm n m).
  reflexivity.
Qed.

(* Exercise: 4 stars (mult_comm) *)
Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  rewrite -> plus_assoc.
  rewrite -> (plus_comm n m).
  reflexivity.
Qed.

Lemma n_mult_m_plus_n : forall n m : nat,
  (n * m) + n = n * (S m).
Proof.
  intros n m.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> mult_O_l.
  rewrite -> mult_O_l.
  rewrite -> plus_O_r.
  reflexivity.

  Case "n = S n'".
  unfold mult. fold mult.
  rewrite <- plus_1_l.
  rewrite -> (plus_comm 1 n').
  rewrite -> plus_assoc.
  rewrite -> (plus_comm m (n' * m)).
  rewrite <- plus_assoc.
  rewrite <- plus_assoc.
  rewrite -> (plus_comm m (n' + 1)).
  rewrite <- plus_assoc.
  rewrite -> plus_1_l.
  rewrite -> plus_assoc.
  rewrite -> IHn'.
  rewrite (plus_comm (S m) (n' * (S m))).
  reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros n m.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> mult_O_r.
  rewrite -> mult_O_l.
  reflexivity.

  Case "n = S n'".
  unfold mult. fold mult.
  rewrite -> IHn'.
  rewrite <- n_mult_m_plus_n.
  rewrite -> plus_comm.
  reflexivity.
Qed.

(* Exercise: 2 stars, optional (evenb_n__oddb_S_n) *)
Theorem evenb_n__oddb_S_n : forall n : nat,
  evenb n = negb (evenb (S n)).
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  unfold evenb. unfold negb.
  reflexivity.

  Case "n = S n'".
  unfold evenb at 2. fold evenb.
  rewrite -> IHn'.
  rewrite -> negb_involutive.
  reflexivity.
Qed.

(* More Exercises *)

(* Exercise: 3 stars, optional (more_exercises) *)

Theorem ble_nat_refl : forall n : nat,
  true = ble_nat n n.
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  unfold ble_nat.
  reflexivity.

  Case "n = S n'".
  unfold ble_nat. fold ble_nat.
  rewrite <- IHn'.
  reflexivity.
Qed.

Theorem zero_nbeg_S : forall n : nat,
  beq_nat O (S n) = false.
Proof.
  intro n.
  unfold beq_nat.
  reflexivity.
Qed.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  intro b.
  destruct b.

  Case "b = true".
  unfold andb.
  reflexivity.

  Case "b = false".
  unfold andb.
  reflexivity.
Qed.

Theorem plus_ble_compat_l : forall n m p : nat,
  ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros n m p.
  intro H_ble_nat_n_m_true.
  induction p as [ | p' ].

  Case "p = O".
  rewrite -> plus_O_n.
  rewrite -> plus_O_n.
  rewrite -> H_ble_nat_n_m_true.
  reflexivity.

  Case "p = S p'".
  rewrite -> (plus_comm (S p') n).
  rewrite <- plus_n_Sm.
  rewrite -> (plus_comm (S p') m).
  rewrite <- plus_n_Sm.
  unfold ble_nat. fold ble_nat.
  rewrite <- (plus_comm p' n).
  rewrite <- (plus_comm p' m).
  rewrite -> IHp'.
  reflexivity.
Qed.

Theorem S_nbeq_O : forall n : nat,
  beq_nat (S n) O = false.
Proof.
  intro n.
  unfold beq_nat.
  reflexivity.
Qed.

Theorem mult_1_l : forall n : nat,
  1 * n = n.
Proof.
  intro n.
  unfold mult.
  rewrite -> plus_O_r.
  reflexivity.
Qed.

Lemma mult_1_r : forall n : nat,
  n * 1 = n.
Proof.
  intro n.
  induction n as [ | n' ].

  Case "n = O".
  unfold mult.
  reflexivity.

  Case "n = S n'".
  unfold mult. fold mult.
  rewrite -> IHn'.
  rewrite -> plus_1_l.
  reflexivity.
Qed.

Theorem all3_spec : forall b c : bool,
  orb
  (andb b c)
  (orb (negb b) (negb c)) = true.
Proof.
  intros b c.
  destruct b.

  Case "b = true".
  destruct c.

  SCase "c = true".
  unfold negb. unfold andb. unfold orb.
  reflexivity.

  SCase "c = false".
  unfold negb. unfold andb. unfold orb.
  reflexivity.

  Case "b = false".
  destruct c.

  SCase "c = true".
  unfold negb. unfold andb. unfold orb.
  reflexivity.

  SCase "c = false".
  unfold negb. unfold andb. unfold orb.
  reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> plus_O_n.
  rewrite -> plus_O_n.
  reflexivity.

  Case "S n' = O".
  unfold plus. fold plus.
  unfold mult. fold mult.
  rewrite -> IHn'.
  rewrite -> plus_assoc.
  reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p.
  induction n as [ | n' ].

  Case "n = O".
  rewrite -> mult_O_l.
  rewrite -> mult_O_l.
  reflexivity.

  Case "n = S n'".
  unfold mult. fold mult.
  rewrite -> IHn'.
  rewrite -> mult_plus_distr_r.
  reflexivity.
Qed.

(* Exercise: 2 stars, optional (plus_swap' *)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  rewrite -> plus_assoc.
  replace (n + m) with (m + n).
  reflexivity.
  rewrite -> plus_comm.
  reflexivity.
Qed.

(* Exercise: 3 stars, optional *)

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b.
  destruct b.

  Case "b = true".
  remember (f true) as ftrue.
  destruct ftrue.

  SCase "f true = true".
  rewrite <- Heqftrue.
  symmetry.
  apply Heqftrue.

  SCase "f true = false".
  remember (f false) as ffalse.
  destruct ffalse.

  SSCase "f false = true".
  symmetry.
  apply Heqftrue.

  SSCase "f false = false".
  symmetry.
  apply Heqffalse.
  remember (f false) as ffalse.
  destruct ffalse.

  SCase "f false = true".
  remember (f true) as ftrue.
  destruct ftrue.

  SSCase "f true = true".
  symmetry.
  apply Heqftrue.

  SSCase "f true = false".
  symmetry.
  apply Heqffalse.

  SCase "f false = false".
  rewrite <- Heqffalse.
  symmetry.
  apply Heqffalse.
Qed.

(* Exercise: 4 stars, recommended (binary) *)

(* a: First, write an inductive definition of the type [bin] corresponding to
   this description of binary numbers. *)

Inductive bin : Type :=
  | zero : bin
  | twice : bin -> bin
  | twice_plus_one : bin -> bin.

(* b: Next, write an increment function for binary numbers, and a function to
   convert binary numbers to unary numbers. *)

Fixpoint increment (b : bin) : bin :=
  match b with
    | zero => twice_plus_one zero
    | twice b' => twice_plus_one b'
    | twice_plus_one b' => twice (increment b')
  end.

Fixpoint binary_to_unary (b : bin) : nat :=
  match b with
    | zero => O
    | twice b' => double (binary_to_unary b')
    | twice_plus_one b' => S (double (binary_to_unary b'))
  end.

(* c: Finally, prove that your increment and binary-to-unary functions commute:
   that is, incrementing a binary number and then converting it to unary yields
   the same result as first converting it to unary and then incrementing. *)

Theorem binary_and_unary_commute : forall (b : bin),
  binary_to_unary (increment b) = S (binary_to_unary b).
Proof.
  intro b.
  induction b as [ | b' | b' ].

  Case "b = zero".
  unfold increment.
  unfold binary_to_unary.
  unfold double.
  reflexivity.

  Case "b = twice b'".
  unfold increment.
  unfold binary_to_unary. fold binary_to_unary.
  reflexivity.

  Case "b = twice_plus_one b'".
  unfold increment. fold increment.
  unfold binary_to_unary. fold binary_to_unary.
  rewrite -> IHb'.
  unfold double. fold double.
  reflexivity.
Qed.

(* Exercise: 5 stars (binary_inverse) *)

(* a: First, write a function to convert natural numbers to binary numbers. Then
   prove that starting with any natural number, converting to binary, then
   converting back yields the same natural number you started with. *)

(* To convert from a base-10 integer numeral to its base-2 (binary) equivalent,
   the number is divided by two, and the remainder is the least-significant
   bit. The (integer) result is again divided by two, its remainder is the next
   least significant bit. This process repeats until the quotient becomes
   zero. *)

(* TODO *)

(* b: You might naturally think that we should also prove the opposite
   direction: that starting with a binary number, converting to a natural, and
   then back to binary yields the same number we started with. However, it is
   not true!  Explain what the problem is. *)

(* TODO *)

(* c: Define a function normalize from binary numbers to binary numbers such
   that for any binary number b, converting to a natural and then back to binary
   yields (normalize b). Prove it. *)

(* TODO *)

(* Exercise: 2 stars, optional (decreasing) *)

(* converge will not be accepted by Coq, despite the fact that it has a
   decreasing argument. *)

(*
Definition minusOne (n : nat) : nat :=
  n - 1.

Fixpoint converge (n : nat) : nat :=
  match n with
    | O => O
    | n => converge (minusOne n)
  end.
*)

(* end-of-Basics.v *)


Require Import Basics Types CommutativeSquares MyLemmas MyTacs.

(* This whole file is adapted from the file Limits1.v of : *)
(* From https://github.com/peterlefanulumsdaine/hott-limits *)

Open Scope path_scope.
Context `{Funext}.

Section Diagram.
  Record graph :=
    { graph0 :> Type;
      graph1 :> graph0 -> graph0 -> Type }.

  Record diagram (G : graph) :=
    { diagram0 :> G -> Type;
      diagram1 : forall (i j : G), G i j -> (diagram0 i -> diagram0 j) }.

  Global Arguments diagram0 [G] D i : rename.
  Global Arguments diagram1 [G] D [i j] g x : rename.
End Diagram.

Notation "D '_f' g" := (diagram1 D g) (at level 10).

Section DiagramMap.
  Context {G: graph}.

  Record diagram_map (D1 D2 : diagram G) :=
    { diagram_map_obj :> forall i, D1 i -> D2 i;
      diagram_map_comm: forall i j (g: G i j) x,
            D2 _f g (diagram_map_obj i x) = diagram_map_obj j (D1 _f g x) }.

  Global Arguments diagram_map_obj [D1 D2] m i x : rename.
  Global Arguments diagram_map_comm  [D1 D2] m [i j] f x : rename.
  Global Arguments Build_diagram_map [D1 D2] _ _.

  Lemma path_diagram_map {D1 D2: diagram G} {m1 m2: diagram_map D1 D2}
        (h_obj: forall i, m1 i == m2 i)
        (h_comm: forall (i j: G) (g: G i j) (x: D1 i),
                diagram_map_comm m1 g x @ h_obj j (D1 _f g x) =
                ap (D2 _f g) (h_obj i x) @ diagram_map_comm m2 g x)
  : m1 = m2.
    destruct m1 as [m1_obj m1_comm].
    destruct m2 as [m2_obj m2_comm].
    simpl in *. revert h_obj h_comm.
    set (E := (@equiv_functor_forall _
           G (fun i => m1_obj i = m2_obj i)
           G (fun i => m1_obj i == m2_obj i)
           idmap _
           (fun i => @apD10 _ _ (m1_obj i) (m2_obj i)))
                (fun i => isequiv_apD10 _ _ _ _)).
    equiv_intro E h_obj.
    revert h_obj.
    equiv_intro (@apD10 _ _ m1_obj m2_obj) h_obj.
    destruct h_obj. simpl.
    intros h_comm.
    assert (H : m1_comm = m2_comm). {
      funext i j f x.
      apply (concatR (concat_1p _)).
      apply (concatR (h_comm _ _ _ _)).
      apply inverse, concat_p1. }
    destruct H. exact 1.
  Defined.

  Definition diagram_idmap (D : diagram G) : diagram_map D D
    := Build_diagram_map (fun _ => idmap) (fun _ _ _ _ => 1).

  Definition diagram_comp {D1 D2 D3 : diagram G} (m2 : diagram_map D2 D3)
             (m1 : diagram_map D1 D2) : diagram_map D1 D3.
    apply (Build_diagram_map (fun i => m2 i o m1 i)).
    intros i j f.
    exact (comm_square_comp (diagram_map_comm m2 f) (diagram_map_comm m1 f)).
  Defined.

  Record diagram_equiv (D1 D2: diagram G) :=
    { diag_equiv_map :> diagram_map D1 D2;
      diag_equiv_isequiv : forall i, IsEquiv (diag_equiv_map i) }.

  Global Arguments diag_equiv_map [D1 D2] e : rename.
  Global Arguments diag_equiv_isequiv [D1 D2] e i : rename.
  Global Arguments Build_diagram_equiv [D1 D2] m H : rename.

  Lemma diagram_equiv' (D1 D2: diagram G)
    : {path_type : forall x, (diagram0 D1 x) <~> (diagram0 D2 x)
                             & forall (i j:G), forall x:G i j, (path_type j) o (diagram1 D1 x) == (diagram1 D2 x) o (path_type i) } -> diagram_equiv D1 D2.
  Proof.
    intros [p pp].
    simple refine (Build_diagram_equiv _ _).
    simple refine (Build_diagram_map _ _).
    intro x; apply (p x).
    intros i j g x; cbn.
    exact (pp i j g x)^.
    intro i. cbn. apply equiv_isequiv.
  Defined.

  Lemma diagram_equiv_inv {D1 D2 : diagram G} (w : diagram_equiv D1 D2)
  : diagram_map D2 D1.
    apply (Build_diagram_map (fun i => (BuildEquiv (diag_equiv_isequiv w i))^-1)).
    intros i j f.
    apply (@comm_square_inverse _ _ _ _ _ _
                                (BuildEquiv (diag_equiv_isequiv w i)) (BuildEquiv (diag_equiv_isequiv w j))).
    intros x; apply diagram_map_comm.
  Defined.

  Lemma diagram_inv_is_section {D1 D2 : diagram G} (w : diagram_equiv D1 D2)
  : diagram_comp w (diagram_equiv_inv w) = diagram_idmap D2.
    destruct w as [[w_obj w_comm] is_eq_w]. simpl in *.
    set (we i := BuildEquiv (is_eq_w i)).
    simple refine (path_diagram_map _ _).
    exact (fun i => eisretr (we i)). simpl.
    intros i j f x. apply (concatR (concat_p1 _)^).
    apply (comm_square_inverse_is_retr (we i) (we j) _ x).
  Defined.

  Lemma diagram_inv_is_retraction {D1 D2 : diagram G} (w : diagram_equiv D1 D2)
  : diagram_comp (diagram_equiv_inv w) w = diagram_idmap D1.
    destruct w as [[w_obj w_comm] is_eq_w]. simpl in *.
    set (we i := BuildEquiv (is_eq_w i)).
    simple refine (path_diagram_map _ _).
    exact (fun i => eissect (we i)). simpl.
    intros i j f x. apply (concatR (concat_p1 _)^).
    apply (comm_square_inverse_is_sect (we i) (we j) _ x).
  Defined.

  Global Instance reflexive_diagram_equiv : Reflexive diagram_equiv
    := λ D, Build_diagram_equiv (diagram_idmap D) _.

  Global Instance symmetric_diagram_equiv : Symmetric diagram_equiv
    := λ D1 D2 m, Build_diagram_equiv (diagram_equiv_inv m) _.

  Global Instance transitive_diagram_equiv : Transitive diagram_equiv.
    refine (λ D1 D2 D3 m1 m2, Build_diagram_equiv (diagram_comp m2 m1) _).
    simpl. intros i; apply isequiv_compose'. apply m1. apply m2.
  Defined.
End DiagramMap.

Notation "D1 ≃ D2" := (diagram_equiv D1 D2) (at level 10).

(*  *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Cat: Category Theory with classes.
 *
 * This module implements the category [CAT] of categories and functors.
 *
 * Author: Matthieu Sozeau <mattam@mattam.org>
 *)

Require Import Coq.Program.Program.
Require Import SetoidClass.
Require Import Setoid.
Require Import Cat.Functor.

Typeclasses Transparent Datatypes.id.

Program Instance CAT : Category category functor := {
  morphisms := functor_setoid ;
  id := identity_functor ;
  compose := functor_composition
}.

  Next Obligation.
  Proof.
    revert a.
    intros [obj₁ hom₁ cat₁].
    do 2 red ; simpl.

    split_dep; reflex.
  Qed.

  Next Obligation.
  Proof.
    revert a b c.
    intros [obj₁ hom₁ cat₁].
    intros [obj₂ hom₂ cat₂].
    intros [obj₃ hom₃ cat₃].
    do 2 red.
    intros [Fobj [Fmor F]].
    intros [Gobj [Gmor G]].
    intros Heq.
    red.
    intros [Fobj' [Fmor' F']].
    intros [Gobj' [Gmor' G']].
    simpl.

    simpl in Heq.
    intros. destruct_conjs.
    subst ; simpl_JMeq ; subst.
    split_dep ; reflex.
  Qed.

  Next Obligation.
  Proof.
    revert a b f.
    intros [obj₁ hom₁ cat₁].
    intros [obj₂ hom₂ cat₂].
    intros [Fobj [Fmor F]].

    simpl.
    split_dep.
      apply compose_id_left.
      unfold Datatypes.id, Basics.compose.
      apply eq_eqdep.
      extensionality a ; extensionality b ; extensionality h.
      reflex.
  Qed.

  Next Obligation.
  Proof.
    revert a b f.
    intros [obj₁ hom₁ cat₁].
    intros [obj₂ hom₂ cat₂].
    intros [Fobj [Fmor F]].

    simpl.
    split_dep.
      apply compose_id_right.
      unfold Datatypes.id, Basics.compose.
      apply eq_eqdep.
      extensionality a ; extensionality b ; extensionality h.
      reflex.
  Qed.

  Next Obligation.
  Proof.
    revert a b c d f g h.
    intros [obj₁ hom₁ cat₁].
    intros [obj₂ hom₂ cat₂].
    intros [obj₃ hom₃ cat₃].
    intros [obj₄ hom₄ cat₄].
    intros [Fobj [Fmor F]].
    intros [Gobj [Gmor G]].
    intros [Hobj [Hmor H]].

    simpl.
    split_dep.
      apply compose_assoc.

      unfold Datatypes.id, Basics.compose.
      apply eq_eqdep.
      reflex.
  Qed.