Require Import RelationClasses.

From Paco Require Import paco.
Require Import sflib.

Require Import Axioms.
Require Import Basic.
Require Import Loc.
Require Import Time.

Fixpoint incr_time_seq (n: nat): Time.t :=
  match n with
  | O => BinNums.xI (BinNums.xH)
  | S n' => BinNums.xI (incr_time_seq n')
  end.

Lemma incr_time_seq_succesor' n
  :
    DenseOrder.DOAux.lt (incr_time_seq n) (incr_time_seq (S n)).
Proof.
  ginduction n; ss; i.
  { econs. econs. }
  { econs. eauto. }
Qed.

Lemma incr_time_seq_lt' n0 n1
      (LT: n0 < n1)
  :
    DenseOrder.DOAux.lt (incr_time_seq n0) (incr_time_seq n1).
Proof.
  ginduction LT.
  { eapply incr_time_seq_succesor'. }
  { etrans.
    { eapply IHLT. }
    { eapply incr_time_seq_succesor'. }
  }
Qed.

Lemma incr_time_seq_diverge' ts
  :
    exists n, <<LT: DenseOrder.DOAux.lt ts (incr_time_seq n)>>.
Proof.
  ginduction ts.
  { des. exists (S n). ss. econs. eauto. }
  { exists 0. ss. econs. }
  { exists 0. ss. econs. }
Qed.

Lemma incr_time_seq_lt n0 n1
      (LT: n0 < n1)
  :
    Time.lt (incr_time_seq n0) (incr_time_seq n1).
Proof.
  set (incr_time_seq_lt' n0 n1 LT). inv l; try by econs.
  destruct n0; ss.
Qed.

Lemma incr_time_seq_diverge ts
  :
    exists n, <<LT: Time.lt ts (incr_time_seq n)>>.
Proof.
  set (incr_time_seq_diverge' ts). des.
  exists n. inv LT; try by econs.
  destruct n; ss.
Qed.

Definition lb_time (times: Time.t -> Prop) (ts ts': Time.t) :=
  forall t (IN: times t) (LT: Time.lt ts t),
    Time.lt ts' t.

Lemma eq_lb_time times ts
  :
    lb_time times ts ts.
Proof.
  ii. auto.
Qed.

Lemma lb_time_lower times ts ts'0 ts'1
      (LB: lb_time times ts ts'0)
      (TS: Time.le ts'1 ts'0)
  :
    lb_time times ts ts'1.
Proof.
  ii. exploit LB; eauto.
  i. eapply TimeFacts.le_lt_lt; eauto.
Qed.

Definition well_ordered (times: Time.t -> Prop): Prop :=
  forall (sub: Time.t -> Prop)
         (SUB: sub <1= times)
         x
         (INHABITED: sub x),
  exists ts,
    (<<SAT: sub ts>>) /\
    (<<LEAST: forall ts' (IN: sub ts'), Time.le ts ts'>>).

Lemma lb_time_exists times
      (WO: well_ordered times)
      ts
  :
    exists ts', <<TS: Time.lt ts ts'>> /\ <<LB: lb_time times ts ts'>>.
Proof.
  destruct (classic (exists x, __guard__(fun x => <<IN: times x>> /\ <<LT: Time.lt ts x>>) x)).
  { des. eapply WO in H.
    { des. exists (Time.middle ts ts0). unguard. des. splits; auto.
      { eapply Time.middle_spec; auto. }
      { ii. hexploit (LEAST t).
        { splits; eauto. }
        i. eapply TimeFacts.lt_le_lt; eauto.
        eapply Time.middle_spec; auto. }
    }
    { i. unguard. ss. des. auto. }
  }
  { exists (Time.incr ts). splits; auto.
    { eapply Time.incr_spec. }
    { ii. exfalso. eapply H. unguard. esplits; eauto. }
  }
Qed.

Lemma sub_well_ordered times0 times1
      (WO: well_ordered times0)
      (SUB: times1 <1= times0)
  :
    well_ordered times1.
Proof.
  ii. exploit WO.
  { i. eapply SUB. eapply SUB0. eapply PR. }
  { eauto. }
  { i. des. exists ts. splits; eauto. }
Qed.

Lemma join_well_ordered times0 times1
      (WO0: well_ordered times0)
      (WO1: well_ordered times1)
  :
    well_ordered (times0 \1/ times1).
Proof.
  (* ii. exploit SUB; eauto. i. des.
  { destruct (classic (exists ts1, <<IN1: (sub /1\ times1) ts1>>)) as [?|NIN].
    { des. exploit (WO0 (sub /1\ times0)).
      { i. des; auto. }
      { instantiate (1:=x). splits; auto. } i. des.
      exploit (WO1 (sub /1\ times1)).
      { i. des; auto. }
      { instantiate (1:=ts1). splits; auto. } i. des.
      exists (Time.meet ts ts0). splits; auto.
      { unfold Time.meet. des_ifs. }
      { i. unfold Time.meet. des_ifs.
        { exploit SUB; eauto. i. des; eauto. }
        { exploit SUB; eauto. i. des; eauto.
          exploit LEAST; eauto. i.
          transitivity ts; eauto. left. auto. }
      }
    }
    { exploit (WO0 sub); eauto.
      i. exploit SUB; eauto. i. des; auto. exfalso. eauto. }
  }
  { destruct (classic (exists ts0, <<IN0: (sub /1\ times0) ts0>>)) as [?|NIN].
    { des. exploit (WO1 (sub /1\ times1)).
      { i. des; auto. }
      { instantiate (1:=x). splits; auto. } i. des.
      exploit (WO0 (sub /1\ times0)).
      { i. des; auto. }
      { instantiate (1:=ts0). splits; auto. } i. des.
      exists (Time.meet ts ts1). splits; auto.
      { unfold Time.meet. des_ifs. }
      { i. unfold Time.meet. des_ifs.
        { exploit SUB; eauto. i. des; eauto. }
        { exploit SUB; eauto. i. des; eauto.
          exploit LEAST; eauto. i.
          transitivity ts; eauto. left. auto. }
      }
    }
    { exploit (WO1 sub); eauto.
      i. exploit SUB; eauto. i. des; auto. exfalso. eauto. }
  } *)
Admitted.

Lemma empty_well_ordered
  :
    well_ordered bot1.
Proof.
  ii. eapply SUB in INHABITED. ss.
Qed.

Lemma singleton_well_ordered ts
  :
    well_ordered (eq ts).
Proof.
  ii. exploit SUB; eauto. i. subst.
  esplits; eauto. i. eapply SUB in IN. subst. refl.
Qed.

Lemma finite_well_ordered (l: list Time.t)
  :
    well_ordered (fun ts => List.In ts l).
Proof.
  induction l.
  { ss. eapply empty_well_ordered. }
  { ss. eapply join_well_ordered; eauto.
    eapply singleton_well_ordered. }
Qed.

Lemma finite_join_well_ordered
      (sets: nat -> (Time.t -> Prop))
      (WO: forall n, well_ordered (sets n))
      n
  :
    well_ordered (fun ts => exists n', (<<LT: n' < n>>) /\ (<<SAT: sets n' ts>>)).
Proof.
  induction n.
  { eapply sub_well_ordered with (times0 := bot1).
    { eapply empty_well_ordered. }
    { i. ss. des. inv LT. }
  }
  { eapply sub_well_ordered.
    { eapply join_well_ordered.
      { eapply IHn. }
      { eapply (WO n). }
    }
    { i. des. inv LT; auto. left. exists n'; eauto. }
  }
Qed.

Lemma increasing_join_well_ordered
      (f: nat -> Time.t)
      (sets: nat -> (Time.t -> Prop))
      (MON: forall n0 n1 (LT: n0 < n1), Time.lt (f n0) (f n1))
      (DIV: forall ts, exists n, <<LT: Time.lt ts (f n)>>)
      (LB: forall n ts (SAT: sets n ts), Time.le (f n) ts)
      (WO: forall n, well_ordered (sets n))
  :
    well_ordered (fun ts => exists n, <<SAT: sets n ts>>).
Proof.
  ii. hexploit (DIV x); eauto. i. des.
  exploit SUB; eauto. i. des.
  assert (LT0: n0 < n).
  { destruct (Compare_dec.le_lt_dec n n0); auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
    { eapply LB. eapply SAT. } eapply TimeFacts.lt_le_lt.
    { eapply LT. }
    { eapply Lt.le_lt_or_eq in l. des.
      { left. eapply MON; eauto. }
      { subst. refl. }
    }
  }
  exploit finite_join_well_ordered.
  { eapply WO. }
  { instantiate (1:=n).
    instantiate (1:=fun ts =>
                      exists n', (<<LT: n' < n>>) /\ (<<SAT: sets n' ts>>) /\ (<<SUB: sub ts>>)).
    i. ss. des. eauto. }
  { instantiate (1:=x). ss. esplits; eauto. }
  i. des. exists ts. splits; auto.
  i. destruct (Time.le_lt_dec x ts').
  { transitivity x; auto. eapply LEAST. exists n0. splits; auto. }
  { exploit (SUB ts'); eauto. i. des. eapply LEAST; eauto.
    exists n1. splits; eauto.
    destruct (Compare_dec.le_lt_dec n n1); auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
    { eapply LB. eapply SAT1. } eapply TimeFacts.lt_le_lt.
    { eapply l. } etrans.
    { left. eapply LT. }
    { eapply Lt.le_lt_or_eq in l0. des.
      { left. eapply MON; eauto. }
      { subst. refl. }
    }
  }
Qed.

Definition incr_times (ts: Time.t):=
  exists n, incr_time_seq n = ts.

Lemma incr_times_well_ordered
  :
    well_ordered incr_times.
Proof.
  hexploit (increasing_join_well_ordered
              incr_time_seq
              (fun n => eq (incr_time_seq n))).
  { eapply incr_time_seq_lt. }
  { eapply incr_time_seq_diverge. }
  { i. subst. refl. }
  { i. apply singleton_well_ordered. }
  i. eapply sub_well_ordered; eauto.
Qed.

Lemma mapped_well_ordered
      (f: Time.t -> Time.t -> Prop)
      (times ftimes: Time.t -> Prop)
      (MAPLT: forall t0 t1 ft0 ft1
                     (MAP0: f t0 ft0)
                     (MAP1: f t1 ft1),
          Time.lt t0 t1 <-> Time.lt ft0 ft1)
      (WO: well_ordered times)
      (FTIMES: forall fts (IN: ftimes fts),
          exists ts,
            (<<MAP: f ts fts>>) /\
            (<<TIMES: times ts>>))
  :
    well_ordered ftimes.
Proof.
  ii.
  dup INHABITED. eapply SUB in INHABITED. dup INHABITED. eapply FTIMES in INHABITED. des.
  exploit (WO (fun ts => exists fts, (<<MAP: f ts fts>>) /\ (<<TIMES: sub fts>>))).
  { i. des. eapply SUB in TIMES0. eapply FTIMES in TIMES0. des.
    destruct (Time.le_lt_dec x0 ts0).
    { destruct l.
      { exploit MAPLT.
        { eapply MAP0. }
        { eapply MAP1. } i. des.
        exfalso. eapply Time.lt_strorder. eapply x1; eauto.
      }
      { inv H. auto. }
    }
    { exploit MAPLT.
      { eapply MAP1. }
      { eapply MAP0. } i. des.
      exfalso. eapply Time.lt_strorder. eapply x1; eauto.
    }
  }
  { eauto. }
  { i. des. exists fts. splits; auto. i.
    dup IN. eapply SUB in IN. dup IN. eapply FTIMES in IN. des.
    exploit LEAST; eauto. i.
    destruct (Time.le_lt_dec fts ts'); auto.
    erewrite <- MAPLT in l; eauto. timetac.
  }
Qed.


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

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import UnicodeNotations.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import Auxiliary.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Local Notation "G □ F" := (functor_composite _ _ _ F G) (at level 35).

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

Section def_functor_pointwise_coprod.

Variable C D : precategory.
Variable HD : Coproducts D.
Variable hsD : has_homsets D.

Section coproduct_functor.

Variables F G : functor C D.

Local Notation "c ⊗ d" := (CoproductObject _ (HD c d))(at level 45).

Definition coproduct_functor_ob (c : C) : D := F c ⊗ G c.

Definition coproduct_functor_mor (c c' : C) (f : c ⇒ c')
  : coproduct_functor_ob c ⇒ coproduct_functor_ob c'
  := CoproductOfArrows _ _ _ (#F f) (#G f).

Definition coproduct_functor_data : functor_data C D.
Proof.
  exists coproduct_functor_ob.
  exact coproduct_functor_mor.
Defined.

Lemma is_functor_coproduct_functor_data : is_functor coproduct_functor_data.
Proof.
  split; simpl; intros.
  - unfold functor_idax; intros; simpl in *.
    apply pathsinv0.
    apply Coproduct_endo_is_identity.
    + unfold coproduct_functor_mor.
      rewrite CoproductOfArrowsIn1.
      rewrite functor_id.
      apply id_left.
    + unfold coproduct_functor_mor.
      rewrite CoproductOfArrowsIn2.
      rewrite functor_id.
      apply id_left.
  - unfold functor_compax, coproduct_functor_mor;
    intros; simpl in *.
    unfold coproduct_functor_mor.
    do 2 rewrite functor_comp.
    rewrite <- CoproductOfArrows_comp.
    apply idpath.
(* former proof:
    unfold CoproductOfArrows.
    apply pathsinv0.
    apply CoproductArrowUnique.
    + rewrite assoc. simpl in *.
      set (H:= CoproductIn1Commutes ).
      set (H2 := H D _ _ (HD (F a) (G a))).
      rewrite H2.
      rewrite <- assoc.
      rewrite functor_comp.
      repeat rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn1Commutes.
    + rewrite assoc.
      set (H:= CoproductIn2Commutes D _ _ (HD (F a) (G a))).
      rewrite H.
      rewrite functor_comp.
      repeat rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes.
*)
Qed.

Definition coproduct_functor : functor C D := tpair _ _ is_functor_coproduct_functor_data.

Definition coproduct_nat_trans_in1_data : ∀ c, F c ⇒ coproduct_functor c
  := λ c : C, CoproductIn1 _ (HD (F c) (G c)).

Lemma is_nat_trans_coproduct_nat_trans_in1_data
  : is_nat_trans _ _ coproduct_nat_trans_in1_data.
Proof.
  unfold is_nat_trans.
  intros c c' f.
  unfold coproduct_nat_trans_in1_data.
  unfold coproduct_functor. simpl.
  unfold coproduct_functor_mor.
  assert (XX:= CoproductOfArrowsIn1).
  assert (X1 := XX _ (F c) (G c) (HD (F c) (G c))).
  assert (X2 := X1 _ _ (HD (F c') (G c'))).
  rewrite X2.
  apply idpath.
Qed.

Definition coproduct_nat_trans_in1 : nat_trans _ _
  := tpair _ _ is_nat_trans_coproduct_nat_trans_in1_data.

Definition coproduct_nat_trans_in2_data : ∀ c, G c ⇒ coproduct_functor c
  := λ c : C, CoproductIn2 _ (HD (F c) (G c)).

Lemma is_nat_trans_coproduct_nat_trans_in2_data
  : is_nat_trans _ _ coproduct_nat_trans_in2_data.
Proof.
  unfold is_nat_trans.
  intros c c' f.
  unfold coproduct_nat_trans_in2_data.
  unfold coproduct_functor. simpl.
  unfold coproduct_functor_mor.
  assert (XX:= CoproductOfArrowsIn2).
  assert (X1 := XX _ (F c) (G c) (HD (F c) (G c))).
  assert (X2 := X1 _ _ (HD (F c') (G c'))).
  rewrite X2.
  apply idpath.
Qed.

Definition coproduct_nat_trans_in2 : nat_trans _ _
  := tpair _ _ is_nat_trans_coproduct_nat_trans_in2_data.

Section vertex.

(** The coproduct morphism of a diagram with vertex [A] *)

Variable A : functor C D.
Variable f : F ⟶ A.
Variable g : G ⟶ A.

Definition coproduct_nat_trans_data : ∀ c, coproduct_functor c ⇒ A c.
Proof.
  intro c.
  apply CoproductArrow.
  - exact (f c).
  - exact (g c).
Defined.

Lemma is_nat_trans_coproduct_nat_trans_data : is_nat_trans _ _ coproduct_nat_trans_data.
Proof.
  intros a b k.
  simpl.
  unfold coproduct_functor_mor.
  unfold coproduct_nat_trans_data.
  simpl.
  set (XX:=precompWithCoproductArrow).
  set (X1 := XX D _ _ (HD (F a) (G a))).
  set (X2 := X1 _ _ (HD (F b) (G b))).
  rewrite X2.
  clear X2 X1 XX.
  set (XX:=postcompWithCoproductArrow).
  set (X1 := XX D _ _ (HD (F a) (G a))).
  rewrite X1.
  rewrite (nat_trans_ax f).
  rewrite (nat_trans_ax g).
  apply idpath.
Qed.

Definition coproduct_nat_trans : nat_trans _ _
  := tpair _ _ is_nat_trans_coproduct_nat_trans_data.

Lemma coproduct_nat_trans_In1Commutes :
  nat_trans_comp _ _ _ coproduct_nat_trans_in1 coproduct_nat_trans = f.
Proof.
  apply nat_trans_eq.
  - apply hsD.
  - intro c; simpl.
    apply CoproductIn1Commutes.
Qed.

Lemma coproduct_nat_trans_In2Commutes :
  nat_trans_comp _ _ _ coproduct_nat_trans_in2 coproduct_nat_trans = g.
Proof.
  apply nat_trans_eq.
  - apply hsD.
  - intro c; simpl.
    apply CoproductIn2Commutes.
Qed.

End vertex.

Lemma coproduct_nat_trans_univ_prop (A : [C, D, hsD])
  (f : (F : [C,D,hsD]) ⇒ A) (g : (G : [C,D,hsD]) ⇒ A) :
   ∀
   t : Σ fg : (coproduct_functor:[C,D,hsD]) ⇒ A,
       (coproduct_nat_trans_in1 : (F:[C,D,hsD]) ⇒ coproduct_functor);; fg = f
      ×
       (coproduct_nat_trans_in2: (G : [C,D,hsD]) ⇒ coproduct_functor);; fg = g,
   t =
   tpair
     (λ fg : (coproduct_functor:[C,D,hsD]) ⇒ A,
      (coproduct_nat_trans_in1 : (F:[C,D,hsD]) ⇒ coproduct_functor);; fg = f
   ×
      (coproduct_nat_trans_in2 : (G:[C,D,hsD]) ⇒ coproduct_functor) ;; fg = g)
     (coproduct_nat_trans A f g)
     (dirprodpair (coproduct_nat_trans_In1Commutes A f g)
        (coproduct_nat_trans_In2Commutes A f g)).
Proof.
  intro t.
  simpl in *.
  destruct t as [t1 [ta tb]].
  simpl in *.
  apply (total2_paths_second_isaprop).
  - apply isapropdirprod;
    apply isaset_nat_trans;
    apply hsD.
  - simpl.
    apply nat_trans_eq.
    + apply hsD.
    + intro c.
      unfold coproduct_nat_trans.
      simpl.
      unfold coproduct_nat_trans_data.
      simpl.
      apply CoproductArrowUnique.
      * apply (nat_trans_eq_pointwise _ _ _ _ _ _ ta).
      * apply (nat_trans_eq_pointwise _ _ _ _ _ _ tb).
Qed.

Definition functor_precat_coproduct_cocone
  : CoproductCocone [C, D, hsD] F G.
Proof.
  exists (tpair _ coproduct_functor (dirprodpair coproduct_nat_trans_in1
                                                 coproduct_nat_trans_in2)).
  intros A f g.
  exists (tpair _ (coproduct_nat_trans A f g)
             (dirprodpair (coproduct_nat_trans_In1Commutes _ _ _ )
                          (coproduct_nat_trans_In2Commutes _ _ _ ))).
  simpl.
  apply coproduct_nat_trans_univ_prop.
Defined.

End coproduct_functor.

Definition Coproducts_functor_precat : Coproducts [C, D, hsD].
Proof.
  intros F G.
  apply functor_precat_coproduct_cocone.
Defined.

End def_functor_pointwise_coprod.


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedPair.

Lemma annotated_reducible_pp:
  forall Θ Γ A B t1 t2,
    wf B 1 ->
    is_annotated_type B ->
    is_annotated_term t1 ->
    subset (fv B) (support Γ) ->
    [[ Θ; Γ ⊨ t1 : A ]] ->
    [[ Θ; Γ ⊨ t2 : open 0 B t1 ]] ->
    [[ Θ; Γ ⊨ pp t1 t2 : T_prod A B ]].
Proof.
  intros; apply open_reducible_pp; repeat step || erase_open; side_conditions.
Qed.

Lemma annotated_reducible_pi1:
  forall Θ Γ t A B,
    [[ Θ; Γ ⊨ t : T_prod A B ]] ->
    [[ Θ; Γ ⊨ pi1 t : A ]].
Proof.
  steps; eauto using open_reducible_pi1.
Qed.

Lemma annotated_reducible_pi2:
  forall Θ Γ t A B,
    wf B 1 ->
    is_annotated_type B ->
    is_annotated_term t ->
    subset (fv B) (support Γ) ->
    [[ Θ; Γ ⊨ t : T_prod A B ]] ->
    [[ Θ; Γ ⊨ pi2 t : open 0 B (pi1 t) ]].
Proof.
  repeat step || erase_open.
  eapply open_reducible_pi2;
    steps;
    side_conditions.
Qed.


From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.

Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.

Import ListNotations.
Import HListNotations.

Set Universe Polymorphism.

Section FOList.

  Variable (T: Type).

  Inductive sorts : Set := | TS | LS.

  Scheme Equality for sorts.
  Set Universe Polymorphism.

  Inductive funs: arity sorts -> sorts -> Type :=
    | nil_f : funs [] LS
    | cons_f : funs [TS; LS] LS.

  Inductive rels: arity sorts -> Type :=.

  Definition sig: signature :=
    {| sig_sorts := sorts;
      sig_funs := funs;
      sig_rels := rels |}.

  Definition fm ctx := FirstOrder.fm sig ctx.
  Definition tm ctx := FirstOrder.tm sig ctx.

  Definition mod_sorts (s: sig_sorts sig) : Type :=
    match s with
    | LS => list T
    | TS => T
    end.

  Obligation Tactic := idtac.
  Equations
    mod_fns params ret (f: sig_funs sig params ret) (args: HList.t mod_sorts params)
    : mod_sorts ret :=
    {
      mod_fns _ _ nil_f _ := nil;
      mod_fns _ _ cons_f (h ::: t ::: _) := cons h t;
    }.

  Definition mod_rels params
    (args: sig_rels sig params)
    (env: HList.t mod_sorts params) : Prop :=
    match args with
    end.

  Program Definition fm_model : model sig := {|
    FirstOrder.mod_sorts := mod_sorts;
    FirstOrder.mod_fns := mod_fns;
    FirstOrder.mod_rels := mod_rels;
  |}.

End FOList.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal57.

From lfind Require Import LFind.
Lemma lfind_state  (u:natural) (v:natural) (w:natural) (x:natural) (y:natural) (z:lst):@eq lst (drop u (drop (Succ v) (drop (Succ w) (Cons x (Cons y z)))))
  (drop (Succ u) (drop v (drop w (Cons x z)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal57_theorem0_36_lem/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (u:natural) (v:natural) (w:natural) (x:natural) (y:natural) (z:lst) :=
 let lfind_var := "u:" ++ "(" ++ show u ++ ")"++ "|" ++"v:" ++ "(" ++ show v ++ ")"++ "|" ++"w:" ++ "(" ++ show w ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print u lfind_var
 in lfind_state lfind_v  v w x y z.
QuickChick collect_data.
Success.


(**

This file describes transformations of the layout of records and arrays on
the memory. It includes some important definitions and results that are
used both in Semantics.v and TrLowLevel.v.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export Typing.

(* ---------------------------------------------------------------------- *)
(** Size of types *)

(** Used to compute the size of a type. Assuming the size of type variables
    are known. Used throughout in the low-level transformation/semantics. *)

Inductive typ_size (CS:ll_typdefctx_typvar_sizes) : typ -> size -> Prop :=
  | typ_size_unit :
      typ_size CS (typ_unit) 1
  | typ_size_int :
      typ_size CS (typ_int) 1
  | typ_size_double :
      typ_size CS (typ_double) 2
  | typ_size_bool :
      typ_size CS (typ_bool) 1
  | typ_size_ptr : forall T',
      typ_size CS (typ_ptr T') 1
  | typ_size_array : forall n T' k,
      k >= 0 ->
      typ_size CS T' n ->
      typ_size CS (typ_array T' (Some k)) (n*k)
  | typ_size_struct : forall Tfs n (m:monoid_op int) (g:field->size->size),
      dom Tfs = dom n ->
      (forall (f:field),
        f \indom Tfs ->
        typ_size CS Tfs[f] n[f]) ->
      m = monoid_make (fun a b => a + b) 0 ->
      g = (fun k v => v) ->
      typ_size CS (typ_struct Tfs) (fold m g n)
  | typ_size_typvar : forall Tv,
      Tv \indom CS ->
      typ_size CS (typ_var Tv) CS[Tv].

(* ---------------------------------------------------------------------- *)
(** Some previous necessary definitions *)

(** Conversion from lists to maps. *)

Axiom list_to_map : forall A B, list A -> list B -> map A B.

Axiom list_to_map_spec : forall (ks:list field) (vs:list offset),
      length ks = length vs
  /\  forall (i:int),
        index ks i ->
            ks[i] \indom (list_to_map ks vs)
        /\  (list_to_map ks vs)[ks[i]] = vs[i].

(** Function used to argue about the offsets. *)

Inductive prefix_sum : list int -> list int -> int -> Prop :=
  | prefix_sum_nil : forall acc,
      prefix_sum nil nil acc
  | prefix_sum_cons : forall l l' acc i,
      prefix_sum l l' (i + acc) ->
      prefix_sum (i::l) (acc::l') acc.

(** prefix_sum l l' <===> |l| = |l'| *)

Lemma prefix_sum_length : forall l l' n,
  prefix_sum l l' n ->
  length l = length l'.
Proof using.
  introv Hps. induction Hps.
  { rewrite~ length_nil. }
  { repeat rewrite length_cons. rewrite~ IHHps. }
Qed.

(** prefix_sum l l' <===> l'[i] = Σ 0<=j<i l[j] *)

Lemma prefix_sum_spec : forall l l' n,
  prefix_sum l l' n ->
  (forall i,
    index l i ->
    l'[i] = fold_left Z.add n (take i l)).
Proof using.
  introv Hps. induction Hps.
  { introv Hi. false. rewrite index_eq_index_length in Hi.
    rewrite length_nil in Hi. inverts Hi. math. }
  { introv Hi. rewrite read_cons_case. case_if.
    { subst. eauto. }
    { lets Hi': Hi.
      rewrite index_eq_index_length in Hi.
      rewrite int_index_eq in Hi.
      destruct Hi as (Hle&Hlt).
      rewrite length_cons in Hlt.
      rewrite take_cons_pos; try solve [ math ].
      rewrite fold_left_cons.
      asserts Hl: (index (length l) (i0 - 1)).
      { rewrite int_index_eq. math. }
      rewrite <- index_eq_index_length in Hl.
      forwards*: IHHps Hl. } }
Qed.

(* ---------------------------------------------------------------------- *)
(** Type-directed transformation to low-level *)

(** Check that the LLC and the C are coherent. *)

Inductive ll_typdefctx_ok (C:typdefctx) (LLC:ll_typdefctx) : Prop :=
  | low_level_ctx_ok_intros : forall CS CFOrd CFOff,
      LLC = make_ll_typdefctx CS CFOff CFOrd ->
      (* Assumptions regarding size. For basic types and arrays. *)
      dom C = dom CS ->
      (forall Tv,
        0 <= CS[Tv]) ->
      (* Same fields in C and LLC. *)
      (forall Tv Tfs,
        Tv \indom C ->
        typing_struct C (typ_var Tv) Tfs ->
            dom Tfs = dom CFOff[Tv]
        /\  dom Tfs = to_set CFOrd[Tv]) ->
      (* Coherency between the sizes. *)
      (forall Tv Tfs,
        Tv \indom C ->
        typing_struct C (typ_var Tv) Tfs ->
        (exists FT FS FO,
            (* Fields types. *)
            FT = List.map (fun f => Tfs[f]) CFOrd[Tv]
            (* Fields sizes. *)
        /\  List.Forall2 (typ_size CS) FT FS
            (* Fields offsets. *)
        /\  prefix_sum FS FO 0
            (* The relationship. *)
        /\  CS[Tv] = fold_right Z.add 0 FS
        /\  CFOff[Tv] = list_to_map CFOrd[Tv] FO)) ->
      ll_typdefctx_ok C LLC.

(** Given a list of accesses, computes the offset. Used to translate
    pointer values. *)

Inductive tr_ll_accesses (C:typdefctx) (LLC:ll_typdefctx) : accesses -> offset -> Prop :=
  | tr_ll_accesses_nil :
      tr_ll_accesses C LLC nil 0%Z
  | tr_ll_accesses_access_array : forall T T' K πs i n o,
      typing_array C T T' (Some K) ->
      typ_size (typvar_sizes LLC) T' n ->
      tr_ll_accesses C LLC πs o ->
      (0 <= i < K)%Z ->
      tr_ll_accesses C LLC ((access_array T i)::πs) ((i * n) + o)
  | tr_ll_accesses_access_field : forall Tfs FO πs Tv f o,
      typing_struct C (typ_var Tv) Tfs ->
      FO = fields_offsets LLC ->
      Tv \indom FO ->
      f \indom FO[Tv] ->
      tr_ll_accesses C LLC πs o ->
      (0 <= FO[Tv][f])%Z ->
      tr_ll_accesses C LLC ((access_field (typ_var Tv) f)::πs) (FO[Tv][f] + o).

(** Relates values with a list of words. This is how the memory is
    transformed. *)

Inductive tr_ll_val (C:typdefctx) (LLC:ll_typdefctx) (α:alpha) : typ -> val -> list word -> Prop :=
  | tr_ll_val_unit :
      tr_ll_val C LLC α typ_unit val_unit (word_int 0%Z::nil)
  | tr_ll_val_bool : forall b,
      tr_ll_val C LLC α typ_bool (val_bool b) (word_int (if b then 1 else 0)%Z::nil)
  | tr_ll_val_int : forall i,
      tr_ll_val C LLC α typ_int (val_int i) (word_int i::nil)
  | tr_ll_val_double : forall d,
      tr_ll_val C LLC α typ_double (val_double d) (word_int d::word_int d::nil)
  | tr_ll_val_abstract_ptr : forall T π l o,
      tr_ll_accesses C LLC π o ->
      tr_ll_val C LLC α (typ_ptr T) (val_abstract_ptr l π) ((word_int (α[l] + o))::nil)
  | tr_ll_val_array : forall k T a a',
      length a = k ->
      length a' = k ->
      (forall i,
        index a i ->
        tr_ll_val C LLC α T a[i] a'[i]) ->
      tr_ll_val C LLC α (typ_array T (Some k)) (val_array T a) (concat a')
  | tr_ll_val_struct : forall FCOrd Tv Tfs sc st s s',
      FCOrd = fields_order LLC ->
      Tv \indom FCOrd ->
      Tv \indom C ->
      typing_struct C (typ_var Tv) Tfs ->
      sc = List.map (fun f => s[f]) FCOrd[Tv] ->
      st = List.map (fun f => Tfs[f]) FCOrd[Tv] ->
      length s' = length FCOrd[Tv] ->
      (forall i,
        index s' i ->
        tr_ll_val C LLC α st[i] sc[i] s'[i]) ->
      tr_ll_val C LLC α (typ_var Tv) (val_struct (typ_var Tv) s) (concat s').

(* ---------------------------------------------------------------------- *)
(** Semantics of the low-level memory accesses *)

(** l[i:i+n] = l' *)

Definition list_slice {A:Type} (l:list A) (i:int) (n:int) (l':list A) : Prop :=
      l' = take n (drop i l)
  /\  0 <= n
  /\  0 <= i
  /\  i + n <= length l.

(** m(l)[o:o+n] = ws *)

Inductive read_ll_state (m:state) (l:loc) (o:offset) (n:size) (ws':words) : Prop :=
  | read_ll_state_intro : forall ws,
      l \indom m ->
      m[l] = val_words ws ->
      list_slice ws o n ws' ->
      read_ll_state m l o n ws'.

(** l[0:i] ++ l' ++ [i+|l'|:|l|-1] = lr *)

Definition list_slice_update {A:Type} (l:list A) (i:int) (l':list A) (lr:list A) : Prop :=
      lr = (take i l) ++ l' ++ (drop (i + length l') l)
  /\  0 <= i
  /\  i + length l' <= length l.

(** m(l)[0:o] ++ ws ++ m(l)[o+|ws|:|m(l)|-1] = m'(l) *)

Inductive write_ll_state (m:state) (l:loc) (o:offset) (ws':words) (m':state) : Prop :=
  | write_ll_state_intro : forall ws ws'',
      l \indom m ->
      m[l] = val_words ws ->
      list_slice_update ws o ws' ws'' ->
      m' = m[l := (val_words ws'')] ->
      write_ll_state m l o ws' m'.

(* ---------------------------------------------------------------------- *)
(** General results about these predicates. *)

Section LowLevelLemmas.

(** The relation typ_size is a function. *)

Lemma functional_typ_size : forall CS T n1 n2,
  typ_size CS T n1 ->
  typ_size CS T n2 ->
  n1 = n2.
Proof using.
  introv Hn1 Hn2. gen n2. induction Hn1; intros;
  try solve [ inverts~ Hn2 ].
  { inverts Hn2 as Hk Hn2. forwards~: IHHn1 Hn2. subst~. }
  { inverts Hn2. subst. asserts: (n = n0).
    { applys~ read_extens.
      { congruence. }
      { introv Hi. rewrite <- H in Hi. applys~ H1. } }
    subst~. }
Qed.

(** If the low-level context is properly defined then the sizes should
    be positive. *)

Lemma ll_typdefctx_sizes_pos : forall C LLC CS,
  ll_typdefctx_ok C LLC ->
  CS = typvar_sizes LLC ->
  (forall Tv,
    Tv \indom C ->
    0 <= CS[Tv]).
Proof using.
  introv Hok Heq. inverts~ Hok. simpls. subst~.
Qed.

(** If the low-level context is properly defined all type variables
    should have a size assigned to it. *)

Lemma ll_typdefctx_typvar_sizes_dom : forall C LLC,
  ll_typdefctx_ok C LLC ->
  dom C = dom (typvar_sizes LLC).
Proof using.
  introv Hok. inverts~ Hok.
Qed.

(** Type sizes are positive. *)

Lemma typ_size_pos : forall C LLC T n,
  ll_typdefctx_ok C LLC ->
  typ_size (typvar_sizes LLC) T n ->
  0 <= n.
Proof using.
  introv Hok Hn. induction Hn; intros; try solve [ math ].
  { asserts: (0 <= k).
    { math. }
    applys~ Z.mul_nonneg_nonneg. }
  { admit. (* TODO: Some result on fold should do it. *) }
  { forwards* HCS: ll_typdefctx_sizes_pos Hok.
    rewrite ll_typdefctx_typvar_sizes_dom at 1; eauto. }
Qed.

(** Offsets are always positive. *)

Lemma accesses_offset_gez : forall C LLC π o,
  ll_typdefctx_ok C LLC ->
  tr_ll_accesses C LLC π o ->
  0 <= o.
Proof using.
  introv Hok Hπ. induction Hπ.
  { math. }
  { inverts H1 as Hi HK.
    forwards* Hn: typ_size_pos.
    apply Zle_lt_or_eq in Hi.
    apply Zle_lt_or_eq in Hn.
    apply Zle_lt_or_eq in IHHπ.
    inverts Hi; inverts Hn; inverts IHHπ;
    try solve [ try forwards*: Z.mul_pos_pos i n; math ]. }
  { apply Zle_lt_or_eq in H3.
    apply Zle_lt_or_eq in IHHπ.
    inverts H3; inverts IHHπ; math. }
Qed.

(** The relation tr_ll_accesses (the low-level translation of accesses
    into offsets) is a function. *)

Lemma functional_tr_ll_accesses : forall C LLC π o1 o2,
  tr_ll_accesses C LLC π o1 ->
  tr_ll_accesses C LLC π o2 ->
  o1 = o2.
Proof using.
  introv Ho1 Ho2. gen o2. induction Ho1; intros.
  { inverts~ Ho2. }
  { inverts Ho2 as HTa HTn Hπs.
    forwards~ (HTeq&Hoseq): functional_typing_array H HTa. subst.
    forwards~: functional_typ_size H0 HTn. subst.
    forwards~: IHHo1 Hπs. subst~. }
  { inverts Ho2 as HTs HTvin Hfin Hπs.
    forwards~: IHHo1 Hπs. subst~. }
Qed.

(** Lemma about length of concatenation. TODO: Move somewhere else. *)

Lemma length_concat_fixed : forall A (l:list (list A)) n,
  (forall i,
    index l i ->
    length l[i] = n) ->
  length (concat l) = n * length l.
Proof using.
  introv Hl. gen A n. induction l; intros.
  { rewrite concat_nil. repeat rewrite~ length_nil. math. }
  { rewrite concat_cons. rewrite length_app.
    rewrite length_cons. forwards Heq: IHl n.
    { introv Hi. forwards~: Hl (i+1).
      { rewrite index_eq_index_length in *.
        rewrite length_cons. rewrite int_index_eq in *. math. }
      rewrite read_cons_case in H. case_if.
      { rewrite index_eq_inbound in Hi. math. }
      { asserts Heq: (i+1-1 = i). { math. }
        rewrite Heq in H. auto. } }
    rewrite Heq. forwards~ Heq': Hl 0.
    { rewrite index_eq_inbound. rewrite length_cons. math. }
    rewrite read_zero in Heq'. rewrite Heq'.
    rewrite Z.mul_add_distr_l. math. }
Qed.

(** Lemma about length of concatenation. TODO: Move somewhere else. *)

Lemma length_concat_variable : forall A (l:list (list A)) (n:list int),
  length l = length n ->
  (forall i,
    index l i ->
    length l[i] = n[i]) ->
  length (concat l) = fold_right Z.add 0 n.
Proof using.
  introv Hl Hn. gen A n. induction l; intros.
  { rewrite concat_nil. rewrite length_nil in *.
    symmetry in Hl. forwards~ Hl': length_zero_inv Hl.
    subst. rewrite~ fold_right_nil. }
  { rewrite concat_cons. rewrite length_app.
    rewrite length_cons in Hl.
    forwards~ (a'&l'&Ha'l'): length_pos_inv_cons n.
    { rewrite <- Hl. math. }
    subst. rewrite length_cons in Hl.
    forwards~ Hlc: IHl l'.
    { math. }
    { introv Hi.
      forwards~ Hlli: Hn (i+1).
      { rewrite index_eq_index_length in *.
        rewrite length_cons.
        rewrite int_index_eq in *. math. }
      { rewrite read_cons_case in Hlli. case_if.
        { rewrite index_eq_inbound in Hi. math. }
        { asserts Heq: (i+1-1 = i). { math. }
          rewrite Heq in Hlli. rewrite Hlli.
          rewrite read_cons_case. case_if.
          rewrite~ Heq. } } }
    rewrite Hlc. forwards~ Hla: Hn 0.
    { rewrite index_eq_inbound.
      rewrite length_cons. math. }
    repeat rewrite read_zero in Hla.
    rewrite Hla. rewrite~ fold_right_cons. }
Qed.

(** Relationship between size of types and the translation of values. *)

Lemma typ_size_length_lw : forall C α v LLC T lw n,
  ll_typdefctx_ok C LLC ->
  tr_ll_val C LLC α T v lw ->
  typ_size (typvar_sizes LLC) T n ->
  length lw = n.
Proof using.
  introv HLLC Htr Hn. gen α v lw. induction Hn; intros;
  try solve [ inverts Htr; rewrite~ length_one ].
  { (* double *)
    inverts Htr. rewrite length_cons. rewrite~ length_one. }
  { (* array *)
    inverts Htr as Hl Htr. rewrite <- Hl.
    applys~ length_concat_fixed. introv Hi'. asserts Hi: (index a i).
    { rewrite index_eq_index_length in *. rewrite~ <- Hl. }
    forwards~ Htrai: Htr Hi. applys* IHHn. }
  { (* struct *)
    inverts Htr as HTvin' HTvin'' HT Hl Htr.
    inverts HLLC as HDC Hpos HDstr Hfields. simpls.
    forwards~ (FT&FS&FO&HFT&HFS&Hps&HCSTv&HCFOffTv): Hfields HTvin'' HT.
    rewrite HCSTv at 1. applys~ length_concat_variable.
    { asserts HlFS: (length FS = length FO).
      { applys* prefix_sum_length. }
      asserts HlFO: (length FO = length CFOrd[Tv]).
      { forwards~ (HR&_): list_to_map_spec CFOrd[Tv] FO. }
      rewrite Hl. rewrite HlFS at 1. rewrite~ <- HlFO. }
    introv Hi. forwards~ Htrs'i: Htr Hi.
    remember CS as CS'.
    remember CFOrd as CFOrd'.
    remember CFOff as CFOff'.
    remember (make_ll_typdefctx CS' CFOff' CFOrd') as LLC'.
    admit. (* TODO: Need to change the approach to prove this. *) }
Qed.

(** If T --π--> T' then |T| >= |T'|. *)

Lemma follow_typ_size : forall C LLC π T T' n n',
  ll_typdefctx_ok C LLC ->
  follow_typ C T π T' ->
  typ_size (typvar_sizes LLC) T n ->
  typ_size (typvar_sizes LLC) T' n' ->
  n' <= n.
Proof using.
  introv Hok Hπ Hn Hn'. gen n n'. induction Hπ; intros.
  { forwards~: functional_typ_size Hn Hn'. subst. math. }
  { inverts Hn; try solve [ inverts H ].
    { asserts Hk: (0%Z < k).
      { admit. (* TODO: More index assumptions needed. *) }
      inverts H.
      forwards* Hn0: IHHπ n0.
      admit. (* TODO: This is maths but can't find the lemma. *) }
    { admit. } }
  { admit. }
Qed.

(** If |T| = n and T --π--> T' and |π| = o then o < n *)

Lemma typ_size_gt_offset : forall T T' C LLC π o n,
  ll_typdefctx_ok C LLC ->
  typ_size (typvar_sizes LLC) T n ->
  follow_typ C T π T' ->
  tr_ll_accesses C LLC π o ->
    π <> nil ->
  o < n.
Proof using.
  introv Hok Hn HF Hπ Hneq. gen n T T'. induction Hπ; intros.
  { false. }
  { inverts HF. subst. induction H.
    { inverts Hn. asserts: (i < k).
      { admit. (* TODO: This should be added in follow_typ. *) }
      forwards*: functional_typ_size T n n1. subst.
      tests: (πs = nil).
      { inverts Hπ.
        admit. (* This is maths. *) }
      { inverts_head typing_array. forwards*: IHHπ n1 T1 T'0.
        admit. (* This is maths. *) } }
    { applys~ IHtyping_array.
      { introv HN. inverts HN. }
      { admit. (* TODO: This should come from ll_typdefctx_ok.
        typ_size (typvar_sizes LLC) C[Tv] (typvar_sizes LLC)[Tv]. *) }
      { inverts_head typing_array. auto. } } }
  { inverts HF.
    forwards* HTfseq: functional_typing_struct C (typ_var Tv) Tfs Tfs0.
    subst. inverts Hn. admit.
    (* TODO: (fields_offsets LLC)[Tv][f] + o <= (typvar_sizes LLC)[Tv]*)  }
Qed.

End LowLevelLemmas.


(** * Episode 02: Hello PeaCoq *)

(** Comments go between _left-paren star_ and _star right-paren_.
<<
(* (* they can even be nested *) *)
>>
*)

(** This _binding_ associates the name [x] to the expression [0]: *)

Definition x := 0.

(** Coq code is primarily a sequence of bindings. In PeaCoq, we can step through the bindings one at a time by pressing:
<<
  Control-Alt-Down
>>
When we ask Coq to process a binding like:
<<
  Definition foo := bar.
>>
it does the following:
- Type check the expression [bar].
  - This ensures that, if asked, Coq will be able to evaluate [bar] down to a value.
- Extend the environment to associate the name [foo] to the expression [bar].
*)

(** Coq also has _commands_ which let us poke around and ask Coq questions. For example, the [Print] command displays the value associated with a name:
*)

Print x.

(** It only works on names though; this will crash:
<<
Print 1.
>>
*)

(** The [Check] command displays the type of an expression: *)

Check x.

(** The [Eval cbv in] command evaluates an expression down to a value: *)

Eval cbv in (1 + 1).

(** Here is a simple _inductive definition_: *)

Inductive boolean :=
| btrue : boolean
| bfalse : boolean.

(** It says that [boolean] is a type and that there are exactly two values that have type [boolean], [btrue] and [bfalse]. *)

(** Coq actually doesn't have any built-in types! However, the standard prelude provides a several familiar types. For example, the type [bool] from the standard prelude is just like our type [boolean]: *)

Print bool.

(** We can also bind names to functions by including arguments to our Definitions: *)

Definition bid (x: bool) := x.

(** This binds a function [bid] to a function which takes a sinlge argument, [x] of type [bool] and when called simply returns [x]. *)

(** We call functions via juxtaposition which is a fancy way of saying we just write the function name and the argument next to it: *)

Eval cbv in (bid true).
Eval cbv in (bid false).

(** In Coq we can also prove that our functions work as expected.  Here is a simple proof showing that bid has the behavior we expect: it always just returns its argument: *)

Lemma bid_ok :
  forall b, bid b = b.
Proof.
  intro.

(** The _tactic_ [intro] above transforms the _proof goal_ from:
<<

  ============================
   forall b : bool, bid b = b
>>
to:
<<
  b : bool
  ============================
   bid b = b
>>

You can think of it as proving a universally quantified claim about booleans by considering an arbitrary boolean.

*)

  unfold bid.

(** The tactic [unfold bid] above transforms the proof goal to:
<<
  b : bool
  ============================
   b = b
>>

This simply replaces the identifier [bid] with whatever it is bound to in the current environment.

*)

  reflexivity.

(** Finally, the [reflexivity] tactic solves this subgoal. Since we don't have any outstanding subgoals, the proof is done and we end with a nice [Qed.] *)

Qed.

(** We can also define functions that do case analysis, or _pattern matching_, on their arguments: *)

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

Eval cbv in (bneg true).
Eval cbv in (bneg false).

(** To define functions of multiple arguments, just add another argument! *)

Definition band (l: bool) (r: bool) : bool :=
  match l with
    | true =>
      match r with
        | true => true
        | false => false
       end
    | false => false
  end.

Eval cbv in (band true true).
Eval cbv in (band true false).
Eval cbv in (band false true).
Eval cbv in (band false false).

(** We can also lump arguments of the same type together. *)

Definition bor (l r: bool) : bool :=
  match l with
    | true => true
    | false =>
      match r with
        | true => true
        | false => false
       end
  end.

Eval cbv in (bor true true).
Eval cbv in (bor true false).
Eval cbv in (bor false true).
Eval cbv in (bor false false).

(** What types do our functions have? *)

Check bid.
(** <<
bid
     : bool -> bool
>> *)

Check bneg.
(** <<
bid
     : bool -> bool
>> *)

Check band.
(** <<
band
     : bool -> bool -> bool
>> *)

Check bor.
(** <<
bor
     : bool -> bool -> bool
>> *)

(** A function with type [A -> B] takes an argument of type [A] and returns a result of type [B].  The arrow [->] associates to the right, so [A -> B -> C] means the same as [A -> (B -> C)].  Here we see _currying_ where we can encode functions of _multiple_ arguments as functions of _single_ arguments which take an argument and return a _function_ that takes the next argument and return a _function_ that takes the next argument and return ... until all the arguments have been taken and then the function can simply return the result. *)

Lemma demorgan_band:
  forall l r,
  band l r = bneg (bor (bneg l) (bneg r)).
Proof.
  intros.

  (** [intros] works like [intro], but it slurps up all the universally quantified variables at the front of a goal. *)

  intros.

  (** [destruct] does case analysis. *)
  destruct l.

  (** In the case that [l = true], we want to also do case analysis on [r]: *)
  destruct r.

  (** We can solve both the subcases with [reflexivity]. *)
  reflexivity.
  reflexivity.

  (** In the case that [l = false], [reflexivity] does the trick. *)
  { reflexivity. }
Qed.

(** Another of DeMorgan's laws can be proved similarly: *)

Lemma demorgan_bor:
  forall l r,
  bor l r = bneg (band (bneg l) (bneg r)).
Proof.
  intros. destruct l.
  { reflexivity. }
  { destruct r.
    { reflexivity. }
    { reflexivity. }
  }
Qed.

(** The curly baces ``{'' and ``}'' help us note which subgoals we're in and make the structure of the proof a little bit clearer.  While they're technically optional, PeaCoq will always generate them to help make the resulting proof term easier to understand. *)

(** _Side Note_ : We can write our functions to just bind a name to an expression and use [fun] to build an _anonymous function_: *)

Definition bneg' : bool -> bool :=
  fun (b: bool) =>
    match b with
      | true => false
      | false => true
    end.

(** Also we can often omit certain type annotations, and Coq will figure them out automatically! *)

Definition bneg'' :=
  fun (b: bool) =>
    match b with
      | true => false
      | false => true
    end.

Check bneg''.

Definition bneg''' : bool -> bool :=
  fun b =>
    match b with
      | true => false
      | false => true
    end.

Check bneg'''.

(** The same goes for functions with multiple arguments: *)

Definition band' : bool -> bool -> bool :=
  fun (l: bool) =>
    fun (r: bool) =>
      match l with
        | true =>
          match r with
            | true => true
            | false => false
          end
        | false => false
      end.

Lemma band_equiv_band':
  forall b, band b = band' b.
Proof.
  reflexivity.
Qed.

(** OK, enough booleans. Let's look at numbers. *)

Definition nid (x: nat) := x.

Eval cbv in (nid 0).
Eval cbv in (nid 1).
Eval cbv in (nid 2).

Check (nid 2).

Lemma nid_ok :
  forall n, nid n = n.
Proof.
  reflexivity.
Qed.

(** [nat] is defined a bit differently from [bool]: *)

Print nat.
(** <<
Inductive nat : Set :=
  | O : nat
  | S : nat -> nat.
>> *)

(** The [S] _constructor_ takes a [nat] as an argument.  This allows [nat] to contain infinitely many terms: [O] represents 0 and [S n] represents [1 + n]. *)

Eval cbv in O.
Eval cbv in (S O).
Eval cbv in (S (S O)).
Eval cbv in (S (S (S O))).
Eval cbv in (S (S (S (S O)))).

(** This also means that if we want to write functions over [nat], we need _recursive_ definitions, which we introduce with [Fixpoint]: *)

Fixpoint nadd (n1 n2: nat) : nat :=
  match n1 with
    | O => n2
    | S n => S (nadd n n2)
  end.

Fixpoint nmult (n1 n2: nat) : nat :=
  match n1 with
    | O => O
    | 1 => n2
    | S n => nadd n2 (nmult n n2)
  end.

Fixpoint factorial n :=
  match n with
  | O => 1
  | S m => n * factorial m
  end.

(** We can prove things about functions over [nat] similar to our proofs about functions over [bool]: *)

Lemma nadd_0_n:
  forall n, nadd 0 n = n.
Proof.
  reflexivity.
Qed.

(** However, some of these proof will also require [induction], which we'll talk about extensively during the course: *)

Lemma nadd_n_0:
  forall n, nadd n 0 = n.
Proof.
  intro. induction n.
  { reflexivity. }
  { simpl. rewrite -> IHn. reflexivity. }
Qed.

(** _Question_ : Why did we need [induction] for [nadd_n_0] but not for [nadd_0_n] ? *)

(** Consider these types for representing pairs of nats and booleans and also booleans and nats respectively: *)

Inductive nat_and_bool :=
| nnb : nat -> bool -> nat_and_bool.

Inductive bool_and_nat :=
| bnn : bool -> nat -> bool_and_nat.

(** We can write functions that swap these around: *)

Definition swap_nat_and_bool (x : nat_and_bool) : bool_and_nat :=
  match x with
    | nnb n b => bnn b n
  end.

Definition swap_bool_and_nat x :=
  match x with
    | bnn b n => nnb n b
  end.

(** We can also prove that these swaps work as we expect: *)

Lemma swap_swap:
  forall x, swap_nat_and_bool (swap_bool_and_nat x) = x.
Proof.
  intro. destruct x0. reflexivity.
Qed.

(** These definitions are overly specific though, we should define some sort of generic pair type. Unfortunately, our technique for writing parameterized definitions doesn't really cut it here:
<<
Definition pair x y :=
   ... (* what do we put here ?! *)
>>
*)

(** Instead we can use the type [prod]: *)

Print prod.
(** <<
Inductive prod A B :=
  |  pair : A -> B -> A * B
>> *)

(** This is an example of a _parameterized type_.  With it we can write a generic [swap] function: *)

Definition swap (A B: Type) (p: A * B) : B * A :=
  match p with
    | pair a b => pair b a
  end.

(** Note that we don't have to include all the type arguments.  This is due to Coq's inference mechanisms, which we will disucuss in more detail later. *)

(** We can also prove our generic swap correct: *)

Lemma swap_ok:
  forall A B (p: A * B),
  swap B A (swap A B p) = p.
Proof.
  intros. destruct p. reflexivity.
Qed.

(** One parameterized type named [option] is super useful for encoding partial functions: *)

Print option.
(** <<
Inductive option (A : Type) : Type :=
  | Some : A -> option A
  | None : option A.
>> *)

Definition pred (n: nat) : option nat :=
  match n with
    | O => None
    | S m => Some m
  end.

(** Next time we'll talk more about inductive types and how they can be used to encode syntax.  However, you should check out the list type and think about it until then: *)

Print list.
(** <<
Inductive list (A : Type) : Type :=
  | nil : list A
  | cons : A -> list A -> list A.
>> *)

Eval cbv in (cons 1 (cons 2 (cons 3 nil))).


From Coq Require Import Init.Nat.
From Coq  Require Import Program.Equality.

Set Implicit Arguments.
Set Maximal Implicit Insertion.

Module Stlc.

  (** Use the same reified type for the whole development *)
  Inductive type : Type :=
  | TBool: type
  | TNum: type
  | TArrow : type -> type -> type.

  Declare Custom Entry stlc_ty.
  Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
  Notation "( x )" := x (in custom stlc_ty, x at level 99).
  Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
  Notation "S -> T" := (TArrow S T) (in custom stlc_ty at level 2, right associativity).
  Notation "'Num'" := TNum (in custom stlc_ty at level 0).
  Notation "'Bool'" := TBool (in custom stlc_ty at level 0).

  (** This is STLC PHOAS syntax [Term] without control flow,
      it includes normalization by evaluation using reify/reflect as seen in Oliver Danvy et al.
      As reification of Coq terms [if _ then _ else _] is impossible without
      meta-programming, we develop a meta-language [IM] that reifies control-flow, then
      commute with reify/reflect on STLC with our meta-language.

      We get the following commutative square for *reflect*

                                  ireflect
      IM (Term typeDenote) t ----------------> IM typeDenote t
             |                                       |
             |                                       |
             |                                       |
             v                    reflect            v
          Term typeDenote t  -----------------> typeDenote t

      And the following for *reify*

                        reify
      typeDenote t  -------------> Term typeDenote t
             |                             |
             | RET                         | RET
             |                             |
             v            ireify           v
      IM typeDenote t  ----------------> IM (Term typeDenote) t
   *)
  Section vars.
    (** This is how to get reflected Coq terms *)
    Variable var : type -> Type.

    Inductive Term: type -> Type :=
    (* Constants *)
    | NUM: nat -> Term <{{ Num }}>
    | BOOL: bool -> Term <{{ Bool }}>
    (* Finite field arithmetic *)
    | ADD: Term <{{ Num }}> -> Term <{{ Num }}> -> Term <{{ Num }}>
    | SUB: Term <{{ Num }}> -> Term <{{ Num }}> -> Term <{{ Num }}>
    | MUL: Term <{{ Num }}> -> Term <{{ Num }}> -> Term <{{ Num }}>
    | DIV: Term <{{ Num }}> -> Term <{{ Num }}> -> Term <{{ Num }}>
    (* Logical formulas *)
    | EQ: Term <{{ Num }}> -> Term <{{ Num }}> -> Term <{{ Bool }}>
    | AND: Term <{{ Bool }}> -> Term <{{ Bool }}> -> Term <{{ Bool }}>
    | OR: Term <{{ Bool }}> -> Term <{{ Bool }}> -> Term <{{ Bool }}>
    | NOT: Term <{{ Bool }}> -> Term <{{ Bool }}>
    (* Lambda *)
    | APP: forall a b, Term <{{ a -> b }}> -> Term a -> Term b
    | VAR: forall a, var a -> Term a
    | LAM: forall a b, (var a -> Term b) -> Term <{{ a ->  b }}>.

    Fixpoint typeDenote (t : type) : Set :=
      match t with
      | <{{ Bool }}> => bool
      | <{{ Num }}> => nat
      | <{{ t1 -> t2 }}> => typeDenote t1 -> typeDenote t2
      end.

    (* Normalization via reify/reflect Danvy et al. *)
    Class Nbe (t: type) := {
      reify: typeDenote t -> Term t;
      reflect: Term t -> typeDenote t
                          }.

    Instance Nbe_lam {a b: type} `{Nbe a} `{Nbe b}: Nbe <{{ a -> b }}> := {
      reify v := LAM (fun x => reify (v (reflect (VAR x))));
      reflect e :=  fun x => reflect (APP e (reify x))
                                                                        }.
  End vars.

  (** This is the metalanguage with if-then-else. I am defining another
      [T: type -> Type] because I want to be able to reflect terms in stages,
      first in Terms and then in IM.

      This allows us to have both Terms and IM Terms reified,
      using [IM (Term typeDenote) t] and object terms reflected while
      meta-terms remain reified using [IM typeDenote t]. This is a handy
      trick for staged compilation of meta-languages! *)
  Section mvars.

    Variable T: type -> Type.
    Inductive IM: type -> Type :=
    | ITE: forall t, Term typeDenote <{{ Bool }}> ->
                IM t ->
                IM t ->
                IM t
    | RET: forall t, T t -> IM t.
  End mvars.

  Arguments VAR [var a].
  Arguments NUM {var}.
  Arguments BOOL {var}.
  Arguments ADD {var}.
  Arguments SUB {var}.
  Arguments MUL {var}.
  Arguments DIV {var}.
  Arguments EQ {var}.
  Arguments AND {var}.
  Arguments OR {var}.
  Arguments APP [var a b].
  Arguments LAM [var a b].
  (** Maximally insert types in class *)
  Arguments Nbe {var}.
  Arguments Nbe_lam {var} {a} {b}.
  Arguments reify {var} {t}.
  Arguments reflect {var} {t}.
  (** Meta terms *)
  Arguments ITE {T t}.
  Arguments RET {T t}.

  Declare Custom Entry stlc.
  Notation "'fp' n" := (NUM n) (in custom stlc at level 0).
  Notation "'true'"  := true (at level 1).
  Notation "'true'" := (BOOL true) (in custom stlc at level 0).
  Notation "'false'"  := false (at level 1).
  Notation "'false'" := (BOOL false) (in custom stlc at level 0).
  Notation "<{ e }>" := e (e custom stlc at level 99).
  Notation "( x )" := x (in custom stlc, x at level 99).
  Notation "x" := x (in custom stlc at level 0, x constr at level 0).
  Notation "x y" := (APP x y) (in custom stlc at level 1, left associativity).
  Notation "\ x , y" :=
    (LAM (fun x => y)) (in custom stlc at level 90,
                        x constr,
                        y custom stlc at level 80,
                        left associativity).
  Notation "\_ , y" :=
    (LAM (fun _ => y)) (in custom stlc at level 90,
                        y custom stlc at level 80,
                        left associativity).
  Notation "# n" := (VAR n) (in custom stlc at level 0).
  Notation "{ x }" := x (in custom stlc at level 1, x constr).
  Notation "x + y" := (ADD x y) (in custom stlc at level 2,
                                            left associativity).
  Notation "x - y" := (SUB x y) (in custom stlc at level 2,
                                            left associativity).
  Notation "x * y" := (MUL x y) (in custom stlc at level 1,
                                            left associativity).
  Notation "x && y" := (AND x y) (in custom stlc at level 4,
                                             left associativity).
  Notation "x || y" := (OR x y) (in custom stlc at level 4,
                                             left associativity).
  Notation "x == y" := (EQ x y) (in custom stlc at level 3,
                                      left associativity).
  Notation "! x " := (NOT x) (in custom stlc at level 3).
  Notation "'if' x 'then' y 'else' z" :=
    (ITE x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).

  Fixpoint termDenote t (e : Term typeDenote t) {struct e} : typeDenote t :=
    match e in (Term _ t) return (typeDenote t) with
    | VAR v => v
    | NUM f => f
    | BOOL v => v
    | ADD f1 f2 => (termDenote f1) + (termDenote f2)
3    | SUB f1 f2 => (termDenote f1) - (termDenote f2)
    | MUL f1 f2 => (termDenote f1) * (termDenote f2)
    | DIV f1 f2 => (termDenote f1) / (termDenote f2)
    | EQ f1 f2 => eqb (termDenote f1) (termDenote f2)
    | AND b1 b2 => andb (termDenote b1) (termDenote b2)
    | OR b1 b2 => orb (termDenote b1) (termDenote b2)
    | NOT b => negb (termDenote b)
    | APP e1 e2 => (termDenote e1) (termDenote e2)
    | LAM e' => fun x => termDenote (e' x)
    end.

  Inductive norm t: Term (IM typeDenote) t -> Term (IM typeDenote) t -> Prop :=
  |
  Fixpoint mtermDenote t (e: IM (Term typeDenote) t) : typeDenote t :=
    match e with
    | ITE c e1 e2 => if (termDenote c) then (mtermDenote e1) else mtermDenote e2
    | RET e => termDenote e
    end.

  Instance Nbe_int : Nbe <{{ Num }}> := {
    reify v := NUM v;
    reflect v := termDenote v;
                                }.

  Instance Nbe_bool : Nbe <{{ Bool }}> := {
    reify v := BOOL v;
    reflect v := termDenote v;
                                  }.

  Fixpoint resolver(t: type): Nbe t :=
    match t with
    | <{{ Bool }}> => Nbe_bool
    | <{{ Num }}> => Nbe_int
    | <{{ a -> b }}> => Nbe_lam (resolver a) (resolver b)
    end.

  Fixpoint mreflect t (e: IM (Term typeDenote) t): IM typeDenote t :=
    match e with
    | ITE c e1 e2 =>
      ITE (BOOL (reflect (resolver <{{ Bool }}>) c))
          (mreflect e1) (mreflect e2)
    | RET e => RET (reflect (resolver _) e)
    end.

  (** Conversely, this function is dumb and uninteresting. Since we cannot
      reify if-then-else statements from Gallina to IM *)
  Definition mreify{t: type} (e: typeDenote t): IM (Term typeDenote) t :=
    RET (reify (resolver t) e).

  Definition normalize {t: type} (e: Term typeDenote t) : Term typeDenote t :=
    reify (resolver t) (reflect (resolver t) e).

  Inductive fof: type -> Prop :=
  | fo_bool: fof <{{ Bool }}>
  | fo_num: fof <{{ Num }}>
  | fof_bool: forall a,
      fof <{{ a }}> ->
      fof <{{ Bool -> a }}>
  | fof_num: forall a,
      fof <{{ a }}> ->
      fof <{{ Num -> a }}>.

  Set Implicit Arguments.
  Inductive value: forall {t: type}, Term typeDenote t -> Prop :=
  | Value_bool: forall x, @value <{{ Bool }}> (@VAR typeDenote <{{ Bool }}> x)
  | Value_btrue: @value <{{ Bool }}> <{ true }>
  | Value_bfalse: @value <{{ Bool }}> <{ false }>
  | Value_const: forall (x: nat), value (NUM x).

  Inductive hnff: forall (t: type), Term typeDenote t -> Prop :=
  | HNF_bool_ar: forall a f,
      (forall (arg: typeDenote <{{ Bool }}>), @hnff <{{ a }}> (f arg)) ->
      @hnff <{{ Bool -> a }}> (LAM f)
  | HNF_num_ar: forall a f,
      (forall (arg: typeDenote <{{ Num }}>), @hnff <{{ a }}> (f arg)) ->
      @hnff <{{ Num -> a }}> (LAM f)
  | HNF_bool: forall e,
      value e ->
      @hnff <{{ Bool }}> e
  | HNF_num: forall e,
      value e ->
      @hnff <{{ Num }}> e.

  (** Provide default witnesses for hnff *)
  (* Hint Extern 3 (typeDenote <{{ Bool }}>) => exact (true).
  Hint Extern 3 (typeDenote <{{ Num }}>) => exact (0:%p).
  *)
  Theorem normalize_correct: forall (t: type) (e: Term typeDenote t),
      fof t  ->
      @hnff t (@normalize t e).
  Proof with eauto.
    intros.
    generalize dependent e.
    generalize dependent H.
    induction t; intros; dependent destruction e; cbn; try constructor;
      invert H; cbn; try constructor...
    - destruct b; constructor.
    - destruct (eq_field (termDenote e1) (termDenote e2)); constructor.
    - destruct (termDenote e1); destruct (termDenote e2); constructor.
    - destruct (termDenote e1); destruct (termDenote e2); constructor.
    - destruct (termDenote e); constructor.
    - destruct (termDenote e1); destruct (termDenote e2); destruct (termDenote e3); constructor.
    - destruct ((termDenote e1 (termDenote e2))); constructor.
    - destruct t; constructor.
  Defined.

  Definition t: Term typeDenote <{{ Bool -> Bool }}> :=
    <{ \x, (if # x then \y, # y else \z, ! # z) # x }>.

  Eval cbv in normalize t.

  Eval cbv in reflect (resolver _) (reify (resolver <{{ Bool -> Bool }}>) f).
  Eval cbv in reflect (resolver _) (normalize t) true.

  Example notnormal: @hnff <{{ Bool -> Bool }}> (normalize t).
  Proof.
    constructor.
    intros.
    constructor.
    unfold t; simpl.
    destruct arg.
    - constructor.
    - constructor.
  Qed.

End Stlc.


From Hammer Require Import Hammer.

Require Import BinInt Ring_theory.
Local Open Scope Z_scope.

Notation Zpower_pos := Z.pow_pos (compat "8.3").
Notation Zpower := Z.pow (compat "8.3").
Notation Zpower_0_r := Z.pow_0_r (compat "8.3").
Notation Zpower_succ_r := Z.pow_succ_r (compat "8.3").
Notation Zpower_neg_r := Z.pow_neg_r (compat "8.3").
Notation Zpower_Ppow := Pos2Z.inj_pow (compat "8.3").

Lemma Zpower_theory : power_theory 1 Z.mul (@eq Z) Z.of_N Z.pow.
Proof. hammer_hook "Zpow_def" "Zpow_def.Zpower_theory".
constructor. intros.
destruct n;simpl;trivial.
unfold Z.pow_pos.
rewrite <- (Z.mul_1_r (pow_pos _ _ _)). generalize 1.
induction p; simpl; intros; rewrite ?IHp, ?Z.mul_assoc; trivial.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section original_spp_inverse_projection_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma original_spp__inverse_projection_postulate :
  alternative_strong_parallel_postulate -> inverse_projection_postulate.
Proof.
  intros ospp A B C P Q Hacute Hout HPQ HPer HCop.
  assert_diffs.
  assert_cols.
  elim(col_dec A B C).
  { intro.
    exists P.
    split; Col.
    apply (l6_7 _ _ A); auto.
    apply not_bet_out; Col.
    intro.
    destruct Hacute as [x [y [z [HPer2 Hlta]]]].
    assert_diffs.
    assert(HN := not_and_lta A B C x y z).
    apply HN.
    split; auto.
    split.
    apply l11_31_2; Between.
    intro; destruct Hlta; CongA.
  }
  intro HNCol1.
  assert(HNCol2 : ~ Col B P Q) by (apply per_not_col; auto).
  assert(HQ0 := cop_not_par_same_side A B Q P P C).
  destruct HQ0 as [Q0 []]; Col; Cop.
    intro; apply HNCol2; ColR.
  assert(HNCol3 : ~ Col A B Q0) by (apply (one_side_not_col123 _ _ _ C); Side).
  assert(P<>Q0) by (intro; subst; Col).
  assert (HSuma := ex_suma C B P B P Q0).
  destruct HSuma as [D [E [F]]]; auto.

  assert(HY := ospp C B P Q0 D E F).
  destruct HY as [Y []]; auto.
    apply (col_one_side _ A); Side.
  { intro.
    assert(Hlta : LtA A B C C B P).
    { apply acute_per__lta; auto.
      apply (bet_per_suma__per123 _ _ _ B P Q0 D E F); auto.
      apply l8_2.
      apply (l8_3 Q); Perp; Col.
    }
    destruct Hlta as [Hlea HNConga].
    apply HNConga.
    apply conga_right_comm.
    apply l6_6 in Hout.
    apply out2__conga; try (apply out_trivial); auto.
  }

  exists Y.
  split; [|ColR].
  assert(HB0 := l10_15 A B B C).
  destruct HB0 as [B0 []]; Col.
  assert(HNCol4 : ~ Col A B B0) by (apply (one_side_not_col123 _ _ _ C); Side).
  assert(HNCol5 : ~ Col B C P) by (intro; apply HNCol1; ColR).
  assert_diffs.
  assert(P<>Y) by (intro; subst; auto).
  apply (col_one_side_out _ B0); auto.
  apply (one_side_transitivity _ _ _ P).
  apply (one_side_transitivity _ _ _ A).
  - apply invert_one_side.
    apply in_angle_one_side; Col.
    { intro.
      assert(HInter := l8_16_1 B0 B A C B).
      destruct HInter; Col; Perp.
      assert(Habs : LtA A B C A B C) by (apply acute_per__lta; auto).
      destruct Habs; CongA.
    }
    apply l11_24.
    apply lea_in_angle; Side.
    apply lta__lea.
    apply acute_per__lta; auto.
    apply perp_per_1; Perp.

  - apply out_one_side; Col.

  - apply l12_6.
    assert(HPar : Par B B0 P Y).
    { apply (l12_9 _ _ _ _ A B); Perp; Cop.
      apply coplanar_trans_1 with C; Col; Cop.
      apply perp_right_comm.
      apply (perp_col1 _ _ _ P); Col.
      apply perp_sym.
      apply (perp_col1 _ _ _ Q); Perp; ColR.
    }
    destruct HPar; auto.
    exfalso.
    spliter.
    apply HNCol2; ColR.
Qed.

End original_spp_inverse_projection_postulate.


Require Import CoreData.CoreData.
Require Import CoreAutomation.

Lemma cup_Z : ⊃ ∝ Z 2 0 0.
Proof.
  prop_exists_nonzero 1.
  Msimpl; simpl.
  solve_matrix.
  autorewrite with Cexp_db; easy.
Qed.

Lemma cap_Z : ⊂ ∝ Z 0 2 0.
Proof.
  prop_exists_nonzero 1.
  Msimpl; simpl.
  solve_matrix.
  autorewrite with Cexp_db; easy.
Qed.

Lemma cup_X : ⊃ ∝ X 2 0 0.
Proof. colorswap_of cup_Z. Qed.

Lemma cap_X : ⊂ ∝ X 0 2 0.
Proof. colorswap_of cap_Z. Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e384m79x2e376m1_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import CoqChess.Game.Player.
Require Import CoqChess.Game.Game.

CoInductive strategy {G : Game} (p : Player) : GameState G -> Type :=
  | atom_strategy : forall b res,
      atomic_res b = Some res -> strategy p b
  | eloise_strategy : forall b,
      to_play b = p -> forall m,
      strategy p (exec_move b m) -> strategy p b
  | abelard_strategy : forall b,
      to_play b = opp p ->
      (forall m, strategy p (exec_move b m)) ->
      strategy p b.

Arguments atom_strategy {_} {_} {_} {_} _.
Arguments eloise_strategy {_} {_} {_} _ _.
Arguments abelard_strategy {_} {_} {_} _ _.

Definition strat_id {G} {p} {s : GameState G} (str : strategy p s) : strategy p s :=
  match str with
  | atom_strategy res_pf => atom_strategy res_pf
  | eloise_strategy play_pf m str => eloise_strategy play_pf m str
  | abelard_strategy play_pf strs => abelard_strategy play_pf strs
  end.

Lemma strat_id_eq {G : Game} {p} {s : GameState G} (str : strategy p s) :
  str = strat_id str.
Proof.
  destruct str; reflexivity.
Qed.

Inductive winning_strategy {G : Game} (p : Player) : forall {s : GameState G},
  strategy p s -> Prop :=
  | atom_strat_win : forall s (res_pf : atomic_res s = Some (Win p)),
      winning_strategy p (atom_strategy res_pf)
  | eloise_strat_win : forall s (play_pf : to_play s = p) (m : Move s)
      (str : strategy p (exec_move s m)), winning_strategy p str ->
      winning_strategy p (eloise_strategy play_pf m str)
  | abelard_strat_win : forall s (play_pf : to_play s = opp p)
      (strs : forall m, strategy p (exec_move s m)),
      (forall m, winning_strategy p (strs m)) ->
      winning_strategy p (abelard_strategy play_pf strs).

CoInductive drawing_strategy {G : Game} (p : Player) : forall {s : GameState G},
  strategy p s -> Prop :=
  | atom_strat_draw : forall s (res_pf : atomic_res s = Some Draw),
      drawing_strategy p (atom_strategy res_pf)
  | eloise_strat_draw : forall s (play_pf : to_play s = p) (m : Move s)
      (str : strategy p (exec_move s m)), drawing_strategy p str ->
      drawing_strategy p (eloise_strategy play_pf m str)
  | abelard_strat_draw : forall s (play_pf : to_play s = opp p)
      (strs : forall m, strategy p (exec_move s m)),
      (forall m, drawing_strategy p (strs m) \/ winning_strategy p (strs m)) ->
      drawing_strategy p (abelard_strategy play_pf strs).


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__NCdistinct.
Require Export lemma__collinearorder.
Require Export lemma__collinearparallel.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelsymmetric.
Require Export logic.
Require Export proposition__28B.
Definition proposition__28C : forall B D G H, (euclidean__defs.RT B G H G H D) -> ((euclidean__defs.OS B D G H) -> (euclidean__defs.Par G B H D)).
Proof.
intro B.
intro D.
intro G.
intro H.
intro H0.
intro H1.
assert (* Cut *) (euclidean__axioms.nCol G H B) as H2.
- assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as H2 by exact H1.
assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as __TmpHyp by exact H2.
destruct __TmpHyp as [x H3].
destruct H3 as [x0 H4].
destruct H4 as [x1 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H14.
- assert (* Cut *) (euclidean__axioms.nCol G H D) as H3.
-- assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as H3 by exact H1.
assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as __TmpHyp by exact H3.
destruct __TmpHyp as [x H4].
destruct H4 as [x0 H5].
destruct H5 as [x1 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H16.
-- assert (* Cut *) (euclidean__axioms.neq H D) as H4.
--- assert (* Cut *) ((euclidean__axioms.neq G H) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.neq G D) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq D H) /\ (euclidean__axioms.neq D G)))))) as H4.
---- apply (@lemma__NCdistinct.lemma__NCdistinct G H D H3).
---- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H7.
--- assert (* Cut *) (euclidean__axioms.neq D H) as H5.
---- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric H D H4).
---- assert (* Cut *) (euclidean__axioms.neq G B) as H6.
----- assert (* Cut *) ((euclidean__axioms.neq G H) /\ ((euclidean__axioms.neq H B) /\ ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq B H) /\ (euclidean__axioms.neq B G)))))) as H6.
------ apply (@lemma__NCdistinct.lemma__NCdistinct G H B H2).
------ destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H11.
----- assert (* Cut *) (euclidean__axioms.neq B G) as H7.
------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric G B H6).
------ assert (* Cut *) (exists A, (euclidean__axioms.BetS B G A) /\ (euclidean__axioms.Cong G A G B)) as H8.
------- apply (@lemma__extension.lemma__extension B G G B H7 H6).
------- destruct H8 as [A H9].
destruct H9 as [H10 H11].
assert (* Cut *) (euclidean__axioms.BetS A G B) as H12.
-------- apply (@euclidean__axioms.axiom__betweennesssymmetry B G A H10).
-------- assert (* Cut *) (exists C, (euclidean__axioms.BetS D H C) /\ (euclidean__axioms.Cong H C H D)) as H13.
--------- apply (@lemma__extension.lemma__extension D H H D H5 H4).
--------- destruct H13 as [C H14].
destruct H14 as [H15 H16].
assert (* Cut *) (euclidean__axioms.BetS C H D) as H17.
---------- apply (@euclidean__axioms.axiom__betweennesssymmetry D H C H15).
---------- assert (* Cut *) (euclidean__defs.Par A B C D) as H18.
----------- apply (@proposition__28B.proposition__28B A B C D G H H12 H17 H0 H1).
----------- assert (* Cut *) (euclidean__axioms.Col D H C) as H19.
------------ right.
right.
right.
right.
left.
exact H15.
------------ assert (* Cut *) (euclidean__axioms.Col C D H) as H20.
------------- assert (* Cut *) ((euclidean__axioms.Col H D C) /\ ((euclidean__axioms.Col H C D) /\ ((euclidean__axioms.Col C D H) /\ ((euclidean__axioms.Col D C H) /\ (euclidean__axioms.Col C H D))))) as H20.
-------------- apply (@lemma__collinearorder.lemma__collinearorder D H C H19).
-------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H25.
------------- assert (* Cut *) (euclidean__axioms.neq H D) as H21.
-------------- assert (* Cut *) ((euclidean__axioms.neq G H) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.neq G D) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq D H) /\ (euclidean__axioms.neq D G)))))) as H21.
--------------- apply (@lemma__NCdistinct.lemma__NCdistinct G H D H3).
--------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
exact H4.
-------------- assert (* Cut *) (euclidean__defs.Par A B H D) as H22.
--------------- apply (@lemma__collinearparallel.lemma__collinearparallel A B H C D H18 H20 H21).
--------------- assert (* Cut *) (euclidean__defs.Par H D A B) as H23.
---------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B H D H22).
---------------- assert (* Cut *) (euclidean__axioms.Col B G A) as H24.
----------------- right.
right.
right.
right.
left.
exact H10.
----------------- assert (* Cut *) (euclidean__axioms.Col A B G) as H25.
------------------ assert (* Cut *) ((euclidean__axioms.Col G B A) /\ ((euclidean__axioms.Col G A B) /\ ((euclidean__axioms.Col A B G) /\ ((euclidean__axioms.Col B A G) /\ (euclidean__axioms.Col A G B))))) as H25.
------------------- apply (@lemma__collinearorder.lemma__collinearorder B G A H24).
------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H30.
------------------ assert (* Cut *) (euclidean__defs.Par H D G B) as H26.
------------------- apply (@lemma__collinearparallel.lemma__collinearparallel H D G A B H23 H25 H6).
------------------- assert (* Cut *) (euclidean__defs.Par G B H D) as H27.
-------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric H D G B H26).
-------------------- exact H27.
Qed.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.

Module Definitions
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module SF := SysF(VarTyp)(set).
Export SF.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

 *)

(* Our calculus: *)

Inductive PTyp : Type :=
  | PInt : PTyp
  | Fun : PTyp -> PTyp -> PTyp
  | And : PTyp -> PTyp -> PTyp
  | PBVarT : nat -> PTyp
  | PFVarT : var -> PTyp
  | ForAll : PTyp -> PTyp -> PTyp (* disjoint constraint *)
  | Bot : PTyp.

Fixpoint ptyp2styp (t : PTyp) : STyp :=
  match t with
    | PInt => STInt
    | Fun t1 t2 => STFun (ptyp2styp t1) (ptyp2styp t2)
    | And t1 t2 => STTuple (ptyp2styp t1) (ptyp2styp t2)
    | PBVarT n => STBVarT n
    | PFVarT v => STFVarT v
    | ForAll _ t => STForAll (ptyp2styp t)
    | Bot => STForAll (STBVarT 0)
  end.

Notation "'|' t '|'" := (ptyp2styp t) (at level 60).

Fixpoint open_rec_typ_source (k : nat) (u : PTyp) (t : PTyp) {struct t} : PTyp :=
  match t with
  | PInt        => PInt
  | Fun t1 t2   => Fun (open_rec_typ_source k u t1) (open_rec_typ_source k u t2)
  | And t1 t2   => And (open_rec_typ_source k u t1) (open_rec_typ_source k u t2)
  | PFVarT x    => PFVarT x
  | PBVarT i    => if Nat.eqb k i then u else (PBVarT i)
  | ForAll d t => ForAll (open_rec_typ_source k u d) (* d comes before forall *)
                        (open_rec_typ_source (S k) u t)
  | Bot         => Bot
  end.

Definition open_typ_source (t : PTyp) u := open_rec_typ_source 0 u t.

Fixpoint subst_typ_source (z : var) (u : PTyp) (t : PTyp) {struct t} : PTyp :=
  match t with
  | PInt        => PInt
  | Fun t1 t2   => Fun (subst_typ_source z u t1) (subst_typ_source z u t2)
  | And t1 t2   => And (subst_typ_source z u t1) (subst_typ_source z u t2)
  | PFVarT x    => if VarTyp.eqb x z then u else (PFVarT x)
  | PBVarT i    => PBVarT i
  | ForAll d t  => ForAll (subst_typ_source z u d) (subst_typ_source z u t)
  | Bot         => Bot
  end.

Fixpoint bot_source (t : PTyp) {struct t} : PTyp :=
  match t with
  | PInt        => PInt
  | Fun t1 t2   => Fun (bot_source t1) (bot_source t2)
  | And t1 t2   => And (bot_source t1) (bot_source t2)
  | PFVarT x    => Bot
  | PBVarT i    => PBVarT i
  | ForAll d t  => ForAll (bot_source d) (bot_source t)
  | Bot         => Bot
  end.

Fixpoint fv_ptyp (pTyp : PTyp) : vars :=
  match pTyp with
    | PInt        => empty
    | Fun t1 t2   => union (fv_ptyp t1) (fv_ptyp t2)
    | And t1 t2   => union (fv_ptyp t1) (fv_ptyp t2)
    | PBVarT n    => empty
    | PFVarT v    => singleton v
    | ForAll d t  => union (fv_ptyp d) (fv_ptyp t)
    | Bot         => empty
  end.

Inductive PType : PTyp -> Prop :=
  | PType_Var : forall x, PType (PFVarT x)
  | PType_Int : PType PInt
  | PType_Fun : forall t1 t2, PType t1 -> PType t2 -> PType (Fun t1 t2)
  | PType_And : forall t1 t2, PType t1 -> PType t2 -> PType (And t1 t2)
  | PType_ForAll : forall L d t,
                     PType d ->
                     (forall x, not (In x L) -> PType (open_typ_source t (PFVarT x))) ->
                     PType (ForAll d t)
  | PType_Bot : PType Bot.

Hint Constructors PType.

Inductive Atomic : PTyp -> Prop :=
  | AInt : Atomic PInt
  | AFun : forall t1 t2, Atomic (Fun t1 t2)
  | AVar : forall v, Atomic (PFVarT v)
  | AForAll : forall d t, Atomic (ForAll d t)
  | ABot : Atomic Bot.

Inductive BottomLike : PTyp -> Prop :=
  (* | BLVar : forall x, BottomLike (PFVarT x) *)
  | BLBot : BottomLike Bot
  | BLAnd1 : forall t1 t2, BottomLike t1 -> BottomLike (And t1 t2)
  | BLAnd2 : forall t1 t2, BottomLike t2 -> BottomLike (And t1 t2)
  | BLFun : forall t1 t2, BottomLike t2 -> BottomLike (Fun t1 t2) (* what if t1 is bottomlike? should be bottom too ? *)
  | BLForAll : forall L d t,
                 (forall x, not (In x L) -> BottomLike (open_typ_source t (PFVarT x))) ->
                 BottomLike (ForAll d t).

(* Subtyping relation *)

Inductive usub : PTyp -> PTyp -> Prop :=
  | USInt : usub PInt PInt
  | USFun : forall o1 o2 o3 o4, usub o3 o1 -> usub o2 o4 -> usub (Fun o1 o2) (Fun  o3 o4)
  | USAnd1 : forall t t1 t2, usub t t1 -> usub t t2 -> usub t (And  t1 t2)
  | USAnd2 : forall t t1 t2 , usub t1 t -> usub (And t1 t2) t
  | USAnd3 : forall t t1 t2, usub t2 t -> usub (And t1 t2) t
  | USVar   : forall v, usub (PFVarT v) (PFVarT v)
  | USForAll : forall L d t1 t2,
                 (forall x, not (In x L) -> usub (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                 usub (ForAll d t1) (ForAll d t2)
  | USBot : forall t, PType t -> usub Bot t.

Inductive sub : PTyp -> PTyp -> (SExp var) -> Prop :=
  | SInt : sub PInt PInt (STLam _ (STBVar _ 0))
  | SFun : forall o1 o2 o3 o4 c1 c2, sub o3 o1 c1 -> sub o2 o4 c2 ->
     sub (Fun o1 o2) (Fun o3 o4) (STLam _ (STLam _ (STApp _ c2 (STApp _ (STBVar _ 1) (STApp _ c1 (STBVar _ 0))))))
  | SAnd1 : forall t t1 t2 c1 c2, sub t t1 c1 -> sub t t2 c2 ->
     sub t (And  t1 t2) (STLam _
       (STPair _ (STApp _ c1 (STBVar _ 0)) (STApp _ c2 (STBVar _ 0))))
  | SAnd2 : forall t t1 t2 c, sub t1 t c -> Atomic t ->
     sub (And  t1 t2) t (STLam _
       ((STApp _ c (STProj1 _ (STBVar _ 0)))))
  | SAnd3 : forall t t1 t2 c, sub t2 t c -> Atomic t ->
     sub (And  t1 t2) t (STLam _
       ((STApp _ c (STProj2 _ (STBVar _ 0)))))
  | SVar : forall v, sub (PFVarT v) (PFVarT v) (STLam _ (STBVar _ 0))
  | SForAll : forall L d t1 t2 c,
                (forall x, not (In x L) -> sub (open_typ_source t1 (PFVarT x))
                                         (open_typ_source t2 (PFVarT x))
                                         (open_typ_term c (STFVarT x))) ->
                sub (ForAll d t1) (ForAll d t2)
                    (STLam _ (STTLam _ (STApp _ c (STTApp _ (STBVar _ 0) (STBVarT 0)))))
  | SBot : forall t, PType t -> sub Bot t (STLam _ (STTApp _ (STBVar _ 0) (| t |))).

Hint Constructors Atomic sub usub.

Definition Sub (t1 t2 : PTyp) : Prop := exists (e:SExp var), sub t1 t2 e.

(* Smart constructors for Sub *)

Definition sint : Sub PInt PInt.
unfold Sub. exists (STLam _ (STBVar _ 0)).
exact SInt.
Defined.

Definition sfun : forall o1 o2 o3 o4, Sub o3 o1 -> Sub o2 o4 -> Sub (Fun o1 o2) (Fun  o3 o4).
unfold Sub; intros. destruct H. destruct H0.
exists (STLam _ (
       STLam _ (STApp _ x0 (STApp _ (STBVar _ 1) (STApp _ x (STBVar _ 0)))))).
apply SFun. auto. auto.
Defined.

Definition sand1 : forall t t1 t2, Sub t t1 -> Sub t t2 -> Sub t (And t1 t2).
unfold Sub. intros. destruct H. destruct H0.
exists (STLam _ (
       STPair _ (STApp _ x (STBVar _ 0)) (STApp _ x0 (STBVar _ 0)))).
apply SAnd1. auto. auto.
Defined.

Definition sand2_atomic :
  forall t t1 t2, Sub t1 t -> Atomic t -> Sub (And  t1 t2) t.
  unfold Sub. intros t t1 t2 H H0. destruct t; try (now inversion H0).
  - destruct H.
    exists (STLam _ ((STApp _ x (STProj1 _ (STBVar _ 0))))).
    apply SAnd2; auto.
  - destruct H.
    exists (STLam _ ((STApp _ x (STProj1 _ (STBVar _ 0))))).
    apply SAnd2; auto.
  - destruct H.
    exists (STLam _ ((STApp _ x (STProj1 _ (STBVar _ 0))))).
    apply SAnd2; auto.
  - destruct H.
    exists (STLam _ ((STApp _ x (STProj1 _ (STBVar _ 0))))).
    apply SAnd2; auto.
  - destruct H.
    exists (STLam _ ((STApp _ x (STProj1 _ (STBVar _ 0))))).
    apply SAnd2; auto.
Defined.

Definition sand2 : forall t t1 t2, Sub t1 t -> Sub (And t1 t2) t.
  intro t.
  induction t; intros.
  (* Case PInt *)
  - apply sand2_atomic. auto. apply AInt.
  (* Case Fun *)
  - apply sand2_atomic. auto. apply AFun.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1; auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H6. destruct H6.
    unfold Sub in H7. destruct H7.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H1.
    inversion H1.
    subst.
    assert (Ha : Sub Bot t1). inversion H0; eexists; auto.
    apply IHt1 with (t3 := t3) in Ha.
    destruct Ha.
    assert (Ha : Sub Bot t2) by (inversion H0; eexists; auto).
    apply IHt2 with (t3 := t3) in Ha.
    destruct Ha.
    eexists.
    apply SAnd1; eauto.
  (* Case BVar *)
  - inversion H. inversion H0. inversion H2. inversion H2. inversion H1.
  (* Case FVar *)
  - apply sand2_atomic; auto.
  (* Case ForAll *)
  - apply sand2_atomic; auto; apply AForAll.
  (* Case Bot *)
  - apply sand2_atomic; auto; apply ABot.
Qed.

Definition sand3_atomic :
  forall t t1 t2, Sub t2 t -> Atomic t -> Sub (And t1 t2) t.
  unfold Sub; intros t t1 t2 H H0.
  destruct t; try (now inversion H0);
  destruct H; exists (STLam _ ((STApp _ x (STProj2 _ (STBVar _ 0))))); apply SAnd3; auto.
Defined.

Definition sand3 : forall t t1 t2, Sub t2 t -> Sub (And t1 t2) t.
  intros t; induction t; intros.
  (* Case PInt *)
  - apply sand3_atomic. auto. apply AInt.
  (* Case Fun *)
  - apply sand3_atomic. auto. apply AFun.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1. auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H6. destruct H6.
    unfold Sub in H7. destruct H7.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H1.
    inversion H1.
    inversion H0; subst.
    admit.
  (* Case BVar *)
  - inversion H; inversion H0; inversion H2. inversion H1.
  (* Case FVar *)
  - apply sand3_atomic; auto.
  (* Case ForAll *)
  - apply sand3_atomic; auto; apply AForAll.
  (* Case Bot *)
  - apply sand3_atomic; auto; apply ABot.
Admitted.

Definition svar : forall v, Sub (PFVarT v) (PFVarT v).
  intros.
  unfold Sub.
  exists (STLam _ (STBVar _ 0)).
  apply SVar.
Defined.

(*
Definition sforall : forall L t1 t2 c,
                (forall x, not (In x L) -> sub (open_ptyp t1 (PFVar x))
                                         (open_ptyp t2 (PFVar x))
                                         (open_typ_term c (STFVarT x))) ->
                Sub (ForAll t1) (ForAll t2).
  intros.
  unfold Sub.
  eexists.
  eapply SForAll.
  intros.

  pick_fresh.
 *)

(** Environment definitions **)

Inductive TyEnvSource : Type :=
  | TyDis : PTyp -> TyEnvSource
  | TermV : PTyp -> TyEnvSource.

Hint Constructors TyEnvSource.

Inductive WFEnv : context TyEnvSource -> Prop :=
  | WFNil : WFEnv nil
  | WFPushV : forall Gamma v ty,
                WFEnv Gamma -> not (In v (fv_ptyp ty)) -> ~ In v (dom Gamma) ->
                WFEnv (extend v (TyDis ty) Gamma)
  | WFPushT : forall Gamma v ty,
                WFEnv Gamma -> ~ In v (dom Gamma) -> WFEnv (extend v (TermV ty) Gamma).

Hint Constructors WFEnv.

Fixpoint subst_env (Gamma : context TyEnvSource) (z : var) (u : PTyp) :=
  match Gamma with
    | nil => nil
    | (x,TyDis d) :: tl => (x, TyDis (subst_typ_source z u d)) ::
                           (subst_env tl z u)
    | (x, TermV ty) :: tl => (x, TermV ty) :: (subst_env tl z u)
  end.

Definition MapsTo (Gamma : context TyEnvSource) (z : var) (d : PTyp) :=
  find (fun x => eqb (fst x) z) Gamma = Some (z, TyDis d).

Definition TyEnvMatch {A} (f : PTyp -> A) (tyenv : TyEnvSource) : A :=
  match tyenv with
    | TyDis d => f d
    | TermV ty => f ty
  end.

Definition codom (c : context TyEnvSource) : vars :=
  fold_right (fun el r => union (TyEnvMatch fv_ptyp (snd el)) r) empty c.

(* Disjointness: Implementation *)

Definition hd (p : PTyp) : nat :=
  match p with
  | PInt       => 0
  | Fun t1 t2  => 1
  | ForAll d t => 2
  | Bot        => 3
  | PBVarT n   => 4
  | PFVarT v   => 5
  | And t1 t2  => 6
  end.

Definition OrthoAx (t1 t2 : PTyp) : Prop :=
  (hd t1 < 3 /\ hd t2 < 3 /\ not (hd t1 = hd t2)).

Inductive Ortho : context TyEnvSource -> PTyp -> PTyp -> Prop :=
  | OAnd1 : forall Gamma t1 t2 t3, Ortho Gamma t1 t3 -> Ortho Gamma t2 t3 -> Ortho Gamma (And t1 t2) t3
  | OAnd2 : forall Gamma t1 t2 t3, Ortho Gamma t1 t2 -> Ortho Gamma t1 t3 -> Ortho Gamma t1 (And t2 t3)
  | OFun  : forall Gamma t1 t2 t3 t4, Ortho Gamma t2 t4 -> Ortho Gamma (Fun t1 t2) (Fun t3 t4)
  | OForAll : forall L Gamma d t1 t2,
                (forall x, not (In x L) -> Ortho (extend x (TyDis d) Gamma)
                                           (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                Ortho Gamma (ForAll d t1) (ForAll d t2)
  | OVar : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                       usub (bot_source A) (bot_source ty) ->
                       PType ty ->
                       PType A ->
                       Ortho Gamma (PFVarT x) ty
  | OVarSym : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                          usub (bot_source A) (bot_source ty) ->
                          PType ty ->
                          PType A ->
                          Ortho Gamma ty (PFVarT x)
  | OBot1 : forall Gamma t, Ortho Gamma Bot t
  | OBot2 : forall Gamma t, Ortho Gamma t Bot
  | OAx : forall Gamma t1 t2, OrthoAx t1 t2 -> Ortho Gamma t1 t2.

              (*
Lemma obot1 : forall A, BottomLike A -> forall B Gamma, Ortho Gamma A B.
  intros A botA. induction botA; intros.
  apply OBot1. apply OAnd1. auto. auto.
*)

Hint Constructors Ortho.

(* Disjointness: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

(* Well-formed types *)

Inductive WFTyp : context TyEnvSource -> PTyp -> Prop :=
  | WFInt : forall Gamma, WFEnv Gamma -> WFTyp Gamma PInt
  | WFFun : forall Gamma t1 t2, WFTyp Gamma t1 -> WFTyp Gamma t2 -> WFTyp Gamma (Fun t1 t2)
  | WFAnd : forall Gamma t1 t2, WFTyp Gamma t1 -> WFTyp Gamma t2 -> Ortho Gamma t1 t2 -> WFTyp Gamma (And t1 t2)
  | WFVar : forall Gamma x ty, List.In (x,TyDis ty) Gamma -> WFEnv Gamma -> WFTyp Gamma (PFVarT x)
  | WFForAll : forall L Gamma d t,
                 (forall x, not (In x L) -> WFTyp (extend x (TyDis d) Gamma) (open_typ_source t (PFVarT x))) ->
                 WFTyp Gamma d ->
                 WFTyp Gamma (ForAll d t)
  | WFBot : forall Gamma, WFEnv Gamma -> WFTyp Gamma Bot.

Hint Constructors WFTyp.

(* Reflexivity *)
Hint Resolve sint sfun sand1 sand2 sand3 svar SInt SFun SAnd1 SAnd2 SAnd3 SVar SForAll.

(* Definitions borrowed from STLC_Tutorial *)

(* Our source language *)
Inductive PExp :=
  | PFVar  : var -> PExp
  | PBVar  : nat -> PExp
  | PLit   : nat -> PExp
  | PLam   : PExp -> PExp
  | PApp   : PExp -> PExp -> PExp
  | PMerge : PExp -> PExp -> PExp
  | PAnn   : PExp -> PTyp -> PExp (* only for the algorithmic version *)
  | PTLam  : PTyp -> PExp -> PExp
  | PTApp  : PExp -> PTyp -> PExp.

(* Free variables *)

(** Source language **)
Fixpoint fv_source (pExp : PExp) : vars :=
  match pExp with
    | PFVar v => singleton v
    | PBVar _ => empty
    | PLit _ => empty
    | PLam t => fv_source t
    | PApp t1 t2 => union (fv_source t1) (fv_source t2)
    | PMerge t1 t2 => union (fv_source t1) (fv_source t2)
    | PAnn t1 A => fv_source t1
    | PTLam tydis t => union (fv_ptyp tydis) (fv_source t)
    | PTApp t ty => union (fv_source t) (fv_ptyp ty)
  end.

(* Tactics dealing with instantiation of fresh variables, taken from STLC_Tutorial *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => singleton x) in
  let C := gather_vars_with (fun x : PExp => fv_source x) in
  let D := gather_vars_with (fun x : PTyp => fv_ptyp x) in
  let E := gather_vars_with (fun x : STyp => fv_typ x) in
  let F := gather_vars_with (fun (x : SExp var) => fv x) in
  let G := gather_vars_with (fun (x : context (TyEnv STyp)) => dom x) in
  let H := gather_vars_with (fun (x : context TyEnvSource) =>
                              union (dom x) (codom x)) in
  constr:(union A (union B (union C (union D (union E (union F (union G H))))))).

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

(* Opening a term "u" with term "t" *)

(** Source language **)
Fixpoint open_rec_source (k : nat) (u : PExp) (t : PExp) {struct t} : PExp  :=
  match t with
  | PBVar i      => if Nat.eqb k i then u else (PBVar i)
  | PFVar x      => PFVar x
  | PLit x       => PLit x
  | PLam t1      => PLam (open_rec_source (S k) u t1)
  | PApp t1 t2   => PApp (open_rec_source k u t1) (open_rec_source k u t2)
  | PMerge t1 t2 => PMerge (open_rec_source k u t1) (open_rec_source k u t2)
  | PAnn e t     => PAnn (open_rec_source k u e) t
  | PTLam ty t   => PTLam ty (open_rec_source k u t)
  | PTApp t ty   => PTApp (open_rec_source k u t) ty
  end.

Fixpoint open_rec_typ_term_source (k : nat) (u : PTyp) (t : PExp) {struct t} : PExp :=
  match t with
  | PBVar i      => PBVar i
  | PFVar x      => PFVar x
  | PLit x       => PLit x
  | PLam t1      => PLam (open_rec_typ_term_source k u t1)
  | PApp t1 t2   => PApp (open_rec_typ_term_source k u t1)
                        (open_rec_typ_term_source k u t2)
  | PMerge t1 t2 => PMerge (open_rec_typ_term_source k u t1)
                          (open_rec_typ_term_source k u t2)
  | PAnn e t     => PAnn (open_rec_typ_term_source k u e) t
  | PTLam ty t   => PTLam ty (open_rec_typ_term_source (S k) u t)
  | PTApp t ty   => PTApp (open_rec_typ_term_source k u t)
                         (open_rec_typ_source k u ty)
  end.

Definition open_source t u := open_rec_source 0 u t.
Definition open_typ_term_source t u := open_rec_typ_term_source 0 u t.

(* Functions on contexts *)

Definition ptyp2styp_tyenv (t : TyEnvSource) : TyEnv STyp :=
  match t with
    | TyDis _ => TyVar _
    | TermV t => TermVar _ (ptyp2styp t)
  end.

Definition conv_context (env : context TyEnvSource) : context (TyEnv STyp) :=
  mapctx ptyp2styp_tyenv env.

Notation "'∥' t '∥'" := (conv_context t) (at level 60).

Inductive PTerm : PExp -> Prop :=
  | PTerm_Var : forall x,
      PTerm (PFVar x)
  | PTerm_Lit : forall n,
      PTerm (PLit n)
  | PTerm_Lam : forall L t1,
      (forall x, not (In x L) -> PTerm (open_source t1 (PFVar x))) ->
      PTerm (PLam t1)
  | PTerm_App : forall t1 t2,
      PTerm t1 ->
      PTerm t2 ->
      PTerm (PApp t1 t2)
  | PTerm_Merge : forall t1 t2,
      PTerm t1 ->
      PTerm t2 ->
      PTerm (PMerge t1 t2)
  | PTerm_Ann : forall e t,
      PTerm e ->
      PTerm (PAnn e t)
  | PTerm_TLam : forall L t ty,
      (forall x, not (In x L) -> PTerm (open_typ_term_source t (PFVarT x))) ->
      PTerm (PTLam ty t)
  | PTerm_TApp : forall t ty,
      PTerm t ->
      PType ty ->
      PTerm (PTApp t ty).

Hint Constructors PTerm.

Inductive Dir := Inf | Chk.

(* bidirection type-system (algorithmic):

T |- e => t ~> E     (inference mode: infers the type of e producing target E) (use Inf)
T |- e <= t ~> E     (checking mode: checks the type of e producing target E) (use Chk)

Inspiration for the rules:

https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf

 *)

Inductive has_type_source_alg : context TyEnvSource -> PExp -> Dir -> PTyp -> (SExp var) -> Prop :=
  (* Inference rules *)
  | ATyVar : forall Gamma x ty, WFEnv Gamma -> List.In (x,TermV ty) Gamma -> WFTyp Gamma ty ->
                      has_type_source_alg Gamma (PFVar x) Inf ty (STFVar _ x)
  | ATyLit : forall Gamma x, WFEnv Gamma -> has_type_source_alg Gamma (PLit x) Inf PInt (STLit _ x)
  | ATyApp : forall Gamma A B t1 t2 E1 E2,
              has_type_source_alg Gamma t1 Inf (Fun A B) E1 ->
              has_type_source_alg Gamma t2 Chk A E2 ->
              has_type_source_alg Gamma (PApp t1 t2) Inf B (STApp _ E1 E2)
  | ATyMerge : forall Gamma A B t1 t2 E1 E2,
                has_type_source_alg Gamma t1 Inf A E1 ->
                has_type_source_alg Gamma t2 Inf B E2 ->
                Ortho Gamma A B ->
                has_type_source_alg Gamma (PMerge t1 t2) Inf (And A B) (STPair _ E1 E2)
  | ATyAnn : forall Gamma t1 A E, has_type_source_alg Gamma t1 Chk A E ->
                         has_type_source_alg Gamma (PAnn t1 A) Inf A E
  | ATyTApp : forall Gamma t A ty d E,
                WFTyp Gamma A ->
                has_type_source_alg Gamma t Inf (ForAll d ty) E ->
                Ortho Gamma A d ->
                has_type_source_alg Gamma (PTApp t A) Inf (open_typ_source ty A) (STTApp _ E (|A|))
  (* Checking rules *)
  | ATyLam : forall L Gamma t A B E,
               (forall x, not (In x L) ->
                     has_type_source_alg (extend x (TermV A) Gamma) (open_source t (PFVar x)) Chk B (open E (STFVar _ x))) ->
               WFTyp Gamma A ->
               has_type_source_alg Gamma (PLam t) Chk (Fun A B) (STLam _ E)
  | ATySub : forall Gamma t A B C E,
               has_type_source_alg Gamma t Inf A E ->
               sub A B C ->
               WFTyp Gamma B ->
               has_type_source_alg Gamma t Chk B (STApp _ C E)
  | ATyTLam : forall L Gamma t A d E,
               WFTyp Gamma d ->
               (forall x, not (In x L) ->
                     has_type_source_alg (extend x (TyDis d) Gamma)
                                         (open_typ_term_source t (PFVarT x))
                                         Chk
                                         (open_typ_source A (PFVarT x))
                                         (open_typ_term E (STFVarT x))) ->
               has_type_source_alg Gamma (PTLam d t) Chk (ForAll d A) (STTLam _ E).

Hint Constructors has_type_source_alg.

Lemma decidability_types :
  forall (A B : PTyp), sumbool (A = B) (not (A = B)).
Proof.
  decide equality.
  case_eq (Nat.eqb n n0); intros.
  left; apply beq_nat_true in H; auto.
  right; apply beq_nat_false in H.
  unfold not; intros H1; inversion H1; contradiction.

  apply VarTyp.eq_dec.
Qed.

Hint Resolve decidability_types.

Module PTypDecidable <: DecidableType.

  Definition t := PTyp.

  Definition eq (x : PTyp) y := (x = y).

  Definition eq_refl : forall x : t, eq x x.
    Proof. destruct x; reflexivity. Defined.

  Definition eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. destruct x; destruct y; intros; auto; symmetry; assumption. Defined.

  Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros; rewrite H; assumption. Defined.

  Definition eq_equiv : Equivalence eq :=
    Build_Equivalence _ eq_refl eq_sym eq_trans.

  Definition eq_dec : forall x y, sumbool (eq x y) (not (eq x y)).
    Proof. apply decidability_types. Defined.

End PTypDecidable.

Import PTypDecidable.
Require Import Coq.Structures.DecidableTypeEx.

Module VarTypDecidable <: DecidableType.

  Definition t := VarTyp.t.

  Definition eq (x : VarTyp.t) y := (VarTyp.eq x y).

  Definition eq_equiv : Equivalence eq.
    Proof. apply VarTyp.eq_equiv. Defined.

  Definition eq_refl : forall x : t, eq x x.
    Proof. apply reflexivity. Defined.

  Definition eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. intros; symmetry; assumption. Defined.

  Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros; rewrite H; assumption. Defined.

  Definition eq_dec : forall x y, sumbool (eq x y) (not (eq x y)).
    Proof. apply VarTyp.eq_dec. Defined.

End VarTypDecidable.

Ltac orthoax_inv H :=
  let H' := fresh in
  let m := fresh in
  let H1 := fresh in
  let H2 := fresh in
  inversion H as [H' | m H1 H2 ]; orthoax_inv H1.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t1 is not part of OrthoAx *)
Ltac orthoax_inv_l :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [H1 _]; orthoax_inv H1
  end.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t2 is not part of OrthoAx *)
Ltac orthoax_inv_r :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [_ [H1 _]]; orthoax_inv H1
  end.

Lemma sound_sub : forall t1 t2, usub t1 t2 -> Sub t1 t2.
Proof.
  intros; induction H; auto.
  - unfold Sub.
    eexists.
    apply_fresh SForAll as x.
    admit.
  - eexists; eauto.
Admitted.

Lemma complete_sub : forall t1 t2, Sub t1 t2 -> usub t1 t2.
Proof.
  intros; destruct H; induction H; auto.
  - apply_fresh USForAll as x.
    apply H0.
    not_in_L x.
Qed.

End Definitions.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Epsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This file provides indefinite description under the form of
    Hilbert's epsilon operator; it does not assume classical logic. *)

Require Import ChoiceFacts.

Set Implicit Arguments.

(** Hilbert's epsilon: operator and specification in one statement *)

Axiom epsilon_statement :
  forall (A : Type) (P : A->Prop), inhabited A ->
    { x : A | (exists x, P x) -> P x }.

Lemma constructive_indefinite_description :
  forall (A : Type) (P : A->Prop),
    (exists x, P x) -> { x : A | P x }.
Proof.
  apply epsilon_imp_constructive_indefinite_description.
  exact epsilon_statement.
Qed.

Lemma small_drinkers'_paradox :
  forall (A:Type) (P:A -> Prop), inhabited A ->
    exists x, (exists x, P x) -> P x.
Proof.
  apply epsilon_imp_small_drinker.
  exact epsilon_statement.
Qed.

Theorem iota_statement :
  forall (A : Type) (P : A->Prop), inhabited A ->
  { x : A | (exists! x : A, P x) -> P x }.
Proof.
  intros; destruct epsilon_statement with (P:=P); firstorder.
Qed.

Lemma constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.
Proof.
  apply iota_imp_constructive_definite_description.
  exact iota_statement.
Qed.

(** Hilbert's epsilon operator and its specification *)

Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (epsilon_statement P i).

Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists x, P x) -> P (epsilon i P)
  := proj2_sig (epsilon_statement P i).

(** Church's iota operator and its specification *)

Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (iota_statement P i).

Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists! x:A, P x) -> P (iota i P)
  := proj2_sig (iota_statement P i).