Require Import List Arith.
Open Scope list_scope.

Inductive Kind := KProp | KType.

Module Def.

Section Syntax.

Definition id := nat.

Inductive Term :=
  | TVar : id -> Term
  | TSort : Kind -> Term
  | TFor : id -> Term -> Term -> Term
  | TFun : id -> Term -> Term -> Term
  | TApp : Term -> Term -> Term
  | TRef : Term -> Term -> Term
  | TPrf : Term -> Term.

Inductive ContextSnippet :=
  | CType : id -> Term -> ContextSnippet
  | CHold : Term -> ContextSnippet.

Definition Context := list ContextSnippet.

End Syntax.

Section Operation.

Definition removeVal := remove Nat.eq_dec.
Fixpoint ListIn_dec x L :=
  match L with
  | nil => false
  | h :: L' =>
    if Nat.eqb x h then true else ListIn_dec x L'
  end.

Fixpoint FreeValueIn (M:Term) :=
  match M with
  | TVar x => x :: nil
  | TSort _ => nil
  | TFor x A B => removeVal x (FreeValueIn A) ++ (FreeValueIn B)
  | TFun x A t => removeVal x (FreeValueIn A) ++ (FreeValueIn t)
  | TApp M N => FreeValueIn M ++ FreeValueIn N
  | TRef A P => FreeValueIn A ++ FreeValueIn P
  | TPrf P => FreeValueIn P
  end.

Parameter Subst : Term -> id -> Term -> Term.
Parameter VarCase : forall x y N ,
  Subst (TVar x) y N = if Nat.eqb x y then N else TVar y.
Parameter SortCase : forall s y N ,
  Subst (TSort s) y N = TSort s.
Parameter ForCase : forall x A B y N ,
  if Nat.eqb x y then
    Subst (TFor x A B) y N = TFor x A B
  else if orb (negb (ListIn_dec x (FreeValueIn N))) (negb (ListIn_dec y (FreeValueIn B))) then
    Subst (TFor x A B) y N = TFor x A (Subst B y N)
  else
    exists z , andb (negb (ListIn_dec  z (FreeValueIn N))) (negb (ListIn_dec z (FreeValueIn B))) = true /\
    Subst (TFor x A B) y N = TFor z A (Subst (Subst B x (TVar z)) y N).
Parameter FunCase : forall x A B y N ,
  if Nat.eqb x y then
    Subst (TFun x A B) y N = TFun x A B
  else if orb (negb (ListIn_dec x (FreeValueIn N))) (negb (ListIn_dec y (FreeValueIn B))) then
    Subst (TFun x A B) y N = TFun x A (Subst B y N)
  else
    exists z , andb (negb (ListIn_dec  z (FreeValueIn N))) (negb (ListIn_dec z (FreeValueIn B))) = true /\
    Subst (TFun x A B) y N = TFun z A (Subst (Subst B x (TVar z)) y N).
Parameter AppCase : forall M1 M2 y N ,
  Subst (TApp M1 M2) y N = TApp (Subst M1 y N) (Subst M2 y N).
Parameter RefCase : forall M1 M2 y N ,
  Subst (TRef M1 M2) y N = TRef (Subst M1 y N) (Subst M2 y N).
Parameter PrfCase : forall P y N ,
  Subst (TPrf P) y N = TPrf (Subst P y N).

