(** * Utilities : boolean equalities, list operators, ... *)

(** The NatDed development, Pierre Letouzey, 2019.
    This file is released under the CC0 License, see the LICENSE file *)

Require Import Bool Arith Lia Ascii String AsciiOrder StringOrder List.
Import ListNotations.
Open Scope lazy_bool_scope.
Add Search Blacklist "OrdersEx.Nat_as".

Lemma lazy_andb_iff (b b' : bool) :
 b &&& b' = true <-> b = true /\ b' = true.
Proof.
 now destruct b, b'.
Qed.

Lemma lazy_andb_false (a:bool) : a &&& false = false.
Proof.
 now destruct a.
Qed.

Lemma lazy_orb_true (a:bool) : a ||| true = true.
Proof.
 now destruct a.
Qed.

Lemma lazy_orb_false (a:bool) : a ||| false = a.
Proof.
 now destruct a.
Qed.

Lemma lazy_orb_iff (a b:bool) : a ||| b = true <-> a = true \/ b = true.
Proof.
 split; destruct a; destruct b; simpl; intuition.
Qed.

Lemma cons_app {A} (x:A) l : x::l = [x]++l.
Proof.
 reflexivity.
Qed.

(** Generic boolean equalities (via Coq Classes) *)

Delimit Scope eqb_scope with eqb.
Local Open Scope eqb_scope.

Class Eqb (A : Type) := eqb : A -> A -> bool.
Infix "=?" := eqb : eqb_scope.
Arguments eqb {A} {_} !_ !_.

Class EqbSpec A `{Eqb A} :=
 eqbspec : forall x y:A, reflect (x=y) (x =? y).

Hint Extern 10 => case eqbspec : eqb.

Instance eqb_inst_nat : Eqb nat := Nat.eqb.
Instance eqbspec_nat : EqbSpec nat := Nat.eqb_spec.

Instance eqb_inst_ascii : Eqb ascii := AsciiOrder.ascii_eqb.
Instance eqbspec_ascii : EqbSpec ascii := AsciiOrder.ascii_eqb_spec.

Instance eqb_inst_string : Eqb string := StringOrder.string_eqb.
Instance eqbspec_string : EqbSpec string := StringOrder.string_eqb_spec.

Arguments eqb_inst_nat !_ !_.
Arguments eqb_inst_ascii !_ !_.
Arguments eqb_inst_string !_ !_.

Lemma eqb_refl {A} `{EqbSpec A} (x:A) : (x =? x) = true.
Proof.
 now case eqbspec.
Qed.

Lemma eqb_eq {A} `{EqbSpec A} (x y:A) : (x =? y) = true <-> x = y.
Proof.
 now case eqbspec.
Qed.

Lemma eqb_neq {A} `{EqbSpec A} (x y:A) : (x =? y) = false <-> x <> y.
Proof.
 now case eqbspec.
Qed.

Lemma eqb_sym {A} `{EqbSpec A} (x y:A) : (x =? y) = (y =? x).
Proof.
 case (eqbspec y x); intros.
 - apply eqb_eq. auto.
 - apply eqb_neq. auto.
Qed.

Lemma eqb_trans {A} `{EqbSpec A} (x y z:A) : (x =? y) = true -> (y =? z) = true -> (x =? z) = true.
Proof.
  intros; apply eqb_eq in H1; apply eqb_eq in H2; apply eqb_eq; subst; trivial.
Qed.

(** List stuff *)

Fixpoint OrList (l:list bool) :=
  match l with
  | [] => false
  | h::l' => h ||| (OrList l')
  end.

Lemma OrListTrue : forall l, (exists x, x = true /\ In x l) <-> (OrList l = true).
Proof.
  induction l; split; intros.
  - repeat destruct H. destruct H0.
  - discriminate H.
  - destruct H; destruct H; simpl; destruct a; trivial;
    apply IHl; exists x; split; try assumption; simpl in H0;
    destruct H0; subst; try discriminate H0; assumption.
  - simpl; simpl in H; destruct a eqn:Heq.
    -- exists a; split; try assumption; left; symmetry; assumption.
    -- apply IHl in H; destruct H; exists x; destruct H; split; try assumption; right; assumption.
Qed.

Fixpoint AndList (l:list bool) :=
  match l with
  | [] => true
  | x::l' => x && AndList l'
  end.

Fixpoint list_assoc {A B}`{Eqb A} x (l:list (A*B)) :=
 match l with
 | [] => None
 | (y,z)::l => if x =? y then Some z else list_assoc x l
 end.

Fixpoint list_assoc_dft {A B}`{Eqb A} x (l:list (A*B)) (d:B) :=
 match l with
 | [] => d
 | (y,z)::l => if x =? y then z else list_assoc_dft x l d
 end.

Definition list_unassoc {A B}`{Eqb A} x : list (A*B) -> list (A*B) :=
 filter (fun '(y,_) => negb (y =? x)).

Fixpoint list_mem {A}`{Eqb A} x (l:list A) :=
  match l with
  | [] => false
  | y::l => (x =? y) ||| list_mem x l
  end.

Definition list_forallb2 {A B} (f: A -> B -> bool) :=
 fix forallb2 l1 l2 :=
 match l1, l2 with
 | [], [] => true
 | x1::l1, x2::l2 => f x1 x2 &&& forallb2 l1 l2
 | _, _ => false
 end.

Fixpoint list_index {A} `{Eqb A} (x:A) l : option nat :=
  match l with
  | [] => None
  | y::l => if x =? y then Some 0
            else option_map S (list_index x l)
  end.

Fixpoint list_max l :=
  match l with
  | [] => 0
  | n::l => Nat.max n (list_max l)
  end.

Ltac cons := constructor; congruence.

Instance eqb_inst_list {A}`{Eqb A} : Eqb (list A) := list_forallb2 eqb.

Instance eqbspec_list {A}`{EqbSpec A} : EqbSpec (list A).
Proof.
 red.
 induction x; destruct y; simpl; try cons.
 cbn.
 case eqbspec; [ intros <- | cons ].
 case IHx; cons.
Defined.
(* rename swap *)
Fixpoint swapb {A} `{EqbSpec A} (l1 l2: list A): bool :=
  match l1, l2 with
  | [], [] => false
  | [_], [_] => false
  | (x1::l1'), (x2::l2') => match l1', l2' with
                                       | (x1'::l1''), (x2'::l2'')
                                                => ((x1 =? x2') &&& (x1' =? x2) &&& (l1'' =? l2'')) ||| ((x1 =? x2) &&& swapb l1' l2')
                                       | _, _ => false
                                      end
  | _, _ => false
  end.

Lemma swapb_pattern {A} `{EqbSpec A}: forall l1 l2 a1 a2,
  swapb (l1 ++ a1 :: a2 :: l2)(l1 ++ a2 :: a1 :: l2) = true.
Proof.
  intros. generalize dependent l1.
  induction l2; intros; induction l1.
  - simpl; repeat rewrite eqb_refl; trivial.
  - simpl. destruct (l1 ++ [a1; a2]) eqn:Heq.
    + destruct l1; inversion Heq.
    + destruct (l1 ++ [a2; a1]) eqn:Heq'.
      ++ destruct l1; inversion Heq'.
      ++ apply lazy_orb_iff; right; rewrite eqb_refl; assumption.
  - repeat rewrite app_nil_l; simpl; rewrite lazy_orb_iff; left; repeat rewrite eqb_refl; trivial.
  - simpl. destruct (l1 ++ a1 :: a2 :: a :: l2) eqn:Heq.
    + destruct l1; inversion Heq.
    + destruct (l1 ++ a2 :: a1 :: a :: l2) eqn:Heq'.
      ++ destruct l1; inversion Heq'.
      ++ rewrite lazy_orb_iff; right; rewrite eqb_refl; assumption.
Qed.

Definition swap {A} `{EqbSpec A} (l1 l2:list A): Prop :=
  exists a1 a2 h t, l1 = h ++ a1 :: a2 :: t /\ l2 = h ++ a2 :: a1 :: t.

