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

(**********************************************************************)

(** The integer logarithms with base 2. *)

(** THIS FILE IS DEPRECATED.
    Please rather use [Z.log2] (or [Z.log2_up]), which
    are defined in [BinIntDef], and whose properties can
    be found in [BinInt.Z]. *)

(*  There are three logarithms defined here,
    depending on the rounding of the real 2-based logarithm:
    - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)]
      i.e. [Log_inf x] is the biggest integer that is smaller than [Log x]
    - [Log_sup]: [y = (Log_sup x) iff 2^(y-1) < x <= 2^y]
      i.e. [Log_inf x] is the smallest integer that is bigger than [Log x]
    - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)]
      i.e. [Log_nearest x] is the integer nearest from [Log x] *)

Require Import ZArith_base Omega Zcomplements Zpower.
Local Open Scope Z_scope.

Section Log_pos. (* Log of positive integers *)

  (** First we build [log_inf] and [log_sup] *)

  Fixpoint log_inf (p:positive) : Z :=
    match p with
      | xH => 0 (* 1 *)
      | xO q => Z.succ (log_inf q)       (* 2n *)
      | xI q => Z.succ (log_inf q)       (* 2n+1 *)
    end.

  Fixpoint log_sup (p:positive) : Z :=
    match p with
      | xH => 0	(* 1 *)
      | xO n => Z.succ (log_sup n) (* 2n *)
      | xI n => Z.succ (Z.succ (log_inf n))	(* 2n+1 *)
    end.

  Hint Unfold log_inf log_sup.

  Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p).
  Proof.
   induction p; simpl; now rewrite ?Pos2Z.inj_succ, ?IHp.
  Qed.

  Lemma Zlog2_log_inf : forall p, Z.log2 (Zpos p) = log_inf p.
  Proof.
   unfold Z.log2. destruct p; simpl; trivial; apply Psize_log_inf.
  Qed.

  Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p.
  Proof.
   induction p; simpl log_sup.
   - change (Zpos p~1) with (2*(Zpos p)+1).
     rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy.
     unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc.
   - change (Zpos p~0) with (2*Zpos p).
     now rewrite Z.log2_up_double, IHp.
   - reflexivity.
  Qed.

  (** Then we give the specifications of [log_inf] and [log_sup]
    and prove their validity *)

  Hint Resolve Z.le_trans: zarith.

  Theorem log_inf_correct :
    forall x:positive,
      0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Z.succ (log_inf x)).
  Proof.
    simple induction x; intros; simpl;
      [ elim H; intros Hp HR; clear H; split;
	[ auto with zarith
	  | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial);
	    rewrite two_p_S by trivial;
	    rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xI p);
		omega ]
	| elim H; intros Hp HR; clear H; split;
	  [ auto with zarith
	    | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial);
	      rewrite two_p_S by trivial;
	      rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xO p);
		  omega ]
	| unfold two_power_pos; unfold shift_pos; simpl;
	  omega ].
  Qed.

  Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p).
  Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p).

  Opaque log_inf_correct1 log_inf_correct2.

  Hint Resolve log_inf_correct1 log_inf_correct2: zarith.

  Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p.
  Proof.
    simple induction p; intros; simpl; auto with zarith.
  Qed.

  (** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)]
      either [(log_sup p)=(log_inf p)+1] *)

  Theorem log_sup_log_inf :
    forall p:positive,
      IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p)
    else log_sup p = Z.succ (log_inf p).
  Proof.
    simple induction p; intros;
      [ elim H; right; simpl;
	rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
	  rewrite BinInt.Pos2Z.inj_xI; unfold Z.succ; omega
	| elim H; clear H; intro Hif;
	  [ left; simpl;
	    rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
	      rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
		rewrite <- (proj1 Hif); rewrite <- (proj2 Hif);
		  auto
	    | right; simpl;
	      rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
		rewrite BinInt.Pos2Z.inj_xO; unfold Z.succ;
		  omega ]
	| left; auto ].
  Qed.

  Theorem log_sup_correct2 :
    forall x:positive, two_p (Z.pred (log_sup x)) < Zpos x <= two_p (log_sup x).
  Proof.
    intro.
    elim (log_sup_log_inf x).
    (* x is a power of two and [log_sup = log_inf] *)
    intros [E1 E2]; rewrite E2.
    split; [ apply two_p_pred; apply log_sup_correct1 | apply Z.le_refl ].
    intros [E1 E2]; rewrite E2.
    rewrite (Z.pred_succ (log_inf x)).
    generalize (log_inf_correct2 x); omega.
  Qed.

  Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p.
  Proof.
    simple induction p; simpl; intros; omega.
  Qed.

  Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Z.succ (log_inf p).
  Proof.
    simple induction p; simpl; intros; omega.
  Qed.

  (** Now it's possible to specify and build the [Log] rounded to the nearest *)

  Fixpoint log_near (x:positive) : Z :=
    match x with
      | xH => 0
      | xO xH => 1
      | xI xH => 2
      | xO y => Z.succ (log_near y)
      | xI y => Z.succ (log_near y)
    end.

  Theorem log_near_correct1 : forall p:positive, 0 <= log_near p.
  Proof.
    simple induction p; simpl; intros;
      [ elim p0; auto with zarith
	| elim p0; auto with zarith
	| trivial with zarith ].
    intros; apply Z.le_le_succ_r.
    generalize H0; now elim p1.
    intros; apply Z.le_le_succ_r.
    generalize H0; now elim p1.
  Qed.

  Theorem log_near_correct2 :
    forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p.
  Proof.
    simple induction p.
    intros p0 [Einf| Esup].
    simpl. rewrite Einf.
    case p0; [ left | left | right ]; reflexivity.
    simpl; rewrite Esup.
    elim (log_sup_log_inf p0).
    generalize (log_inf_le_log_sup p0).
    generalize (log_sup_le_Slog_inf p0).
    case p0; auto with zarith.
    intros; omega.
    case p0; intros; auto with zarith.
    intros p0 [Einf| Esup].
    simpl.
    repeat rewrite Einf.
    case p0; intros; auto with zarith.
    simpl.
    repeat rewrite Esup.
    case p0; intros; auto with zarith.
    auto.
  Qed.

End Log_pos.

Section divers.

  (** Number of significative digits. *)

  Definition N_digits (x:Z) :=
    match x with
      | Zpos p => log_inf p
      | Zneg p => log_inf p
      | Z0 => 0
    end.

  Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x.
  Proof.
    simple induction x; simpl;
      [ apply Z.le_refl | exact log_inf_correct1 | exact log_inf_correct1 ].
  Qed.

  Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z.of_nat n.
  Proof.
    simple induction n; intros;
      [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ].
  Qed.

  Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z.of_nat n.
  Proof.
    simple induction n; intros;
      [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ].
  Qed.

  (** [Is_power p] means that p is a power of two *)
  Fixpoint Is_power (p:positive) : Prop :=
    match p with
      | xH => True
      | xO q => Is_power q
      | xI q => False
    end.

  Lemma Is_power_correct :
    forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1).
  Proof.
    split;
      [ elim p;
	[ simpl; tauto
	  | simpl; intros; generalize (H H0); intro H1; elim H1;
	    intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity
	  | intro; exists 0%nat; reflexivity ]
	| intros; elim H; intros; rewrite H0; elim x; intros; simpl; trivial ].
  Qed.

  Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p.
  Proof.
    simple induction p;
      [ intros; right; simpl; tauto
	| intros; elim H;
	  [ intros; left; simpl; exact H0
	    | intros; right; simpl; exact H0 ]
	| left; simpl; trivial ].
  Qed.

End divers.


Require Import Program.
Require Import Axioms.

Set Implicit Arguments.

Theorem f_jmequal2 :
  forall (A1 A1' A2 A2' B:Type) (f:A1 -> A2 -> B) (g:A1' -> A2' -> B)
    (x1:A1) (y1:A1') (x2:A2) (y2:A2'),
    JMeq f g -> JMeq x1 y1 -> JMeq x2 y2 -> f x1 x2 = g y1 y2.
Proof.
  intros. destruct H0. destruct H1. rewrite (JMeq_eq H). reflexivity.