Inductive AlphaConv : Term -> Term -> Prop :=
  | ARenameFor : forall x A B y ,
    AlphaConv (TFor x A B) (TFor y A (Subst B x (TVar y)))
  | ARenameFun : forall x A B y ,
    AlphaConv (TFun x A B) (TFun y A (Subst B x (TVar y)))
  | ACongTFor1 : forall x A A' B ,
    AlphaConv A A' ->
    AlphaConv (TFor x A B) (TFor x A' B)
  | ACongTFor2 : forall x A B B' ,
    AlphaConv B B' ->
    AlphaConv (TFor x A B) (TFor x A B')
  | ACongTFun1 : forall x A A' B ,
    AlphaConv A A' ->
    AlphaConv (TFun x A B) (TFor x A' B)
  | ACongTFun2 : forall x A B B' ,
    AlphaConv B B' ->
    AlphaConv (TFun x A B) (TFor x A B')
  | ACongTApp1 : forall M M' N ,
    AlphaConv M M' ->
    AlphaConv (TApp M N) (TApp M' N)
  | ACongTApp2 : forall M N N' ,
    AlphaConv N N' ->
    AlphaConv (TApp M N) (TApp M N')
  | ACongTRef1 : forall M M' N ,
    AlphaConv M M' ->
    AlphaConv (TRef M N) (TRef M' N)
  | ACongTRef2 : forall M N N' ,
    AlphaConv N N' ->
    AlphaConv (TRef M N) (TRef M N')
  | ACongPrf : forall P P' ,
    AlphaConv P P' ->
    AlphaConv (TPrf P) (TPrf P')
  | ARefl : forall M ,
    AlphaConv M M
  | ASym : forall M N ,
    AlphaConv M N ->
    AlphaConv N M
  | ATrans : forall L M N ,
    AlphaConv L M ->
    AlphaConv M N ->
    AlphaConv L N.

Inductive BetaStep : Term -> Term -> Prop :=
  | BStep : forall x A M N ,
    BetaStep (TApp (TFun x A M) N) (Subst M x N)
  | BCongTFor1 : forall x A A' B ,
    BetaStep A A' ->
    BetaStep (TFor x A B) (TFor x A' B)
  | BCongTFor2 : forall x A B B' ,
    BetaStep B B' ->
    BetaStep (TFor x A B) (TFor x A B')
  | BCongTFun1 : forall x A A' B ,
    BetaStep A A' ->
    BetaStep (TFun x A B) (TFor x A' B)
  | BCongTFun2 : forall x A B B' ,
    BetaStep B B' ->
    BetaStep (TFun x A B) (TFor x A B')
  | BCongTApp1 : forall M M' N ,
    BetaStep M M' ->
    BetaStep (TApp M N) (TApp M' N)
  | BCongTApp2 : forall M N N' ,
    BetaStep N N' ->
    BetaStep (TApp M N) (TApp M N')
  | BCongTRef1 : forall M M' N ,
    BetaStep M M' ->
    BetaStep (TRef M N) (TRef M' N)
  | BCongTRef2 : forall M N N' ,
    BetaStep N N' ->
    BetaStep (TRef M N) (TRef M N')
  | BCongPrf : forall P P' ,
    BetaStep P P' ->
    BetaStep (TPrf P) (TPrf P').

Inductive BetaEq : Term -> Term -> Prop :=
  | Beta : forall M N ,
    BetaStep M N -> BetaEq M N
  | BRefl : forall M ,
    BetaEq M M
  | BSym : forall M N ,
    BetaEq M N -> BetaEq N M
  | BTrans : forall L M N ,
    BetaEq L M -> BetaEq M N ->
    BetaEq L N.

End Operation.

Section System.

Inductive ContextJudge : Context -> Type :=
  | Empty : ContextJudge nil
  | StartType : forall G A x s ,
    TypeJudge G A (TSort s) ->
    ContextJudge (cons (CType x A) G)
  | StartProp : forall G P ,
    TypeJudge G P (TSort KProp) ->
    ContextJudge (cons (CHold P) G)
with TypeJudge : Context -> Term -> Term -> Type :=
  | AxiomKind : TypeJudge nil (TSort KProp) (TSort KType)
  | Weakning : forall G t T h ,
    TypeJudge G t T ->
    ContextJudge (cons h G) ->
    TypeJudge (cons h G) t T
  | Variab : forall x A G ,
    ContextJudge (cons (CType x A) G) ->
    TypeJudge (cons (CType x A) G) (TVar x) A
  | ForForm : forall G x A B s1 s2 ,
    TypeJudge G A (TSort s1) ->
    TypeJudge (cons (CType x A) G) B (TSort s2) ->
    TypeJudge G (TFor x A B) (TSort s2)
  | ForIntro : forall G x A t B s ,
    TypeJudge G (TFor x A B) (TSort s) ->
    TypeJudge (cons (CType x A) G) t B ->
    TypeJudge G (TFun x A t) (TFor x A B)
  | ForElim : forall G M N x A B ,
    TypeJudge G M (TFor x A B) ->
    TypeJudge G N A ->
    TypeJudge G (TApp M N) (Subst B x M)
  | RefForm : forall G x A P ,
    TypeJudge G A (TSort KType) ->
    TypeJudge G P (TFor x A (TSort KProp)) ->
    TypeJudge G (TRef A P) (TSort KType)
  | RefIntro : forall G t A P ,
    TypeJudge G t A ->
    ProofJudge G (TApp P t) ->
    TypeJudge G t (TRef A P)
  | RefElim : forall G t A P ,
    TypeJudge G t (TRef A P) ->
    TypeJudge G t A
  | Conversion : forall G t A B s ,
    BetaEq A B ->
    TypeJudge G t A ->
    TypeJudge G B (TSort s) ->
    TypeJudge G t B
  | ProofAbstraction : forall G P ,
    ProofJudge G P ->
    TypeJudge G (TPrf P) P
with ProofJudge : Context -> Term -> Type :=
  | Assumption : forall G P ,
    ContextJudge (cons (CHold P) G) ->
    ProofJudge (cons (CHold P) G) P
  | ProofExistence : forall G P t ,
    TypeJudge G P (TSort KProp) ->
    TypeJudge G t P ->
    ProofJudge G P
  | RefInversion : forall G t A P ,
    TypeJudge G t (TRef A P) ->
    ProofJudge G (TApp P t).

End System.

End Def.


(* * First-Order Logic *)

Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
Require Import ListAutomation.
Import ListAutomationNotations.

From Coq Require Import Eqdep_dec.
Require Import Coq.Vectors.Vector.
Local Notation vec := t.

Require Export FO_Bi_Int_Syntax.

Set Default Proof Using "Type".

(* ** Discreteness *)

Require Import EqdepFacts.

Lemma inj_pair2_eq_dec' A :
  eq_dec A -> forall (P : A -> Type) (p : A) (x y : P p), existT P p x = existT P p y -> x = y.
Proof.
  apply Eqdep_dec.inj_pair2_eq_dec.
Qed.

Ltac resolve_existT := try
  match goal with
     | [ H2 : @existT ?X _ _ _ = existT _ _ _ |- _ ] => eapply Eqdep_dec.inj_pair2_eq_dec in H2;
                                                      [subst | try (eauto || now intros; decide equality)]
  end.

Lemma dec_vec_in X n (v : vec X n) :
  (forall x, vec_in x v -> forall y, dec (x = y)) -> forall v', dec (v = v').
Proof with subst; try (now left + (right; intros[=])).
  intros Hv. induction v; intros v'.
  - pattern v'. apply Vector.case0...
  - apply (Vector.caseS' v'). clear v'. intros h0 v'.
    destruct (Hv h (vec_inB h v) h0)... edestruct IHv.
    + intros x H. apply Hv. now right.
    + left. f_equal. apply e.
    + right. intros H. inversion H. resolve_existT. tauto.
Qed.

#[global]
Instance dec_vec X {HX : eq_dec X} n : eq_dec (vec X n).
Proof.
  intros v. refine (dec_vec_in _ _ _ _).
Qed.

Section EqDec.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Hypothesis eq_dec_Funcs : eq_dec syms.
  Hypothesis eq_dec_Preds : eq_dec preds.
  Hypothesis eq_dec_binop : eq_dec binop.
  Hypothesis eq_dec_quantop : eq_dec quantop.

  Global Instance dec_term : eq_dec term.
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence))
    using eq_dec_Funcs.
    intros t. induction t as [ | ]; intros [|? v']...
    - decide (x = n)...
    - decide (F = f)... destruct (dec_vec_in _ _ _ X v')...
  Qed.

End EqDec.

(* ** Enumerability *)

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Variable list_Funcs : nat -> list syms.
  Hypothesis enum_Funcs' : list_enumerator__T list_Funcs syms.

  Variable list_Preds : nat -> list preds.
  Hypothesis enum_Preds' : list_enumerator__T list_Preds preds.

  Variable list_binop : nat -> list binop.
  Hypothesis enum_binop' : list_enumerator__T list_binop binop.

  Variable list_quantop : nat -> list quantop.
  Hypothesis enum_quantop' : list_enumerator__T list_quantop quantop.

  Fixpoint vecs_from X (A : list X) (n : nat) : list (vec X n) :=
    match n with
    | 0 => [Vector.nil X]
    | S n => [ Vector.cons X x _ v | (x,  v) ∈ (A × vecs_from X A n) ]
    end.

  Fixpoint L_term n : list term :=
    match n with
    | 0 => []
    | S n => L_term n ++ var n :: concat ([ [ func F v | v ∈ vecs_from _ (L_term n) (ar_syms F) ] | F ∈ L_T n])
    end.

  Lemma L_term_cml :
    cumulative L_term.
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Lemma list_prod_in X Y (x : X * Y) A B :
    x el (A × B) -> exists a b, x = (a , b) /\ a el A /\ b el B.
  Proof.
    induction A; cbn.
    - intros [].
    - intros [H | H] % in_app_or. 2: firstorder.
      apply in_map_iff in H as (y & <- & Hel). exists a, y. tauto.
  Qed.

  Lemma vecs_from_correct X (A : list X) (n : nat) (v : vec X n) :
    (forall x, vec_in x v -> x el A) <-> v el vecs_from X A n.
  Proof.
    induction n; cbn.
    - split.
      + intros. left. pattern v. now apply Vector.case0.
      + intros [<- | []] x H. inv H.
    - split.
      + intros. revert H. apply (Vector.caseS' v).
        clear v. intros ? t0 H. in_collect (pair h t0); destruct (IHn t0).
        eauto using vec_inB. apply H0. intros x Hx. apply H. now right.
      + intros Hv. apply in_map_iff in Hv as ([h v'] & <- & (? & ? & [= <- <-] & ? & ?) % list_prod_in).
        intros x H. inv H; destruct (IHn v'); eauto. apply H2; trivial. now resolve_existT.
  Qed.

  Lemma vec_forall_cml X (L : nat -> list X) n (v : vec X n) :
    cumulative L -> (forall x, vec_in x v -> exists m, x el L m) -> exists m, v el vecs_from _ (L m) n.
  Proof.
    intros HL Hv. induction v; cbn.
    - exists 0. tauto.
    - destruct IHv as [m H], (Hv h) as [m' H']. 1,3: eauto using vec_inB.
      + intros x Hx. apply Hv. now right.
      + exists (m + m'). in_collect (pair h v). 1: apply (cum_ge' (n:=m')); intuition lia.
      apply vecs_from_correct. rewrite <- vecs_from_correct in H. intros x Hx.
      apply (cum_ge' (n:=m)). all: eauto. lia.
  Qed.

  Lemma enum_term :
    list_enumerator__T L_term term.
  Proof with try (eapply cum_ge'; eauto; lia).
    intros t. induction t using term_rect.
    - exists (S x); cbn; eauto.
    - apply vec_forall_cml in H as [m H]. 2: exact L_term_cml. destruct (el_T F) as [m' H'].
      exists (S (m + m')); cbn. in_app 3. eapply in_concat_iff. eexists. split. 2: in_collect F...
      apply in_map. rewrite <- vecs_from_correct in H |-*. intros x H''. specialize (H x H'')...
  Qed.

  Lemma enumT_term :
    enumerable__T term.
  Proof using enum_Funcs'.
    apply enum_enumT. exists L_term. apply enum_term.
  Qed.

  Fixpoint L_form n : list form :=
    match n with
    | 0 => [⊥;⊤]
    | S n => L_form n
              ++ concat ([ [ atom P v | v ∈ vecs_from _ (L_term n) (ar_preds P) ] | P ∈ L_T n])
              ++ concat ([ [ bin op phi psi | (phi, psi) ∈ (L_form n × L_form n) ] | op ∈ L_T n])
              ++ concat ([ [ quant op phi | phi ∈ L_form n ] | op ∈ L_T n])
    end.

  Lemma L_form_cml :
    cumulative L_form.
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Lemma enum_form :
    list_enumerator__T L_form form.
  Proof with (try eapply cum_ge'; eauto; lia).
    intros phi. induction phi.
    - exists 1. cbn; eauto.
    - exists 1. cbn; eauto.
    - rename t into v. destruct (el_T P) as [m Hm], (vec_forall_cml term L_term _ v) as [m' Hm']; eauto using enum_term.
      exists (S (m + m')); cbn. in_app 2. eapply in_concat_iff. eexists. split.
      2: in_collect P... eapply in_map. rewrite <- vecs_from_correct in *. intuition...
    - destruct (el_T b) as [m Hm], IHphi1 as [m1], IHphi2 as [m2]. exists (1 + m + m1 + m2). cbn.
      in_app 3. apply in_concat. eexists. split. apply in_map... in_collect (pair phi1 phi2)...
    - destruct (el_T q) as [m Hm], IHphi as [m' Hm']. exists (1 + m + m'). cbn -[L_T].
      in_app 4. apply in_concat. eexists. split. apply in_map... in_collect phi...
  Qed.

  Lemma enumT_form :
    enumerable__T form.
  Proof using enum_Funcs' enum_Preds' enum_binop' enum_quantop'.
    apply enum_enumT. exists L_form. apply enum_form.
  Defined.

End Enumerability.


Require Import Coq.Lists.List Coq.Arith.Arith Coq.Arith.PeanoNat Omega.
Require Import AutoIndTac Util Get.

Require Export OrderedBitVector.

Set Implicit Arguments.

(** HELPER FUNCTIONS for bitvector functions **)

(** zero extension **)
Fixpoint zext' (l:nat) (bv:bitvec) :=
match l with
| 0 => nil
| S l' => match bv with
         |nil => O:: zext' l' nil
         |a::b' => a::zext' l' b'
         end
end.

Lemma zext'_length : forall l bv, length (zext' l bv) = l.
Proof.
  intros. general induction l.
  - auto.
  - simpl. case bv; simpl.
    * rewrite (IHl nil); reflexivity.
    * intros. rewrite (IHl l0); reflexivity.
Qed.

Definition zext bv := zext' k bv.

Corollary zext_length : forall bv, length (zext bv) = k.
Proof.
  intros. unfold zext; rewrite (zext'_length k bv); reflexivity.
Qed.

Definition zero := zext (O::nil).

(** sign extension **)
Fixpoint sext' (l:nat) (bv:bitvec) (b:bit) :=
match l with
| 0 => nil
| S l' => match bv with
              | nil => b:: sext' l' nil b
              | a::b' => a::sext' l' b' a
          end
end.

Lemma sext'_length : forall l bv b, length (sext' l bv b) = l.
Proof.
  intros. general induction l.
  - auto.
  - simpl. case bv; simpl.
    * rewrite (IHl nil b); reflexivity.
    * intros. rewrite (IHl l0 b0); reflexivity.
Qed.

Lemma sext'_I : forall l, l > 0 -> exists bv', (sext' l nil I) = I::bv'.
Proof.
  intros. destruct l.
  - isabsurd.
  - simpl. eauto.
Qed.

Definition sext bv b := sext' k bv b.

Corollary sext_length : forall bv b, length (sext bv b) = k.
Proof.
  intros. unfold sext. rewrite (sext'_length k bv b); reflexivity.
Qed.

Definition bitComplement b :=
match b with
| I => O
| O => I
end.

(* Complement *)
Fixpoint complement' l bv :=
match l with
| 0 => nil
| S l' => match bv with
              | nil => sext' (S l') nil I
              | a::b' => bitComplement  a :: complement' l' b'
          end
end.

Lemma complement'_length : forall l bv, length (complement' l bv) = l.
Proof.
  intros. general induction l.
  - auto.
  - simpl. case bv.
    * simpl. rewrite (sext'_length l nil I); reflexivity.
    * intros; simpl. rewrite (IHl l0 ); reflexivity.
Qed.

Definition complement bv :=
  complement' k bv.

Corollary complement_length : forall bv, length (complement bv) = k.
Proof.
  intros; unfold complement. rewrite (complement'_length k bv); reflexivity.
Qed.

(** Left shift **)
Fixpoint shl s b :=
match s with
|0 => b
| S s' => O::b
end.

Fixpoint toBool b :=
match b with
| nil => false
| I::b' => true
| O::b' => toBool b'
end.

Lemma toBool_I_true:
  forall l,
    1 <= l
    -> toBool (sext' l (I::nil) I) = true.
Proof.
  intros l geq.
  destruct l; try auto; isabsurd.
Qed.

Lemma toBool_nil_ext_false:
  forall l,
    toBool (zext' l (nil)) = false.

Proof.
  intros l.
  induction l.
  - auto.
  - simpl; rewrite IHl; auto.
Qed.

Lemma toBool_O_false:
  forall l,
    toBool (zext' l (O::nil)) = false.

Proof.
  intros l; destruct l.
  - auto.
  - simpl. rewrite toBool_nil_ext_false; auto.
Qed.

Definition msb b :=
match List.rev b with
| nil => O
| a::b' => a
end.

(** Increment function based on the size of an argument**)
Fixpoint incr' (k:nat) (b:bitvec) :=
match k with
| 0 => nil
| S k' => match b with
            | nil => I::(sext' k' nil I)
            | O::b' => I:: (sext' k' b' I)
            | I::b' => O:: incr' k' b'
          end
end.

(** increment function that uses the defined size **)
Definition incr (b:bitvec) :=
incr' k (sext' k b O).

(** Decrement function TODO: Maybe remove it **)
Fixpoint decr (b:bitvec) :=
match b with
| nil => nil
| O::nil => O::nil
| I::b' => O::b'
| O::b' => I::decr b'
end.

Definition bitAnd (b1:bit) (b2:bit) :=
match b1, b2 with
|I,I => I
|_,_ => O
end.

Definition bitOr (b1:bit) (b2:bit) :=
match b1, b2 with
|O,O => O
|_,_ => I
end.

Definition bitXor (b1:bit) (b2:bit) :=
match b1, b2 with
|O,O => O
|I,I => O
|_,_ => I
end.

Fixpoint bvAndBounded k b1 b2 :=
match k with
| 0 => nil
| S k' => match b1,b2 with
              | nil, _ => nil
              | _, nil => nil
              |a::b1', b::b2' => bitAnd a b :: bvAndBounded k' b1' b2'
          end
end.

Definition bvAnd b1 b2 :=
bvAndBounded k (sext' k b1 O) (sext' k b2 O).

Fixpoint bvAndBit k bv b :bitvec :=
match k with
| 0 => nil
| S k' => match bv with
              |b1:: bv' => (bitAnd b1 b) :: (bvAndBit k' bv' b)
              |nil => O::bvAndBit k' nil b
          end
end.

(* bounded addition for bitvectors such that we get the 2's complement semantics **)
Fixpoint bvAddBounded k a b c :=
match k with
| 0 => nil
| S k'=> match a with
             |a1::a' => match b with
                            |b1::b'
                             => let c' := (bitOr (bitAnd b1 c)(bitOr (bitAnd a1 c)(bitAnd a1 b1))) in
                                let r  := (bitXor a1 (bitXor b1 c)) in
                                r ::(bvAddBounded k' a' b' c' )
                            |nil
                             => let r := bitXor a1 c in
                                 let c':= bitAnd a1 c in
                                 r:: (bvAddBounded k' a' nil c')
                        end
             |nil => match b with
                         |b1::b'
                          => let r := bitXor b1 c in
                             let c' := bitAnd b1 c in
                             r:: (bvAddBounded k' nil b' c')
                          |nil => c::(bvAddBounded k' nil nil c)
                     end
         end
end.

(** Bitvector Addition for binary  numbers. Forwards the call to bvAddBounded with k defined before. **)
Definition bvAdd (a:bitvec) (b:bitvec)  :bitvec :=
bvAddBounded k (sext' k a O) (sext' k b O) O.

Definition bvSub (a:bitvec) (b:bitvec) :bitvec :=
bvAdd( bvAdd a (complement b) ) (zext' k (I::nil)).

Fixpoint bvMult' k s a b :=
match k with
| 0 => nil
| S k' => match b with
            |b1::b' => bvAddBounded (2*k) (shl s (bvAndBit (k+s) a b1)) (bvMult' k' (S s) a b' ) O
            |nil => nil
                    end
end.

Definition bvMult a b :=
bvMult' (2*k) 0 (sext' (2*k) a O) (sext' (2*k) b O).

Definition neg b :=
bvAdd (complement b) (zext' k (I::nil)).

Definition bitEq b1 b2 :=
match b1, b2 with
|I,I => I
|O,O => I
|_,_ => O
end.

Fixpoint bvEq b1 b2 :=
match b1, b2 with
| nil, nil => sext' k (nil) I
| nil, _ => nil
| _, nil => nil
| a1::b1', a2::b2' => match bitEq a1 a2 with
                        |I => bvEq b1' b2'
                        |O => nil
                      end

end.

Fixpoint bvLessZero b1 :=
match msb b1 with
| I => true
| O => false
end.

Definition bvZero b :=
toBool (bvEq b zero).
(*
  match b with
| nil => true
| I::b' => false
| O::b' => bvZero b'
end.*)

(** Define a function to map a single bit to a natural number **)
Definition bitToNat (b1:bit) :nat :=
match b1 with
|I => 1
|O => 0
end.

(** For every bit there exists a number *)
Lemma exists_number_bit:
forall b:bit, exists n:nat, bitToNat b = n.

Proof.
intros. destruct b.
- exists 0. reflexivity.
- exists 1. reflexivity.
Qed.

(** Now define the natural number for bitvectors **)
Fixpoint bitvecToNat (b:list bit) :nat :=
match b with
|nil => 0
|b1::b' => bitToNat b1 + 2 * bitvecToNat b'
end.

(** For every bitvector there exists a number **)
Lemma exists_number_bitvec:
forall b:list bit, exists n:nat, bitvecToNat b = n.

Proof.
intros.  general induction b.
- exists 0; reflexivity.
- destruct IHb.  destruct a.
  + exists (2*x).  simpl. rewrite H. auto.
  + exists ((2*x)+1). simpl. rewrite H. omega.

Qed.

(** TODO: Find better division algorithm **)
Fixpoint bvDiv' a b1 b2 :=
match a with
| 0 =>  O::nil
| S n' => match  toBool (bvEq b1 b2) with
           | true =>  (zext' k (I::nil))
           | false => incr( bvDiv' n' (bvSub b1 b2) b2)
          end
end.

Lemma sext'_nil_true : toBool (sext' k nil I) = true.
Proof.
  simpl. pose proof (sext'_I). destruct (H k).
  Focus 2.  rewrite H0. unfold toBool. econstructor.
  - pose K_ge1. apply le_lt_n_Sm in l. apply lt_S_n in l.
    change (0 < k); auto.
Qed.

(** Lemmas about the functions **)
Lemma bvEq_equiv_eq:
forall b1 b2, toBool(bvEq b1 b2) <-> eq b1 b2.

Proof.
intros; split; intros.
- general induction b1; destruct b2.
  + reflexivity.
  + simpl in H. unfold toBool in H. exfalso; assumption.
  + simpl in H. exfalso; assumption.
  + destruct a,b.
    * simpl. simpl in H. f_equal. eapply IHb1. assumption.
    * simpl in H; exfalso; assumption.
    * simpl in H; exfalso; assumption.
    * f_equal. simpl in H; eapply IHb1; assumption.
- general induction b1.
  + unfold bvEq. rewrite (sext'_nil_true); econstructor.
  + destruct a.
    * simpl. eapply (IHb1 b1). reflexivity.
    * simpl. eapply (IHb1 b1); reflexivity.
Qed.

Lemma bvEq_refl:
forall b,
toBool (bvEq b b) = true.

Proof.
intros. general induction b.
+ simpl. rewrite (sext'_nil_true); reflexivity.
+ simpl. destruct a; simpl; eauto.
Qed.

(** Division wrapper function. Starts the bvDiv' function with the size argument b1.
Because b1 is the biggest amount of steps needed to compute b1 / b2 (in the case where b2
is 1. As a bitvector can also be mapped to it's natural number counterpart we take this number as
the amount of steps. In the worst case this will only produce more steps then needed as 2^k is
the maximum number for natural numbers and 2^(k-1) for 2s complement.
There is also special threatening needed for signs.
Function is defined also for x/y where y = 0 because the smt solver always has total functions **)
Definition bvDiv (b1:bitvec) (b2:bitvec) :option bitvec:=
if [ b2 = zero ]
then None
else
Some (match bvLessZero b1, bvLessZero b2 with
| true, true => (bvDiv' (bitvecToNat b1) (neg b1) (neg b2))
| true, false => neg ( bvDiv' (bitvecToNat b1) (neg b1) b2)
| false, true => neg (bvDiv' (bitvecToNat b1) b1 (neg b2))
| false, false => bvDiv' (bitvecToNat b1) b1 b2
end).

Lemma not_zero:
 forall b, bvZero b = false ->  b  <> zero.

Proof.
 intros. general induction b.
- unfold bvZero in H. unfold zero. hnf; intros.
  rewrite H0 in H. unfold zero in H.
  rewrite (bvEq_refl (zext (O::nil))) in H; isabsurd.
- unfold bvZero in *; unfold zero in *. hnf; intros. rewrite H0 in H.
  rewrite (bvEq_refl (zext (O::nil))) in H; isabsurd.
Qed.

Lemma zext_nil_eq_sext:
  forall l, sext' l nil O = zext' l nil.

Proof.
  intros; general induction l.
  - simpl. reflexivity.
  - simpl. f_equal; eauto; assumption.
Qed.


(** Considered preliminaries *)
Set Implicit Arguments.
Require Import List Omega Morphisms.
Import ListNotations.
Require Export terms std.

Fixpoint sapp {X} (A: list X) (sigma: fin -> X): fin -> X :=
  match A with
  | nil => sigma
  | a :: A => a .: sapp A sigma
  end.

Notation "A .+ sigma" := (sapp A sigma) (at level 67, right associativity).

Lemma sapp_app X (A B: list X) sigma:
  (A ++ B) .+ sigma = A .+ B .+ sigma.
Proof.
  induction A; cbn; eauto.
  f_equal; eauto.
Qed.

Lemma nth_error_sapp X L (x: X) n sigma:
  nth_error L n = Some x -> (L .+ sigma) n = x.
Proof.
  induction L in n |-*; cbn.
  + destruct n; cbn in *;  discriminate.
  + firstorder. destruct n; cbn in *.
    congruence. eauto.
Qed.

Lemma sapp_lt_in X x (A: list X) sigma:
  x < length A -> (A .+ sigma) x ∈ A.
Proof.
  intros H. eapply nth_error_In with (n := x).
  eapply nth_error_lt_Some in H as [a].
  erewrite nth_error_sapp; eauto.
Qed.

Lemma sapp_ge_in X x (A: list X) sigma:
  length A <= x -> sapp A sigma x = sigma (x - length A).
Proof.
  induction A in x |-*.
  - cbn. intros _. destruct x; reflexivity.
  - intros H. destruct x. inv H.
    cbn; rewrite <-IHA; eauto using le_S_n.
Qed.

Lemma ren_plus_base (X: Const): @ren_exp X shift = ren_exp (plus 1).
Proof. reflexivity. Qed.

Lemma ren_comp X delta delta' s:
  @ren_exp X delta (ren_exp delta' s) = ren_exp (delta' >> delta) s.
Proof. asimpl. reflexivity. Qed.

Lemma ren_plus_combine X n m s:
  @ren_exp X (plus n) (ren_exp (plus m) s) = ren_exp (plus (n + m)) s.
Proof.
  rewrite ren_comp. f_equal.
  induction n; cbn; fext; intros; cbn.
  + reflexivity.
  + rewrite <-IHn. reflexivity.
Qed.

Lemma it_up_ren_spec n delta x:
  it n up_ren delta x = if dec2 lt x n then x else n + delta (x - n).
Proof.
  induction n in x, delta |-*; cbn.
  - destruct dec2; intuition.
  - destruct x; cbn; destruct dec2; intuition.
    all: unfold funcomp; erewrite IHn.
    all: destruct dec2; intuition.
Qed.

Lemma it_up_ren_lt n delta x:
  x < n -> it n up_ren delta x = x.
Proof.
  intros; rewrite it_up_ren_spec; destruct dec2; intuition.
Qed.

Lemma it_up_ren_ge n delta x:
  x >= n -> it n up_ren delta x = n + delta (x - n).
Proof.
  intros; rewrite it_up_ren_spec; destruct dec2; intuition.
Qed.

Lemma it_up_spec X n (sigma: fin -> @exp X) x:
  it n up_exp_exp sigma x =
  if dec2 lt x n then var_exp x else ren_exp (plus n) (sigma (x - n)).
Proof.
  induction n in x, sigma |-*; cbn.
  - asimpl; destruct dec2; [omega|]; now destruct x.
  - destruct x; cbn; destruct dec2; intuition; [omega| |].
    all: unfold funcomp; erewrite IHn.
    all: destruct dec2; intuition; try omega; now asimpl.
Qed.

Lemma it_up_lt X n (sigma: fin -> @exp X) x:
  x < n -> it n up_exp_exp sigma x = var_exp x.
Proof.
  intros; rewrite it_up_spec; destruct dec2; intuition.
Qed.

Lemma it_up_ge X n (sigma: fin -> @exp X) x:
  x >= n -> it n up_exp_exp sigma x = ren_exp (plus n) (sigma (x - n)).
Proof.
  intros; rewrite it_up_spec; destruct dec2; intuition; omega.
Qed.

Lemma it_up_var_sapp X A n delta e:
  (forall x, delta x >= x) -> n = length A  ->
  subst_exp (A .+ var_exp) (ren_exp (it n up_ren delta) e) = subst_exp (A .+ delta >> @var_exp X) e.
Proof.
  intros; subst. asimpl. eapply ext_exp.
  intros; unfold funcomp.
  assert (x < length A \/ x >= length A) as [] by omega.
  + rewrite it_up_ren_lt; eauto.
    eapply nth_error_lt_Some in H0 as [a].
    erewrite !nth_error_sapp; eauto.
  + rewrite it_up_ren_ge; simplify; eauto.
    erewrite !sapp_ge_in; simplify; eauto. omega.
Qed.

Lemma select_variables_subst X S I sigma:
    I ⊆ nats (length S) -> map (subst_exp (S .+ sigma))  (map (@var_exp X) I) = select I S.
Proof.
  intros. rewrite map_map; cbn.  induction I; cbn; eauto.
  destruct (nth_error S a) eqn: H1.
  + rewrite IHI; firstorder.
    f_equal. now eapply nth_error_sapp.
  + exfalso. apply nth_error_None in H1.
    specialize (H a).  mp H; [now left|].
    eapply nats_lt in H. omega.
Qed.

Lemma max_le_left n m:  n <= max n m.
Proof. eauto using Nat.max_lub_l. Qed.

Lemma max_le_right n m: m <= max n m.
Proof. eauto using Nat.max_lub_r. Qed.

Hint Resolve max_le_left max_le_right.

(* finite maps *)
Definition dom X (A: list X) := nats (length A).

Lemma dom_length X (A: list X) : length (dom A) = length A.
Proof. unfold dom; now simplify. Qed.

Lemma dom_map X Y (A: list X) (f: X -> Y): dom (map f A) = dom A.
Proof. unfold dom; now simplify. Qed.

Hint Rewrite dom_length dom_map: simplify.

Lemma dom_in X x (A: list X):
  x ∈ dom A -> exists y, nth A x = Some y.
Proof.
  now intros ? % nats_lt % nth_error_lt_Some.
Qed.

Lemma dom_nth X x A (y: X):
  nth A x = Some y -> x ∈ dom A.
Proof.
  now intros ? % nth_error_Some_lt % lt_nats.
Qed.

Lemma dom_lt_iff X x (A: list X): x ∈ dom A <-> x < length A.
Proof. split; eauto using nats_lt, lt_nats. Qed.

Hint Resolve <-dom_lt_iff.

Ltac domin H :=
  match type of H with
  | nth _ _ = _ => eapply dom_nth in H as ?
  | _ ∈ dom _ => eapply dom_in in H as [y H]; rewrite ?H
  end.

Hint Resolve nth_error_In.
Hint Resolve le_plus_r le_plus_l.
Hint Resolve Max.max_lub.
Hint Resolve Nat.le_succ_diag_r le_Sn_le.

Hint Rewrite Nat.max_lub_iff Max.max_0_r Max.max_0_l: simplify.
Hint Rewrite Nat.mul_0_r Nat.mul_succ_r Nat.mul_0_l Nat.mul_succ_l: simplify.
Hint Rewrite Nat.add_succ_r : simplify.

Arguments exp : clear implicits.

Coercion app : exp >-> Funclass.
Notation "'lambda' s" := (lam s) (at level 65, right associativity).

Arguments var_exp {_} _.
Notation var := var_exp.

Notation "A → B" := (arr A B) (at level 65, right associativity).

Coercion typevar : nat >-> type.
Definition alpha : type := 0.

Notation "gamma • s" := (subst_exp gamma s) (at level 69, right associativity).
Notation ren := ren_exp.
Notation up := up_exp_exp.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
Require Import Basic_Cons.Product.
Require Import Basic_Cons.Exponential.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import Cat.Cat_Product.

(** The exponential in cat is jsut the functor category. *)

Local Open Scope functor_scope.

(** Evaluation functor. *)
Program Definition Exp_Cat_Eval (C C' : Cat) : ((Func_Cat C.1 C'.1) × C.1) –≻ C'.1 :=
{|
  FO := fun x => ((fst x) _o (snd x))%object;
  FA := fun A B f => (((fst B) _a (snd f)) ∘ (@Trans _ _ _ _ (fst f) _))%morphism
|}.

Next Obligation. (* F_compose *)
Proof.
  repeat rewrite F_compose.
  repeat rewrite assoc.
  match goal with
      [|- (?A ∘ ?B = ?A ∘ ?C)%morphism] => cut (B = C); [intros H; rewrite H; clear H|]; trivial
  end.
  repeat rewrite assoc_sym.
  match goal with
      [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] => cut (A = C); [intros H; rewrite H; clear H|]; trivial
  end.
  rewrite Trans_com; trivial.
Defined.

(* Exp_Cat_Eval defined *)

(** The arrow map of curry functor. *)
Definition Exp_Cat_morph_ex_A
        {C C' C'' : Cat} (F : (C''.1 × C.1) –≻  C'.1)
        (a b : C''.1) (h : (a –≻ b)%morphism)
  :
    ((Fix_Bi_Func_1 a F) –≻ (Fix_Bi_Func_1 b F))%nattrans.
Proof.
  refine
    (
      @Build_NatTrans
        _
        _
        (Fix_Bi_Func_1 a F)
        (Fix_Bi_Func_1 b F)
        (fun c => (F @_a (_, _) (_, _) (h, id c))%morphism)
        _
        _
    ); cbn; auto.
Defined.

(* Exp_Cat_morph_ex_A defined *)

Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

(** The curry functor. *)
Program Definition Exp_Cat_morph_ex
        {C C' C'' : Cat}
        (F : (C''.1 × C.1) –≻ C'.1)
  :
    C''.1 –≻ (Func_Cat C.1 C'.1) :=
{|
  FO := fun a => Fix_Bi_Func_1 a F;
  FA := Exp_Cat_morph_ex_A F
|}.

(** Proof that currying after uncurrying gives back the same functor. *)
Lemma Exp_cat_morph_ex_eval_id
      {C C' C'' : Cat}
      (u : C''.1 –≻ (Func_Cat C.1 C'.1))
  :
    (u =
     Exp_Cat_morph_ex
       (Exp_Cat_Eval C C'
                     ∘ Prod_Functor (u ∘ Cat_Proj1 C''.1 C.1)
                     (Functor_id C.1 ∘ Cat_Proj2 C''.1 C.1) ∘
                     Diag_Func (C''.1 × C.1))
    )%morphism.
Proof.
  Func_eq_simpl.
  {
    extensionality a; extensionality b; extensionality h; cbn.
    apply NatTrans_eq_simplify.
    extensionality m.
    transitivity
      (
        (
          match f_equal (fun w => ((w a) _o m)%object) H in _ = V return (V –≻ _)%morphism with
            idpath =>
            match f_equal (fun w => (w b) _o m)%object H in _ = U return (_ –≻ U)%morphism with
              idpath => Trans (u _a h)%morphism m
            end
          end
        )
      ).
    {
      destruct H; trivial.
    }
    {
      match goal with
        [|- match ?X with idpath => match ?Y with idpath => _ end end = _] =>
        generalize X as H1;
          generalize Y as H2
      end.
      intros H1 H2.
      cbn in *.
      rewrite ( @center _ ((C'.2) _ _ H1 idpath)).
      rewrite ( @center _ ((C'.2) _ _ H2 idpath)).
      auto.
    }
  }
  {
    FunExt; cbn.
    Func_eq_simpl; cbn; auto.
  }
Qed.

(** The exponential for category of categories (functor categories). *)
Definition Cat_Exponential (C C' : Cat) : @Exponential Cat _ C C'.
Proof.
  refine
    (
      @Build_Exponential
        Cat
        _
        C
        C'
        (Func_Cat C.1 C'.1; @CoDom_Cat_HSet_Functor_HSet (C.1) (C'.1) (C'.2))
        (Exp_Cat_Eval C C')
        (fun C'' F => @Exp_Cat_morph_ex C C' C'' F)
        _
        _
    ); cbn.
  {
    intros z f.
    Func_eq_simpl.
    FunExt; cbn.
    rewrite <- F_compose; cbn.
    auto.
  }
  {
    intros z f u u' H1 H2.
    rewrite H1 in H2; clear H1.
    assert (H3 := @f_equal _ _ Exp_Cat_morph_ex _ _ H2); clear H2.
    cbn in *.
    repeat rewrite <- Exp_cat_morph_ex_eval_id in H3; trivial.
  }
Qed.

(* Cat_Exponentials defined *)

Program Instance Cat_Has_Exponentials : Has_Exponentials Cat := Cat_Exponential.


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

Require Import List Arith Lia Wellfounded.

Require Import bt env.

Set Implicit Arguments.

Inductive Var : Set := in_Var : nat -> Var.
Inductive Fun : Set := in_Fun : nat -> Fun.

Hint Resolve eq_nat_dec.

Definition Var_eq_dec : forall x y : Var, { x = y } + { x <> y }.
Proof. decide equality. Qed.

Definition Fun_eq_dec : forall f g : Fun, { f = g } + { f <> g }.
Proof. decide equality. Qed.

Local Notation "e ⇢ x" := (@get_env _ _ e x).
Local Notation "e ⦃  x ⇠ v ⦄" := (@set_env _ _ Var_eq_dec e x v).

Inductive fun_expr : Set :=
  | fe_var    : Var -> fun_expr

  | fe_null   : fun_expr
  | fe_pair   : fun_expr -> fun_expr -> fun_expr
  | fe_match  : fun_expr -> fun_expr -> Var -> Var -> fun_expr -> fun_expr

  | fe_let    : Var -> fun_expr -> fun_expr -> fun_expr

  | fe_call   : Fun -> fun_expr -> fun_expr.

Delimit Scope expr_scope with fun_expr.

Notation " £ x " := (fe_var x) (at level 0, format "£ x") : expr_scope.

Notation ø := fe_null.
Notation " x '#' y " := (fe_pair x y) (at level 26, y at level 0, format "x # y", right associativity) : expr_scope.
Notation " 'MATCH' e 'WITH' 'ø' ⇒ a 'OR' x '#' y ⇒ b " := (fe_match e a x y b) (at level 29, format "MATCH  e  WITH  ø  ⇒  a  OR  x # y  ⇒  b", x at level 0, y at level 0) : expr_scope.

Notation " 'LET' x '::=' y 'IN' z " := (fe_let x y z) (at level 25, format "LET  x ::= y  IN  z", x at level 0, y at level 0, z at level 0) : expr_scope.
Notation " 'CALL' f 'ON' x " := (fe_call  f x) (at level 25, f at level 0, format "CALL  f  ON  x", x at level 0) : expr_scope.

Open Scope expr_scope.

Reserved Notation " f '//' s '~~>' v" (at level 70, no associativity).

Section fun_sem.

  Variable (param : Fun -> Var) (body : Fun -> fun_expr).

  Inductive fun_sem : fun_expr -> env Var bt -> bt -> Prop :=
    | in_fs_var  : forall x e,                       £ x // e ~~> e⇢x
    | in_fs_null : forall e,                           ø // e ~~> ω
    | in_fs_pair : forall f g e a b,                   f // e ~~> a
                                               ->      g // e ~~> b
                                               ->    f#g // e ~~> ⟨a,b⟩
    | in_fs_match_0 : forall f u x y v e a,            f // e ~~> ω
                            ->                         u // e ~~> a
                            -> MATCH f WITH ø⇒u OR x#y⇒v // e ~~> a
    | in_fs_match_1 : forall f u x y v e a b c,        f // e ~~> ⟨a,b⟩
                            ->                         v // e⦃x⇠a⦄⦃y⇠b⦄ ~~> c
                            -> MATCH f WITH ø⇒u OR x#y⇒v // e ~~> c
    | in_fs_let : forall x f g e a b,                  f // e ~~> a
                            ->                         g // e⦃x⇠a⦄ ~~> b
                            ->            LET x::=f IN g // e ~~> b
    | in_fs_call : forall p g e a b,                   g // e ~~> a
                            ->                    body p // e⦃param p⇠a⦄ ~~> b
                            ->               CALL p ON g // e ~~> b

  where "f // e ~~> v" := (fun_sem f e v).

  Fact fs_var x e a : e⇢x = a -> £x // e ~~> a.
  Proof.
    intros E.
    rewrite <- E.
    constructor 1.
  Qed.

(* intros []; constructor. Qed. *)

  Fact fun_sem_var_inv x e a : £x // e ~~> a -> a = e⇢x.
  Proof. inversion 1; auto. Qed.

  Fact fun_sem_null_inv e a : ø // e ~~> a -> a = ω.
  Proof. inversion 1; auto. Qed.

  Fact fun_sem_pair_inv f g e v : f#g // e ~~> v
                               -> exists a b, v = ⟨a,b⟩ /\ f // e ~~> a /\ g // e ~~> b.
  Proof. inversion 1; exists a, b; auto. Qed.

  Fact fun_sem_match_inv f u x y v e c :
        MATCH f WITH ø⇒u OR x#y⇒v // e ~~> c -> f // e ~~> ω /\ u // e ~~> c
                                 \/ exists a b, f // e ~~> ⟨a,b⟩ /\ v // e⦃x⇠a⦄⦃y⇠b⦄ ~~> c.
  Proof.
    inversion 1.
    + left; auto.
    + right; exists a, b; auto.
  Qed.

  Fact fun_sem_let_inv x f g e v : LET x::=f IN g // e ~~> v -> exists a, f // e ~~> a /\ g // e⦃x⇠a⦄ ~~> v.
  Proof. inversion 1; exists a; auto. Qed.

  Fact fun_sem_call_inv fi g e v : CALL fi ON g // e ~~> v -> exists a, g // e ~~> a /\ body fi // e⦃param fi⇠a⦄ ~~> v.
  Proof. inversion 1; exists a; auto. Qed.

  Fact fun_sem_det f e a b : f // e ~~> a -> f // e ~~> b -> a = b.
  Proof.
    intros H1; revert H1 b.
    induction 1 as [ x e
                   | e
                   | f g e a b H1 IH1 H2 IH2
                   | f u x y v e a H1 IH1 H2 IH2
                   | f u x y v e a b c H1 IH1 H2 IH2
                   | x f g e a b H1 IH1 H2 IH2
                   | p g e a b H1 IH1 H2 IH2 ].
    + intros v H; apply fun_sem_var_inv in H; auto.
    + intros v H; apply fun_sem_null_inv in H; auto.
    + intros v H; apply fun_sem_pair_inv in H.
      destruct H as (a' & b' & H3 & H4 & H5); subst; f_equal; auto.
    + intros c H.
      apply fun_sem_match_inv in H.
      destruct H as [ (H3 & H4) | (a' & b' & H3 & H4) ]; auto.
      apply IH1 in H3; discriminate.
    + intros w H.
      apply fun_sem_match_inv in H.
      destruct H as [ (H3 & H4) | (a' & b' & H3 & H4) ].
      * apply IH1 in H3; discriminate.
      * apply IH1 in H3; inversion H3.
        apply IH2; subst; auto.
    + intros v H.
      apply fun_sem_let_inv in H.
      destruct H as (a' & H3 & H4).
      apply IH1 in H3; subst; auto.
    + intros v H.
      apply fun_sem_call_inv in H.
      destruct H as (a' & H3 & H4).
      apply IH1 in H3; subst; auto.
  Qed.

  Section loop.

    Variables (p : Var) (loop : Fun) (Hloop1 : param loop = p) (Hloop2 : body loop = CALL loop ON £p).

    Let loop_does_not_stop f e a : f // e ~~> a -> forall e', f = CALL loop ON e' -> False.
    Proof.
      induction 1 as [ x e
                     | e
                     | f g e a b H1 IH1 H2 IH2
                     | f u x y v e a H1 IH1 H2 IH2
                     | f u x y v e a b c H1 IH1 H2 IH2
                     | x f g e a b H1 IH1 H2 IH2
                     | fi g e a b H1 IH1 H2 IH2 ]; intros e'; try discriminate.
      inversion 1; subst fi g.
      rewrite Hloop2 in IH2.
      apply (IH2 _ eq_refl).
    Qed.

    Theorem loop_spec f e a : ~ CALL loop ON f // e ~~> a.
    Proof.
      intros H.
      apply loop_does_not_stop with (1 := H) (2 := eq_refl).
    Qed.

  End loop.

End fun_sem.


Require Export Undecidability.FOL.Syntax.Core.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Vector.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Set Default Proof Using "Type".

Local Notation vec := Vector.t.

Import FullSyntax.
Export FullSyntax.

(* Tarski Semantics ***)

Section Tarski.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  (* Semantic notions *)

  Section Semantics.

    Variable domain : Type.

    Class interp := B_I
      {
        i_func : forall f : syms, vec domain (ar_syms f) -> domain ;
        i_atom : forall P : preds, vec domain (ar_preds P) -> Prop ;
      }.

    Definition env := nat -> domain.

    Context {I : interp}.

    Fixpoint eval (rho : env) (t : term) : domain :=
      match t with
      | var s => rho s
      | func f v => i_func (Vector.map (eval rho) v)
      end.

    Fixpoint sat {ff : falsity_flag} (rho : env) (phi : form) : Prop :=
      match phi with
      | atom P v => i_atom (Vector.map (eval rho) v)
      | falsity => False
      | bin Impl phi psi => sat rho phi -> sat rho psi
      | bin Conj phi psi => sat rho phi /\ sat rho psi
      | bin Disj phi psi => sat rho phi \/ sat rho psi
      | quant All phi => forall d : domain, sat (d .: rho) phi
      | quant Ex phi => exists d : domain, sat (d .: rho) phi
      end.

  End Semantics.

  Notation "rho ⊨ phi" := (sat rho phi) (at level 20).

End Tarski.

Arguments sat {_ _ _ _ _} _ _, {_ _ _} _ {_} _ _.
Arguments interp {_ _} _, _ _ _.

Notation "p ⊨ phi" := (sat _ p phi) (at level 20).
Notation "I ⊨= phi" := (forall p, sat I p phi) (at level 20).
Notation "p ⊫ A" := (forall psi, psi el A -> sat _ p psi) (at level 20).

Section Defs.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ff : falsity_flag}.

  Definition valid_ctx A phi := forall D (I : interp D) rho, (forall psi, psi el A -> rho ⊨ psi) -> rho ⊨ phi.
  Definition valid phi := forall D (I : interp D) rho, rho ⊨ phi.
  Definition valid_L A := forall D (I : interp D) rho, rho ⊫ A.
  Definition satis phi := exists D (I : interp D) rho, rho ⊨ phi.
  Definition fullsatis A := exists D (I : interp D) rho, rho ⊫ A.

End Defs.


(** Adapted from "Elements of Set Theory" Chapter 3 **)
(** Coq coding by choukh, May 2020 **)

Require Export ZFC.Elements.EST3_2.

(*** EST第三章3：等价关系，等价类，商集，三歧性，线序 ***)

(* 在A上的二元关系R *)
Definition is_binRel : set → set → Prop := λ R A, R ⊆ A × A.

Definition BinRel : set → (set → set → Prop) → set :=
  λ A P, Rel A A P.

Lemma binRelI : ∀ A (P : set → set → Prop), ∀ a b ∈ A,
  P a b → <a, b> ∈ BinRel A P.
Proof.
  intros A P a Ha b Hb H. apply SepI.
  apply CPrdI; auto. zfc_simple.
Qed.

Lemma binRelE1 : ∀ A P p,
  p ∈ BinRel A P → ∃a ∈ A, ∃b ∈ A, p = <a, b> ∧ P a b.
Proof with auto.
  intros. apply SepE in H as [Hp H].
  apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]]. subst p.
  zfc_simple. exists a. split... exists b. split...
Qed.

Lemma binRelE2 : ∀ A P a b,
  <a, b> ∈ BinRel A P → a ∈ A ∧ b ∈ A ∧ P a b.
Proof.
  intros. apply SepE in H as [Hp H].
  apply CPrdE2 in Hp as [Ha Hb]. zfc_simple. split; auto.
Qed.

Lemma binRelE3 : ∀ A P a b,
  <a, b> ∈ BinRel A P → P a b.
Proof.
  intros. apply binRelE2 in H as [_ [_ H]]. apply H.
Qed.

Lemma binRel_is_binRel : ∀ A P, is_binRel (BinRel A P) A.
Proof.
  intros * p Hp.
  apply binRelE1 in Hp as [a [Ha [b [Hb [Hp _]]]]].
  subst p. apply CPrdI; auto.
Qed.

Lemma binRel_is_rel : ∀ R A, is_binRel R A → is_rel R.
Proof.
  intros * H p Hp. apply H in Hp. apply cprd_is_pairs in Hp. apply Hp.
Qed.

Lemma dom_binRel : ∀ R A, is_binRel R A → dom R ⊆ A.
Proof.
  intros * Hr x Hx. apply domE in Hx as [y Hp].
  apply Hr in Hp. apply CPrdE2 in Hp as [Hx _]. apply Hx.
Qed.

Lemma ran_binRel : ∀ R A, is_binRel R A → ran R ⊆ A.
Proof.
  intros * Hr x Hx. apply ranE in Hx as [y Hp].
  apply Hr in Hp. apply CPrdE2 in Hp as [_ Hx]. apply Hx.
Qed.

(* 自反性 *)
Definition refl : set → set → Prop := λ R A,
  ∀x ∈ A, <x, x> ∈ R.

(* 对称性 *)
Definition symm : set → Prop := λ R,
  ∀ x y, <x, y> ∈ R → <y, x> ∈ R.

(* 传递性 *)
Definition tranr : set → Prop := λ R,
  ∀ x y z, <x, y> ∈ R → <y, z> ∈ R → <x, z> ∈ R.

(** 等价关系 **)
Definition equiv : set → set → Prop := λ R A,
  is_binRel R A ∧ refl R A ∧ symm R ∧ tranr R.

Theorem equiv_fld : ∀ R, is_rel R →
  symm R → tranr R → equiv R (fld R).
Proof with eauto.
  intros R Hr Hs Ht. repeat split...
  - intros x Hx. apply rel_pair in Hx as Hxp... rewrite Hxp in *.
    apply CPrdI. apply BUnionI1. eapply domI...
    apply BUnionI2. eapply ranI...
  - intros x Hx. apply BUnionE in Hx as [].
    + apply domE in H as [y Hp]. apply Hs in Hp as Hp'. eapply Ht...
    + apply ranE in H as [y Hp]. apply Hs in Hp as Hp'. eapply Ht...
Qed.

(* 等价类 *)
Definition EquivClass : set → set → set := λ x R,
  {t ∊ ran R | <x, t> ∈ R}.
Notation "[ x ] R" := (EquivClass x R) (at level 35, format "[ x ] R") : set_scope.

Lemma eqvcI : ∀ R x y, <x, y> ∈ R → y ∈ [x]R.
Proof with eauto. intros. apply SepI... eapply ranI... Qed.

Lemma eqvcE : ∀ R x y, y ∈ [x]R → <x, y> ∈ R.
Proof. intros. apply SepE2 in H. apply H. Qed.

Lemma eqvc_refl: ∀ R A, refl R A → ∀x ∈ A, x ∈ [x]R.
Proof. intros R A Hrf x Hx. apply eqvcI. apply Hrf; auto. Qed.

Lemma eqvc_ident : ∀ R A, ∀ x y ∈ A, equiv R A →
  [x]R = [y]R ↔ <x, y> ∈ R.
Proof with eauto.
  intros R A x Hx y Hy [_ [Hrf [Hsy Htr]]]. split.
  - intros Heq.
    assert (y ∈ [y]R) by (eapply eqvc_refl; eauto).
    rewrite <- Heq in H. apply eqvcE in H...
  - intros Hp. ext w Hw.
    + apply eqvcE in Hw. apply eqvcI...
    + apply eqvcE in Hw. apply eqvcI...
Qed.

(* 划分 *)
Definition partition : set → set → Prop := λ Π A,
  (* 子集 *) (∀B ∈ Π, ⦿ B ∧ B ⊆ A) ∧
  (* 不交 *) (∀ X Y ∈ Π, X ≠ Y → disjoint X Y) ∧
  (* 穷尽 *) ∀x ∈ A, ∃X ∈ Π, x ∈ X.

(* 商集：等价类的集合 *)
Definition Quotient : set → set → set := λ R A,
  {[x]R | x ∊ A}.
Notation "A / R" := (Quotient R A) : set_scope.

Lemma quotI : ∀ R A, ∀a ∈ A, [a]R ∈ A / R.
Proof. intros R A a Ha. apply ReplAx. exists a. split; auto. Qed.

Lemma quotE : ∀ R A, ∀x ∈ A / R, ∃a ∈ A, [a]R = x.
Proof.
  intros R A x Hx. apply ReplAx in Hx as [a [Ha Heq]].
  exists a. split; auto.
Qed.

Theorem quotient_is_partition : ∀ R A,
  equiv R A → partition (A/R) A.
Proof with eauto.
  intros R A [Hr [Hrf [Hsy Htr]]]. split; [|split].
  - intros B HB. split.
    + apply quotE in HB as [a [Ha Heq]]. subst B.
      exists a. apply eqvcI. apply Hrf...
    + intros x Hx. apply quotE in HB as [a [Ha Heq]].
      subst B. apply eqvcE in Hx. apply Hr in Hx.
      apply CPrdE2 in Hx as [_ Hx]...
  - intros X HX Y HY Hnq. apply EmptyI.
    intros t Ht. apply Hnq. apply BInterE in Ht as [H1 H2].
    apply ReplAx in HX as [x [Hx Hxeq]].
    apply ReplAx in HY as [y [Hy Hyeq]]. subst X Y.
    apply eqvcE in H1. apply eqvcE in H2.
    eapply eqvc_ident... repeat split...
  - intros x Hx. exists ([x]R). split.
    apply ReplAx. exists x. split... eapply eqvc_refl...
Qed.

(* 函数与关系的相容性 *)
Definition compatible : set → set → set → Prop := λ R A F,
  ∀ x y ∈ A, <x, y> ∈ R → <F[x], F[y]> ∈ R.

Lemma compatibleE0 : ∀ R A F, equiv R A → F: A ⇒ A →
  compatible R A F → ∃F', F': A/R ⇒ A/R ∧ ∀x ∈ A, F'[[x]R] = [F[x]]R.
Proof with eauto.
  intros * Hqv [Hf [Hdf Hrf]] Hc.
  set ({<[x]R, [F[x]]R> | x ∊ A}) as F'.
  assert (Hf': is_function F'). {
    split.
    (* is_rel *)
    - intros p Hp. apply ReplAx in Hp as [x []]. subst p. eexists...
    - intros x Hx. rewrite <- unique_existence.
      split. apply domE in Hx...
      intros y1 y2 Hy1 Hy2.
      apply ReplAx in Hy1 as [a1 [Ha1 Heq1]].
      apply ReplAx in Hy2 as [a2 [Ha2 Heq2]].
      apply op_iff in Heq1 as [Heq1 Hy1].
      apply op_iff in Heq2 as [Heq2 Hy2].
      subst. symmetry in Heq2.
      eapply eqvc_ident in Heq2... apply Hc in Heq2...
      apply func_correct in Ha1... apply func_correct in Ha2...
      eapply eqvc_ident; [| |eauto..]; apply Hrf; eapply ranI...
  }
  assert (Hdf': dom F' = A/R). {
    ext Hx.
    - apply domE in Hx as [y Hp]. apply ReplAx in Hp as [a [Hp Heq]].
      apply op_iff in Heq as [Heq _]. subst x. apply quotI...
    - apply quotE in Hx as [a [Ha Heq]]. eapply domI.
      apply ReplAx. exists a. split... apply op_iff...
  }
  assert (Hrf': ran F' ⊆ A/R). {
    intros y Hy. apply ranE in Hy as [].
    apply ReplAx in H as [a [Ha Heq]].
    apply op_iff in Heq as [_ Hy]. subst A y.
    apply func_correct in Ha as Hp... apply ranI in Hp as Hr.
    apply Hrf in Hr. apply quotI...
  }
  exists F'. split. split... intros a Ha.
  (* F'[[x]R] = [F[x]]R *)
  assert (Hd: [a]R ∈ A/R) by (apply quotI; auto).
  rewrite <- Hdf' in Hd. apply func_correct in Hd...
  apply ReplAx in Hd as [b [Hb Heq]].
  apply op_iff in Heq as [H1 H2].
  eapply eqvc_ident in H1... apply Hc in H1... subst A.
  apply func_correct in Ha as Har... apply ranI in Har.
  apply func_correct in Hb as Hbr... apply ranI in Hbr.
  apply Hrf in Har. apply Hrf in Hbr.
  apply (eqvc_ident R (dom F)) in H1... congruence.
Qed.

Theorem compatibleE : ∀ R A F, equiv R A → F: A ⇒ A →
  compatible R A F → ∃!F', F': A/R ⇒ A/R ∧ ∀x ∈ A, F'[[x]R] = [F[x]]R.
Proof with eauto.
  intros * Hqv Hf Hc.
  pose proof compatibleE0 as [F1 [[HF1 [Hd1 Hr1]] H1]]...
  exists F1. split. split... split...
  intros F2 [[HF2 [Hd2 Hr2]] H2].
  apply func_ext_intro... rewrite Hd1, Hd2...
  intros x Hx. rewrite Hd1 in Hx. apply quotE in Hx as [a [Ha Heq]].
  apply H1 in Ha as Heq1. apply H2 in Ha as Heq2. congruence.
Qed.

Theorem compatibleI : ∀ R A F, equiv R A → F: A ⇒ A →
  (∃F', F': A/R ⇒ A/R ∧ ∀x ∈ A, F'[[x]R] = [F[x]]R) →
  compatible R A F.
Proof with eauto.
  intros * Hqv [HF [Hd Hr]] [F' [[HF' [Hd' Hr']] H]].
  intros a Ha b Hb Hp. subst A.
  apply func_correct in Ha as Hp1... apply ranI in Hp1.
  apply func_correct in Hb as Hp2... apply ranI in Hp2.
  apply Hr in Hp1. apply Hr in Hp2.
  apply (eqvc_ident R (dom F)) in Hp...
  assert (Ha': [a]R ∈ dom F') by (rewrite Hd'; apply quotI; auto).
  apply func_correct in Ha'... assert (Hb' := Ha').
  rewrite Hp in Hb' at 2.
  assert (F'[[a]R] = F'[[b]R]) by (eapply func_sv; eauto).
  apply H in Ha. apply H in Hb.
  eapply eqvc_ident... congruence.
Qed.

(** 序关系 **)

(* 三歧性 *)
Definition trich : set → set → Prop := λ R A, ∀ x y ∈ A,
  <x, y> ∈ R ∧ x ≠ y ∧ <y, x> ∉ R ∨
  <x, y> ∉ R ∧ x = y ∧ <y, x> ∉ R ∨
  <x, y> ∉ R ∧ x ≠ y ∧ <y, x> ∈ R.

(* 严格全序，线序 *)
Definition linearOrder : set → set → Prop := λ R A,
  is_binRel R A ∧ tranr R ∧ trich R A.

(* 反自反性 *)
Definition irrefl : set → Prop := λ R,
  ∀ x, <x, x> ∉ R.

(* 连通性 *)
Definition connected : set → set → Prop := λ R A,
  ∀ x y ∈ A, x ≠ y → <x, y> ∈ R ∨ <y, x> ∈ R.

Theorem lo_irrefl : ∀ R A,
  linearOrder R A → irrefl R.
Proof.
  intros * [Hrl [_ Htri]] x Hp. apply Hrl in Hp as Hx.
  apply CPrdE2 in Hx as [Hx _]. firstorder.
Qed.

Theorem lo_connected : ∀ R A,
  linearOrder R A → connected R A.
Proof. intros * [_ [_ Htri]] x Hx y Hy Hnq. firstorder. Qed.

Theorem trich_iff : ∀ R A, is_binRel R A → tranr R →
  trich R A ↔ irrefl R ∧ connected R A.
Proof with eauto; try congruence.
  intros * Hrl Htr. split; intros.
  - split. eapply lo_irrefl. split...
    apply lo_connected. split...
  - intros x Hx y Hy. destruct H as [Hir Hco].
    destruct (classic (x = y)).
    + right. left. subst. repeat split...
    + destruct (Hco x Hx y Hy H).
      * left. repeat split...
        intros Hp. eapply Hir...
      * right. right. repeat split...
        intros Hp. eapply Hir...
Qed.


Require Import Braun.monad.monad Braun.common.log.
Require Import Braun.common.util Braun.common.big_oh Braun.common.le_util.
Require Import Arith Arith.Even Arith.Div2.
Require Import Coq.Program.Wf Arith.Even Arith.Div2 Arith Init.Wf Omega.

Include WfExtensionality.

Program Fixpoint add1_time (n:nat) {measure n} :=
  match n with
    | 0 => 1
    | S _ => if (even_odd_dec n)
             then 1
             else (add1_time (div2 n)) + 1
  end.

Lemma add1_time_0 : add1_time 0 = 1.
Proof.
  unfold_sub add1_time (add1_time 0); auto.
Qed.

Lemma add1_time_S : forall n, 1 <= add1_time (S n).
Proof.
  intros n.
  apply (well_founded_ind
           lt_wf
           (fun n =>
              1 <= add1_time n)).
  intros.
  destruct x.
  rewrite add1_time_0;auto.
  unfold_sub add1_time (add1_time (S x)).
  dispatch_if EW' EW';auto.
  fold_sub add1_time.
  destruct x; auto.
  omega.
Qed.

Definition add1_result (n:nat) (res:nat) (c:nat) :=
  n+1 = res /\ c = add1_time n.
Hint Unfold add1_result.

Load "add1_gen.v".

Next Obligation.
Proof.
  split;auto.
  unfold_sub add1_time (add1_time (S wildcard')).
  fold_sub add1_time.
  dispatch_if EW EW'; intuition.
  assert False; intuition.
  apply (not_even_and_odd (S wildcard')); auto.
Qed.

Next Obligation.
Proof.
  clear H2 am add1.
  rename H into EW.
  rename H1 into SR.

  destruct SR; subst sd2 an.

  split.
  replace (div2 (S wildcard') + 1 + (div2 (S wildcard') + 1))
  with (S (div2 (S wildcard') + div2 (S wildcard')) + 1);[|omega].
  replace (div2 (S wildcard') + div2 (S wildcard'))
  with (double (div2 (S wildcard')));[|unfold double;auto].
  rewrite <- odd_double; auto.

  unfold_sub add1_time (add1_time (S wildcard')).
  fold_sub add1_time.
  dispatch_if EW' EW''; intuition.
  assert False; intuition.
  apply (not_even_and_odd (S wildcard')); auto.
Qed.

Program Fixpoint add1_time2 (n:nat) {measure n} :=
  match n with
    | 0 => 0
    | S _ => if (even_odd_dec n)
             then 1
             else (add1_time2 (div2 n)) + 1
  end.

Lemma  add1_time_Sn : forall n,
                        add1_time (S n) <= (add1_time (div2 (S n))) + 1.
Proof.
  intros.
  unfold_sub add1_time (add1_time (S n)).
  fold_sub add1_time.
  dispatch_if EW EW.
  omega.
  destruct n; auto.
Qed.

Lemma add1_time12 : big_oh add1_time add1_time2.
Proof.
  exists 1.
  exists 14.
  intros n LE.
  destruct n; intuition.
  clear LE.
  apply (well_founded_induction
           lt_wf
           (fun n => add1_time (S n) <= 14 * add1_time2 (S n))).
  clear n; intros n IND.
  unfold_sub add1_time (add1_time (S n)); fold_sub add1_time.
  unfold_sub add1_time2 (add1_time2 (S n)); fold add1_time2.
  dispatch_if COND1 COND1'; try omega.
  destruct n.
  simpl; omega.
  rewrite mult_plus_distr_l.
  apply plus_le_compat;[|omega].
  apply IND; auto.
Qed.

Theorem add1_log : big_oh add1_time cl_log.
Proof.
  apply (big_oh_trans add1_time add1_time2).
  apply add1_time12.

  exists 0.
  exists 1.
  intros n _.
  rewrite mult_1_l.
  apply (well_founded_induction
           lt_wf
           (fun n => add1_time2 n <= cl_log n)).
  clear n; intros n IND.
  destruct n.
  unfold_sub add1_time2 (add1_time2 0).
  omega.

  unfold_sub add1_time2 (add1_time2 (S n)).
  fold add1_time2.

  dispatch_if COND1 COND1'.
  rewrite <- fl_log_cl_log_relationship.
  apply le_n_S.
  omega.

  destruct n.
  simpl.
  rewrite cl_log_div2'.
  apply le_n_S.
  omega.

  apply (le_trans (add1_time2 (S (div2 n)) + 1)
                  (cl_log (S (div2 n)) + 1)).
  apply plus_le_compat;auto.
  apply IND.
  apply lt_n_S.
  auto.

  replace (cl_log (S (S n))) with (S (cl_log (div2 (S (S n)))));[|rewrite cl_log_div2';auto].
  simpl div2.
  omega.
Qed.

Lemma cl_log_bnd_add1_time : forall n,
                               1 <= n ->
                               add1_time n <= 2 * cl_log n.
Proof.
  intros.
  apply le_trans with (2*add1_time2 n).
  destruct n ; intuition.
  apply (well_founded_induction
           lt_wf
           (fun n => add1_time (S n) <= 2 * add1_time2 (S n))).
  intros.
  unfold_sub add1_time (add1_time (S x)); fold_sub add1_time.
  unfold_sub add1_time2 (add1_time2 (S x)); fold add1_time2.
  dispatch_if COND1 COND1'; try omega.
  destruct x.
  simpl; omega.
  rewrite mult_plus_distr_l.
  apply plus_le_compat;[|omega].
  apply H0; auto.
  apply mult_le_compat_l.
  apply (well_founded_induction
           lt_wf
           (fun n => add1_time2 n <= cl_log n)).
  intros.
  destruct x.
  unfold_sub add1_time2 (add1_time2 0).
  omega.

  unfold_sub add1_time2 (add1_time2 (S x)).
  fold add1_time2.

  dispatch_if COND1 COND1'.
  rewrite <- fl_log_cl_log_relationship.
  apply le_n_S.
  omega.

  destruct x.
  simpl.
  rewrite cl_log_div2'.
  apply le_n_S.
  omega.

  apply (le_trans (add1_time2 (S (div2 x)) + 1)
                  (cl_log (S (div2 x)) + 1)).
  apply plus_le_compat;auto.
  apply H0.
  apply lt_n_S.
  auto.

  replace (cl_log (S (S x))) with (S (cl_log (div2 (S (S x)))));[|rewrite cl_log_div2';auto].
  simpl div2.
  omega.
Qed.


(**

The motivation of top-like comes from defining disjointness for types: "Two types are disjoint if they have no common super types".
However, since we introduce [Top] to our type system, now every two types have at least one common supertype: [Top].

Situation is becoming more complicated after we introduce intersection types and its subtyping,
Top, Top & Top, Top & Top & Top ... are supertypes of all types. We need to generalize the idea of top-like types like these.

 **)

Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Metalib.LibTactics.
Require Import Language.

(** * Definition *)

Inductive toplike : type -> Prop :=
| Tl_Top :
    toplike Top
| Tl_And : forall A B,
    toplike A ->
    toplike B ->
    toplike (And A B)
| Tl_Arr : forall A B,
    toplike B ->
    toplike (Arr A B).

Hint Constructors toplike : core.

(** * Automations *)

(** ** Structural Inversion *)

Ltac solve_toplike :=
  match goal with
  | [H: toplike Int |- _] =>
      (inversion H)
  | [H: toplike (Arr _ ?B) |- toplike ?B] =>
      (dependent destruction H; assumption)
  end.

Hint Extern 5 => solve_toplike : core.

(** ** Contradictions *)

Ltac contra_toplike :=
  match goal with
  | [H1: toplike ?A, H2: not (toplike ?A) |- _] =>
      (contradiction)
  | [H1: toplike (Arr _ ?A), H2: not (toplike ?A) |- _] =>
      (dependent destruction H1; contradiction)
  | [H1: toplike (And ?A _), H2: not (toplike ?A) |- _] =>
      (dependent destruction H1; contradiction)
  | [H1: toplike (And _ ?A), H2: not (toplike ?A) |- _] =>
      (dependent destruction H1; contradiction)
  end.

Hint Extern 5 => contra_toplike : core.

(** * Properties *)

(** ** Decidablility *)

(** For any type A, it's toplike or not toplike *)

Lemma toplike_decidable:
  forall A,
    toplike A \/ ~ toplike A.
Proof.
  intro A.
  induction A.
  - Case "Int".
    right. intro Contra. inversion Contra.
  - Case "Top".
    left. constructor.
  - Case "Arr".
    destruct IHA1; destruct IHA2; eauto;
      try solve [right; intros Contra; eauto].
  - Case "And".
    destruct IHA1; destruct IHA2; eauto;
      try solve [right; intros Contra; eauto].
Qed.


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

Notation rel := (fun A B => A -> B -> Prop).
Notation inv := ((fun X Y (R : X -> Y -> Prop) x y => R y x) _ _).

Notation "R 'inc1' S" := (forall x, R x -> S x) (at level 72).
Notation "R 'inc2' S" := (forall x y, R x y -> S x y) (at level 72).

Notation " R 'o'    S" := (fun x z => exists y, R x y /\ S y z) (at level 65).

Notation " R 'cap2' S " := (fun x y => R x y /\ S x y) (at level 65).
Notation " R 'cup2' S " := (fun x y => R x y \/ S x y) (at level 65).

Definition total { X Y } (R : X -> Y -> Prop) : Prop := forall v, exists x, R v x.
Definition functional { X Y } (R : X -> Y -> Prop) : Prop := forall v x y, R v x -> R v y -> x = y.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rlt_irrefl.
Require Export XR_Rlt_asym.
Require Export XR_total_order_T.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_dec : forall r1 r2, {r1 < r2} + {~ r1 < r2}.
Proof.
  intros x y.
  destruct (total_order_T x y) as [ [ hxy | heq ] | hyx ].
  {
    left.
    exact hxy.
  }
  {
    subst y.
    right.
    apply Rlt_irrefl.
  }
  {
    right.
    apply Rlt_asym.
    exact hyx.
  }
Qed.


Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Lt.

Open Scope nat_scope.

(* trivial helpers *)

Theorem eq_ge: forall (a b : nat), Eq = nat_compare a b -> a >= b.
Proof.
    intros a b Eq.
Admitted.

Theorem gt_ge: forall (a b : nat), Gt = nat_compare a b -> a >= b.
Proof.
Admitted.

Theorem not_eq_r: forall (n m : nat), n >= m -> ~ n < m.
Proof.
Admitted.

Theorem not_ge_r: forall (n m : nat), n < m -> ~ n >= m.
Proof.
Admitted.

Theorem eq_nmo_mo: forall (n m o : nat),
    Eq = nat_compare n m -> Eq = nat_compare n o -> Eq = nat_compare m o.
Proof.
    intros n m o H1 H2.
        assert (A1 : n = m). apply nat_compare_eq. symmetry. assumption.
        assert (A2 : n = o). apply nat_compare_eq. symmetry. assumption.
        rewrite A1 in H2.
        assumption.
Qed.

Theorem gt_nmo_mo : forall (n m o : nat),
    Eq = nat_compare n m -> Gt = nat_compare n o -> Gt = nat_compare m o.
Proof.
    intros n m o H1 H2.
        assert (A1 : n = m). apply nat_compare_eq. symmetry. assumption.
        assert (A2 : n > o). apply nat_compare_gt. symmetry. assumption.
        rewrite A1 in H2.
        assumption.
Qed.


Require Import UniMath.Foundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.

Require Import UniMath.CategoryTheory.opp_precat.

Definition opp_cat (C : category)
  : category.
Proof.
  exists (opp_precat C).
  apply has_homsets_op.
Defined.

Notation " C ^opp" := (opp_cat C) (at level 31).

(* functor_opp is defined as a functor between precategories,
   so in order to avoid always explicit casting, the following is introduced: *)
Definition functor_op {C D : category} (F : functor C D)
  : functor (opp_cat C) (opp_cat D)
  := functor_opp F.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.derive.Derive.
Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.

Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.

Section mod_ops.
  Import Positional.
  Local Coercion Z.of_nat : nat >-> Z.
  Local Coercion QArith_base.inject_Z : Z >-> Q.
  (* Design constraints:
     - inputs must be [Z] (b/c reification does not support Q)
     - internal structure must not match on the arguments (b/c reification does not support [positive]) *)
  Context (limbwidth_num limbwidth_den : Z)
          (limbwidth_good : 0 < limbwidth_den <= limbwidth_num)
          (s : Z)
          (c : list (Z*Z))
          (n : nat)
          (len_c : nat)
          (idxs : list nat)
          (len_idxs : nat)
          (m_nz:s - Associational.eval c <> 0) (s_nz:s <> 0)
          (Hn_nz : n <> 0%nat)
          (Hc : length c = len_c)
          (Hidxs : length idxs = len_idxs).
  Definition weight (i : nat)
    := 2^(-(-(limbwidth_num * i) / limbwidth_den)).

  Local Ltac Q_cbv :=
    cbv [Qceiling inject_Z Qle Qfloor Qdiv Qnum Qden Qmult Qinv Qopp].

  Local Lemma weight_ZQ_correct i
        (limbwidth := (limbwidth_num / limbwidth_den)%Q)
    : weight i = 2^Qceiling(limbwidth*i).
  Proof using limbwidth_good.
    clear -limbwidth_good.
    cbv [limbwidth weight]; Q_cbv.
    destruct limbwidth_num, limbwidth_den, i; try reflexivity;
      repeat rewrite ?Pos.mul_1_l, ?Pos.mul_1_r, ?Z.mul_0_l, ?Zdiv_0_l, ?Zdiv_0_r, ?Z.mul_1_l, ?Z.mul_1_r, <- ?Z.opp_eq_mul_m1, ?Pos2Z.opp_pos;
      try reflexivity; try lia.
  Qed.

  Local Ltac t_weight_with lem :=
    clear -limbwidth_good;
    intros; rewrite !weight_ZQ_correct;
    apply lem;
    try lia; Q_cbv; destruct limbwidth_den; cbn; try lia.

  Definition wprops : @weight_properties weight.
  Proof using limbwidth_good.
    constructor.
    { cbv [weight Z.of_nat]; autorewrite with zsimplify_fast; reflexivity. }
    { intros; apply Z.gt_lt. t_weight_with (@pow_ceil_mul_nat_pos 2). }
    { t_weight_with (@pow_ceil_mul_nat_multiples 2). }
    { intros; apply Z.gt_lt. t_weight_with (@pow_ceil_mul_nat_divide 2). }
  Defined.
  Local Hint Immediate (weight_0 wprops) : core.
  Local Hint Immediate (weight_positive wprops) : core.
  Local Hint Immediate (weight_multiples wprops) : core.
  Local Hint Immediate (weight_divides wprops) : core.

  Local Lemma weight_1_gt_1 : weight 1 > 1.
  Proof using limbwidth_good.
    clear -limbwidth_good.
    cut (1 < weight 1); [ lia | ].
    cbv [weight Z.of_nat]; autorewrite with zsimplify_fast.
    apply Z.pow_gt_1; [ lia | ].
    Z.div_mod_to_quot_rem_in_goal; nia.
  Qed.

  Lemma weight_unique_iff : forall i j, (i <= n)%nat -> (j <= n)%nat -> weight i = weight j <-> i = j.
  Proof using limbwidth_good.
    clear Hn_nz; clear dependent c.
    cbv [weight]; split; intro H'; subst; trivial; [].
    apply (f_equal (fun x => limbwidth_den * (- Z.log2 x))) in H'.
    rewrite !Z.log2_pow2, !Z.opp_involutive in H' by (Z.div_mod_to_quot_rem; nia).
    Z.div_mod_to_quot_rem.
    destruct i as [|i], j as [|j]; autorewrite with zsimplify_const in *; [ reflexivity | exfalso; nia.. | ].
    nia.
  Qed.
  Lemma weight_unique : forall i j, (i <= n)%nat -> (j <= n)%nat -> weight i = weight j -> i = j.
  Proof using limbwidth_good. apply weight_unique_iff. Qed.

  Derive carry_mulmod
         SuchThat (forall (f g : list Z)
                          (Hf : length f = n)
                          (Hg : length g = n),
                      (eval weight n (carry_mulmod f g)) mod (s - Associational.eval c)
                      = (eval weight n f * eval weight n g) mod (s - Associational.eval c))
         As eval_carry_mulmod.
  Proof.
    revert carry_mulmod; instantiate (1:=ltac:(clear -idxs s c n)); intro carry_mulmod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    rewrite <-eval_mulmod with (s:=s) (c:=c) by auto with zarith.
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carry_mulmod; reflexivity.
  Qed.

  Derive carry_squaremod
         SuchThat (forall (f : list Z)
                          (Hf : length f = n),
                      (eval weight n (carry_squaremod f)) mod (s - Associational.eval c)
                      = (eval weight n f * eval weight n f) mod (s - Associational.eval c))
         As eval_carry_squaremod.
  Proof.
    revert carry_squaremod; instantiate (1:=ltac:(clear -idxs s c n)); intro carry_squaremod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    rewrite <-eval_squaremod with (s:=s) (c:=c) by auto with zarith.
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carry_squaremod; reflexivity.
  Qed.

  Derive carry_scmulmod
         SuchThat (forall (x : Z) (f : list Z)
                          (Hf : length f = n),
                      (eval weight n (carry_scmulmod x f)) mod (s - Associational.eval c)
                      = (x * eval weight n f) mod (s - Associational.eval c))
         As eval_carry_scmulmod.
  Proof.
    revert carry_scmulmod; instantiate (1:=ltac:(clear -idxs s c n)); intro carry_scmulmod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    push_Zmod.
    rewrite <-eval_encode with (s:=s) (c:=c) (x:=x) (weight:=weight) (n:=n) by auto with zarith.
    pull_Zmod.
    rewrite<-eval_mulmod with (s:=s) (c:=c) by (auto with zarith; distr_length).
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carry_scmulmod; reflexivity.
  Qed.

  Derive carrymod
         SuchThat (forall (f : list Z)
                          (Hf : length f = n),
                      (eval weight n (carrymod f)) mod (s - Associational.eval c)
                      = (eval weight n f) mod (s - Associational.eval c))
         As eval_carrymod.
  Proof.
    revert carrymod; instantiate (1:=ltac:(clear -idxs s c n)); intro carrymod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carrymod; reflexivity.
  Qed.

  Derive addmod
         SuchThat (forall (f g : list Z)
                          (Hf : length f = n)
                          (Hg : length g = n),
                      (eval weight n (addmod f g)) mod (s - Associational.eval c)
                      = (eval weight n f + eval weight n g) mod (s - Associational.eval c))
         As eval_addmod.
  Proof.
    revert addmod; instantiate (1:=ltac:(clear -s c n)); intro addmod.
    clear -limbwidth_good.
    intros.
    rewrite <-eval_add by auto with zarith.
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst addmod; reflexivity.
  Qed.

  Derive submod
         SuchThat (forall (balance : list Z)
                          (f g : list Z)
                          (length_balance : length balance = n)
                          (eval_balance : eval weight n balance mod (s - Associational.eval c) = 0)
                          (Hf : length f = n)
                          (Hg : length g = n),
                      (eval weight n (submod balance f g)) mod (s - Associational.eval c)
                      = (eval weight n f - eval weight n g) mod (s - Associational.eval c))
         As eval_submod.
  Proof.
    revert submod; instantiate (1:=ltac:(clear -s c n)); intro submod.
    clear -s_nz m_nz limbwidth_good.
    intros.
    rewrite <-eval_sub with (balance:=balance) by auto with zarith.
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst submod; reflexivity.
  Qed.

  Derive oppmod
         SuchThat (forall (balance : list Z)
                          (f: list Z)
                          (length_balance : length balance = n)
                          (eval_balance : eval weight n balance mod (s - Associational.eval c) = 0)
                          (Hf : length f = n),
                      (eval weight n (oppmod balance f)) mod (s - Associational.eval c)
                      = (- eval weight n f) mod (s - Associational.eval c))
         As eval_oppmod.
  Proof.
    revert oppmod; instantiate (1:=ltac:(clear -s c n)); intro oppmod.
    clear -s_nz m_nz limbwidth_good.
    intros.
    rewrite <-eval_opp with (balance:=balance) by auto with zarith.
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst oppmod; reflexivity.
  Qed.

  Derive carry_addmod
         SuchThat (forall (f g : list Z)
                          (Hf : length f = n)
                          (Hg : length g = n),
                      (eval weight n (carry_addmod f g)) mod (s - Associational.eval c)
                      = (eval weight n f + eval weight n g) mod (s - Associational.eval c))
         As eval_carry_addmod.
  Proof.
    revert carry_addmod; instantiate (1:=ltac:(clear -idxs s c n)); intro carry_addmod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    rewrite <-eval_add by auto with zarith.
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carry_addmod; reflexivity.
  Qed.

  Derive carry_submod
         SuchThat (forall (balance : list Z)
                          (f g : list Z)
                          (length_balance : length balance = n)
                          (eval_balance : eval weight n balance mod (s - Associational.eval c) = 0)
                          (Hf : length f = n)
                          (Hg : length g = n),
                      (eval weight n (carry_submod balance f g)) mod (s - Associational.eval c)
                      = (eval weight n f - eval weight n g) mod (s - Associational.eval c))
         As eval_carry_submod.
  Proof.
    revert carry_submod; instantiate (1:=ltac:(clear -idxs s c n)); intro carry_submod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    rewrite <-eval_sub with (balance:=balance) by auto with zarith.
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carry_submod; reflexivity.
  Qed.

  Derive carry_oppmod
         SuchThat (forall (balance : list Z)
                          (f: list Z)
                          (length_balance : length balance = n)
                          (eval_balance : eval weight n balance mod (s - Associational.eval c) = 0)
                          (Hf : length f = n),
                      (eval weight n (carry_oppmod balance f)) mod (s - Associational.eval c)
                      = (- eval weight n f) mod (s - Associational.eval c))
         As eval_carry_oppmod.
  Proof.
    revert carry_oppmod; instantiate (1:=ltac:(clear -idxs s c n)); intro carry_oppmod.
    clear -m_nz s_nz limbwidth_good Hn_nz idxs.
    intros.
    rewrite <-eval_opp with (balance:=balance) by auto with zarith.
    etransitivity;
      [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs)
          by auto with zarith; reflexivity ].
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst carry_oppmod; reflexivity.
  Qed.

  Derive encodemod
         SuchThat (forall (f:Z),
                      (eval weight n (encodemod f)) mod (s - Associational.eval c)
                      = f mod (s - Associational.eval c))
         As eval_encodemod.
  Proof.
    revert encodemod; instantiate (1:=ltac:(clear -s c n)); intro encodemod.
    clear -limbwidth_good s_nz m_nz Hn_nz.
    intros.
    etransitivity.
    2:rewrite <-@eval_encode with (weight:=weight) (n:=n) by auto with zarith; reflexivity.
    eapply f_equal2; [|trivial]. eapply f_equal.
    subst encodemod; reflexivity.
  Qed.
End mod_ops.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import utils.
Import Order.TTheory GRing.Theory Num.Theory.

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

Lemma addr_lteif0r b (R : numDomainType) (x y : R) :
  (0 < x + y ?<= if b)%R = (- x < y ?<= if b)%R.
Proof. by rewrite addrC -{1}(opprK x) subr_lteif0r. Qed.

(******************************************************************************)
(*  extensions for interval                                                   *)
(******************************************************************************)

Section IntervalPo.

Local Open Scope order_scope.

Variable (disp : unit) (T : porderType disp).
Notation itv_bound := (itv_bound T).
Notation interval := (interval T).

Definition itv_isinf (i : interval) :=
  match i with
    | Interval (BInfty false) _ | Interval _ (BInfty true) => false
    | Interval (BInfty true) _ | Interval _ (BInfty false) => true
    | _ => false
  end.

Definition itv_nonempty (i : interval) :=
  match i with
    | Interval (BSide lb lr) (BSide ub ur) => lr < ur ?<= if lb && ~~ ub
    | Interval (BInfty false) _ | Interval _ (BInfty true) => false
    | Interval (BInfty true) _ | Interval _ (BInfty false) => true
  end.

End IntervalPo.

Section IntervalLattice.

Local Open Scope order_scope.

Variable (disp : unit) (T : latticeType disp).

Lemma in_itv_bigI S x (s : seq S) (f : S -> interval T) :
  (x \in \big[Order.meet/`]-oo, +oo[%O]_(ix <- s) f ix) =
  all (fun ix => x \in f ix) s.
Proof.
by rewrite -big_all; apply/(big_morph (fun i => x \in i)); first exact: in_itvI.
Qed.

End IntervalLattice.

Section IntervalTotal.

Local Open Scope order_scope.

Variable (disp : unit) (T : orderType disp).

Lemma itv_total_meetsE (S : Type) (s : seq S) (f : S -> interval T) :
  \meet_(ix <- s) f ix \in
  `]-oo, +oo[ :: [seq f ix `&` f ix' | ix <- s, ix' <- s].
Proof.
case: s => [|x s]; rewrite ?big_nil // inE; apply/orP; right.
elim: s x => [|y s ih] x; rewrite !big_cons;
  first by rewrite big_nil meetx1 inE meetxx.
move: (itv_total_meet3E (f x) (f y) (\meet_(ix <- s) f ix)).
rewrite meetA 3!inE => /or3P [] /eqP ->.
- by rewrite /= !inE eqxx orbT.
- move: (ih x); rewrite big_cons 2!allpairs_consr 2!mem_cat allpairs_consr /=.
  by rewrite !(mem_cat, inE) -!orbA => /or4P [] ->; rewrite ?orbT.
- move: (ih y); rewrite big_cons 2!allpairs_consr 2!mem_cat allpairs_consr /=.
  by rewrite !(mem_cat, inE) -!orbA => /or4P [] ->; rewrite ?orbT.
Qed.

Lemma itv_total_joinsE (S : Type) (s : seq S) (f : S -> interval T) :
  \join_(ix <- s) f ix \in
  Interval +oo -oo :: [seq f ix `|` f ix' | ix <- s, ix' <- s].
Proof.
case: s => [|x s]; rewrite ?big_nil // inE; apply/orP; right.
elim: s x => [|y s ih] x; rewrite !big_cons;
  first by rewrite big_nil joinx0 inE joinxx.
move: (itv_total_join3E (f x) (f y) (\join_(ix <- s) f ix)).
rewrite joinA 3!inE => /or3P [] /eqP ->.
- by rewrite /= !inE eqxx orbT.
- move: (ih x); rewrite big_cons 2!allpairs_consr 2!mem_cat allpairs_consr /=.
  by rewrite !(mem_cat, inE) -!orbA => /or4P [] ->; rewrite ?orbT.
- move: (ih y); rewrite big_cons 2!allpairs_consr 2!mem_cat allpairs_consr /=.
  by rewrite !(mem_cat, inE) -!orbA => /or4P [] ->; rewrite ?orbT.
Qed.

End IntervalTotal.

Local Open Scope ring_scope.

Arguments itv_nonempty {disp T} i.

Lemma itv_nonemptyP (R : numFieldType) (i : interval R) :
  reflect (exists x, x \in i) (itv_nonempty i).
Proof.
case: i => [] [c1 x|[]] [c2 z|[]]; apply/(iffP idP) => [|[y /andP[]]] //=.
- by move=> hxz; exists ((x + z) / 2%:R); apply: mid_in_itv.
- exact: lteif_trans.
- by exists (x + 1); rewrite in_itv lteifS // ltr_addl ltr01.
- by exists (z - 1); rewrite in_itv lteifS // gtr_addl ltrN10.
- by exists 0.
Qed.

Lemma itv_bigI_pairwiseP
    disp (I : eqType) (T : orderType disp) (s : seq I) (f : I -> interval T) P :
  (exists x, all (fun i => x \in f i) s && P x) <->
  ((exists x, P x) /\
   (forall i j, i \in s -> j \in s ->
      exists x, [&& x \in f i, x \in f j & P x])).
Proof.
split=> [[x] /andP [Hx HPx]|[[x' Px'] H]].
- by split=> [|i j Hi Hj]; exists x; rewrite // (allP Hx _ Hi) (allP Hx _ Hj).
- case/predU1P: (itv_total_meetsE s f) => [|/allpairsP [[i j]/=[hi hj]]] hbigI;
    first by exists x'; rewrite -in_itv_bigI hbigI.
  case: (H _ _ hi hj) => x /and3P [hi' hj' Px]; exists x.
  by rewrite -in_itv_bigI hbigI in_itvI hi' hj'.
Qed.

Lemma itv_bigI_pairwise0
      (I : eqType) (R : realFieldType) (s : seq I) (f : I -> interval R) :
  itv_nonempty (\big[Order.meet/`]-oo, +oo[]_(i <- s) f i) =
  all itv_nonempty [seq f i1 `&` f i2 | i1 <- s, i2 <- s]%O.
Proof.
apply/itv_nonemptyP/all_allpairsP => [|H].
- case=> x; rewrite in_itv_bigI => /allP Hs i j Hi Hj.
  by apply/itv_nonemptyP; exists x; rewrite in_itvI !Hs.
- case/predU1P: (itv_total_meetsE s f) => [|/allpairsP [[i j] /= [hi hj]]] ->;
    first by exists 0.
  by case/itv_nonemptyP: (H _ _ hi hj) => x; exists x.
Qed.

(******************************************************************************)
(*  Archimedean axiom for numDomainType                                       *)
(******************************************************************************)

Lemma int_archi :
  forall x : int, (0 < x) -> forall y : int, exists c, (y < x *+ c).
Proof.
move=> x Hx y; exists (absz (1 + (y %/ x)%Z)).
rewrite -mulr_natr mulrC -ltz_divLR // natz.
by case: (y %/ x)%Z => //= x'; rewrite ltz_nat.
Qed.

Section periodic_itv_inf.
Variable (R : numDomainType) (period : R) (P : pred R).
Variable (period_noninfinitesimal : forall y : R, exists c, y < period *+ c).
Variable (P_periodic : forall x : R, P (period + x) = P x).

Lemma periodic_itv_inf i :
  itv_isinf i -> (exists x, P x) -> exists x, (x \in i) && P x.
Proof.
case: i => -[bl lb|[]] [bu ub|[]] //= _ [x Hx].
- case: (period_noninfinitesimal (lb - x)) => c Hc.
  exists (x + period *+ c); rewrite in_itv andbT; apply/andP; split.
  + by apply: lteifS; rewrite addrC -ltr_sub_addr.
  + by elim: c {Hc} => [|c ?];
      rewrite ?mulr0n ?addr0 // mulrS addrCA P_periodic.
- case: (period_noninfinitesimal (x - ub)) => c Hc.
  exists (x - period *+ c); rewrite in_itv; apply/andP; split.
  + by apply: lteifS; rewrite ltr_sub_addr addrC -ltr_sub_addr.
  + elim: c {Hc} => [|c IH]; first by rewrite mulr0n subr0.
    by rewrite -P_periodic addrCA mulrS opprD (addrA period) subrr sub0r.
Qed.

End periodic_itv_inf.

Section periodic_qe_principle.

Variable (R : realDomainType) (period : R) (P : pred R).
Variable (period_noninfinitesimal : forall y : R, exists c, y < period *+ c).
Variable (P_periodic : forall x : R, P (period + x) = P x).

Lemma periodic_qe_principle (lbs ubs : seq (bool * R)) :
  (exists x : R, [&& all (fun lb => lb.2 < x ?<= if lb.1) lbs,
                     all (fun ub => x < ub.2 ?<= if ub.1) ubs & P x]) <->
  if nilp lbs || nilp ubs
  then exists x : R, P x
  else (forall (lb ub : bool * R), lb \in lbs -> ub \in ubs ->
        exists x : R, [&& lb.2 < x ?<= if lb.1, x < ub.2 ?<= if ub.1 & P x]).
Proof.
split=> [|H]; first by
  case=> x /and3P [Hlb Hub HP]; case: ifP => [Hnil|Hnil lb ub Hlb' Hub'];
  exists x; rewrite // (allP Hlb _ Hlb') (allP Hub _ Hub').
have Hperiod: exists x, P x.
  case: lbs ubs H => [|lb ?] [|ub ?] //= /(_ lb ub); rewrite !inE !eqxx.
  by case=> // x /and3P [_ _ ?]; exists x.
set lbs' := [seq Interval (BSide lb.1 lb.2) (BInfty _ false) | lb <- lbs].
set ubs' := [seq Interval (BInfty _ true) (BSide (~~ ub.1) ub.2) | ub <- ubs].
suff [x /andP [H0 H1]]: exists x, all (fun i => x \in i) (lbs' ++ ubs') && P x.
  exists x; move: H0; rewrite H1 andbT {}/lbs' {}/ubs' all_cat !all_map.
  by congr andb; apply: eq_in_all => b _ /=; rewrite in_itv (negbK, andbT).
apply/itv_bigI_pairwiseP; split=> //= i' j'; rewrite !mem_cat.
by move=> /orP [] /mapP [i Hi Hi'] /orP [] /mapP [j Hj Hj'];
  (try by case: (periodic_itv_inf _ P_periodic (i := i' `&` j')%O _ Hperiod);
     rewrite ?(Hi', Hj') => // x Hx; exists x; rewrite andbA -in_itvI);
  move: H Hi Hj; do 2 case: nilP=> [-> //| _]; move => /= H Hi Hj;
  [move: (H i j Hi Hj) | move: (H j i Hj Hi)];
  case=> x H0; exists x; rewrite Hi' Hj' !in_itv andbT negbK //= andbCA.
Qed.

End periodic_qe_principle.


Set Implicit Arguments.

Require Import Coq.Structures.DecidableTypeEx.
Require Import Coq.FSets.FSetInterface.

Module UWFacts_fun (E : UsualDecidableType) (Import M : WSfun E).

  Require Import Coq.FSets.FSetProperties.
  Module Import P := WProperties_fun E M.
  Import FM.

  Module FSetNotations.
    Infix "+" := union : fset_scope.
    Infix "-" := diff : fset_scope.
    Infix "*" := inter : fset_scope.
    Infix "<=" := Subset : fset_scope.
    Delimit Scope fset_scope with fset.
    Module FSetNotationsTrial.
      Notation " [ ] " := empty : fset_scope.
      Notation "m %- k" := (remove k m) (at level 60) : fset_scope.
    End FSetNotationsTrial.
  End FSetNotations.

  Definition Disjoint a b := forall x, ~ (In x a /\ In x b).

  Import ListNotations.
  Require Import Platform.Cito.GeneralTactics.

  Require Import Platform.Cito.SetoidListFacts.

  Lemma NoDup_elements : forall s, List.NoDup (elements s).
    intros.
    apply NoDupA_NoDup.
    apply elements_3w.
  Qed.

  Lemma of_list_fwd : forall e ls,
    In e (of_list ls)
    -> List.In e ls.
    intros.
    eapply of_list_1 in H.
    eapply InA_eq_In_iff; eauto.
  Qed.

  Lemma of_list_bwd : forall e ls,
    List.In e ls
    -> In e (of_list ls).
    intros.
    eapply of_list_1.
    eapply InA_eq_In_iff; eauto.
  Qed.

  Local Hint Resolve of_list_fwd of_list_bwd.

  Lemma of_list_spec : forall e ls, In e (of_list ls) <-> List.In e ls.
    generalize of_list_fwd, of_list_bwd; firstorder.
  Qed.

  Lemma of_list_singleton : forall e, Equal (of_list [e]) (singleton e).
    intros.
    unfold of_list.
    simpl.
    unfold Equal.
    split; intros.
    eapply singleton_iff.
    eapply add_iff in H.
    openhyp.
    eauto.
    eapply empty_iff in H.
    intuition.
    eapply singleton_iff in H.
    eapply add_iff; eauto.
  Qed.

  Lemma of_list_cons : forall e ls, Equal (of_list (e :: ls)) (union (singleton e) (of_list ls)).
    unfold Equal; intuition.
    simpl in *.
    apply add_iff in H; intuition (subst; eauto).
    apply union_iff; left; apply singleton_iff; auto.
    eapply union_iff; eauto.
    simpl.
    apply union_iff in H.
    openhyp.
    eapply singleton_iff in H.
    eapply add_iff; eauto.
    eapply add_iff; eauto.
  Qed.

  Global Add Morphism Disjoint with signature Equal ==> Equal ==> iff as Disjoint_m.
    unfold Equal, Disjoint; firstorder.
  Qed.

  Local Hint Resolve union_2 union_3.

  Lemma Disjoint_union : forall s1 s2 s3, Disjoint s1 (union s2 s3) <-> (Disjoint s1 s2 /\ Disjoint s1 s3).
    unfold Disjoint; intuition eauto.
    apply union_iff in H3; intuition eauto.
  Qed.

  Local Hint Resolve singleton_2.

  Lemma Disjoint_singletons : forall e1 e2, Disjoint (singleton e1) (singleton e2) <-> e1 <> e2.
    unfold Disjoint; intuition eauto.
    apply singleton_iff in H1; apply singleton_iff in H2.
    congruence.
  Qed.

  Lemma Disjoint_singleton : forall e s, Disjoint (singleton e) s <-> ~ In e s.
    unfold Disjoint; intuition eauto.
    apply singleton_iff in H1.
    congruence.
  Qed.

  Local Hint Resolve inter_1 inter_2 inter_3.

  Lemma inter_is_empty_iff : forall s1 s2, is_empty (inter s1 s2) = true <-> Disjoint s1 s2.
    unfold Disjoint; intuition eauto.
    apply is_empty_2 in H.
    eapply H; eauto.
    apply is_empty_1.
    hnf; intuition.
    eauto.
  Qed.

  Lemma Equal_Subset_iff : forall s1 s2, Equal s1 s2 <-> (Subset s1 s2 /\ Subset s2 s1).
    unfold Equal, Subset; firstorder.
  Qed.

  Lemma iff_not_iff P Q : (P <-> Q) -> (~ P <-> ~ Q).
  Proof.
    split; intros; intuition.
  Qed.

  Lemma singleton_not_iff x x' : ~ In x' (singleton x) <-> x <> x'.
  Proof.
    eapply iff_not_iff.
    eapply singleton_iff.
  Qed.

  Lemma union_not_iff a b x : ~ In x (union a b) <-> (~ In x a /\ ~ In x b).
  Proof.
    etransitivity.
    - eapply iff_not_iff.
      eapply union_iff.
    - intuition.
  Qed.

  Lemma of_list_not_iff x ls : ~ In x (of_list ls) <-> ~ List.In x ls.
    eapply iff_not_iff.
    eapply of_list_spec.
  Qed.

  Require Platform.Cito.ListFacts1.

  Lemma set_disjoint_list_disjoint ls1 ls2 : Disjoint (of_list ls1) (of_list ls2) -> ListFacts1.Disjoint ls1 ls2.
    unfold ListFacts1.Disjoint, Disjoint.
    intros Hdisj e [Hin1 Hin2].
    eapply Hdisj; split; eapply of_list_spec; eauto.
  Qed.

  Lemma list_disjoint_set_disjoint ls1 ls2 : ListFacts1.Disjoint ls1 ls2 -> Disjoint (of_list ls1) (of_list ls2).
    unfold ListFacts1.Disjoint, Disjoint.
    intros Hdisj e [Hin1 Hin2].
    eapply Hdisj; split; eapply of_list_spec; eauto.
  Qed.

  Lemma compat_bool_f A (f : A -> bool) : SetoidList.compat_bool Logic.eq f.
    unfold SetoidList.compat_bool.
    intuition.
  Qed.

  Lemma for_all_elim p s : for_all p s = true -> forall x, In x s -> p x = true.
  Proof.
    intros H x Hin.
    eapply for_all_iff in H; eauto.
    eapply compat_bool_f; eauto.
  Qed.

  Global Arguments for_all_elim [p s] _ _ _.

  Lemma for_all_intro p s : (forall x, In x s -> p x = true) -> for_all p s = true.
  Proof.
    intros H.
    eapply for_all_iff; eauto.
    eapply compat_bool_f; eauto.
  Qed.

  Lemma for_all_singleton_elim p x : for_all p (singleton x) = true -> p x = true.
  Proof.
    intros H.
    specialize (for_all_elim H); intros HH.
    eapply HH.
    eapply singleton_iff; eauto.
  Qed.

  Lemma for_all_union_elim p a b : for_all p (union a b) = true -> for_all p a = true /\ for_all p b = true.
  Proof.
    intros H.
    specialize (for_all_elim H); intros HH.
    split.
    - eapply for_all_intro.
      intros; eapply HH.
      eapply union_iff; intuition.
    - eapply for_all_intro.
      intros; eapply HH.
      eapply union_iff; intuition.
  Qed.

  Lemma for_all_of_list_elim p ls : for_all p (of_list ls) = true -> List.forallb p ls = true.
  Proof.
    intros H.
    specialize (for_all_elim H); intros HH.
    eapply List.forallb_forall.
    intros x Hin.
    eapply HH.
    eapply of_list_spec; eauto.
  Qed.

End UWFacts_fun.