Lemma swapb_is_swap {A} `{EqbSpec A}:
  forall (l1 l2: list A), swapb l1 l2 = true <->  swap l1 l2.
Proof.
  split.
  - destruct l1; destruct l2; intros; try discriminate H1.
    + destruct l1; discriminate H1.
    + simpl in H1. revert dependent l2; revert a; revert a0. induction l1; destruct l2;
       try (intro; discriminate H1);
       intro; rewrite lazy_orb_iff in H1; destruct H1.
       * repeat rewrite lazy_andb_iff in H1; repeat rewrite eqb_eq in H1.
            destruct H1; destruct H1; subst; exists a2, a0, [], l2; intuition.
       * simpl in H1; rewrite lazy_andb_iff in H1; destruct H1; apply IHl1 in H2;
         apply eqb_eq in H1; subst;
         destruct H2; destruct H1; destruct H1; destruct H1; destruct H1; rewrite H1; rewrite H2;
         exists x, x0, (a0 :: x1), x2; intuition.
  - unfold swap; intros; destruct H1; destruct H1; destruct H1; destruct H1; destruct H1; subst;
    apply swapb_pattern.
Qed.

Lemma app_one_nil{A}: forall (c:A) (a:list A), not (a ++ [c] = []).
Proof.
  intros; unfold not; intros; destruct (app_cons_not_nil a [] c); symmetry; assumption.
Qed.

Lemma injection_rev{A}: forall (c1 c2:A) (a1 a2:list A),
      a1 ++ [c1] = a2 ++ [c2] -> a1 = a2 /\ c1 = c2.
Proof.
  induction a1; induction a2; intros; split; injection H as H; subst; trivial;
  try(destruct (app_one_nil c2 a2); symmetry; assumption);
  try(destruct (app_one_nil c1 a1); assumption);
  apply IHa1 in H0; destruct H0; subst; trivial.
Qed.

Lemma list_mem_in {A}`{EqbSpec A} (l : list A) x :
 list_mem x l = true <-> In x l.
Proof.
 induction l as [|a l IH]; simpl.
 - easy.
 - case eqbspec.
   + intros <-. intuition discriminate.
   + rewrite IH. intuition.
Qed.

Lemma InDec {A}`{EqbSpec A}: forall (l: list A)(a:A), (In a l) \/ ~ (In a l).
Proof.
  intros; destruct (list_mem a l) eqn:Heq.
  - apply list_mem_in in Heq; left; trivial.
  - right; unfold not; intro; apply list_mem_in in H1; rewrite H1 in Heq; discriminate Heq.
Qed.

Lemma list_assoc_in {A B}`{EqbSpec A} (l : list (A*B)) x :
 list_assoc x l <> None <-> In x (map fst l).
Proof.
 induction l as [|(a,b) l IH]; simpl.
 - easy.
 - case eqbspec.
   + intros <-. intuition discriminate.
   + rewrite IH. intuition.
Qed.

Lemma list_assoc_notin {A B}`{EqbSpec A} (l : list (A*B)) x :
 list_assoc x l = None <-> ~In x (map fst l).
Proof.
 induction l as [|(a,b) l IH]; simpl.
 - easy.
 - case eqbspec.
   + intros <-. intuition discriminate.
   + rewrite IH. intuition.
Qed.

Lemma list_assoc_in2 {A B}`{EqbSpec A} (l : list (A*B)) x y :
 list_assoc x l = Some y -> In (x,y) l.
Proof.
 induction l as [|(a,b) l IH]; simpl.
 - easy.
 - case eqbspec.
   + intros <- [= <-]. now left.
   + intuition.
Qed.