Qed.

Definition coerce_aux : forall (A B:Set),
  B = A -> { f : A -> B | forall x, JMeq (f x) x }.
intros A B eq. rewrite <- eq. exists (fun (x:B) => x). intro x. reflexivity.
Defined.

Definition coerce : forall (A B:Set),
  B = A -> A -> B.
intros. apply (projT1 (coerce_aux H) H0).
Defined.

Lemma coerce_jmeq : forall (A B : Set) (eql : A = B) x,
  JMeq (coerce eql x) x.
intros. unfold coerce.
destruct (coerce_aux eql).
simpl. apply j.
Save.

Theorem f_jmequal :
  forall (A1 A1' B B':Set) (f:A1 -> B) (g:A1' -> B')
    (x1:A1) (y1:A1'),
    B = B' ->
    JMeq f g -> JMeq x1 y1 -> JMeq (f x1) (g y1).
Proof.
  intros. destruct H. destruct H1. rewrite (JMeq_eq H0). reflexivity.
Qed.

Theorem f_jmequal_type :
  forall (A1 A1':Type) (B:A1 -> Set) (B':A1'->Set)
         (f:forall a, B a) (g:forall a, B' a)
    (x1:A1) (y1:A1'),
    (forall a a', JMeq a a' -> B a = B' a') ->
    JMeq f g -> JMeq x1 y1 -> JMeq (f x1) (g y1).
intros.
destruct H1.
assert (B = B'). ext a. apply H. reflexivity.
revert f g H0. rewrite H1. intros. rewrite H0. reflexivity.
Save.

Lemma jmeq_exist : forall (A B:Set) (x:A) (x':B) (P:A->Prop) (Q:B->Prop) p p',
  A = B ->
  (forall a b, JMeq a b -> P a = Q b) ->
  JMeq (exist P x p) (exist Q x' p') ->
  JMeq x x'.
intros.
destruct H.
assert (P = Q). ext a. apply H0. reflexivity.
destruct H.
assert (exist P x p = exist P x' p'). apply JMeq_eq. apply H1.
inversion H.
destruct H3. reflexivity.
Save.

Lemma coerce_twice : forall (A B:Set) (eqp:A = B) (eqp':B=A) x,
  coerce eqp (coerce eqp' x) = x.
intros.
apply JMeq_eq. eapply JMeq_trans; apply coerce_jmeq.
Save.

Lemma coerce_twice_jmeq : forall (A B C:Set) (eqp:A = B) (eqp':B=C) x,
  JMeq (coerce eqp (coerce eqp' x)) x.
intros.
eapply JMeq_trans; apply coerce_jmeq.
Save.

Lemma eq_JMeq : forall A (x y:A), x = y -> JMeq x y.
intros. rewrite H. reflexivity.
Save.


Require Import ZArith.
Require Import List.
Require Import VCF.Coqlib.
Require Import VCF.PairConstructors.
Require Import VCF.KnasterTarski.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import VCF.BinRelDomain.
Require Import VCF.WhileCallLang.

Definition state := Z -> Z.
Definition constant_func {A: Type} (c: Z): A -> Z := fun _ => c.

Fixpoint aeval (a : aexp) : state -> Z :=
  match a with
  | ANum n => constant_func n
  | APlus a1 a2 => (aeval a1 + aeval a2)%Func
  | AMinus a1 a2  => (aeval a1 - aeval a2)%Func
  | AMult a1 a2 => (aeval a1 * aeval a2)%Func
  | ADeref a1 => fun st => st ((aeval a1) st)
  end.

Fixpoint beval (b : bexp) : state -> Prop :=
  match b with
  | BTrue       => Sets.full
  | BFalse      => Sets.empty
  | BEq a1 a2   => ZFunc.test_eq (aeval a1) (aeval a2)
  | BLe a1 a2   => ZFunc.test_le (aeval a1) (aeval a2)
  | BNot b1     => Sets.complement (beval b1)
  | BAnd b1 b2  => Sets.intersect (beval b1 ) (beval b2)
  end.

Definition if_sem
  (cond: state -> Prop)
  (then_branch else_branch: state -> state -> Prop)
  : state -> state -> Prop
:=
  Sets.union
    (Rel.concat (Rel.test cond) then_branch)
    (Rel.concat (Rel.test (Sets.complement cond)) else_branch).

Definition loop_sem_CL:
  @CompleteLattice_Setoid
    (state -> state -> Prop)
    Sets.included
    Sets.equiv
    Sets.omega_union
:= SETS_included_CL.

Local Existing Instance loop_sem_CL.

Definition loop_sem (cond: state -> Prop) (loop_body: state -> state -> Prop):
  state -> state -> Prop :=
  KT_fix_l
    (fun sem =>
       Sets.union
         (Rel.concat
           (Rel.test cond)
           (Rel.concat loop_body sem))
         (Rel.test (Sets.complement cond))).

Lemma loop_sem_recur:
  forall cond loop_body,
    Sets.equiv
      (loop_sem cond loop_body)
      (Sets.union
         (Rel.concat
           (Rel.test cond)
           (Rel.concat loop_body (loop_sem cond loop_body)))
         (Rel.test (Sets.complement cond))).
Proof.
  intros.
  unfold loop_sem.
  match goal with
  | |- Sets.equiv (KT_fix_l ?F) _ =>
    pose proof KnasterTarski_fixpoint_theorem_l F as H; apply H; clear H
  end.
  hnf; intros.
  solve_mono BinRel_solve_mono.
Qed.

Fixpoint ceval (c: com) (callee: func_name -> state -> state -> Prop): state -> state -> Prop :=
  match c with
  | CSkip => Rel.id
  | CAss a1 a2 =>
      fun st1 st2 =>
        st2 (aeval a1 st1) = aeval a2 st1 /\
        forall l, aeval a1 st1 <> l -> st1 l = st2 l
  | CSeq c1 c2 => Rel.concat (ceval c1 callee) (ceval c2 callee)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1 callee) (ceval c2 callee)
  | CWhile b c => loop_sem (beval b) (ceval c callee)
  | CCall f => callee f
  end.

Definition single_binrel {A B C} (a0: A) (R: B -> C -> Prop): A -> B -> C -> Prop :=
  fun a b c => a = a0 /\ R b c.

Definition feval (fc: func_name * com) (callee: func_name -> state -> state -> Prop): func_name -> state -> state -> Prop :=
  match fc with
  | (f, c) => single_binrel f (ceval c callee)
  end.

Definition peval_pre (p: prog) (callee: func_name -> state -> state -> Prop):=
  fold_right Sets.union Sets.empty (map (fun fc => feval fc callee) p).

Definition prog_sem_CL:
  @CompleteLattice_Setoid
    (func_name -> state -> state -> Prop)
    Sets.included
    Sets.equiv
    Sets.omega_union
:= SETS_included_CL.

Existing Instance prog_sem_CL.

Fixpoint peval (p: prog): func_name -> state -> state -> Prop :=
  KT_fix_l (peval_pre p).

(***********************************************************)

Record partial_prog_denote: Type := {
  defined_funcs: func_name -> Prop;
  func_nodup: Prop;
  partial_sem: (func_name -> state -> state -> Prop) ->
               (func_name -> state -> state -> Prop);
}.

Record partial_prog_denote_equiv (d1 d2: partial_prog_denote): Prop := {
  defined_funcs_equiv: forall f,
    defined_funcs d1 f <-> defined_funcs d2 f;
  func_nodup_equiv:
    func_nodup d1 <-> func_nodup d2;
  partial_sem_equiv: Sets.equiv (partial_sem d1) (partial_sem d2)
}.

Definition partial_peval (p: list (func_name * com)): partial_prog_denote := {|
  defined_funcs := fun f => exists c, In (f, c) p;
  func_nodup := NoDup (map fst p);
  partial_sem := fun extern_sem =>
                   KT_fix_l (fun sem => peval_pre p (Sets.union extern_sem sem))
|}.

Definition union_pair {A: Type} {A_SETS: Sets.SETS A} (p: A * A): A :=
  Sets.union (fst p) (snd p).

Lemma union_pair_equiv: forall {A: Type} {A_SETS: Sets.SETS A} p1 p2,
  pair_rel2 Sets.equiv Sets.equiv p1 p2 -> Sets.equiv (union_pair p1) (union_pair p2).
Admitted.

Definition partial_prog_denote_compose (d1 d2: partial_prog_denote): partial_prog_denote := {|
  defined_funcs := Sets.union (defined_funcs d1) (defined_funcs d2);
  func_nodup := func_nodup d1 /\
                func_nodup d2 /\
                Sets.equiv
                  (Sets.intersect (defined_funcs d1) (defined_funcs d2))
                  Sets.empty;
  partial_sem := fun extern_sem =>
                   union_pair
                     (KT_fix2_l
                       (fun _ sem2 => partial_sem d1 (Sets.union extern_sem sem2))
                       (fun sem1 _ => partial_sem d2 (Sets.union extern_sem sem1)))
|}.

Theorem separate_compile: forall p1 p2,
  partial_prog_denote_equiv
    (partial_peval (p1 ++ p2))
    (partial_prog_denote_compose (partial_peval p1) (partial_peval p2)).
Proof.
Admitted.


Parameters p1 p2 t1 t2 : Prop.

Definition aff1 := t1 \/ ~t1 /\ p2.
Definition aff2 := p1.
Definition k := (aff1 /\ aff2) \/ (~aff1 /\ ~aff2).

Definition h1 := ~(p1 /\ t1) /\ ~(p2 /\ t2).
Definition h2 := (p1 \/ t1) /\ (p2 \/ t2).

Lemma epreuve_3 : h1 /\ h2 /\ k -> p1 /\ p2.
Proof.
unfold k, h1, h2.
unfold aff1, aff2.
intros.

destruct H.
destruct H0.
destruct H.
destruct H0.

destruct H1.
destruct H1.
destruct H1.
elimtype False.
auto.

destruct H1.
split.
assumption.
assumption.

destruct H1.
destruct H0.
elimtype False.
auto.
elimtype False.
auto.

Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Cat.Cat_Iso.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import KanExt.LocalFacts.NatIso.

Require Import Limits.Limit.
Require Import Limits.Isomorphic_Cat.

Section GenProd_Sum.
  Context {A : Type} {C : Category} (map : A → C).

  Definition GenProd := Limit (Discr_Func map).

  Identity Coercion GenProd_Limit : GenProd >-> Limit.

  Definition GenSum := CoLimit (Discr_Func_op map).

  Identity Coercion GenSum_CoLimit : GenSum >-> CoLimit.

End GenProd_Sum.

(** The fact That if a category has generalized products of some type, its dual also has
generalized sums of that type. *)

Section GenProd_to_GenSum.
  Context {A : Type} {C : Category} {map : A → C} (L : GenProd map).
  Definition GenProd_to_GenSum : @GenSum A (C^op) map :=
    Local_Right_KanExt_Iso ((@Discr_Func_Iso (C^op) A map)⁻¹) L.

End GenProd_to_GenSum.

(** The fact That if a category has generalized sums of some type, its dual has
generalized products of that type. *)
Section GenSum_to_GenProd.
  Context {A : Type} {C : Category} {map : A → C} (L : GenSum map).

  Definition GenSum_to_GenProd : @GenProd A (C^op) map :=
    Local_Right_KanExt_Iso (Discr_Func_Iso map) L.

End GenSum_to_GenProd.

(** If we have GenSum for all functions from a type A, where A is isomorphic to B
we have all GenSum for all functions from B. We show this by showing that for the
underlying functor of any GenSum from B is isomorphic to the underlying functor of
some GrnSum from A precomposed with the provided isomorphism.
*)
Section GenSum_IsoType.
  Context {A B : Type} (Iso : (A ≃≃ B ::> Type_Cat)%isomorphism) {C : Category}
          (SM : forall f : A → C, GenSum f).

  Program Definition GenSum_IsoType_map_Iso (map : B → C):
    (
      (((Discr_Func_op map)^op)%functor
        ≃≃ ((Discr_Func_op (fun x : A => map ((iso_morphism Iso) x)) ∘ (iso_morphism (Opposite_Cat_Iso (Inverse_Isomorphism (Discr_Cat_Iso Iso)))))^op)%functor
        ::> Func_Cat _ _)%isomorphism
    )%morphism
    :=
      {|
        iso_morphism :=
          {|
            Trans :=
              Trans
                (iso_morphism
                   (IsoCat_NatIso (Opposite_Cat_Iso (Discr_Cat_Iso Iso)) (Discr_Func_op map))
                )
          |};
        inverse_morphism :=
          {|
            Trans :=
              Trans
                (inverse_morphism
                   (IsoCat_NatIso (Opposite_Cat_Iso (Discr_Cat_Iso Iso)) (Discr_Func_op map))
                )
          |}
      |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    apply (
        f_equal
          Trans
          (
            right_inverse
              (IsoCat_NatIso (Opposite_Cat_Iso (Discr_Cat_Iso Iso)) (Discr_Func_op map))
          )
      ).
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    apply (
        f_equal
          Trans
          (
            left_inverse
              (IsoCat_NatIso (Opposite_Cat_Iso (Discr_Cat_Iso Iso)) (Discr_Func_op map))
          )
      ).
  Qed.

  Definition  GenSum_IsoType (map : B → C) : GenSum map :=
    Local_Right_KanExt_Iso
      (GenSum_IsoType_map_Iso map)
      (
        CoLimit_From_Isomorphic_Cat
          (Opposite_Cat_Iso (Inverse_Isomorphism (Discr_Cat_Iso Iso)))
          (SM (fun x : A => map ((iso_morphism Iso) x)))
      ).

End GenSum_IsoType.


Parameters p1 p2 p3 t1 t2 t3 : Prop.

Definition aff1 := t2.
Definition aff2 := t2.
Definition aff3 := t1.

Definition k := (aff1 /\ ~aff2 /\ ~aff3) \/ (~aff1 /\ aff2 /\ ~aff3) \/ (aff1 /\ ~aff2 /\ ~aff3).

Definition h1 := ~(p1 /\ t1) /\ ~(p2 /\ t2) /\ ~(p3 /\ t3).
Definition h2 := (p1 \/ t1) /\ (p2 \/ t2) /\ (p3 \/ t3).
Definition h3 := (p1 /\ t2 /\ t3) \/ (t1 /\ p2 /\ t3) \/ (t1 /\ t2 /\ p3).

Lemma epreuve_10 : h1 /\ h2 /\ h3 /\ k -> p1 /\ t2 /\ t3.
Proof.
unfold k, h1, h2, h3.
unfold aff1, aff2, aff3.
intros.
destruct H.
destruct H.
destruct H1.
destruct H0.
destruct H0.
destruct H4.
destruct H3.
destruct H3.
destruct H3.
destruct H7.
split.
assumption.
split; assumption.
destruct H3.
destruct H3.
destruct H7.
destruct H6.
destruct H6.
destruct H9.
elimtype False.
auto.
destruct H6.
destruct H6.
destruct H9.
elimtype False.
auto.
destruct H6.
destruct H9.
elimtype False.
auto.
destruct H3.
destruct H7.
destruct H6.
destruct H6.
destruct H9.
elimtype False.
auto.
destruct H6.
destruct H6.
destruct H9.
elimtype False.
auto.
destruct H6.
destruct H9.
elimtype False.
auto.
Qed.


Require Import List Nat Arith.
Import ListNotations.
Require Import Mmx.ast_instructions.

Check (1,2).
Check pair nat nat.
Definition tag_opcode_assoc :=
  list (tag * nat).

Scheme Equality for list.
Check list_beq.

(* actually this is a good name for this function :p *)
Fixpoint lookup (t : tag) (l : tag_opcode_assoc) : option nat :=
  match l with
    | [] => None
    | (t',n) :: tl => if tag_beq t t'
                      then Some n
                      else lookup t tl
  end.
(* actually this is a good name for this function :p *)
Fixpoint lookdown (n : nat) (l : tag_opcode_assoc) : option tag :=
  match l with
    | [] => None
    | (t,n') :: tl => if  eqb n n'
                      then Some t
                      else lookdown n tl
  end.

(* this table is an association list of type tag_opcode_assoc with every associations that can be made in our langage *)
Definition encdec : tag_opcode_assoc := [(tag_n(ADD),0);(tag_n(AND),1);(tag_i(ADD_I),2);(tag_i(AND_I),3)].

Theorem lookup_encdec : forall (t : tag), exists n,
                          lookup t encdec = Some n.
Proof.
  destruct t.
  -destruct t.
   +simpl. exists 0. reflexivity.
   +simpl. exists 1. reflexivity.
  -destruct t.
   +simpl. exists 2. reflexivity.
   +simpl. exists 3. reflexivity.
Qed.

Require Import Bool.

Print tag.

Definition forall_tag_n (p : tag_normal -> bool): bool :=
  andb (p ADD) (p AND).

Definition forall_tag_i (p : tag_immediate -> bool): bool :=
  andb (p ADD_I) (p AND_I).

Definition forall_tag (p : tag -> bool): bool :=
  andb (forall_tag_n (fun (x : tag_normal) => p (tag_n x)))
       (forall_tag_i (fun (x : tag_immediate) => p (tag_i x))).

Print reflect.

Definition propP := forall x : nat, x = x.
Check propP.

Lemma test_reflect : True -> reflect True true.
Proof.
  exact (ReflectT True).
Qed.

Lemma helpBefore1 : forall (f : tag -> bool), forall_tag f = true -> (forall (t: tag), f t = true).
Proof.
  intros f.
  unfold forall_tag.
  intros H.
  Search (_ && _ = true).
  apply andb_prop in H.
  unfold forall_tag_n in H.
  unfold forall_tag_i in H.
  destruct H.
  apply andb_prop in H.
  destruct H.
  apply andb_prop in H0.
  destruct H0.
  destruct t.
  {
    -destruct t.
     +rewrite H.
      reflexivity.
     +rewrite H1.
      reflexivity.
  }
  {
     -destruct t.
      +rewrite H0.
       reflexivity.
      +rewrite H2.
       reflexivity.
   }
Qed.

Lemma helpBefore2 : forall (f : tag -> bool), (forall (t: tag), f t = true) -> forall_tag f = true.
Proof.
  intros f H.
  unfold forall_tag.
  Search (_ && _ = true).
  apply andb_true_intro.
  split.
  -compute. rewrite H. rewrite H. reflexivity.
  -compute. rewrite H. rewrite H. reflexivity.
Qed.

Lemma forall_tagP: forall (P : tag -> Prop)(f : tag -> bool),
    (forall (t : tag), reflect (P t) (f t)) ->
    reflect (forall t, P t) (forall_tag f).
Proof.
  intros P f H.
  Search reflect.
  apply iff_reflect.
  apply iff_to_and.
  split.
  -Search forall_tag.
   intros.
   rewrite helpBefore2.
   +reflexivity.
   +intros t.
    specialize (H t).
    Search forall_tag.
    apply reflect_iff in H.
    inversion H.
    specialize (H0 t).
    apply H1.
    exact H0.
    (* this part is ok !!! ;) *)
  -intros.
   specialize (H t).
   rewrite helpBefore1 in H.
   inversion H.
   +exact H1.
   +exact H0.
Qed.

SearchAbout leb.
(* the first nat is the maximum we wan't to have in this bounded nat interval *)
Fixpoint forall_bounded (n : nat) (f : nat -> bool) : bool :=
  match n with
  | 0 => f 0
  | S n => f (S n) && forall_bounded n f
  end.

Check forall_bounded.
(* (* SAVE THIS *) *)
(* Lemma help_forall_findP1 : forall (f : nat -> bool), (forall (n: nat), f n = true) -> forall (k : nat), forall_bounded k f = true. *)
(* Proof. *)
(*   intros. *)
(*   induction k. *)
(*   -simpl. *)
(*    apply H. *)
(*   -simpl. *)
(*    rewrite IHk. *)
(*    Search (_ && _ = true). *)
(*    apply andb_true_intro. *)
(*    split. *)
(*    +apply H. *)
(*    +reflexivity. *)
(* Qed. *)
Lemma help_forall_findP1 : forall (f : nat -> bool) (k : nat), (forall (n: nat), n <= k -> f n = true) -> forall_bounded k f = true.
Proof.
  intros.
  induction k.
  -apply H.
   reflexivity.
  -simpl.
   Search (_ && _ = true).
   apply andb_true_intro.
   split.
   +apply H.
    reflexivity.
   +apply IHk.
    intros n.
    specialize (H n).
    intros.
    apply H.
    Search (_ <= S _).
    apply le_S in H0.
    exact H0.
Qed.

Lemma help_forall_findP2 :
  forall (k : nat) (f : nat -> bool), forall_bounded k f = true -> (forall (n: nat), n <= k -> f n = true).
Proof.
  induction k.
  -simpl.
   intros.
   Search (_ <= 0).
   apply le_n_0_eq in H0.
   rewrite <- H0.
   exact H.
  -destruct n.
   +intros.
    apply IHk.
    simpl in H.
    Search (_ && _ = true).
    apply andb_prop in H.
    destruct H.
    exact H1.
    apply Peano.le_0_n.
   +apply andb_prop in H.
    fold forall_bounded in H.
    destruct H.
    intros.
    change (f (S n) = true) with ((fun n => f (S n)) n = true).
    apply IHk.
    {(* c'est donner par H0 et H mais faut trouver un théoreme pour reussir a exprimer ça *)

      admit.
    }
    {
      Search (S _ <= S _).
      apply le_S_n in H1.
      exact H1.
    }
Admitted.

Lemma forall_finP: forall (P : nat -> Prop)(f : nat -> bool) (k : nat),
    (forall (n : nat), reflect (P n) (f n)) ->
    reflect (forall n, n <= k -> P n) (forall_bounded k f).
Proof.
  intros P f k H.
  apply iff_reflect.
  apply iff_to_and.
  split.
  -intros.
   Check help_forall_findP1.
   apply help_forall_findP1.
   intros.
   specialize (H n).
   apply reflect_iff in H.
   inversion H.
   apply H2.
   apply H0.
   exact H1.
  -intros.
   Check help_forall_findP2.
   eapply help_forall_findP2 in H0.
   specialize (H n).
   rewrite H0 in H.
   inversion H.
   exact H2.
   exact H1.
Qed.

Definition imply (a b : bool): bool := if a then b else true.

Lemma implyP: forall A B a b, reflect A a -> reflect B b -> reflect (A -> B) (imply a b).
Proof.
  intros.
  apply reflect_iff in H.
  inversion H.
  apply reflect_iff in H0.
  inversion H0.
  apply iff_reflect.
  apply iff_to_and.
  unfold imply.
  split.
  -intros.
   destruct a.
   +apply H3.
    apply H5.
    apply H2.
    reflexivity.
   +reflexivity.
  -intros.
   destruct b.
   +apply H4.
    reflexivity.
   +destruct a.
    {
      discriminate.
    }
    {
      apply H4.
      apply H1.
      exact H6.
    }
Qed.

SearchAbout beq_nat.

Definition eq_mtag (t1 t2: option tag): bool :=
  match t1,t2 with
  | Some t1', Some t2' => tag_beq t1' t2'
  | _,_ => false
  end.

Lemma eq_mtag_equiv : forall (t1 t2 : option tag), eq_mtag t1 t2 = true -> t1 = t2.
Proof.
  destruct t1.
  -destruct t2.
   +simpl.
   intros.
   apply tag_beq_different in H.
   rewrite H.
   reflexivity.
   +discriminate.
  -discriminate.
Qed.

Definition eq_mnat (t1 t2: option nat): bool :=
  match t1,t2 with
  | Some n1,Some n2 => beq_nat n1 n2
  | _,_ => false
  end.

Lemma eq_mnat_equiv : forall (n1 n2 : option nat), eq_mnat n1 n2 = true -> n1 = n2.
Proof.
  destruct n1.
  -destruct n2.
   +simpl.
    intros.
    Search (_ =? _ = true).
    apply beq_nat_true in H.
    rewrite H.
    reflexivity.
   +discriminate.
  -discriminate.
Qed.

Definition lookdown_encdecP : bool :=
  forall_bounded 3 (fun n =>
                      forall_tag (fun t => imply (eq_mtag (lookdown n encdec) (Some t))
                                                 (eq_mnat (lookup t encdec) (Some n)))).
Definition lookdown_encdecP' : bool :=
  forall_bounded 3 (fun n =>
                      forall_tag (fun t => imply (eq_mnat (lookup t encdec) (Some n))
                                                 (eq_mtag (lookdown n encdec) (Some t)))).

Lemma lookdown_n_inf_3 : forall (n : nat) (t : tag), lookdown n encdec = Some t -> n <=3.
Proof.
  destruct n.
  -intros.
   Search (0 <= _).
   apply Peano.le_0_n.
  -{destruct n.
    -intros.
     Search (S _ <= S _).
     apply le_n_S.
     apply Peano.le_0_n.
    -{
        destruct n.
        -intros.
         repeat (apply le_n_S).
         apply Peano.le_0_n.
        -{
            destruct n.
            -intros.
             repeat (apply le_n_S).
             apply Peano.le_0_n.
            -discriminate.
          }
      }
   }
Qed.

Theorem lookdown_encdec : forall (n : nat) (t : tag), lookdown n encdec = Some t -> lookup t encdec = Some n.
Proof.
  SearchAbout (_ < _ \/ _).
  (* Nat.lt_ge_cases" *)
  assert (reflect (forall (n : nat), n <= 3 -> forall
                       (t : tag), lookdown n encdec = Some t -> lookup t encdec = Some n)
                  lookdown_encdecP).
  {
    unfold lookdown_encdecP.
    SearchAbout forall_bounded.
    Check forall_finP.
    apply forall_finP.
    intro n.
    Check forall_tag.
    apply forall_tagP.
    SearchAbout imply.
    intros t.
    apply implyP.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
    {
      apply iff_reflect.
      apply iff_to_and.
      split.
      +intros.
       rewrite H.
       simpl.
       rewrite tag_beq_reflexivity.
       reflexivity.
      +intros.
       apply eq_mtag_equiv in H.
       exact H.
    }
    exact H.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
    {
      apply iff_reflect.
      apply iff_to_and.
      split.
      -intros.
      rewrite H.
      simpl.
      Search (_ =? _).
      rewrite <- beq_nat_refl.
      reflexivity.
      -intros.
       apply eq_mnat_equiv in H.
       exact H.
    }
    exact H.
  }
  assert (H': lookdown_encdecP = true) by reflexivity.
  rewrite H' in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 3).
  intros.
  destruct H1.
  -apply H0.
   exact H1.
   exact H2.
  -assert (exists m, n = 4 + m).
   {
     admit.
   }
   destruct H3.
   subst n.
   simpl in H2.
   discriminate.
  Admitted.

Theorem lookup_encdecP : forall (n : nat) (t : tag) , lookup t encdec = Some n -> lookdown n encdec = Some t.
Proof.
  SearchAbout reflect.
  assert (reflect (forall (n : nat), n <= 3 -> forall (t : tag), lookup t encdec = Some n -> lookdown n encdec = Some t) lookdown_encdecP').
  {
    unfold lookdown_encdecP.
    SearchAbout reflect.
    Check forall_finP.
    apply forall_finP.
    Check forall_tagP.
    intros n.
    apply forall_tagP.
    SearchAbout reflect.
    Check implyP.
    intros t.
    apply implyP.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply Nat.eqb_refl.
       +intros.
        apply eq_mnat_equiv in H.
        exact H.
     }
     exact H.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply tag_beq_reflexivity.
       +intros.
        apply eq_mtag_equiv in H.
        exact H.
     }
     exact H.
  }

  assert (lookdown_encdecP' = true) by reflexivity.
  rewrite H0 in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 3).
  intros.
  destruct H2.
  -apply H1.
   exact H2.
   exact H3.
  -assert (exists m, n = 4 + m).
   {
     admit.
   }
   destruct H4.
   subst n.
   Check lookdown_n_inf_3.
   simpl in H3.
  Admitted.

(* test fin de prog *)
Theorem lookup_encdecP : forall (n : nat) (t : tag) , lookup t encdec = Some n -> lookdown n encdec = Some t.
Proof.
  SearchAbout reflect.
  assert (reflect (forall (n : nat), n <= 3 -> forall (t : tag), lookup t encdec = Some n -> lookdown n encdec = Some t) lookdown_encdecP').
  {
    unfold lookdown_encdecP.
    SearchAbout reflect.
    Check forall_finP.
    apply forall_finP.
    Check forall_tagP.
    intros n.
    apply forall_tagP.
    SearchAbout reflect.
    Check implyP.
    intros t.
    apply implyP.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply Nat.eqb_refl.
       +intros.
        apply eq_mnat_equiv in H.
        exact H.
     }
     exact H.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply tag_beq_reflexivity.
       +intros.
        apply eq_mtag_equiv in H.
        exact H.
     }
     exact H.
  }

  assert (lookdown_encdecP' = true) by reflexivity.
  rewrite H0 in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 3).
  intros.
  destruct H2.
  -apply H1.
   exact H2.
   exact H3.
  -assert (exists m, n = 4 + m).
   {
     admit.
   }
   destruct H4.
   subst n.
   Check lookdown_n_inf_3.
   simpl in H3.
  Admitted.


Require Export GeoCoq.Elements.OriginalProofs.proposition_19.
Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence2.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_legsmallerhypotenuse :
   forall A B C,
   Per A B C ->
   Lt A B A C /\ Lt B C A C.
Proof.
intros.
assert (Per C B A) by (conclude lemma_8_2).
let Tf:=fresh in
assert (Tf:exists D, (BetS C B D /\ Cong C B D B /\ Cong C A D A /\ neq B A)) by (conclude_def Per );destruct Tf as [D];spliter.
assert (nCol A B C) by (conclude lemma_rightangleNC).
assert (Triangle A B C) by (conclude_def Triangle ).
assert (~ Col A C B).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Triangle A C B) by (conclude_def Triangle ).
assert ((LtA C A B A B D /\ LtA B C A A B D)) by (conclude proposition_16).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (~ eq B C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq B D) by (forward_using lemma_betweennotequal).
assert (Out B A A) by (conclude lemma_ray4).
assert (Out B C C) by (conclude lemma_ray4).
assert (Out B D D) by (conclude lemma_ray4).
assert (Cong B A B A) by (conclude cn_congruencereflexive).
assert (Cong B D B C) by (forward_using lemma_doublereverse).
assert (Cong A D A C) by (forward_using lemma_doublereverse).
assert (~ Col A B D).
 {
 intro.
 assert (Col C B D) by (conclude_def Col ).
 assert (Col D B C) by (forward_using lemma_collinearorder).
 assert (Col D B A) by (forward_using lemma_collinearorder).
 assert (neq B D) by (forward_using lemma_betweennotequal).
 assert (neq D B) by (conclude lemma_inequalitysymmetric).
 assert (Col B C A) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA A B D A B C) by (conclude_def CongA ).
assert (CongA A B C A B D) by (conclude lemma_equalanglessymmetric).
assert (LtA B C A A B C) by (conclude lemma_angleorderrespectscongruence).
assert (Lt A B A C) by (conclude proposition_19).
assert (LtA C A B A B C) by (conclude lemma_angleorderrespectscongruence).
assert (~ Col B A C).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA B A C C A B) by (conclude lemma_ABCequalsCBA).
assert (LtA B A C A B C) by (conclude lemma_angleorderrespectscongruence2).
assert (~ Col C B A).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Triangle C B A) by (conclude_def Triangle ).
assert (CongA C B A A B C) by (conclude lemma_ABCequalsCBA).
assert (LtA B A C C B A) by (conclude lemma_angleorderrespectscongruence).
assert (Lt C B C A) by (conclude proposition_19).
assert (Cong C B B C) by (conclude cn_equalityreverse).
assert (Lt B C C A) by (conclude lemma_lessthancongruence2).
assert (Cong C A A C) by (conclude cn_equalityreverse).
assert (Lt B C A C) by (conclude lemma_lessthancongruence).
close.
Qed.

End Euclid.


(* This file contains the definition of a universal machine and the proof that the machine
is actually universal. The universal machine is a machine of type two and it should work
for any continuous function from B -> B. Here, B is usually the Baire space i.e. the set
of all mappings from strings to strings. However, since I don't want to rely on a
handwritten type of strings I use more generaly a space of the form Q -> A for some types
Q and A as substitute for B. The assumptions needed about Q and A are that they are
countable and that A is inhabited. *)
From mathcomp Require Import all_ssreflect.
Require Import core_mf core_bs core_cont core_inseg core_omach core_count.
Require Import ClassicalChoice Psatz FunctionalExtensionality.

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

(* Q: Questions, A: Answers *)
Context (Q Q': Type) (A A' : Type).
(* B: Baire space *)
Notation B := (Q -> A).
Notation B' := (Q' -> A').

Definition U_step (psi : list (Q * A) * Q' -> Q + A') phi q' L :=
match psi (L, q') with
  | inr a' => inl a'
  | inl q => inr ((q, phi q) :: L)
end.

Fixpoint U_rec n (psi: list (Q * A) * Q' -> Q + A') phi q' :=
match n with
	|	0 => U_step psi phi q' nil
	|	S n' => match U_rec n' psi phi q' with
	  | inl a' => inl a'
		| inr L => U_step psi phi q' L
	end
end.

(* This is the definition of the universal machine: *)
Definition U
	(psi: list (Q * A) * Q' -> Q + A')
	(n: nat)
	(phi: Q -> A)
	(q' : Q') :=
match U_rec n psi phi q' with
	| inl a' => Some a'
	| inr L => None
end.

Lemma U_mon psi:
	(U psi) \is_monotone_oracle_machine.
Proof.
move => /= n m phi q' a'; elim: m => [| m].
	by intros; have /eqP <-: n == 0 by rewrite -leqn0.
rewrite /pickle/= [_ <= S m]leq_eqVlt=> ih; case/orP => [/eqP ass | ass eq].
	by case E: (U_rec m.+1 psi phi q') ih => [b|k]// _ <-; rewrite ass.
have:= (ih ass eq); rewrite /U; case E: (U_rec m psi phi q') => //.
by rewrite /U_rec in E; rewrite /U_rec E => <-.
Qed.

Lemma U_rec_step n psi phi q':
	U_rec n.+1 psi phi q' = match U_rec n psi phi q' with
	  | inl a' => inl a'
		| inr L => U_step psi phi q' L
	end.
Proof. done. Qed.

Lemma U_rec_length n psi phi q' L:
	(U_rec n psi phi q') = inr L -> length L = n.+1.
Proof.
elim: n L; first by move => L; rewrite /U_rec/U_step; case: (psi (nil, q')) => [q [<-]|].
move => n ih L; rewrite U_rec_step.
case E: (U_rec n psi phi q') => [ | K] => //; rewrite /U_step.
by case: (psi (K, q')) => // q [<-] /=; rewrite ih.
Qed.

(* List to multivalued function *)
Notation L2MF L := (fun q a => List.In (q, a) L).

Section FLST.
Context (phi: B).
Definition flst L:= zip L (map phi L).

Lemma flst_cons_elts qa L:
	List.In qa (flst L) -> phi (qa.1) = qa.2.
Proof.
by case: qa => q a; elim: L => // p L ih [] // [<-].
Qed.

Lemma lstn_flst q L:
	(List.In q L -> List.In (q, phi q) (flst L)).
Proof.
by elim: L => //= q' L ih [H|H]; [left; rewrite H | right; apply: ih].
Qed.

Lemma flst_lstn qa L:
	List.In qa (flst L) -> List.In qa.1 L.
Proof.
by case: qa => q a; elim: L => //= p L ih []; [case; left | right; apply: ih].
Qed.

Lemma icf_flst L:
	phi \is_choice_for (L2MF (flst L)).
Proof.
apply icf_F2MF_tight => q [a listin].
split => [ |a' <-]; first by exists a; apply: flst_cons_elts listin.
by apply /lstn_flst/(flst_lstn listin).
Qed.

Lemma flst_sing L : (L2MF (flst L)) \is_single_valued.
Proof.
by move=> s t1 t2 /flst_cons_elts /= <- /flst_cons_elts /= <-.
Qed.

Lemma coin_icf_flst psi L:
	psi \is_choice_for (L2MF (flst L))
	<->
	psi \and phi \coincide_on L.
Proof.
rewrite coin_lstn; split => [icf q lstn | prp q a /flst_lstn lstn].
	by rewrite (@flst_cons_elts (q, psi q) L); last by apply/icf/lstn_flst.
by rewrite prp; first apply /lstn_flst.
Qed.

Lemma icf_flst_coin psi L:
	psi \is_choice_for (L2MF(flst L)) <-> psi \and phi \coincide_on L.
Proof. exact: coin_icf_flst. Qed.

Lemma length_flst_in_seg cnt n:
	length (flst (in_seg cnt n)) = n.
Proof. by elim: n => // n ih; rewrite -{2}ih. Qed.

Lemma extend_list (a: A):
	exists listf, forall (L: list (Q * A)), (listf L) \is_choice_for (L2MF L).
Proof.
pose R (L : list(Q * A)) (phi: Q -> A) := phi \is_choice_for (L2MF L).
by have /choice Rtot : R \is_total by move => L; exact: exists_choice (L2MF L) a.
Qed.
End FLST.

Section MINIMAL_MODULI.
Context (F: B ->> B').

Definition listfprop listf :=
	listf \is_choice_for (fun L phi => phi \from_dom F /\ phi \is_choice_for (L2MF L)).

Lemma exists_lstf (a : A) :
	exists listf, listfprop listf.
Proof. exact: exists_choice. Qed.

Context (cnt: nat -> Q).
Notation init_seg := (in_seg cnt).

Lemma phi'prop listf phi n:
	listfprop listf -> phi \from_dom F ->
	(listf (flst phi (init_seg n))) \from_dom F
	/\
	(listf (flst phi (init_seg n))) \is_choice_for (L2MF (flst phi (init_seg n))).
Proof.
move => listfprop phifd.
have prop: phi \from_dom F/\ phi \is_choice_for (L2MF (flst phi (init_seg n))).
	by split; last exact: icf_flst.
by apply: (listfprop (flst phi (init_seg n)) phi).
Qed.

Context (sec: Q -> nat).

Notation size := (max_elt sec).

Definition is_min_mod mf :=
	(fun phi q' => init_seg (mf phi q')) \is_modulus_of F
	/\
	forall phi q' K, phi \from_dom F -> mf_mod F (phi, q') K -> mf phi q' <= size K.

Context (ims: sec \is_minimal_section_of cnt).

Lemma exists_minmod: cnt \is_surjective_function -> F \is_continuous ->
	exists mf, is_min_mod mf.
Proof.
move => sur cont.
pose P phiq n := mf_mod F phiq (init_seg n).
have Pdom: forall phi, phi \from_dom F -> forall q', (phi, q') \from_dom P.
	move => phi fd q'; have [L [/=_ Lprop]]:= (cont phi fd q').
	exists (size L); split => // Fphi FphiFphi.
	apply: cert_mon; first exact: inseg_melt.
	by apply/ Lprop; first by apply FphiFphi.
pose R phiq n := P phiq n /\ (forall K, P phiq (size K) ->  n <= size K).
have Rdom: forall phi, phi \from_dom F -> forall q', (phi, q') \from_dom R.
	move => phi fd q'.
  have [n [p nprop]] := well_order_nat (Pdom phi fd q').
  by exists n; split => // K p'; apply/nprop.
have [mf mfprop] := exists_choice R 0.
exists (fun phi q' => mf (phi, q')).
split => phi q' X.
	by have [n Rn]:= (Rdom phi X q'); apply: (mfprop (phi, q') n Rn).1.
move => fd Xprop; have [n Rn]:= (Rdom phi fd q').
apply: (mfprop (phi, q') n Rn).2; split => // Fphi FphiFphi.
by apply/ cert_mon; [apply: inseg_melt | apply Xprop].
Qed.

Definition compat mf listf:= forall phi, phi \from_dom F ->
	forall (q': Q') m, mf phi q' <= m -> mf (listf (flst phi (init_seg m))) q' <= m.

Lemma minmod_compat mf listf:
	listfprop listf -> is_min_mod mf -> compat mf listf.
Proof.
move => listfprop [mod min] phi phifd q' m ineq.
have [/=_ mod'] := mod phi q' phifd.
pose L := flst phi (init_seg m).
pose phi' := listf L.
have [phi'fd icf]:= (phi'prop m listfprop phifd).
rewrite -/L -/phi' in phi'fd icf.
have coin: phi \and phi' \coincide_on (init_seg m)
	by apply/coin_sym/ icf_flst_coin/icf.
move: phifd => [Fphi FphiFphi].
have ineq': size (init_seg m) <= m by exact/(melt_inseg ims).
suffices ineq'': mf phi' q' <= size (init_seg m) by apply /(leq_trans ineq'').
apply/ min => //; split => // Fphi' /= Fphi'Fphi'.
suffices <-: (Fphi q' = Fphi' q').
	by apply/(cert_cons coin)/cert_mon; [apply/inseg_mon/ineq | apply /mod'].
apply /mod' => //; last apply Fphi'Fphi'.
by apply /coin_mon; [apply /inseg_mon/ineq | apply /coin ].
Qed.

End MINIMAL_MODULI.

Section PSIF.
Context (cnt: nat -> Q).
Notation init_seg := (in_seg cnt).
Notation "mf '\is_modulus_for' F" :=
	((fun phi q' => init_seg (mf phi q')) \is_modulus_of F) (at level 2).
Context (F: B ->> B') (mf: B -> Q' -> nat) (listf: seq (Q * A) -> B) (Ff: B -> B').
Notation L phi m:= (flst phi (init_seg m)).

Definition psiF (L: seq (Q * A) * Q') :=
	if (mf (listf L.1) L.2 <= length L.1)%N
	then
		(inr (Ff (listf L.1) L.2))
	else
		(inl (cnt (length L.1))).

Lemma psiFprop phi q':
	forall n,
		(exists m,
		mf (listf (flst phi (init_seg m))) q' <= m
		/\
		U_rec n psiF phi q' = inl (Ff (listf (flst phi (init_seg m))) q'))
	\/
	forall m, m <= n ->
	U_rec m psiF phi q' = inr (flst phi (init_seg (S m))).
Proof.
pose phin m := listf (L phi m).
elim => [ | n ih].
	rewrite /U_rec/U_step/psiF/=.
	case E: (mf (listf [::]) q' <= 0); first by left; exists 0; split.
	by right => m ineq; have /eqP ->: m == 0; [rewrite -leqn0 | rewrite E].
case: ih => [[] m [] ineq | eq].
	by rewrite /U_rec; left; exists m; split; [apply ineq | rewrite /U_rec b].
case E: (mf (listf (flst phi (init_seg n.+1), q').1) (flst phi (init_seg n.+1), q').2 <= n.+1).
	left; exists (n.+1);rewrite /U_rec in eq;rewrite /U_rec eq =>//.
	by rewrite /U_step/psiF length_flst_in_seg; split; last rewrite E.
right => m; rewrite  leq_eqVlt; case/orP => [/eqP nm | le]; last by rewrite -eq.
have eq': U_rec n psiF phi q' = inr (flst phi (init_seg n.+1)) by apply eq.
by rewrite /U_rec in eq'; rewrite /U_rec nm eq'/U_step/psiF length_flst_in_seg E.
Qed.

Definition Ff_mod phi q' := forall m, mf (listf (L phi m)) q' <= m -> Ff (listf (L phi m)) q' = Ff phi q'.

Lemma Ffprop
	(icf: Ff \is_choice_for F)
	(mod: mf \is_modulus_for F)
	(lstprp: listfprop F listf):
		forall phi q', phi \from_dom F -> Ff_mod phi q'.
Proof.
move => phi q' phifd m.
have phinprop:= (phi'prop cnt m lstprp phifd).
have coin: (listf (L phi m)) \and phi \coincide_on (init_seg m) by apply/icf_flst_coin/(phinprop).2.
move: mod (mod (listf (L phi m)) q' (phinprop).1) => _ [/=_ mprop] ineq.
move: phifd (phinprop).1 => [] Fphi FphiFphi [] Fphin FphinFphin.
apply/mprop; [ apply/ (icf _ Fphin) | | apply/(icf _ Fphi) ] => //.
by apply/coin_mon; [apply/inseg_mon | apply coin].
Qed.

Lemma U_step_compat phi q' (cmpt: compat F cnt mf listf):
	phi \from_dom F -> Ff_mod phi q' -> U_step psiF phi q' (L phi (mf phi q')) = inl (Ff phi q').
Proof.
move => phifd Ffprop.
rewrite /U_step/psiF/=length_flst_in_seg; case: ifP => [|/negP eq].
	by rewrite Ffprop; last by apply/cmpt.
by exfalso; apply eq; apply/cmpt.
Qed.

Lemma U_psiF_cmpt_F
	(sur: cnt \is_surjective_function)
	(icf: Ff \is_choice_for F)
	(mod: (fun phi q' => init_seg (mf phi q')) \is_modulus_of F)
	(lstprp: listfprop F listf)
	(cmpt: compat F cnt mf listf):
		(U psiF) \ocomputes F.
Proof.
move => phi phifd.
pose phin m := listf (L phi m).
have phinprop m:= (phi'prop cnt m lstprp phifd).
have coin m: (phin m) \and phi \coincide_on (init_seg m) by apply/icf_flst_coin/(phinprop m).2.
pose phi' q' := phin (mf phi q').

have U_stops q': U psiF (mf phi q') phi q' = some (Ff phi q').
	rewrite /U.
	case: (psiFprop phi q'(mf phi q'))=> [ [] m []ineq eq | eq].
		by rewrite eq; congr some; rewrite (Ffprop).
	case E: (mf phi q') => [ | m].
		have eq': flst phi (init_seg (mf phi q')) = nil by rewrite E.
		by rewrite /= -eq' U_step_compat => //; apply/ Ffprop.
	have /eq eqn: m <= mf phi q' by rewrite E leqnSn.
	by rewrite /= eqn -E U_step_compat => //; apply/ Ffprop.

have [Fphi FphiFphi]:= phifd.
have eq' q': U psiF (mf phi q') phi q' = Some (Fphi q').
	rewrite U_stops; congr Some.
	by apply: (mod _ _ phifd).2; [ apply/icf/FphiFphi | apply/ coin_ref | ].
split => [|Mphi MphiMphi]; first by exists Fphi => q'; exists (mf phi q'); rewrite eq'.
have ->: Mphi = Fphi => //.
apply: functional_extensionality => q'; apply Some_inj.
have [n eq] := MphiMphi q'.
case/orP: (leq_total n (mf phi q')) => ineq.
	by rewrite -(U_mon ineq eq).
by rewrite -(U_mon ineq (eq' q')).
Qed.
End PSIF.

Lemma U_universal (someq: Q) (somea : A) (somephi': B') (count: Q \is_countable):
	forall F, F \is_continuous -> exists psiF, (U psiF) \ocomputes F.
Proof.
have [ | cnt sur]:= (count_sur Q).2.
	by split; [apply (inhabits someq) | apply count].
move => F Fcont.
have [Ff Fprop] := exists_choice F somephi'.
have [sec isminsec] := minimal_section sur.
have [mf [mprop minmod]] := exists_minmod isminsec sur Fcont.
have [listf listfprop] := exists_lstf F somea.
exists (psiF cnt mf listf Ff).
apply/U_psiF_cmpt_F => //.
exact: (minmod_compat isminsec).
Qed.

(* Lemma comp_cont:
  (exists psiF, (fun n phi q' => U n psiF phi q') \type_two_computes F) -> F \is_continuous.
Proof.
move => [] psiF comp phi q'.
case: (classic (phi \from_dom F)) => [] phifd.
move: (comp phi phifd) => [] [] psi ev prop.
move: (ev q') => [] n eq.
Admitted.
*)
End UNIVERSAL_MACHINE.
Notation L2MF L := (fun q a => List.In (q, a) L).


Require Import List.
Import ListNotations.

From RT Require Import Pred.

(* Terms *)
Inductive term : Type :=
| LNat (n : nat)
| LVar (x : var)
| LAdd (t1 t2 : term)
| LBnd (x : var) (t1 t2 : term)
| LAbs (x : var) (t : term)
| LApp (t1 t2 : term).

(* Refinement types for terms *)
Inductive type : Type :=
(* Refined base type *)
| TRefn (x : var) (p : pred)
(* Dependent function type *)
| TFun (x : var) (T1 T2 : type).

(* Base type, nat *)
Definition TBase x := TRefn x (PBool true).

(* Capture-avoiding change of variables in types *)
Fixpoint change_var_type (T : type) (from to : var) : type :=
  match T with
  | TRefn x p =>
      if x =? from then T else TRefn x (change_var_pred p from to)
  | TFun x T1 T2 =>
      let T1' := change_var_type T1 from to in
      if x =? from then
        TFun x T1' T2
      else
        TFun x T1' (change_var_type T2 from to)
  end.

(* Contexts *)
Definition ctxt := list (var * type).

(* Query a context for the type of a variable *)
Fixpoint lookup (G : ctxt) (x : var) : option type :=
  match G with
  | [] => None
  | (y, T) :: G' =>
      if y =? x then Some T else lookup G' x
  end.

(* Constraint is valid *)
Definition valid c := cnst_prop c.

(* Context entails a constraint *)
Inductive entails : ctxt -> cnst -> Prop :=
| entails_emp :
  forall c, valid c -> entails [] c
| entails_ext :
  forall G x y p c,
    entails G (CImpl y (change_var_pred p x y) c) ->
    entails ((y, TRefn x p) :: G) c.

(* Subtyping rules *)
Inductive subtype : ctxt -> type -> type -> Prop :=
| subtype_refn :
  forall G x1 p1 x2 p2,
    entails G (CImpl x1 p1 (CPred (change_var_pred p2 x2 x1))) ->
    subtype G (TRefn x1 p1) (TRefn x2 p2)
| subtype_fun :
  forall G x1 S1 T1 x2 S2 T2,
    subtype G S2 S1 ->
    subtype ((x2, S2) :: G) (change_var_type T1 x1 x2) T2 ->
    subtype G (TFun x1 S1 T1) (TFun x2 S2 T2).

(* Bidirectional typing constructors *)
Inductive bidir : Type :=
| synth
| check.

(* Bidirectional typing rules for terms *)
Inductive type_judge : bidir -> ctxt -> term -> type -> Prop :=
| synth_var :
  forall G x T,
    lookup G x = Some T -> type_judge synth G (LVar x) T
| synth_nat :
  forall G n x,
    type_judge synth G (LNat n) (TRefn x (PEq (PVar x) (PNat n)))
| synth_add :
  forall G x y z,
    type_judge synth G
      (LAbs x (LAbs y (LAdd (LVar x) (LVar y))))
      (TFun x (TBase x) (TFun y (TBase y) (TRefn z (PEq (PVar z) (PAdd (PVar x) (PVar y))))))
| synth_app :
  forall G x y t T1 T2,
    type_judge synth G t (TFun x T1 T2) ->
    type_judge check G (LVar y) T1 ->
    type_judge synth G (LApp t (LVar y)) (change_var_type T2 x y)
| check_syn :
  forall G t T1 T2,
    type_judge synth G t T1 ->
    subtype G T1 T2 ->
    type_judge check G t T2
| check_abs :
  forall G x t T1 T2,
    type_judge check ((x, T1) :: G) t T2 ->
    type_judge check G (LAbs x t) (TFun x T1 T2)
| check_bnd :
  forall G x t1 t2 T1 T2,
    type_judge synth G t1 T1 ->
    type_judge check ((x, T1) :: G) t2 T2 ->
    type_judge check G (LBnd x t1 t2) T2.

Definition type_synth (G : ctxt) (t : term) (T : type) : Prop :=
  type_judge synth G t T.

Definition type_check (G : ctxt) (t : term) (T : type) : Prop :=
  type_judge check G t T.

(* Useful results *)

Lemma subtype_ctxt_extend :
  forall G x T T1 T2,
    lookup G x = None ->
    subtype G T1 T2 ->
    subtype ((x, T) :: G) T1 T2.
Admitted.

Lemma same_var_change_type : forall T x, change_var_type T x x = T.
Proof.
  intros. induction T.
  - simpl. destruct (x0 =? x) eqn:E0.
    + reflexivity.
    + rewrite same_var_change_pred. reflexivity.
  - simpl. destruct (x0 =? x) eqn:E0.
    + rewrite IHT1. reflexivity.
    + rewrite IHT1, IHT2. reflexivity.
Qed.

Lemma subtype_refl : forall T, subtype [] T T.
Proof.
  intros. induction T.
  - constructor. rewrite same_var_change_pred.
    constructor. compute. intros. assumption.
  - constructor.
    + assumption.
    + rewrite same_var_change_type.
      apply subtype_ctxt_extend.
         -- reflexivity.
         -- assumption.
Qed.


(* Lemmma ForallT_insert and insert_BST from:
 https://softwarefoundations.cis.upenn.edu/vfa-current/SearchTree.html#lookup *)

Require Export BST.

Lemma ForallT_insert : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t -> forall (k : key) (v : V),
      P k v -> ForallT P (insert k v t).
Proof.
    intros. induction t.
    - simpl. split.
    * apply H0.
    * split. reflexivity. reflexivity.
    - destruct (k <? k0) eqn:E.
    * simpl. rewrite E. simpl. split.
        + apply H.
        + split.
        ++ apply IHt1. apply H.
        ++ apply H.
    * simpl. rewrite E. destruct (k0 <? k) eqn:F.
        +  simpl. split.
        ++ apply H.
        ++ split.
        +++ apply H.
        +++ apply IHt2. apply H.
        + simpl. split. apply H0. apply H.
Qed.

Lemma less_than_prop : forall (n m : nat), n < m <-> n <? m = true.
Proof.
    Admitted.

Lemma then_equal : forall (n m : nat), n <? m = false /\  m <? n = false -> n = m.
Proof.
    Admitted.

Theorem insert_BST : forall (V: Type) (k: key) (v: V) (t: tree V), BST t -> BST (insert k v t).
Proof.
    intros. induction t.
    - simpl. apply BST_T.
    * simpl. reflexivity.
    * simpl. reflexivity.
    * apply BST_E.
    * apply BST_E.
    - destruct (k <? k0) eqn:E.
    * simpl. rewrite E. apply BST_T.
        + apply ForallT_insert.
        ++ inversion H. apply H4.
        ++ apply less_than_prop. apply E.
        + destruct t2.
        ++ reflexivity.
        ++ inversion H. apply H5.
        + apply IHt1. inversion H. apply H6.
        + inversion H. apply H7.
    * simpl. rewrite E. destruct (k0 <? k) eqn:F.
        + apply BST_T.
        ++ inversion H. apply H4.
        ++ inversion H. apply ForallT_insert. apply H5. apply less_than_prop. apply F.
        ++ inversion H. apply H6.
        ++ inversion H. apply IHt2. apply H7.
        + apply BST_T. assert (G: k = k0). { simpl. apply then_equal. split. apply E. apply F. }
        ++ inversion H. rewrite G. apply H4.
        ++ assert (G: k = k0). { simpl. apply then_equal. split. apply E. apply F. } rewrite G. inversion H. apply H5.
        ++ inversion H. apply H6.
        ++ inversion H. apply H7.
    Qed.