Lemma list_assoc_app_l {A B}`{EqbSpec A}
 (l l' : list (A*B)) x :
 In x (map fst l) -> list_assoc x (l++l') = list_assoc x l.
Proof.
 induction l as [|(a,b) l IH]; simpl; try easy.
 - case eqbspec; auto.
   intros NE [->|IN]; [easy|auto].
Qed.

Lemma list_assoc_app_r {A B}`{EqbSpec A}
 (l l' : list (A*B)) x :
 ~In x (map fst l) -> list_assoc x (l++l') = list_assoc x l'.
Proof.
 induction l as [|(a,b) l IH]; simpl; try easy.
 - case eqbspec; auto. intros <-. intuition.
Qed.

Lemma list_assoc_dft_alt {A B}`{EqbSpec A} (l : list (A*B)) x d :
 list_assoc_dft x l d =
 match list_assoc x l with
 | None => d
 | Some b => b
 end.
Proof.
 induction l as [|(a,b) l IH]; simpl; auto.
 rewrite IH. now case eqbspec.
Qed.

Lemma list_index_in {A}`{EqbSpec A} (l : list A) x :
  list_index x l <> None <-> In x l.
Proof.
 induction l as [|a l IH]; simpl.
 - easy.
 - case eqbspec.
   + intros <-. intuition discriminate.
   + destruct list_index; simpl. intuition easy. intuition.
Qed.

Lemma list_index_notin {A}`{EqbSpec A} (l : list A) x :
  list_index x l = None <-> ~In x l.
Proof.
 induction l as [|a l IH]; simpl.
 - easy.
 - case eqbspec.
   + intros <-. intuition discriminate.
   + destruct list_index; simpl. intuition easy. intuition.
Qed.

Lemma list_index_nth {A}`{EqbSpec A} (l : list A) n d :
 NoDup l ->
 n < List.length l ->
 list_index (nth n l d) l = Some n.
Proof.
 revert n.
 induction l; simpl.
 - inversion 2.
 - intros n. inversion_clear 1.
   destruct n.
   + now rewrite eqb_refl.
   + intros Hn.
     rewrite IHl; auto with arith; simpl.
     case eqbspec; auto.
     intros <-. destruct H2. apply nth_In. auto with arith.
Qed.

Lemma list_index_lt_length {A}`{EqbSpec A} (l : list A) x n :
  list_index x l = Some n -> n < List.length l.
Proof.
 revert n.
 induction l; simpl. easy.
 intros n.
 case eqbspec.
 - intros <- [= <-]. auto with arith.
 - destruct list_index; simpl in *; intros NE [= <-].
   specialize (IHl n0 eq_refl). auto with arith.
Qed.

Lemma list_index_app_l {A}`{EqbSpec A} x (l l' : list A) :
 In x l ->
 list_index x (l++l') = list_index x l.
Proof.
 induction l; simpl; try easy.
 case eqbspec; auto.
 intros NE Hl. rewrite IHl; auto. intuition. congruence.
Qed.

Lemma list_index_app_l' {A}`{EqbSpec A} x (l l' : list A) :
 ~In x l' ->
 list_index x (l++l') = list_index x l.
Proof.
 induction l; simpl.
 - apply list_index_notin.
 - case eqbspec; auto.
   intros NE Hl. now rewrite IHl.
Qed.

Lemma list_index_app_r {A}`{EqbSpec A} x (l l' : list A) :
 ~In x l ->
 list_index x (l++l') =
  option_map (Nat.add (length l)) (list_index x l').
Proof.
 induction l; simpl.
 - now destruct (list_index x l').
 - case eqbspec.
   + intros ->. intuition.
   + intros NE Hl. rewrite IHl by intuition. now destruct (list_index x l').
Qed.

Lemma list_assoc_index_none {A B}`{EqbSpec A} x (l:list (A*B)) :
  list_assoc x l = None <-> list_index x (map fst l) = None.
Proof.
 induction l as [|(a,b) l IH]; simpl; auto.
 intuition.
 case eqbspec; try easy.
 intros NE. rewrite IH.
 destruct list_index; simpl; intuition congruence.
Qed.

Lemma filter_app {A} (f:A->bool) l l' :
  filter f (l++l') = filter f l ++ filter f l'.
Proof.
 induction l as [|a l IH]; simpl; auto.
 destruct (f a); [simpl; f_equal|]; auto.
Qed.

Lemma unassoc_app {A B}`{Eqb A} x (l1 l2 : list (A*B)) :
 list_unassoc x (l1++l2) = list_unassoc x l1 ++ list_unassoc x l2.
Proof.
 unfold list_unassoc.
 apply filter_app.
Qed.

Lemma unassoc_in {A B}`{EqbSpec A} x a b (l : list (A*B)) :
 In (a,b) (list_unassoc x l) <-> In (a,b) l /\ a <> x.
Proof.
 unfold list_unassoc.
 now rewrite filter_In, <- eqb_neq, negb_true_iff.
Qed.

(** Max and lists *)

Lemma max_S : forall n m, (S(Nat.max n m) = Nat.max (S n) (S m)).
Proof.
  induction n; induction m; simpl; trivial.
Qed.

Lemma max_pred : forall n m, (Nat.pred(Nat.max n m) = Nat.max (Nat.pred n) (Nat.pred m)).
Proof.
  induction n; induction m; simpl; trivial; rewrite Nat.max_0_r; trivial.
Qed.

Lemma le_max: forall n m, n <= Nat.max n m /\ m <= Nat.max n m.
Proof.
   intros; lia.
Qed.

Lemma le_max_bis: forall n m, Nat.max n m <= n \/ Nat.max n m <= m.
Proof.
  intros; lia.
Qed.

Lemma max_le n m p : Nat.max n m <= p <-> n <= p /\ m <= p.
Proof.
 lia.
Qed.

Lemma max_eq n m p : Nat.max n m = p -> n = p \/ m = p.
Proof.
  intros.
  generalize dependent p; generalize dependent m; induction n; intros.
  + simpl in H; right; assumption.
  + destruct m.
    ++ simpl in H; left; trivial.
    ++ rewrite <- max_S in H; destruct p.
      +++ discriminate H.
      +++ injection H as H. apply IHn in H. destruct H; subst; intuition.
Qed.

Lemma max_lt n m p : Nat.max n m < p <-> n < p /\ m < p.
Proof.
 lia.
Qed.

Lemma max_0 n m : Nat.max n m = 0 <-> n=0 /\ m=0.
Proof.
 lia.
Qed.

Lemma le_pred_S : forall n m, Nat.pred n <= m <-> n <= S m.
Proof.
  intros; lia.
Qed.

Lemma eq_pred_S : forall n m, Nat.pred n = m -> n <= S m.
Proof.
  induction n; intros.
  - simpl in H; subst; constructor; trivial.
  - simpl in H; subst; trivial.
Qed.

Lemma eq_pred_S' : forall n m, 1 <= n -> (Nat.pred n = m <-> n = S m).
Proof.
  split; induction n; intros.
  - inversion H.
  - simpl in H0; subst; trivial.
  - discriminate H0.
  - simpl; injection H0 as H0; assumption.
Qed.

Lemma max_mono a a' b b' :
 a <= a' -> b <= b' -> Nat.max a b <= Nat.max a' b'.
Proof.
 lia.
Qed.

Lemma list_max_le l p :
 list_max l <= p <-> (forall n, In n l -> n <= p).
Proof.
 induction l; simpl; rewrite ?max_le in *; intuition; lia.
Qed.

(** /!\ The other direction is only true for non-empty lists *)

Lemma list_max_lt l p :
 list_max l < p -> (forall n, In n l -> n < p).
Proof.
 induction l; simpl; rewrite ?max_lt in *; intuition; lia.
Qed.

Lemma list_max_0 l :
 list_max l = 0 <-> forall n, In n l -> n = 0.
Proof.
 induction l; simpl; rewrite ?max_0 in *; intuition; lia.
Qed.

Lemma list_max_map_le {A} (f:A->nat) l p :
 list_max (map f l) <= p <-> (forall a : A, In a l -> f a <= p).
Proof.
 rewrite list_max_le. split.
 - intros H a Ha. now apply H, in_map.
 - intros H n. rewrite in_map_iff. intros (a & <- & Ha). auto.
Qed.

Lemma list_max_map_0 {A} (f:A->nat) l :
 list_max (map f l) = 0 <-> (forall a : A, In a l -> f a = 0).
Proof.
 rewrite list_max_0. split.
 - intros H a Ha. now apply H, in_map.
 - intros H n. rewrite in_map_iff. intros (a & <- & Ha). auto.
Qed.

Lemma list_max_map_incr {A} (f g : A->nat) l :
 (forall a, In a l -> f a <= g a) ->
 list_max (map f l) <= list_max (map g l).
Proof.
 intros H.
 induction l; cbn in *; auto.
 apply max_mono; auto.
Qed.

(** Map *)

Lemma map_ext_iff {A B} (f g : A -> B) l :
  (forall a : A, In a l -> f a = g a) <-> map f l = map g l.
Proof.
 induction l; cbn.
 - intuition.
 - split.
   + intros H. f_equal; auto. apply IHl; auto.
   + intros [= H H'] b [->|Hb]; rewrite <-?IHl in H'; auto.
Qed.

Lemma map_id_iff {A} (f : A -> A) l :
  (forall a : A, In a l -> f a = a) <-> map f l = l.
Proof.
 rewrite <- (map_id l) at 2. apply map_ext_iff.
Qed.

Lemma forallb_map {A B} (f: B -> bool) (g: A -> B) l :
 forallb f (map g l) = forallb (fun x => f (g x)) l.
Proof.
 induction l; simpl; f_equal; auto.
Qed.

(** Logic *)

Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q. intros Hi. intros Hf. unfold not. unfold not in Hf. intros Hg.
  apply Hf.  apply Hi. apply Hg.
Qed.

Lemma not_inv:
  forall (P:Prop), P-> ~~P.
Proof.
  intros; unfold not; intros; destruct H0; assumption.
Qed.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Structures.Functor.
From Coq Require Import
     Basics.
From ExtLib Require Import
     Extras
     OptionMonad.
Import
  FunNotation
  FunctorNotation.
Open Scope program_scope.

Set Implicit Arguments.
Set Strict Implicit.

Section keyed.
  Variable K : Type.
  Variable R : K -> K -> Prop.
  Variable RD_K : RelDec R.

  Variable V : Type.

  Definition alist : Type := list (K * V).

  Definition alist_remove (k : K) (m : alist) : alist :=
    List.filter (fun x => negb (k ?[ R ] (fst x))) m.

  Definition alist_add (k : K) (v : V) (m : alist) : alist :=
    (k, v) :: alist_remove k m.

  Fixpoint alist_find (k : K) (m : alist) : option V :=
    match m with
      | nil => None
      | (k',v) :: ms =>
        if k ?[ R ] k' then
          Some v
        else
          alist_find k ms
    end.

  Definition alist_find' (k: K) : alist -> option V :=
    fmap snd ∘ find (rel_dec k ∘ fst).

  Lemma alist_find_alt (m: alist) : forall k: K,
      alist_find k m = alist_find' k m.
  Proof.
    induction m; intuition.
    unfold alist_find', compose.
    simpl.
    destruct (k ?[ R ] a0) eqn:Heq; [intuition|].
    rewrite IHm.
    reflexivity.
  Qed.

  Section fold.
    Import MonadNotation.
    Local Open Scope monad_scope.

    Variables T : Type.
    Variable f : K -> V -> T -> T.

    Fixpoint fold_alist (acc : T) (map : alist) : T :=
      match map with
        | nil => acc
        | (k,v) :: m =>
          let acc := f k v acc in
          fold_alist acc m
      end.

    Definition fold_alist' : T -> alist -> T :=
      flip $ fold_left (flip $ uncurry f).

    Lemma fold_alist_alt (map: alist) : forall acc: T,
        fold_alist acc map = fold_alist' acc map.
    Proof.
      induction map; intuition.
      simpl.
      rewrite IHmap.
      reflexivity.
    Qed.

  End fold.

  Definition alist_union (m1 m2 : alist) : alist :=
    fold_alist alist_add m2 m1.

  Global Instance Map_alist : Map K V alist :=
  { empty  := nil
  ; add    := @alist_add
  ; remove := alist_remove
  ; lookup := alist_find
  ; union  := @alist_union
  }.

  Section proofs.
    Hypothesis RDC_K : RelDec_Correct RD_K.

    Hypothesis Refl : Reflexive R.
    Hypothesis Sym : Symmetric R.
    Hypothesis Trans : Transitive R.

    Definition mapsto_alist (m : alist) k v : Prop :=
      alist_find k m = Some v.

    Lemma mapsto_alist_cons : forall k v m k' v',
                                mapsto_alist ((k',v') :: m) k v <->
                                (   (mapsto_alist m k v /\ ~R k k')
                                 \/ (R k k' /\ v = v')).
    Proof.
      unfold mapsto_alist; intuition; simpl in *.
      { consider (k ?[ R ] k'); intros.
        { right. inversion H0; auto. }
        { left. auto. } }
      { consider (k ?[ R ] k'); intros; intuition. }
      { consider (k ?[ R ] k'); intros; intuition. congruence. }
    Qed.

    Theorem mapsto_lookup_alist : forall (k : K) (v : V) (m : list (K * V)),
                                   lookup k m = Some v <-> mapsto_alist m k v.
    Proof.
      reflexivity.
    Qed.

    Theorem mapsto_remove_eq_alist : forall (m : list (K * V)) (k : K) (v : V),
                                       ~mapsto_alist (remove k m) k v.
    Proof.
      unfold mapsto_alist, remove, alist_remove; simpl. intros.
      induction m; simpl; auto.
      { congruence. }
      { destruct a; simpl in *.
        consider (k ?[ R ] k0); auto; intros.
        simpl. consider (k ?[ R ] k0); auto. }
    Qed.

    Theorem mapsto_remove_neq_alist : forall (m : list (K * V)) (k : K),
                                      forall k', ~ R k k' -> forall v', (mapsto_alist m k' v' <-> mapsto_alist (remove k m) k' v').
    Proof.
      unfold mapsto_alist, add; simpl. intros.
      induction m; simpl in *.
      { intuition. }
      { destruct a. simpl in *.
        consider (k' ?[ R ] k0); intros.
        { consider (k ?[ R ] k0); intros.
          { exfalso. eauto. }
          { simpl. consider (k' ?[ R ] k0); intros.
            { intuition. }
            { exfalso; auto. } } }
        { rewrite IHm.
          consider (k ?[ R ] k0); simpl; intros.
          { intuition. }
          { consider (k' ?[ R ] k0); intros.
            { exfalso; auto. }
            { intuition. } } } }
    Qed.

    Theorem mapsto_add_eq_alist : forall (m : list (K * V)) (k : K) (v : V),
                                 mapsto_alist (add k v m) k v.
    Proof.
      unfold mapsto_alist, add, alist_add; simpl. intros.
      consider (k ?[ R ] k); auto.
      intro. exfalso. apply H. reflexivity.
    Qed.

    Theorem mapsto_add_neq_alist : forall (m : list (K * V)) (k : K) (v : V),
                                     forall k', ~ R k k' -> forall v', (mapsto_alist m k' v' <-> mapsto_alist (add k v m) k' v').
    Proof.
      unfold mapsto_alist, add; simpl. intros.
      consider (k' ?[ R ] k); try solve [ intros; exfalso; auto ].
      intros. eapply mapsto_remove_neq_alist in H. eapply H.
    Qed.

    Theorem remove_eq_alist:
      forall (m : alist) (k : K), alist_find k (alist_remove k m) = None.
    Proof.
      unfold mapsto_alist.
      induction m; simpl; eauto; try congruence.
      intros; consider (k ?[ R ] fst a); simpl; intros; eauto.
      destruct a; simpl in *.
      consider (k ?[ R ] k0); eauto. tauto.
    Qed.

    Theorem remove_neq_alist:
      forall (m : alist) (k k' : K), ~R k' k -> alist_find k (alist_remove k' m) = alist_find k m.
    Proof.
      unfold mapsto_alist.
      induction m; simpl; eauto; try congruence.
      destruct a; simpl.
      intros; consider (k' ?[ R ] k); simpl; intros; eauto.
      { consider (k0 ?[ R ] k); intros; eauto.
        exfalso. eapply H. etransitivity; eauto. }
      { consider (k0 ?[ R ] k); eauto. }
    Qed.

    Global Instance MapLaws_alist : MapOk R Map_alist.
    Proof.
      refine {| mapsto := fun k v m => mapsto_alist m k v |};
      eauto using mapsto_lookup_alist, mapsto_add_eq_alist, mapsto_add_neq_alist.
      { intros; intro. inversion H. }
      { unfold mapsto_alist; simpl. intros.
        rewrite remove_eq_alist. congruence. }
      { unfold mapsto_alist. simpl; intros.
        erewrite (@remove_neq_alist m _ _ H).
        reflexivity. }
    Defined.

  End proofs.

  Global Instance Foldable_alist : Foldable alist (K * V) :=
    fun _ f b => fold_alist (fun k v => f (k,v)) b.

End keyed.

Global Instance Functor_alist K : Functor (alist K) :=
{ fmap := fun T U f => map (fun x => (fst x, f (snd x))) }.

(** Performance Test **)
(*
Module TEST.
  Definition m := alist nat nat.
  Instance Map_m : Map nat (alist nat).
    apply Map_alist. eauto with typeclass_instances.
  Defined.

  Definition z : m :=
    (fix fill n acc : m :=
      let acc := add n n acc in
      match n with
        | 0 => acc
        | S n => fill n acc
      end) 500 empty.

  Time Eval compute in
    let z := z in
    (fix find_all n : unit :=
      let _ := lookup n z in
      match n with
        | 0 => tt
        | S n => find_all n
      end) 500.
End TEST.
*)


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

    Author: Brian Aydemir. *)

Require Import FSets.
Require Import ListFacts.
Require Import Coq.Logic.ProofIrrelevance.

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

  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.MSet.Raw.t in *.
      eapply Sort_InA_eq_ext; eauto.
      intros; eapply E.lt_trans; eauto.
      1 : {
        intros x y H x_eq_y.
        simpl in H.
        apply (OFacts.eq_not_lt x_eq_y H).
      }
      1 : {
        apply F.MSet.Raw.isok_iff.
        auto.
      }
    apply F.MSet.Raw.isok_iff, pf2.
    subst s1.
    assert (pf1 = pf2).
    apply proof_irrelevance.
    subst pf2.
    reflexivity.
  Qed.

  (* end hide *)

End Make.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** THIS FILE IS DEPRECATED. Use [PeanoNat.Nat] instead. *)

Require Import PeanoNat.

Local Open Scope nat_scope.
Implicit Types m n p : nat.

Notation min := Nat.min (only parsing).

Definition min_0_l := Nat.min_0_l.
Definition min_0_r := Nat.min_0_r.
Definition succ_min_distr := Nat.succ_min_distr.
Definition plus_min_distr_l := Nat.add_min_distr_l.
Definition plus_min_distr_r := Nat.add_min_distr_r.
Definition min_case_strong := Nat.min_case_strong.
Definition min_spec := Nat.min_spec.
Definition min_dec := Nat.min_dec.
Definition min_case := Nat.min_case.
Definition min_idempotent := Nat.min_id.
Definition min_assoc := Nat.min_assoc.
Definition min_comm := Nat.min_comm.
Definition min_l := Nat.min_l.
Definition min_r := Nat.min_r.
Definition le_min_l := Nat.le_min_l.
Definition le_min_r := Nat.le_min_r.
Definition min_glb_l := Nat.min_glb_l.
Definition min_glb_r := Nat.min_glb_r.
Definition min_glb := Nat.min_glb.

(* begin hide *)
(* Compatibility *)
Notation min_case2 := min_case (only parsing).
Notation min_SS := Nat.succ_min_distr (only parsing).
(* end hide *)


Require Import PropX PropXTac.
Require Import Setoid Classes.Morphisms.

Section machine.
  Variable pc st : Type.

  Definition PropX_imply cs (l r : PropX pc st) : Prop :=
    interp cs (Imply l r).

  Definition PropX_eq cs (l r : PropX pc st) : Prop :=
    PropX_imply cs l r /\ PropX_imply cs r l.

  Theorem PropX_imply_refl cs : Reflexive (PropX_imply cs).
  Proof.
    unfold Reflexive, PropX_imply. intros.
      eapply Imply_I. econstructor. left; auto.
  Qed.

  Theorem PropX_imply_trans cs : Transitive (PropX_imply cs).
  Proof.
    unfold Transitive, PropX_imply. intros.
      eapply Imply_I. eapply Imply_E.
      eapply valid_weaken. eassumption. compute; intros; auto.
      eapply Imply_E. eapply valid_weaken. eassumption. compute; intros; auto.
      propxFo.
  Qed.

  Theorem PropX_eq_refl cs : Reflexive (PropX_eq cs).
  Proof.
    unfold Reflexive, PropX_eq. generalize (PropX_imply_refl cs). intuition eauto.
  Qed.

  Theorem PropX_eq_sym cs : Symmetric (PropX_eq cs).
  Proof.
    unfold Symmetric, PropX_eq. intuition.
  Qed.

  Theorem PropX_eq_trans cs : Transitive (PropX_eq cs).
  Proof.
    unfold Transitive, PropX_eq. generalize PropX_imply_trans.
      intuition;  eapply H; eauto.
  Qed.

  Add Parametric Relation cs : (@PropX pc st) (@PropX_imply cs)
    reflexivity proved by (PropX_imply_refl cs)
    transitivity proved by (PropX_imply_trans cs)
  as imply_rel.

  Add Parametric Relation cs : (@PropX pc st) (@PropX_eq cs)
    reflexivity proved by (PropX_eq_refl cs)
    symmetry proved by (PropX_eq_sym cs)
    transitivity proved by (PropX_eq_trans cs)
  as eq_rel.

  Global Add Parametric Morphism cs : (interp cs) with
    signature (PropX_imply cs ==> Basics.impl)
  as interp_imply.
    intros. intro. eapply Imply_E; eauto.
  Qed.

  Global Add Parametric Morphism cs : (interp cs) with
    signature (PropX_eq cs ==> iff)
  as interp_eq.
    unfold PropX_eq.
    intros. generalize (interp_imply cs). unfold Basics.impl. intuition;
    eapply H0; eauto.
  Qed.
End machine.

Require Import List.

(* I'm sure this is duplication of work *)
Section tactic.
  Variable pcType : Type.
  Variable stateType : Type.

  Variable cs : codeSpec pcType stateType.

  Lemma valid_extend : forall Ps Q R,
    valid cs Ps Q ->
    valid cs (Q :: Ps) R ->
    valid cs Ps R.
  Proof.
    intros.
    eapply Imply_I in H0.
    eapply Imply_E. eassumption.
    eauto.
  Qed.

  Lemma valid_and_split : forall P Ps Q R,
    valid cs ((P /\ Q) :: Ps)%PropX R <->
    valid cs (P :: Q :: Ps)%PropX R.
  Proof.
    split; intros.
    eapply Imply_I in H. eapply Imply_E. eapply valid_weaken. eassumption.
    firstorder.
    eapply And_I; econstructor; firstorder.

    eapply valid_extend. eapply And_E1. econstructor; firstorder.
    eapply valid_extend. eapply And_E2. econstructor; firstorder.
    eapply valid_weaken; eauto. firstorder.
  Qed.

  Lemma valid_perm : forall A B C,
    valid cs (A :: B) C <->
    valid cs (B ++ A :: nil) C.
  Proof.
    split; intros.
    eapply valid_weaken; eauto. intuition.
    eapply valid_weaken; eauto. intuition.
    eapply incl_app; intuition. firstorder.
  Qed.

  Lemma valid_inj :  forall (A : Prop) B C,
    (A -> valid cs B C) ->
    valid cs ([| A |] :: B)%PropX C.
  Proof.
    intros. eapply Inj_E. econstructor; firstorder. intro.
    eapply H in H0.
    eapply valid_weaken; eauto. intuition.
  Qed.

  Lemma valid_ex_clear : forall T (F : T -> PropX pcType stateType) Ps R ,
    (forall x, valid cs (F x :: Ps)%PropX R) ->
    valid cs ((PropX.Exists F) :: Ps)%PropX R.
  Proof.
    intros. eapply Exists_E. econstructor. firstorder.
    intros. eapply valid_weaken. eauto.
    instantiate (1 := B). firstorder.
  Qed.
End tactic.

Ltac propxIntuition :=
  repeat (instantiate; match goal with
                         | [ |- valid _ ((Ex x : _ , _) :: _)%PropX _ ] =>
                           eapply valid_ex_clear; intros
                         | [ |- valid _ ((_ /\ _) :: _)%PropX _ ] =>
                           eapply valid_and_split
                         | [ |- valid _ _ (_ ---> _) ] =>
                           eapply Imply_I
                         | [ |- valid _ ([| _ |] :: _)%PropX _ ] =>
                           eapply valid_inj; intros
                         | [ |- valid _ (_ :: ?X) _ ] =>
                           match X with
                             | context [ (_ /\ _)%PropX ] =>
                               eapply valid_perm; simpl
                             | context [ (Ex x : _ , _)%PropX ] =>
                               eapply valid_perm; simpl
                             | context [ ([| _ |])%PropX ] =>
                               eapply valid_perm; simpl
                           end
                         | [ |- valid _ _ (_ /\ _)%PropX ] =>
                           eapply And_I
(*
                         | [ |- valid _ _ (Ex x : _ , _)%PropX ] =>
                           eapply Exists_I
*)
                         | [ |- valid _ _ (?X _ _) ] =>
                           match X with
                             | @Inj _ _ => fail 1
                             | _ =>
                               solve [ econstructor; firstorder ]
                           end
                         | [ |- valid _ _ ([| _ |])%PropX ] =>
                           eapply Inj_I
                       end).

Section more.
  Variables pc st : Type.

  Global Add Parametric Morphism cs : (@And pc st nil) with
    signature (PropX_eq pc st cs ==> PropX_eq pc st cs ==> PropX_eq pc st cs)
  as And_mor.
    unfold PropX_eq, PropX_imply;
    intuition; unfold interp in *; propxIntuition;
    (eapply Imply_E; [ eapply valid_weaken; eauto; firstorder | econstructor; firstorder ]).
  Qed.
End more.


(***************************************************************************)
(*   This is part of FA_Landau, it is distributed under the terms of the   *)
(*             GNU Lesser General Public License version 3                 *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

(* REALS *)

(* SECTION V Dedekind's Fundamental Theorem *)

Require Export reals.

Section Dedekind.

Variable Fst Snd :Ensemble Real.

Definition R_Divide := ∀ Ξ, Ξ ∈ Fst \/ Ξ ∈ Snd.

Definition ILT_FS := ∀ Ξ Γ, Ξ ∈ Fst -> Γ ∈ Snd -> Ξ < Γ.

Definition Split Ξ :=
  (∀ Γ, Γ < Ξ -> Γ ∈ Fst) /\ (∀ Γ, Γ > Ξ -> Γ ∈ Snd).

Corollary Split_Pa : ∀ Ξ1 Ξ2,
  R_Divide -> ILT_FS -> Ξ1 ∈ Fst -> Ξ2 < Ξ1 -> Ξ2 ∈ Fst.
Proof.
  intros; destruct H with Ξ2; auto; LGR H2 (H0 _ _ H1 H3).
Qed.

Corollary Split_Pb : ∀ Ξ1 Ξ2,
  R_Divide -> ILT_FS -> Ξ1 ∈ Snd -> Ξ1 < Ξ2 -> Ξ2 ∈ Snd.
Proof.
  intros;  destruct H with Ξ2; auto; LGR H2 (H0 _ _ H3 H1).
Qed.

Corollary Split_Pc : ∀ Ξ,
  R_Divide -> ILT_FS -> Ξ ∈ Fst -> Ξ ∈ Snd -> False.
Proof.
  intros; pose proof (H0 _ _ H1 H2); apply OrdR1 in H3; auto.
Qed.

End Dedekind.

Theorem DedekindCut_Unique : ∀ Fst Snd, R_Divide Fst Snd ->
  No_Empty Fst -> No_Empty Snd -> ILT_FS Fst Snd ->
  ∀ Z1 Z2, Split Fst Snd Z1 -> Split Fst Snd Z2 -> Z1 = Z2.
Proof.
  assert (∀ Fst Snd, R_Divide Fst Snd -> No_Empty Fst ->
    No_Empty Snd -> ILT_FS Fst Snd -> ∀ Ξ1 Ξ2, Split Fst Snd Ξ1 ->
    Split Fst Snd Ξ2 -> ~ Ξ1 < Ξ2).
  { intros; intro; red in H, H0, H1, H2, H3, H4; destruct H3, H4.
    assert (neq_zero 2). { reflexivity. }
    assert (Ξ1 < ((Ξ1 + Ξ2) / (1 + 1)) H8).
    { apply Theorem203_1' with (Θ:=(1 + 1)); Simpl_R.
      rewrite Theorem201; Simpl_R.
      rewrite (Theorem175 Ξ1 Ξ2); apply Theorem188_1'; auto. }
    assert (((Ξ1 + Ξ2) / (1 + 1)) H8 < Ξ2).
    { apply Theorem203_1' with (Θ:=(1 + 1)); Simpl_R.
      rewrite Theorem201; Simpl_R; apply Theorem188_1'; auto. }
    apply H6 in H9; apply H4 in H10.
    eapply Split_Pc in H9; eauto. }
  intros; destruct (Theorem167 Z1 Z2) as [H6 | [H6 | H6]]; auto;
  eapply H in H6; eauto; tauto.
Qed.

Definition ded_C Fst :=
  /{X|(P X*)∈Fst /\ (∃ Ξ, Ξ∈Fst /\ (P X*)<Ξ)/}.

Lemma Lemma_DFTa : ∀ Fst Snd, R_Divide Fst Snd ->
  No_Empty Snd -> ILT_FS Fst Snd -> (∃ a, P a ∈ Fst) ->
  Cut_p1 (ded_C Fst) /\ Cut_p2 (ded_C Fst) /\ Cut_p3 (ded_C Fst).
Proof.
  intros; destruct H2 as [ξ H2]; repeat split.
  - EC Z ξ H3; exists Z; constructor; split.
    + eapply Split_Pa; eauto; simpl; apply Theorem158_1; auto.
    + apply (cutp3 ξ) in H3; destruct H3 as  [X [H3 H4]].
      assert (Num_L X ξ); auto. apply Theorem158_1 in H5.
      apply Theorem82 in H4; exists (P X); split.
      * eapply Split_Pa; eauto.
      * simpl; apply Theorem154_3; auto.
  - destruct H0 as [Ξ H0], Ξ; pose proof (H1 _ _ H2 H0);
    simpl in H3; try tauto. ENC W c H4; apply Theorem158_2 in H4.
    exists W; intro; destruct H5, H5, H4.
    + assert ((P W) ∈ Snd).
      { eapply Split_Pb ; eauto; simpl; auto. }
      eapply Split_Pc; eauto.
    + rewrite <- (eq2 H4) in H0; eapply Split_Pc; eauto.
  - destruct H3, H3; eapply Split_Pa; eauto; simpl.
    apply Theorem154_3; auto.
  - destruct H3, H3; apply Theorem91 in H4.
    destruct H4 as [Z [H4 H6]]. exists (P Z); split.
    + eapply Split_Pa; eauto; simpl; apply Theorem154_3; auto.
    + simpl; apply Theorem154_3; auto.
  - red; intros; destruct H3, H3, H4 as [Ξ [H4 H5]], Ξ;
    simpl in H5; try tauto. apply Theorem159 in H5; destruct H5 as
      [Z [H5 H6]]. exists Z; split; try (constructor; split).
    * eapply Split_Pa; eauto.
    * exists (P c); split; auto.
    * apply Theorem83; apply Theorem154_3'; auto.
Qed.

Definition Ded_C Fst Snd (l1 :R_Divide Fst Snd) (l2 :No_Empty Snd)
  (l3 :ILT_FS Fst Snd) (l4 :∃ ξ, P ξ ∈ Fst) : Cut.
  apply mkcut with (ded_C Fst); eapply Lemma_DFTa; eauto.
Defined.

Definition Opp_En Fst := /{ Ξ | (-Ξ) ∈ Fst /}.

Lemma Lemma_DFTb : ∀ Fst Snd, R_Divide Fst Snd ->
  No_Empty Fst -> No_Empty Snd -> ILT_FS Fst Snd ->
  R_Divide (Opp_En Snd) (Opp_En Fst) /\ No_Empty (Opp_En Snd)
  /\ No_Empty (Opp_En Fst) /\  ILT_FS (Opp_En Snd) (Opp_En Fst).
Proof.
  repeat split; red in *; intros.
  - destruct H with (-Ξ); [right|left]; constructor; auto.
  - destruct H1 as [Ξ H1]; exists (-Ξ); constructor; Simpl_R.
  - destruct H0 as [Ξ H0]; exists (-Ξ); constructor; Simpl_R.
  - destruct H3, H4; eapply H2 in H3; eauto.
    apply Theorem183_1'; auto.
Qed.

Lemma Lemma_DFTc : ∀ Fst Snd, R_Divide Fst Snd -> No_Empty Fst ->
   No_Empty Snd -> ILT_FS Fst Snd ->
   (∃ ξ, (P ξ) ∈ Fst) -> (∃ Ξ, Split Fst Snd Ξ).
Proof.
  intros; set (ξ := (Ded_C Fst Snd H H1 H2 H3)).
  exists (P ξ); split; intros Γ H4.
  - elim H3; intros η H5. destruct H with Γ; auto.
    pose proof (H2 _ _ H5 H6). destruct Γ; simpl in H7; try tauto.
    simpl in H4; apply Theorem159 in H4.
    destruct H4 as [X [H4 H8]]. apply Theorem158_1 in H8.
    destruct H8, H8. apply (Split_Pa Fst Snd (P X) (P c)); auto.
  - destruct Γ; simpl in H4; try tauto. apply Theorem159 in H4;
    destruct H4 as [X [H4 H5]]. destruct H with (P c); auto.
    apply (Split_Pb Fst Snd (P X) (P c)); auto.
    assert (Num_U X ξ). { apply Theorem158_2; left; auto. }
    elim H7; constructor; split; eauto.
    apply (Split_Pa Fst Snd (P c) (P X)); auto.
Qed.

Theorem DedekindCut : ∀ Fst Snd, R_Divide Fst Snd -> No_Empty Fst
  -> No_Empty Snd -> ILT_FS Fst Snd -> (∃ Ξ, Split Fst Snd Ξ).
Proof.
  intros; destruct (classic (∃ ξ, (P ξ) ∈ Fst)) as [H3 |H3].
  - apply Lemma_DFTc; auto.
  - destruct (classic (O ∈ Fst)) as [H4 |H4].
    + exists O; red; split; intros Ξ H5.
      * destruct Ξ; inversion H5; destruct H with (N c); auto.
        elim (H2 _ _ H4 H6).
      * destruct Ξ; inversion H5; destruct H with (P c); auto.
        elim H3; eauto.
    + destruct (classic (~ (∃ ξ, (N ξ) ∈ Snd))) as [H5 |H5].
      * exists O; red; split; intros Ξ H6.
        { destruct Ξ; inversion H6; destruct H with (N c); auto;
          elim H5; eauto. }
        { destruct Ξ; inversion H6; destruct H with (P c); auto;
          elim H3; eauto. }
      * apply -> property_not' in H5.
        assert (∃ ξ, (P ξ) ∈ (Opp_En Snd)).
        { destruct H5 as [ξ H5]; exists ξ; constructor. auto. }
        destruct (Lemma_DFTb _ _ H H0 H1 H2), H8, H9.
        destruct (Lemma_DFTc _ _ H7 H8 H9 H10 H6) as [Ξ H11].
        destruct H11; exists (-Ξ); split; intros Γ H13.
        { apply Theorem183_1 in H13; rewrite Theorem177 in H13.
          apply H12 in H13; destruct H13;
          rewrite Theorem177 in H13; auto. }
        { apply Theorem183_1 in H13; rewrite Theorem177 in H13.
          apply H11 in H13; destruct H13;
          rewrite Theorem177 in H13; auto. }
Qed.


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

Benedikt Ahrens, Chris Kapulkin, Mike Shulman
january 2013

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

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

Contents :  Definition of adjunction

	    Definition of equivalence of precategories

	    Equivalence of categories yields weak equivalence
            of object types

            A fully faithful and ess. surjective functor induces
            equivalence of precategories, if the source
            is a category.

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

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
(*Local Notation "'hom' C" := (precategory_morphisms (C := C)) (at level 2).*)
Local Notation "f ;; g" := (compose f g)(at level 50).
Notation "[ C , D ]" := (functor_precategory C D).
Local Notation "# F" := (functor_on_morphisms F)(at level 3).

Definition functor_composite (A B C : precategory) (F : ob [A, B])
      (G : ob [B , C]) : ob [A , C] :=
   functor_composite _ _ _ F G.

Notation "G 'O' F" := (functor_composite _ _ _ F G) (at level 25).

(** * Adjunction *)

Definition form_adjunction (A B : precategory) (F : ob [A, B])
       (G : ob [B, A])
       (eta : nat_trans (functor_identity A) (pr1 (G O F)))
       (eps : nat_trans (pr1 (F O G)) (functor_identity B)) : UU :=
dirprod
  (forall a : ob A,
       # (pr1 F) (pr1 eta a) ;;   pr1 eps (pr1 F a) == identity (pr1 F a))
  (forall b : ob B,
       pr1 eta (pr1 G b) ;; # (pr1 G) (pr1 eps b) == identity (pr1 G b)).

Definition are_adjoints (A B : precategory) (F : ob [A, B])
    (G : ob [B, A]) : UU :=
  total2 (fun etaeps : dirprod
            (nat_trans (functor_identity A) (pr1 (G O F)))
            (nat_trans (pr1 (F O G)) (functor_identity B)) =>
      form_adjunction A B F G (pr1 etaeps) (pr2 etaeps)).

Definition is_left_adjoint (A B : precategory) (F : ob [A, B]) : UU :=
   total2 (fun G : ob [B, A] => are_adjoints A B F G).

Definition right_adjoint {A B : precategory} {F : ob [A, B]}
      (H : is_left_adjoint _ _ F) : functor B A := pr1 H.

Definition eta_from_left_adjoint {A B : precategory} {F : ob [A, B]}
      (H : is_left_adjoint _ _ F) :
  nat_trans (functor_identity A) (pr1 (pr1 H O F)) := pr1 (pr1 (pr2 H)).

Definition eps_from_left_adjoint {A B : precategory} {F : functor A B}
      (H : is_left_adjoint _ _ F)  :
 nat_trans (pr1 (F O pr1 H)) (functor_identity B)
   := pr2 (pr1 (pr2 H)).

Definition triangle_id_left_ad (A B : precategory) (F : functor A B)
      (H : is_left_adjoint _ _ F) :
  forall (a : ob A),
       #F (eta_from_left_adjoint H a);;
       eps_from_left_adjoint H (F a)
       ==
      identity (F a)
   := pr1 (pr2 (pr2 H)).

Definition triangle_id_right_ad (A B : precategory) (F : ob [A, B])
      (H : is_left_adjoint _ _ F) :
  forall b : ob B,
         eta_from_left_adjoint H (right_adjoint H b);;
        #(right_adjoint H) (eps_from_left_adjoint H b) ==
        identity (right_adjoint H b) := pr2 (pr2 (pr2 H)).

(** * Equivalence of (pre)categories *)

Definition equivalence_of_precats {A B : precategory}(F : ob [A, B]) : UU :=
   total2 (fun H : is_left_adjoint _ _ F =>
     dirprod (forall a, is_isomorphism
                    (eta_from_left_adjoint H a))
             (forall b, is_isomorphism
                    (eps_from_left_adjoint H b))
             ).

Definition equivalence_inv {A B : precategory}
  {F : [A, B]} (HF : equivalence_of_precats F) : functor B A :=
    right_adjoint (pr1 HF).

Local Notation "HF ^^-1" := (equivalence_inv HF)(at level 3).

Definition eta_pointwise_iso_from_equivalence {A B : precategory}
  {F : functor A B} (HF : equivalence_of_precats F) :
    forall a, iso a (HF^^-1 (F a)).
  intro a.
  exists (eta_from_left_adjoint (pr1 HF) a).
  exact (pr1 (pr2 HF) a).
Defined.

Definition eps_pointwise_iso_from_equivalence {A B : precategory}
  {F : functor A B} (HF : equivalence_of_precats F) :
    forall b, iso (F (HF^^-1 b)) b.
  intro b.
  exists (eps_from_left_adjoint (pr1 HF) b).
  exact (pr2 (pr2 HF) b).
Defined.

Definition eta_iso_from_equivalence_of_precats {A B : precategory}
  {F : ob [A, B]} (HF : equivalence_of_precats F) :
       iso (C:=[A, A]) (functor_identity A)
                              (right_adjoint (pr1 HF) O F).
Proof.
  exists (eta_from_left_adjoint (pr1 HF)).
  apply functor_iso_if_pointwise_iso.
  apply (pr1 (pr2 HF)).
Defined.

Definition eps_iso_from_equivalence_of_precats {A B : precategory}
  {F : ob [A, B]} (HF : equivalence_of_precats F) :
       iso (C:=[B, B]) (F O right_adjoint (pr1 HF))
                (functor_identity B).
Proof.
  exists (eps_from_left_adjoint (pr1 HF)).
  apply functor_iso_if_pointwise_iso.
  apply (pr2 (pr2 HF)).
Defined.

(** * Equivalence of categories yields equivalence of object types *)
(**  Fundamentally needed that both source and target are categories *)

Lemma equiv_of_cats_is_weq_of_objects (A B : precategory)
   (HA : is_category A) (HB : is_category B) (F : ob [A, B])
   (HF : equivalence_of_precats F) :
     isweq (pr1 (pr1 F)).
Proof.
  set (G := right_adjoint (pr1 HF)).
  set (et := eta_iso_from_equivalence_of_precats HF).
  set (ep := eps_iso_from_equivalence_of_precats HF).
  set (AAcat := is_category_functor_category A _ HA).
  set (BBcat := is_category_functor_category B _ HB).
  set (Et := isotoid _ AAcat et).
  set (Ep := isotoid _ BBcat ep).
  apply (gradth _ (fun b => pr1 (right_adjoint (pr1 HF)) b)).
  intro a.
  set (ou := toforallpaths _ _ _ (base_paths _ _ (base_paths _ _ Et)) a).
  simpl in ou.
  apply (! ou).
  intro y.
  set (ou := toforallpaths _ _ _ (base_paths _ _ (base_paths _ _ Ep)) y).
  apply ou.
Defined.

Definition weq_on_objects_from_equiv_of_cats (A B : precategory)
   (HA : is_category A) (HB : is_category B) (F : ob [A, B])
   (HF : equivalence_of_precats F) : weq
          (ob A) (ob B).
Proof.
  exists (pr1 (pr1 F)).
  apply equiv_of_cats_is_weq_of_objects; assumption.
Defined.

(** If the source precategory is a category, then being split essentially surjective
     is a proposition *)

Lemma isaprop_sigma_iso (A B : precategory) (HA : is_category A)
     (F : ob [A, B]) (HF : fully_faithful F) :
      forall b : ob B,
  isaprop (total2 (fun a : ob A => iso (pr1 F a) b)).
Proof.
  intro b.
  apply invproofirrelevance.
  intros x x'.
  destruct x as [a f].
  destruct x' as [a' f'].
  set (fminusf := iso_comp f (iso_inv_from_iso f')).
  set (g := iso_from_fully_faithful_reflection HF _ _ fminusf).
  apply (total2_paths2 (B:=fun a' => iso ((pr1 F) a') b) (isotoid _ HA g)).
  pathvia (iso_comp (iso_inv_from_iso
    (functor_on_iso _ _ F _ _ (idtoiso (isotoid _ HA g)))) f).
    generalize (isotoid _ HA g).
    intro p0; destruct p0.
    rewrite <- functor_on_iso_inv.
    rewrite iso_inv_of_iso_id.
    apply eq_iso.
    simpl; rewrite functor_id.
    rewrite id_left.
    apply idpath.
  rewrite idtoiso_isotoid.
  unfold g; clear g.
  unfold fminusf; clear fminusf.
  assert (HFg : functor_on_iso A B F a a'
        (iso_from_fully_faithful_reflection HF a a'
           (iso_comp f (iso_inv_from_iso f'))) ==
           iso_comp f (iso_inv_from_iso f')).
    generalize (iso_comp f (iso_inv_from_iso f')).
    intro h.
    apply eq_iso; simpl.
    set (H3:= homotweqinvweq (weq_from_fully_faithful HF a a')).
    simpl in H3. unfold fully_faithful_inv_hom.
    unfold invweq; simpl.
    rewrite H3; apply idpath.
  rewrite HFg.
  rewrite iso_inv_of_iso_comp.
  apply eq_iso; simpl.
  repeat rewrite <- assoc.
  rewrite iso_after_iso_inv.
  rewrite id_right.
  set (H := iso_inv_iso_inv _ _ _ f').
  set (h':= base_paths _ _ H).
  assumption.
Qed.

Lemma isaprop_pi_sigma_iso (A B : precategory) (HA : is_category A)
     (F : ob [A, B]) (HF : fully_faithful F) :
  isaprop (forall b : ob B,
             total2 (fun a : ob A => iso (pr1 F a) b)).
Proof.
  apply impred.
  intro b.
  apply isaprop_sigma_iso; assumption.
Qed.

(** * From full faithfullness and ess surj to equivalence *)

(** A fully faithful and ess. surjective functor induces an
   equivalence of precategories, if the source is a
    category.
*)

Section from_fully_faithful_and_ess_surj_to_equivalence.

Variables A B : precategory.
Hypothesis HA : is_category A.
Variable F : ob [A, B].
Hypothesis HF : fully_faithful F.
Hypothesis HS : essentially_surjective F.

(** Definition of a functor which will later be the right adjoint. *)

Definition rad_ob : ob B -> ob A.
Proof.
  intro b.
  apply (pr1 (HS b (tpair (fun x => isaprop x) _
               (isaprop_sigma_iso A B HA F HF b)) (fun x => x))).
Defined.

(** Definition of the epsilon transformation *)

Definition rad_eps (b : ob B) : iso (pr1 F (rad_ob b)) b.
Proof.
  apply (pr2 (HS b (tpair (fun x => isaprop x) _
               (isaprop_sigma_iso A B HA F HF b)) (fun x => x))).
Defined.

(** The right adjoint on morphisms *)

Definition rad_mor (b b' : ob B) (g : b --> b') : rad_ob b --> rad_ob b'.
Proof.
  set (epsgebs' := rad_eps b ;; g ;; iso_inv_from_iso (rad_eps b')).
  set (Gg := fully_faithful_inv_hom HF (rad_ob b) _ epsgebs').
  exact Gg.
Defined.

(** Definition of the eta transformation *)

Definition rad_eta (a : ob A) : a --> rad_ob (pr1 F a).
Proof.
  set (epsFa := inv_from_iso (rad_eps (pr1 F a))).
  exact (fully_faithful_inv_hom HF _ _ epsFa).
Defined.

(** Above data specifies a functor *)

Definition rad_functor_data : functor_data B A.
Proof.
  exists rad_ob.
  exact rad_mor.
Defined.

Lemma rad_is_functor : is_functor rad_functor_data.
Proof.
  split; simpl.
  intro b.
  unfold rad_mor; simpl.
  rewrite id_right,
    iso_inv_after_iso,
    fully_faithful_inv_identity.
  apply idpath.

  intros a b c f g.
  unfold rad_mor; simpl.
  rewrite <- fully_faithful_inv_comp.
  apply maponpaths.
  repeat rewrite <- assoc.
  repeat apply maponpaths.
  rewrite assoc.
  rewrite iso_after_iso_inv, id_left.
  apply idpath.
Qed.

Definition rad : ob [B, A].
Proof.
  exists rad_functor_data.
  apply rad_is_functor.
Defined.

(** Epsilon is natural *)

Lemma rad_eps_is_nat_trans : is_nat_trans
    (pr1 (F O rad)) (functor_identity B)
       (fun b => rad_eps b).
Proof.
  unfold is_nat_trans.
  simpl.
  intros b b' g.
  unfold rad_mor; unfold fully_faithful_inv_hom.
  set (H3 := homotweqinvweq (weq_from_fully_faithful HF (pr1 rad b) (pr1 rad b'))).
  simpl in *.
  rewrite H3; clear H3.
  repeat rewrite <- assoc.
  rewrite iso_after_iso_inv, id_right.
  apply idpath.
Qed.

Definition rad_eps_trans : nat_trans _ _ :=
   tpair (is_nat_trans _ _ ) _ rad_eps_is_nat_trans.

(** Eta is natural *)

Ltac inv_functor x y :=
   let H:=fresh in
   set (H:= homotweqinvweq (weq_from_fully_faithful HF x y));
     simpl in H;
     unfold fully_faithful_inv_hom; simpl;
     rewrite H; clear H.

Lemma rad_eta_is_nat_trans : is_nat_trans
         (functor_identity A) (pr1 (rad O F))
       (fun a => rad_eta a).
Proof.
  unfold is_nat_trans.
  simpl.
  intros a a' f.
  unfold rad_mor. simpl.
  apply (equal_transport_along_weq _ _
          (weq_from_fully_faithful HF a (rad_ob ((pr1 F) a')))).
  simpl; repeat rewrite functor_comp.
  unfold rad_eta.
  set (HHH := rad_eps_is_nat_trans (pr1 F a) (pr1 F a')).
  simpl in HHH; rewrite <- HHH; clear HHH.
  inv_functor a' (rad_ob ((pr1 F) a')).
  inv_functor a (rad_ob ((pr1 F) a)).
  inv_functor (rad_ob (pr1 F a)) (rad_ob ((pr1 F) a')).
  unfold rad_mor. simpl.
  repeat rewrite <- assoc.
  rewrite iso_inv_after_iso.
  rewrite id_right.
  inv_functor (rad_ob (pr1 F a)) (rad_ob ((pr1 F) a')).
  repeat rewrite assoc.
  rewrite iso_after_iso_inv.
  rewrite id_left.
  apply idpath.
Qed.

Definition rad_eta_trans : nat_trans _ _ :=
   tpair (is_nat_trans _ _ ) _ rad_eta_is_nat_trans.

(** The data [rad], [eta], [eps] forms an adjunction *)

Lemma rad_form_adjunction : form_adjunction A B F rad rad_eta_trans rad_eps_trans.
Proof.
  split; simpl.
  intro a.
  unfold rad_eta.
  inv_functor a (rad_ob (pr1 F a)).
  rewrite iso_after_iso_inv.
  apply idpath.

  intro b.
  apply (equal_transport_along_weq _ _
          (weq_from_fully_faithful HF (rad_ob b) (rad_ob b))).
  simpl; rewrite functor_comp.
  unfold rad_eta.
  inv_functor (rad_ob b) (rad_ob (pr1 F (rad_ob b))).
  unfold rad_mor.
  inv_functor (rad_ob (pr1 F (rad_ob b))) (rad_ob b).
  repeat rewrite assoc.
  rewrite iso_after_iso_inv.
  rewrite <- assoc.
  rewrite iso_inv_after_iso.
  rewrite id_left.
  rewrite functor_id.
  apply idpath.
Qed.

Definition rad_are_adjoints : are_adjoints _ _ F rad.
Proof.
  exists (dirprodpair rad_eta_trans rad_eps_trans).
  apply rad_form_adjunction.
Defined.

Definition rad_is_left_adjoint : is_left_adjoint _ _ F.
Proof.
  exists rad.
  apply rad_are_adjoints.
Defined.

(** Get an equivalence of precategories:

    remains to show that [eta], [eps] are isos
*)

Lemma rad_equivalence_of_precats : equivalence_of_precats F.
Proof.
  exists rad_is_left_adjoint.
  split; simpl.
  intro a.
  unfold rad_eta.
  set (H := fully_faithful_reflects_iso_proof _ _ _ HF
       a (rad_ob ((pr1 F) a))).
  simpl in *.
  set (H' := H (iso_inv_from_iso (rad_eps ((pr1 F) a)))).
  change ((fully_faithful_inv_hom HF a (rad_ob ((pr1 F) a))
     (inv_from_iso (rad_eps ((pr1 F) a))))) with
      (fully_faithful_inv_hom HF a (rad_ob ((pr1 F) a))
     (iso_inv_from_iso (rad_eps ((pr1 F) a)))).
  apply H'.
  intro b. apply (pr2 (rad_eps b)).
Defined.

End from_fully_faithful_and_ess_surj_to_equivalence.


(* A check that sort-polymorphic product is not set too low *)

Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
Check (fun (A:Prop) (B:Type) => (prod A B : Prop)).


Require Import Subst.

Inductive term : Type :=
| Universe : nat -> term
| Lam : term -> bind term -> term
| CCVar : var -> term
| Prod : term -> bind term -> term
| App : term -> term -> term
.

Instance subst_term : Subst term. gen_Subst. Defined.
Instance substLemmas_term : SubstLemmas subst_term. gen_SubstLemmas. Defined.


Require Import common.

Inductive Reg : Set :=
  RA | RB | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | DPTR | PC | SP .

Inductive Flag : Set :=
  FlagC | FlagAC | FlagOV .

Definition beq_reg(r r' : Reg) :=
  match r, r' with
    | RA, RA => true
    | RB, RB => true
    | R0, R0 => true
    | R1, R1 => true
    | R2, R2 => true
    | R3, R3 => true
    | R4, R4 => true
    | R5, R5 => true
    | R6, R6 => true
    | R7, R7 => true
    | _, _     => false
  end.

Definition beq_flag(f f' : Flag) :=
  match f, f' with
    | FlagC, FlagC => true
    | FlagAC, FlagAC => true
    | FlagOV, FlagOV => true
    | _, _ => false
  end.

Definition Regs := Reg -> Byte.

Definition Flags := Flag -> bool.

Definition getReg (rf : Regs) (r : Reg) := rf r.

Definition setReg (rf : Regs) (r : Reg) (v : Byte) :=
  fun r' => if beq_reg r' r then v else rf r'.

Definition getFlag (ff : Flags) (f : Flag) := ff f.

Definition setFlag (ff : Flags) (f : Flag) :=
  fun f' => if beq_flag f' f then true else ff f'.

Definition clearFlag (ff : Flags) (f : Flag) :=
  fun f' => if beq_flag f' f then false else ff f'.


Require Export L LNat LBool Seval.
Require Import Coq.Logic.ConstructiveEpsilon.

Definition cChoice := constructive_indefinite_ground_description_nat_Acc.

Lemma eq_term_dec (s t : term) : (s = t) + (s <> t).
Proof.
  revert t. induction s; intros t; destruct t; try(right; intros H; inv H; fail).
  - decide (n = n0). left. congruence. right. congruence.
  - destruct (IHs1 t1), (IHs2 t2); try (right; congruence). left. congruence.
  - destruct (IHs t). left; congruence. right; congruence.
Qed.

Lemma enc_extinj {X} {H:registered X} m n : enc m == enc n -> m = n.
Proof.
  intros eq. apply unique_normal_forms in eq; try Lproc. now apply inj_enc.
Qed.

Lemma lcomp_comp Y (Ry:registered Y) (u:term) (g: term -> Y):
  (forall x (y:Y), enc y = x -> y = g x) ->
  (exists y:Y, u == enc y) -> {y| u == enc y}.
Proof.
  intros Hg Hu.
  assert (exists n (y:Y), eva n u = Some (enc y)).
  {
    destruct Hu as [y Hy]. apply equiv_lambda in Hy;try Lproc.
    assert (eval (u) (enc y)). split. assumption. Lproc.
    apply eval_seval in H. destruct H as [n Hn]. exists n. exists y. now apply seval_eva.
  }
  eapply cChoice in H. destruct H as [n H].
  destruct (eva n u) as [t|] eqn:Heva.
  -exists (g t). destruct H as [y H]. rewrite <- Heva in H. apply eva_equiv in H.
   assert (lambda t)by now apply eva_lam in Heva. apply eva_equiv in Heva. rewrite Heva in H. erewrite <- Hg. apply equiv_lambda in Heva;try Lproc. rewrite Heva. exact H. apply unique_normal_forms in H;try Lproc. congruence.
  -exists (g 0). destruct H as [? H]. inv H.
  -intros n. destruct (eva n u) eqn:eq.
   +left. destruct H as [n' [y H]]. exists y. apply eva_equiv in H.
    assert (lambda t) by now apply eva_lam in eq. apply eva_equiv in eq. rewrite H in eq. apply unique_normal_forms in eq;[|Lproc..].  congruence.
   +right. intros [y eq']. congruence.
Qed.

Definition bool_enc_inv b:=
  match b with
    | lam (lam (var 1)) => true
    | _ => false
  end.

Lemma bool_enc_inv_correct : (forall x (y:bool), enc y = x -> y = bool_enc_inv x).
Proof.
  intros x [];intros;subst;reflexivity.
  Qed.

Arguments lcomp_comp _{_} _ {_} _ _.