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

Section posidonius_postulate_rah.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma posidonius_postulate__rah : posidonius_postulate -> postulate_of_right_saccheri_quadrilaterals.
Proof.
intro H.
assert (HF : exists A1 A2 B1 B2,
             Per A2 A1 B1 /\ Per A1 A2 B2 /\
             Cong A1 B1 A2 B2 /\ OS A1 A2 B1 B2 /\
             forall A3 B3,
               Col A1 A2 A3 -> Col B1 B2 B3 -> Perp A1 A2 A3 B3 ->
               Cong A3 B3 A1 B1).
  {
  destruct H as [A1' [A2' [B1 [B2 [HNC [HNE [HCop HF]]]]]]].
  destruct (l8_18_existence _ _ _ HNC) as [A1 [HC1 HPerp1]].
  assert (HNC' : ~ Col A1' A2' B2).
    {
    intro HC2.
    destruct (midpoint_existence B1 B2) as [B3 HB3].
    assert (HNE' : B1 <> B2) by (intro; treat_equalities; Col).
    assert (HNE'' : B1 <> B3) by (assert_diffs; auto).
    destruct (l8_18_existence A1' A2' B3) as [A3 [HC4 HPerp3]];
    try (intro; apply HNC; assert_diffs; assert_cols; ColR).
    assert (HCong : Cong A1 B1 A3 B3)
      by (apply HF; Col; Perp; ColR).
    assert (HCong' : Cong B1 B2 B3 B2).
      {
      assert (HNE''' : A3 <> B2).
        {
        intro; assert (A1 = A3); treat_equalities.
          {
          apply l8_18_uniqueness with A1' A2' B1; Col.
          apply perp_col0 with A3 B3; Col; Perp.
          }
        assert (HFalse : B3 <> B1) by (assert_diffs; auto).
        apply HFalse; apply between_cong with A1; Cong.
        unfold Midpoint in *; spliter; Between.
        }
      assert (HNE'''' : B3 <> B2).
        {
        intro; assert (A1 = A3); treat_equalities; [|intuition].
        apply l8_18_uniqueness with A1' A2' B1; Col.
        }
      assert (HNE''''' : A1 <> B2).
        {
        intro; treat_equalities; apply HNE''';
        apply l8_18_uniqueness with A1' A2' B3; Col; Perp;
        try (intro; assert_diffs; assert_cols; apply HNC; ColR).
        apply perp_col0 with A1 B1; assert_cols; Col; Perp;
        try (intro; treat_equalities; Col).
        }
      destruct (l11_50_2 B1 A1 B2 B3 A3 B2);
      try solve[unfold Midpoint in *; spliter; Cong].

        {
        intro H.
        assert (A1 = B2); auto.
        apply perp_sym in HPerp1.
        elim (perp_not_col2 _ _ _ _ HPerp1); intro H';
        [apply l6_21 with A1 B1 A1' A2'|apply l6_21 with A1 B1 A2' A1'];
        assert_diffs; Col; assert_cols; ColR.
        }

        {
        apply out_conga with A3 B3 A3 B3;
        try apply conga_refl; try apply out_trivial; auto; do 2(split; auto);
        [|unfold Midpoint in *; spliter; Between].
        left; apply col_two_sides_bet with B3;
        [assert_diffs; assert_cols; ColR|apply l9_2; apply l9_8_2 with B1].

          {
          split; [intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col;
                  try (intro; treat_equalities; auto); ColR|].
          split; [intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col;
                  try (intro; treat_equalities; auto); ColR|].
          exists B3; split; Col; unfold Midpoint in *; spliter; auto.
          }

          {
          apply l12_6; apply par_not_col_strict with B1; Col;
          try (apply l12_9 with A1' A2'; Perp); Cop;
          try (apply col2_cop__cop with B1 B2; Col; intro; apply HNC; ColR).
          intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col;
          try (intro; treat_equalities; auto); ColR.
          }
        }

        {
        apply l11_16; try apply perp_per_1; try solve[assert_diffs; auto];
        apply perp_col0 with A1' A2'; Perp; ColR.
        }
      }
    assert (HFalse : B3 <> B1) by (assert_diffs; auto).
    apply HFalse; apply between_cong with B2; Cong.
    unfold Midpoint in *; spliter; Between.
    }
  destruct (l8_18_existence A1' A2' B2) as [A2 [HC2 HPerp2]]; Col.
  assert (HNE' : A1 <> A2).
    {
    intro; treat_equalities.
    assert (HCong : Cong A1 B1 A1 B2) by (apply HF; Col; Perp).
    assert (HC2 : Col A1 B1 B2).
      apply cop_perp2__col with A1' A2'; Perp.
    elim (l7_20 A1 B1 B2); Col; intro HMid.
    destruct (midpoint_existence A1 B1) as [M HM].
    elim (l7_20 A1 B1 M); try apply HF; Col; Perp; try (ColR);
    try (apply perp_col0 with A1 B1; assert_diffs; Col; Perp).
    intro; treat_equalities; intuition.
    assert_diffs.
    assert (HX : M<>A1) by auto.
    apply HX.
    apply between_equality with B1;
    unfold Midpoint in *; spliter; Between.
    }
  exists A1, A2, B1, B2.
  split; [|split; [|split; [apply HF; Col; Perp|split]]];
  try (apply l8_2; apply perp_per_2; apply perp_col0 with A1' A2'; Perp).

    {
    apply cop__not_two_sides_one_side; auto; try intro HTS;
    try (apply HNC; ColR); try (apply HNC'; ColR);
    [assert_diffs; apply coplanar_perm_16, col2_cop__cop with A1' A2'; Col; Cop|].
    destruct HTS as [HNC'' [_ [I [HC3 HBet]]]].
    destruct (midpoint_existence B1 I) as [B3 HB3].
    assert (HNE'' : B1 <> I) by (intro; treat_equalities; Col).
    destruct (l8_18_existence A1' A2' B3) as [A3 [HC4 HPerp3]];
    try (intro; apply HNC; assert_diffs; assert_cols; ColR).
    assert (HCong : Cong A1 B1 A3 B3)
      by (apply HF; Col; Perp; ColR).
    assert (HCong' : Cong B1 I B3 I).
      {
      assert (HNE''' : A3 <> I).
        {
        intro; assert (A1 = A3); treat_equalities.
          {
          apply l8_18_uniqueness with A1' A2' B1; Col.
          apply perp_col0 with A3 B3; Col; Perp.
          }
        apply HNE'; apply l8_18_uniqueness with A1' A2' B2; Col.
        apply perp_col0 with A1 B1; Col; Perp; intro; treat_equalities; Col.
        }
      assert (HNE'''' : B3 <> I).
        {
        intro; assert (A1 = A3); treat_equalities; [|intuition].
        apply l8_18_uniqueness with A1' A2' B1; Col.
        }
      assert (HNE''''' : A1 <> I).
        {
        intro; treat_equalities; apply HNE';
        apply l8_18_uniqueness with A1' A2' B2; Col; Perp.
        apply perp_col0 with A1 B1; assert_cols; Col; Perp.
        intro; treat_equalities; Col.
        }
      destruct (l11_50_2 B1 A1 I B3 A3 I);
      try solve[unfold Midpoint in *; spliter; Cong].

        {
        intro H.
        assert (A1 = I); auto.
        apply perp_sym in HPerp1.
        elim (perp_not_col2 _ _ _ _ HPerp1); intro H';
        [apply l6_21 with A1 B1 A1' A2'|apply l6_21 with A1 B1 A2' A1'];
        assert_diffs; Col; assert_cols; ColR.
        }

        {
        apply out_conga with A3 B3 A3 B3;
        try apply conga_refl; try apply out_trivial; auto; do 2(split; auto);
        [|unfold Midpoint in *; spliter; Between].
        left; apply col_two_sides_bet with B3;
        [assert_diffs; assert_cols; ColR|apply l9_2; apply l9_8_2 with B1].

          {
          split; [intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col;
                  try (intro; treat_equalities; auto); ColR|].
          split; [intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col;
                  try (intro; treat_equalities; auto); ColR|].
          exists B3; split; Col; unfold Midpoint in *; spliter; auto.
          }

          {
          apply l12_6; apply par_not_col_strict with B1; Col.

            {
            apply l12_9 with A1' A2'; Perp; Cop.
            assert_cols; apply col2_cop__cop with B1 B2; Col; Cop; ColR.
            }

            {
            intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col;
            try (intro; treat_equalities; auto); ColR.
            }
          }
        }

        {
        apply l11_16; try apply perp_per_1; try solve[assert_diffs; auto];
        apply perp_col0 with A1' A2'; Perp; ColR.
        }
      }
    assert (HFalse : B3 <> B1) by (assert_diffs; auto).
    apply HFalse; apply between_cong with I; Cong.
    unfold Midpoint in *; spliter; Between.
    }

    {
    intros A3 B3 HC3 HC4 HPerp3.
    apply HF; Col; Perp.
    ColR.
    apply perp_sym; apply perp_col0 with A1 A2; assert_diffs; Col; ColR.
    }
  }
destruct HF as [A [D [B [C [HPer1 [HPer2 [HCong [HOS posid]]]]]]]].
assert (HSac : Saccheri A B C D) by repeat (split; finish).
apply (per_sac__rah A B C D); auto.
destruct (midpoint_existence B C) as [M HM].
destruct (midpoint_existence A D) as [N HN].
assert(HPerp := mid2_sac__perp_lower A B C D M N HSac HM HN).
assert(Hdiff := sac_distincts A B C D HSac).
spliter.
assert_diffs.
apply (t22_7__per _ _ _ D M N); Between;
[apply perp_per_1; auto; apply (perp_col1 _ _ _ D); Col; Perp|
apply cong_left_commutativity; apply posid; Col; Perp].
Qed.

End posidonius_postulate_rah.


(* -----------------Description------------------------------------------------------

This file contains basic definitions of Bids, Asks and Fill (trade between
Bid and Ask). These data types are also attached with eqType (i.e, domain
with decidable Equality). We also define projection functions on list
of Bids and Asks.

    Terms          <==>     Explanations
    Bid                     Type for a buy request
    Ask                     Type for an sell request
    fill_type               Type for trade output

    bid_prices B            projection of bid prices in B
    ask_prices A            projection of ask prices in A
    bids_of F               projection of bids in F
    asks_of F               projection of asks in F

Some important results:

  Lemma included_M_imp_included_bids : included M1 M2 -> included (bids_of M1) (bids_of M2).
  Lemma bids_of_perm: perm M M' -> perm (bids_of M) (bids_of M').

  Lemma included_M_imp_included_asks : included M1 M2 -> included (asks_of M1) (asks_of M2).
  Lemma asks_of_perm: perm M M' -> perm (asks_of M) (asks_of M').

  Lemma included_M_imp_included_tps: included M M'->included(trade_prices_of M)(trade_prices_of M').
  Lemma tps_of_perm : perm M M' -> perm (trade_prices_of M) (trade_prices_of M').

 ---------------------------------------------------------------------------------------- *)

Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export DecList DecType MoreDecList.

Section BidAsk.

Record Bid:Type:= Mk_bid{
                        bp:> nat;
                        idb: nat}.

Definition b_eqb (x y:Bid): bool:= (idb x == idb y) && ( bp x == bp y).

Record Ask:Type:= Mk_ask{
                        sp:>nat;
                        ida: nat;}.

Definition a_eqb (x y: Ask): bool:= (ida x == ida y) && (  sp x ==  sp y).

(*
Hypothesis unique_idb : forall b1 b2:Bid, (idb(b1) = idb(b2))-> (b1 = b2).
Hypothesis unique_ida : forall a1 a2:Ask, (ida(a1) = ida(a2))-> (a1 = a2).
*)

(*----------------  Attaching Bid to the EqType ----------------------------------*)

Lemma b_eqb_ref (x:Bid): b_eqb x x = true.
Proof. unfold b_eqb. split_; apply /eqP;auto. Qed.

Hint Resolve b_eqb_ref: auction.
Lemma b_eqb_elim (x y:Bid):  b_eqb x y -> x = y.
Proof. { unfold b_eqb. move /andP. intro H. destruct H as [H1 H2].
         destruct x; destruct y. move /eqP in H1. auto.  } Qed.

Lemma b_eqb_intro (x y:Bid): x=y -> b_eqb x y = true.
Proof. { unfold b_eqb. intros H. apply /andP. split.
         apply /eqP. subst x.  auto. apply /eqP.
         inversion H. auto. } Qed.

Hint Immediate b_eqb_elim b_eqb_intro: auction.

Lemma b_eqP (x y:Bid): reflect (x=y)(b_eqb x y).
Proof. apply reflect_intro. split; auto with auction. Qed.
Hint Resolve b_eqP: auction.

Canonical bid_eqType: eqType:= {| Decidable.E:= Bid; Decidable.eqb:= b_eqb; Decidable.eqP:= b_eqP |}.

(*------------------ Attaching Ask to EqType ------------------------------------ *)

Lemma a_eqb_ref (x: Ask): a_eqb x x = true.
Proof. { unfold a_eqb. apply /andP. split. apply /eqP. auto. apply /eqP.
         auto. } Qed.

Hint Resolve a_eqb_ref: auction.
Lemma a_eqb_elim (x y: Ask):  a_eqb x y -> x = y.
Proof. { unfold a_eqb. move /andP. intro H. destruct H as [H1 H2].
         destruct x; destruct y. move /eqP in H1. auto. } Qed.

Lemma a_eqb_intro (x y: Ask): x=y -> a_eqb x y = true.
Proof. { unfold a_eqb. intros H. apply /andP. split.
         apply /eqP. subst x.  auto. apply /eqP.
         inversion H. auto. } Qed.

Hint Immediate a_eqb_elim a_eqb_intro: auction.

Lemma a_eqP (x y: Ask): reflect (x=y)(a_eqb x y).
Proof. apply reflect_intro. split; auto with auction. Qed.
Hint Resolve a_eqP: auction.

Canonical ask_eqType: eqType:= {| Decidable.E:= Ask; Decidable.eqb:= a_eqb; Decidable.eqP:= a_eqP |}.

(*------------- Price projections for list of Bids and Asks--------------------------*)

Fixpoint bid_prices (B: list Bid): (list nat):=
  match B with
  |nil => nil
  |b::B' => (bp b)::(bid_prices B')
  end.

Lemma bid_prices_intro (B: list Bid) (b: Bid):
  In b B -> (In (bp b) (bid_prices B)).
Proof. { intro H. induction B. simpl. simpl in H. contradiction.
         destruct  H. subst b. simpl. left. auto. simpl. right. auto. } Qed.

Lemma bid_prices_elim (B: list Bid): forall p, In p (bid_prices B)->
                                             exists b, In b B /\ p = bp b.
Proof. { intros p H. induction B. simpl in H. contradiction. simpl in H.
       destruct  H as [H1 | H2].  exists a. split; auto.
       apply IHB in H2 as H0. destruct H0 as [b H0].
       exists b. destruct H0. split.
       eauto. auto. } Qed.

Lemma bid_prices_intro1 (B: list Bid) (B': list Bid):
  B [<=] B' -> ((bid_prices B)  [<=] (bid_prices B')).
Proof. { intro H. intros p. intro H1. assert (H2: exists b, In b B /\ p=bp b).
         apply bid_prices_elim. exact. destruct H2. destruct H0.
         assert (H3: In x B'). auto. subst p. eapply bid_prices_intro. exact. } Qed.

Fixpoint ask_prices (A: list Ask): (list nat):=
  match A with
  |nil => nil
  |a::A' => (sp a)::(ask_prices A')
  end.

Lemma ask_prices_intro (A: list Ask) (a: Ask):
  In a A -> (In (sp a) (ask_prices A)).
Proof. { intro H. induction A. simpl. simpl in H. contradiction.
         destruct  H. subst a. simpl. left. auto. simpl. right. auto. } Qed.

Lemma ask_prices_elim (A: list Ask): forall p, In p (ask_prices A)->
                                             exists a, In a A /\ p = sp a.
Proof. { intros p H. induction A. simpl in H. contradiction. simpl in H.
       destruct  H as [H1 | H2]. exists a. split; auto.
       apply IHA in H2 as H0. destruct H0 as [a0 H0].
       exists a0. destruct H0. split.
       eauto. auto. } Qed.

Lemma ask_prices_intro1 (A: list Ask) (A': list Ask):
  A [<=] A' -> ((ask_prices A)  [<=] (ask_prices A')).
Proof.  { intro H. intros p. intro H1. assert (H2: exists a, In a A /\ p=sp a).
          apply ask_prices_elim. exact. destruct H2. destruct H0.
          assert (H3: In x A'). eauto. subst p. eapply ask_prices_intro. exact. } Qed.

Hint Resolve bid_prices_elim bid_prices_intro bid_prices_intro1: core.
Hint Resolve ask_prices_elim ask_prices_intro ask_prices_intro1: core.

(* ------------definition of  fill_type as record---------------------------- *)

Record fill_type:Type:=  Mk_fill {
                             bid_of: Bid;
                             ask_of: Ask;
                             tp: nat }.

 Definition m_eqb (x y: fill_type): bool:= (bid_of x == bid_of y) && (  ask_of x ==  ask_of y) && (tp x == tp y).

(*------------------ Attaching fill_type to eqType ------------------------------------ *)

Lemma m_eqb_ref (x: fill_type): m_eqb x x = true.
Proof. unfold m_eqb. apply /andP. split. apply /andP. split. all: apply /eqP; auto. Qed.

Hint Resolve m_eqb_ref: auction.
Lemma m_eqb_elim (x y: fill_type):  m_eqb x y -> x = y.
Proof. { unfold m_eqb. destruct x. destruct y. simpl. intros. move /andP in H.
         destruct H. move /andP in H. destruct H. move /eqP in H. move /eqP in H1.
         move /eqP in H0. rewrite H0. rewrite H1. rewrite H. auto. } Qed.

Lemma m_eqb_intro (x y: fill_type): x=y -> m_eqb x y = true.
Proof. { unfold m_eqb. intros H. apply /andP. split. apply /andP.
         split. apply /eqP. subst x. exact. apply /eqP. subst x. exact. apply /eqP.
         subst x. exact. } Qed.

Hint Immediate m_eqb_elim m_eqb_intro: auction.

Lemma m_eqP (x y: fill_type): reflect (x=y)(m_eqb x y).
Proof. apply reflect_intro. split; auto with auction. Qed.
Hint Resolve m_eqP: auction.

Canonical fill_eqType: eqType:= {| Decidable.E:= fill_type; Decidable.eqb:= m_eqb; Decidable.eqP:= m_eqP |}.

Fixpoint bids_of (F: list fill_type) : (list Bid) :=
  match F with
  |nil => nil
  |f::F'=> (bid_of f)::(bids_of F')
  end.

Lemma bids_of_intro (F: list fill_type) (m: fill_type):
  In m F -> (In (bid_of m) (bids_of F)).
Proof. { intro H. induction F. simpl. simpl in H. contradiction. destruct  H.
        subst m. simpl. left. auto. simpl. right. auto. } Qed.

Lemma bids_of_nonempty (F: list fill_type):
  F<>nil -> (bids_of F)<>nil.
Proof. intros. induction F. destruct H. auto. simpl.
apply non_nil_size. simpl. omega. Qed.

Lemma bids_of_elim0 (F: list fill_type) (m: fill_type):
In m F -> In (bid_of m) (bids_of F).
Proof. { induction F as [| a F']. simpl. auto.
         intros. simpl. simpl in H. destruct H.
         left. subst a. auto. right. apply IHF'. exact. } Qed.

Lemma bids_of_delete (F: list fill_type) (m: fill_type):
  In m F -> NoDup (bids_of F) -> (bids_of (delete m F)) = (delete (bid_of m) (bids_of F)).
Proof. { induction F as [| a F']. { simpl. auto. }
         { intros. simpl.
           destruct (m_eqb m a) eqn: Hma.
          { assert (Ht: (b_eqb (bid_of m) (bid_of a))=true).
            move /eqP in Hma. apply /eqP. subst m. auto.
            rewrite Ht. auto. }
            { destruct (b_eqb (bid_of m) (bid_of a)) eqn: Ham.
              { move /eqP in Ham. simpl. rewrite IHF'.
                move /eqP in Hma. eapply element_list with (b:=m)(a:=a). auto. exact.
                 eauto. simpl in H.  destruct H. move /eqP in Hma.
                apply eq_sym ; trivial. subst a. destruct Hma. auto.
                assert (Hbid: ~In (bid_of a) (bids_of F')).  eauto.
                assert (Hbidm: In (bid_of m) (bids_of F')). apply bids_of_elim0. exact.
                rewrite Ham in Hbidm. contradiction. }
               { simpl. rewrite IHF'. move /eqP in Hma.
                 destruct H. symmetry in H. contradiction. exact.
                 eauto. auto. }}}} Qed.

Lemma bids_of_elim (F: list fill_type): forall b, In b (bids_of F)->
                                             exists m, In m F /\ b = bid_of m.
Proof. { intros b H. induction F. simpl in H. contradiction. simpl in H.
       destruct  H as [H1 | H2]. exists a. split; auto.
       apply IHF in H2 as H0. destruct H0 as [m H0]. exists m. destruct H0. split.
       eauto. auto. } Qed.

Lemma bids_of_intro1 (M': list fill_type) (M: list fill_type):
  M [<=] M' -> ((bids_of M)  [<=] (bids_of M')).
Proof.  { intro H. intros b. intro H1. assert (H2: exists m, In m M /\ b=bid_of m).
          apply bids_of_elim. exact. destruct H2. destruct H0. assert (H3: In x M').
          auto. subst b. eapply bids_of_intro. exact. } Qed.

Lemma bids_of_elim1 (M: list fill_type)(m: fill_type)(b: Bid): In b (bids_of (delete m M)) ->
                                                               In b (bids_of M).
Proof. { induction M. simpl. auto. simpl. intros. case (m_eqb m a) eqn: Hm.
         right. exact. simpl in H. destruct H. left. exact. apply IHM in H. right. exact. } Qed.

Lemma count_in_deleted_bids (m: fill_type)(M: list fill_type):
  In m M -> count (bid_of m) (bids_of M) = S (count (bid_of m) (bids_of (delete m M))).
Proof. { induction M.
       { simpl. auto. }
       { intro h1. destruct (m == a) eqn: h2.
         { simpl. rewrite h2. move /eqP in h2.
           subst a. simpl. replace (b_eqb (bid_of m) (bid_of m)) with true. auto. auto. }
         { assert (h1a: In m M).
           { move /eqP in h2. eapply element_list with (b:=m)(a:=a). auto. exact. }
           replace (delete m (a :: M)) with (a :: (delete m M)).
           { simpl. destruct (b_eqb (bid_of m) (bid_of a)) eqn: h3.
             { apply IHM in h1a as h1b. rewrite h1b. auto. }
             { auto. } }
           { simpl. rewrite h2. auto. } } } } Qed.

Lemma included_M_imp_included_bids (M1 M2: list fill_type): included M1 M2 ->
                                                    included (bids_of M1) (bids_of M2).
Proof. { revert M2. induction M1 as [| m1].
       { simpl. auto. }
       { intros M2 h1.
         assert (h2: In m1 M2). eauto.
         assert (h3: included M1 (delete m1 M2)). eauto.
         assert (h3a: included (bids_of M1) (bids_of (delete m1 M2))).
         { auto. }
         assert(h4:count (bid_of m1)(bids_of M2)= S (count (bid_of m1) (bids_of (delete m1 M2)))).
         { eauto using count_in_deleted_bids. }
         eapply included_intro.
         intro x.  simpl. destruct (b_eqb x (bid_of m1)) eqn: C1.
         { (* ---- C1: x = b1 ---- *)
           move /b_eqP in C1. subst x.
           rewrite h4.
           eapply included_elim in h3a  as h3b. instantiate (1 := bid_of m1) in h3b.
           omega. }
         { (*----- C1: x <> b1 ---- *)
           assert (h3b: included M1 M2). eapply included_elim4; apply h1.
           apply IHM1 in h3b as h3c. auto. } } } Qed.

Lemma bids_of_perm (M M': list fill_type): perm M M' -> perm (bids_of M) (bids_of M').
Proof. { intro H. unfold perm in H. move /andP in H. destruct H.
         unfold perm. apply /andP. split. all: eapply included_M_imp_included_bids;exact. } Qed.

Lemma bids_of_nodup (F: list fill_type): NoDup (bids_of F) -> NoDup F.
Proof. { intro H. induction F. auto. assert (H1:NoDup (bids_of F)).
         simpl in H. eauto. apply IHF in H1 as H2. simpl in H.
         assert (~In (bid_of a) (bids_of F)). eauto.
         assert (~In a (F)). intro.  assert (H4:In (bid_of a) (bids_of F)).
         apply bids_of_elim0. exact. contradiction. eauto. } Qed.

Lemma bids_of_delete_delete (F: list fill_type) (m1 m2: fill_type):
  In m1 F -> In m2 F -> NoDup (bids_of F) ->
(bids_of (delete m1 (delete m2 F))) = (delete (bid_of m1) (delete (bid_of m2) (bids_of F))).
Proof. { intros. assert (Hm1m2: m1=m2\/m1<>m2). eapply reflect_EM. auto.
       destruct Hm1m2.
       { subst m1. simpl. assert (H2:(delete m2 (delete m2 F)) = delete m2 F).
         { assert (H3:~In m2 (delete m2 F) ). { apply delete_intro2. apply bids_of_nodup.
         exact. } apply delete_intro1 in H3. auto. }
         assert (H3:(delete (bid_of m2) (delete (bid_of m2) (bids_of F))) = (delete (bid_of m2) (bids_of F))).
         { assert (H4:~In (bid_of m2) (delete (bid_of m2) (bids_of F))). { apply delete_intro2.  exact. } apply delete_intro1 in H4. auto. }
         rewrite H2. rewrite H3. apply bids_of_delete. exact. exact. }
       { assert (H3: (bids_of (delete m2 F)) = (delete (bid_of m2) (bids_of F))).
         apply bids_of_delete. exact. exact.
         assert (H4: (bids_of (delete m1 (delete m2 F))) =
         (delete (bid_of m1) ((delete (bid_of m2) (bids_of F))))).
         rewrite <- H3. apply bids_of_delete. apply delete_intro. exact.  exact.
         { assert (H4: (bids_of (delete m2 F)) = delete (bid_of m2) (bids_of F)).
           apply bids_of_delete. exact. exact. rewrite H4. eauto. } exact. }} Qed.

Fixpoint asks_of (F: list fill_type) : (list Ask) :=
  match F with
  |nil => nil
  |f::F'=> (ask_of f)::(asks_of F')
  end.

Lemma asks_of_intro (F: list fill_type) (m: fill_type):
  In m F -> (In (ask_of m) (asks_of F)).
Proof. { intro H. induction F. simpl. simpl in H. contradiction. destruct  H.
         subst m. simpl. left. auto. simpl. right. auto. } Qed.

Lemma asks_of_nonempty (F: list fill_type):
  F<>nil -> (asks_of F)<>nil.
Proof. intros. induction F. destruct H. auto. simpl.
apply non_nil_size. simpl. omega. Qed.

Lemma asks_of_elim0 (F: list fill_type) (m: fill_type):
In m F -> In (ask_of m) (asks_of F).
Proof. { induction F as [| a F']. simpl. auto.
         intros. simpl. simpl in H. destruct H.
         left. subst a. auto. right. apply IHF'. exact. } Qed.
(*TODO: automate the following Lemma*)
Lemma asks_of_delete (F: list fill_type) (m: fill_type):
  In m F -> NoDup (asks_of F) -> (asks_of (delete m F)) = (delete (ask_of m) (asks_of F)).
Proof. { induction F as [| a F']. { simpl. auto. }
         { intros. simpl.
           destruct (m_eqb m a) eqn: Hma.
          { assert (Ht: (a_eqb (ask_of m) (ask_of a))=true).
            move /eqP in Hma. apply /eqP. subst m. auto.
            rewrite Ht. auto. }
            { destruct (a_eqb (ask_of m) (ask_of a)) eqn: Ham.
              { move /eqP in Ham. simpl. rewrite IHF'.
                move /eqP in Hma.
                destruct H. symmetry in H. contradiction. exact.
                eauto. simpl in H.  destruct H. move /eqP in Hma.
                apply eq_sym ; trivial. subst a. destruct Hma. auto.
                assert (Hask: ~In (ask_of a) (asks_of F')).  eauto.
                assert (Haskm: In (ask_of m) (asks_of F')). apply asks_of_elim0. exact.
                rewrite Ham in Haskm. contradiction. }
               { simpl. rewrite IHF'. move /eqP in Hma.
                 destruct H. symmetry in H. contradiction. exact.
                 eauto. auto. }}}} Qed.

Lemma asks_of_elim (F: list fill_type): forall a, In a (asks_of F)->
                                            exists m, In m F /\ a = ask_of m.
Proof. { intros b H. induction F. simpl in H. contradiction. simpl in H.
       destruct  H as [H1 | H2]. exists a. split; auto.
       apply IHF in H2 as H0. destruct H0 as [m H0]. exists m. destruct H0. split.
       eauto. auto. } Qed.

Lemma asks_of_intro1 (M': list fill_type) (M: list fill_type):
  M [<=] M' -> ((asks_of M)  [<=] (asks_of M')).
Proof.  { intro H. intros a. intro H1. assert (H2: exists m, In m M /\ a=ask_of m).
          apply asks_of_elim. exact. destruct H2. destruct H0. assert (H3: In x M').
          auto. subst a. eapply asks_of_intro. exact. } Qed.

Lemma asks_of_elim1 (M: list fill_type)(m: fill_type)(a: Ask): In a (asks_of (delete m M)) ->
                                                               In a (asks_of M).
Proof. { induction M. simpl. auto. simpl. intros. case (m_eqb m a0) eqn: Hm.
         right. exact. simpl in H. destruct H. left. exact. apply IHM in H.
         right. exact. } Qed.

Lemma count_in_deleted_asks (m: fill_type)(M: list fill_type):
  In m M -> count (ask_of m) (asks_of M) = S (count (ask_of m) (asks_of (delete m M))).
Proof. { induction M.
       { simpl. auto. }
       { intro h1. destruct (m == a) eqn: h2.
         { simpl. rewrite h2. move /eqP in h2.
           subst a. simpl. replace (a_eqb (ask_of m) (ask_of m)) with true. auto. auto. }
         { assert (h1a: In m M).
           { move /eqP in h2. eapply element_list with (b:=m)(a:=a). auto. exact. }
           replace (delete m (a :: M)) with (a :: (delete m M)).
           { simpl. destruct (a_eqb (ask_of m) (ask_of a)) eqn: h3.
             { apply IHM in h1a as h1b. rewrite h1b. auto. }
             { auto. } }
           { simpl. rewrite h2. auto. } } } } Qed.

Lemma included_M_imp_included_asks (M1 M2: list fill_type): included M1 M2 ->
                                                    included (asks_of M1) (asks_of M2).
Proof. { revert M2. induction M1 as [| m1].
       { simpl. auto. }
       { intros M2 h1.
         assert (h2: In m1 M2). eauto.
         assert (h3: included M1 (delete m1 M2)). eauto.
         assert (h3a: included (asks_of M1) (asks_of (delete m1 M2))).
         { auto. }
         assert(h4:count (ask_of m1)(asks_of M2)= S (count (ask_of m1) (asks_of (delete m1 M2)))).
         { eauto using count_in_deleted_asks. }
         eapply included_intro.
         intro x.  simpl. destruct (a_eqb x (ask_of m1)) eqn: C1.
         { (* ---- C1: x = b1 ---- *)
           move /a_eqP in C1. subst x.
           rewrite h4.
           eapply included_elim in h3a  as h3b. instantiate (1 := ask_of m1) in h3b.
           omega. }
         { (*----- C1: x <> b1 ---- *)
           assert (h3b: included M1 M2). eapply included_elim4; apply h1.
           apply IHM1 in h3b as h3c. auto. } } } Qed.

Lemma asks_of_perm (M M': list fill_type): perm M M' -> perm (asks_of M) (asks_of M').
Proof. { intro H. unfold perm in H. move /andP in H. destruct H.
         unfold perm. apply /andP. split. all: eapply included_M_imp_included_asks;exact. } Qed.

Lemma asks_of_nodup (F: list fill_type): NoDup (asks_of F) -> NoDup F.
Proof. { intro H. induction F. auto. assert (H1:NoDup (asks_of F)).
         simpl in H. eauto. apply IHF in H1 as H2. simpl in H.
         assert (~In (ask_of a) (asks_of F)). eauto.
         assert (~In a (F)). intro.  assert (H4:In (ask_of a) (asks_of F)).
         apply asks_of_elim0. exact. contradiction. eauto. } Qed.

Lemma asks_of_delete_delete (F: list fill_type) (m1 m2: fill_type):
  In m1 F -> In m2 F -> NoDup (asks_of F) ->
(asks_of (delete m1 (delete m2 F))) = (delete (ask_of m1) (delete (ask_of m2) (asks_of F))).
Proof. { intros. assert (Hm1m2: m1=m2\/m1<>m2). eapply reflect_EM. auto.
       destruct Hm1m2.
       { subst m1. simpl. assert (H2:(delete m2 (delete m2 F)) = delete m2 F).
         { assert (H3:~In m2 (delete m2 F) ). { apply delete_intro2. apply asks_of_nodup.
         exact. } apply delete_intro1 in H3. auto. }
         assert (H3:(delete (ask_of m2) (delete (ask_of m2) (asks_of F))) = (delete (ask_of m2) (asks_of F))).
         { assert (H4:~In (ask_of m2) (delete (ask_of m2) (asks_of F))). { apply delete_intro2.  exact. } apply delete_intro1 in H4. auto. }
         rewrite H2. rewrite H3. apply asks_of_delete. exact. exact. }
       { assert (H3: (asks_of (delete m2 F)) = (delete (ask_of m2) (asks_of F))).
         apply asks_of_delete. exact. exact.
         assert (H4: (asks_of (delete m1 (delete m2 F))) =
         (delete (ask_of m1) ((delete (ask_of m2) (asks_of F))))).
         rewrite <- H3. apply asks_of_delete. apply delete_intro. exact.  exact.
         { assert (H4: (asks_of (delete m2 F)) = delete (ask_of m2) (asks_of F)).
           apply asks_of_delete. exact. exact. rewrite H4. eauto. } exact. }} Qed.

Fixpoint trade_prices_of (F: list fill_type) : (list nat) :=
  match F with
  |nil => nil
  |f::F'=> (tp f)::(trade_prices_of F')
  end.

Lemma trade_prices_of_intro (F: list fill_type) (m: fill_type):
  In m F -> In (tp m) (trade_prices_of F).
Proof. { intro H. induction F. eauto. destruct H. subst m.
       simpl. left;auto. simpl. right;auto.
       } Qed.

Lemma trade_prices_of_elim (F: list fill_type): forall p, In p (trade_prices_of F) ->
                                                     exists m, In m F /\ p = tp m.
Proof. { intros p H. induction F. simpl in H. contradiction. simpl in H. destruct H.
       exists a. split. eauto. auto. apply IHF in H as H0. destruct  H0 as [m H0].
       destruct H0 as [H1 H2]. exists m. split;eauto. } Qed.

Lemma count_in_deleted_tp (m: fill_type)(M: list fill_type):
  In m M -> count (tp m)(trade_prices_of M) = S (count (tp m) (trade_prices_of (delete m M))).
  Proof.  { induction M.
       { simpl. auto. }
       { intro H1. destruct (m == a) eqn: H2.
         { simpl. rewrite H2. move /eqP in H2.
           subst a. simpl. replace (tp m =? tp m) with true. auto. auto. }
         { assert (H1a: In m M).
           { move /eqP in H2. eapply element_list with (b:=m)(a:=a). auto. exact. }
           replace (delete m (a :: M)) with (a :: (delete m M)).
           { simpl. destruct (tp m =? tp a) eqn: H3.
             { apply IHM in H1a as H1b. rewrite H1b. auto. }
             { auto. } }
           { simpl. rewrite H2. auto. } } } } Qed.

Lemma included_M_imp_included_tps (M M': list fill_type):
 included M M' -> included (trade_prices_of M) (trade_prices_of M').
 Proof. Proof. { revert M'. induction M as [| m].
       { simpl. auto. }
       { intros M' H1.
         assert (H2: In m M'). eauto.
         assert (H3: included M (delete m M')). eauto.
         assert (H3a: included (trade_prices_of M) (trade_prices_of (delete m M'))).
         { auto. }
         assert(H4:count (tp m)(trade_prices_of M')= S (count (tp m) (trade_prices_of (delete m M')))).
         { eauto using count_in_deleted_tp. }
         eapply included_intro.
         intro x.  simpl. destruct (x =? tp m) eqn: C1.
         { (* ---- C1: x = b1 ---- *)
           move /nat_eqP in C1. subst x.
           rewrite H4.
           eapply included_elim in H3a  as H3b. instantiate (1 :=tp m) in H3b.
           omega. }
         { (*----- C1: x <> b1 ---- *)
           assert (H3b: included M M'). eapply included_elim4; apply H1.
           apply IHM in H3b as H3c. auto. } } } Qed.

Lemma tps_of_perm (M M': list fill_type):
 perm M M' -> perm (trade_prices_of M) (trade_prices_of M').
Proof. { intro H. unfold perm in H. move /andP in H. destruct H.
         unfold perm. apply /andP. split. all: eapply included_M_imp_included_tps.
         exact. exact. } Qed.

Hint Resolve bids_of_intro bids_of_elim asks_of_intro asks_of_elim: core.
Hint Resolve trade_prices_of_intro trade_prices_of_elim: core.

Hint Resolve asks_of_intro1 bids_of_intro1 asks_of_perm bids_of_perm: core.
Hint Resolve bids_of_elim1 asks_of_elim1: core.

End BidAsk.

Definition b0 := {|bp:=0;idb:=0|}.
Definition a0 := {|sp:=0;ida:=0|}.
Definition m0 := {|bid_of:=b0;ask_of:=a0;tp:=0|}.

Hint Resolve b_eqb_ref b_eqP : core.
Hint Immediate b_eqb_elim b_eqb_intro: core.

Hint Resolve a_eqb_ref a_eqP : core.
Hint Immediate a_eqb_intro a_eqb_elim: core.

Hint Resolve bid_prices_elim bid_prices_intro bid_prices_intro1: core.
Hint Resolve ask_prices_elim ask_prices_intro ask_prices_intro1: core.

Hint Resolve m_eqb_ref m_eqP: core.
Hint Immediate m_eqb_elim m_eqb_intro: core.

Hint Resolve bids_of_intro bids_of_elim asks_of_intro asks_of_elim: core.
Hint Resolve trade_prices_of_intro trade_prices_of_elim: core.

Hint Resolve asks_of_intro1 bids_of_intro1 asks_of_perm bids_of_perm: core.

Hint Resolve bids_of_perm asks_of_perm tps_of_perm: core.
Hint Resolve bids_of_elim1 asks_of_elim1: core.


From Coq Require Import
     Arith.PeanoNat
     Lists.List
     Strings.String
     Morphisms
     Setoid
     RelationClasses.

From ExtLib Require Import
     Data.String
     Structures.Monad
     Structures.Traversable
     Data.Monads.StateMonad
     Data.List
     Data.Map.FMapAList.

From ITree Require Import
     ITree
     Basics.CategoryKleisli
     Events.State
     Events.MapDefault.

From Coinduction Require Import
	coinduction rel tactics.

From CTree Require Import
     CTree
     Eq
     Interp.Interp
     Interp.State.

Import ListNotations.
Import MonadNotation.
Local Open Scope monad_scope.
Local Open Scope string_scope.

(*|
Imp manipulates a countable set of variables represented as [string]s:
|*)
Definition var : Set := string.

(*|
For simplicity, the language manipulates [nat]s as values.
|*)
Definition value : Type := nat.

Inductive expr : Type :=
| Var (_ : var)
| Lit (_ : value)
| Plus  (_ _ : expr)
| Minus (_ _ : expr)
| Mult  (_ _ : expr).

(*|
Imp with a non-deterministic branching statement
|*)
Inductive stmt : Type :=
| Assign (x : var) (e : expr)    (* x = e *)
| Seq    (a b : stmt)            (* a ; b *)
| If     (i : expr) (t e : stmt) (* if (i) then { t } else { e } *)
| While  (t : expr) (b : stmt)   (* while (t) { b } *)
| Branch (a b : stmt)            (* br { a } or { b } *)
| Skip                           (* ; *)
| Block
.

Variant MemE : Type -> Type :=
| rd (x : var) : MemE value
| wr (x : var) (v : value) : MemE unit.

Section Semantics.
  Fixpoint denote_expr (e : expr) : ctree MemE value :=
    match e with
    | Var v     => trigger (rd v)
    | Lit n     => ret n
    | Plus a b  => l <- denote_expr a ;; r <- denote_expr b ;; ret (l + r)
    | Minus a b => l <- denote_expr a ;; r <- denote_expr b ;; ret (l - r)
    | Mult a b  => l <- denote_expr a ;; r <- denote_expr b ;; ret (l * r)
    end.

  Definition while (step : ctree MemE (unit + unit)) : ctree MemE unit :=
    CTree.iter (fun _ => step) tt.

  Definition is_true (v : value) : bool := if (v =? 0)%nat then false else true.

  Fixpoint denote_imp (s : stmt) : ctree MemE unit :=
    match s with
    | Assign x e =>  v <- denote_expr e ;; trigger (wr x v)
    | Seq a b    =>  denote_imp a ;; denote_imp b
    | If i t e   =>
      v <- denote_expr i ;;
      if is_true v then denote_imp t else denote_imp e

    | While t b =>
      while (v <- denote_expr t ;;
	         if is_true v
             then denote_imp b ;; ret (inl tt)
             else ret (inr tt))

    | Branch a b => brD2 (denote_imp a) (denote_imp b)

    | Skip => ret tt

    | Block => CTree.stuckD

    end.

  (* list of key value pairs *)
  Definition env := alist var value.

  Definition handle_imp : MemE ~> Monads.stateT env (ctree void1) :=
    fun _ e s =>
      match e with
      | rd x => Ret (s, lookup_default x 0 s)
      | wr x v => Ret (Maps.add x v s, tt)
      end.

  Definition interp_imp t : Monads.stateT env (ctree void1) unit :=
    interp_state handle_imp t.

End Semantics.
Notation "⟦ c ⟧" := (denote_imp c).
Notation "'ℑ' c" := (interp_imp (denote_imp c)) (at level 10).

Section Theory.

(*|
  Given the direct translation of the [Branch] construction, the
  primitive equational theory that we have at the [ctree] level is
  straightforwardly lifted to the language level, more specifically
  at the level of uninterpreted ctrees.
|*)
  Lemma branch_commut : forall (a b : stmt),
      ⟦Branch a b⟧ ~ ⟦Branch b a⟧.
  Proof.
    intros; apply brD2_commut.
  Qed.

  Lemma branch_assoc : forall (a b c : stmt),
      ⟦Branch a (Branch b c)⟧ ~ ⟦Branch (Branch a b) c⟧.
  Proof.
    intros; cbn.
    now rewrite brD2_assoc.
  Qed.

  Lemma branch_idem : forall a : stmt,
      ⟦Branch a a⟧ ~ ⟦a⟧.
  Proof.
    intros; apply brD2_idem.
  Qed.

  Lemma branch_congr : forall a a' b b',
      ⟦a⟧ ~ ⟦a'⟧ ->
      ⟦b⟧ ~ ⟦b'⟧ ->
      ⟦Branch a b⟧ ~ ⟦Branch a' b'⟧.
  Proof.
    intros. cbn. apply sb_brD_id.
    intro; destruct x; rewrite ?H, ?H0; reflexivity.
  Qed.

  Lemma branch_block_l : forall a : stmt,
      ⟦Branch Block a⟧ ~ ⟦a⟧.
  Proof.
    intros; apply brD2_stuckD_l.
  Qed.

  Lemma branch_block_r : forall a : stmt,
      ⟦Branch a Block⟧ ~ ⟦a⟧.
  Proof.
    intros; apply brD2_stuckD_r.
  Qed.

(*|
  Strong bisimilarity at the uninterpreted level can be transported
  freely after interpretation via [interp_state_sbisim].
  For instance here transporting [branch_block_r].
|*)

  Lemma handle_imp_is_simple :
    forall (X : Type) (e : MemE X) (s : env), vsimple (E := void1) (handle_imp _ e s).
  Proof.
    unfold handle_imp, h_state, vsimple. intros. destruct e; eauto.
  Qed.

  Lemma branch_block_r_interp : forall (a : stmt) s,
    ℑ (Branch a Block) s ~
    ℑ a s.
  Proof.
    epose proof interp_state_sbisim handle_imp handle_imp_is_simple.
    intros. rewrite branch_block_r. reflexivity.
  Qed.

  Lemma filter_filter : forall {A} f (l : list A), filter f (filter f l) = filter f l.
  Proof.
    intros. induction l.
    - reflexivity.
    - cbn. destruct (f a) eqn:?.
      + cbn. rewrite Heqb. f_equal. apply IHl.
      + apply IHl.
  Qed.

  Lemma alist_add_alist_add : forall {K RD_K V}, RelDec.RelDec_Correct (RD_K) ->
    forall k v v' l, @alist_add K eq RD_K V k v (alist_add _ k v' l) = alist_add _ k v l.
  Proof.
    intros. unfold alist_add, alist_remove. cbn. rewrite filter_filter.
    rewrite RelDec.rel_dec_eq_true; auto.
  Qed.

(*|
Finally, we can put bits together to prove that the programs [p3] and [br p2 or p3]
from Section 2 are indeed equivalent.
|*)
  Example branch_ex : forall s : env,
      ℑ (Branch
           (Seq
              (Assign "x" (Lit 0))
              (Assign "x" (Lit 1)))
           Block) s ~
        ℑ (Assign "x" (Lit 1)) s.
  Proof with (unfold interp_imp).
    intros...
    rewrite branch_block_r_interp...
    rewrite 2 unfold_interp_state.
    cbn. setoid_rewrite sb_guard.
    setoid_rewrite bind_ret_l. rewrite interp_state_ret.
    play.
    - rewrite unfold_interp_state in TR. cbn in TR. rewrite bind_ret_l in TR.
      inv_trans. cbn in TR.
      rewrite unfold_interp_state in TR. cbn in TR.
      inv_trans. subst.
      rewrite alist_add_alist_add. 2: apply RelDec_Correct_string.
      apply equ_sbisim_subrelation in EQ.
      eexists; etrans.
    - inv_trans. subst. eexists.
      rewrite unfold_interp_state. cbn. rewrite bind_ret_l.
      apply trans_guard. rewrite unfold_interp_state. cbn.
      rewrite alist_add_alist_add. 2: apply RelDec_Correct_string.
      etrans. now rewrite EQ.
  Qed.

End Theory.


Require Export PredMonad.Reflection2.OrderedType.
Require Export PredMonad.Reflection2.OrderedContext.

(***
 *** Helper Tactics
 ***)

(* FIXME: move these somewhere sensible! *)
Ltac destruct_ands :=
  repeat (lazymatch goal with | H:_ /\ _ |- _ => destruct H | _ => idtac end).
Ltac split_ands :=
  repeat (lazymatch goal with | |- _ /\ _ => split | _ => idtac end).

(***
 *** Ordered Expressions
 ***)

Inductive OVar A {RA} : Ctx -> Type :=
| OVar_0 {ctx} : OVar A (@CtxCons A RA ctx)
| OVar_S {B RB ctx} : OVar A ctx -> OVar A (@CtxCons B RB ctx)
.

Arguments OVar_0 {A RA ctx}.
Arguments OVar_S {A RA B RB ctx} v.

(* Expressions to represent proper functions *)
Inductive OExpr ctx : forall A {RA:OType A}, Type :=
| Var {A RA} (v:OVar A ctx) : @OExpr ctx A RA
| Embed {A RA} (a:A) : @OExpr ctx A RA
| App {A RA B RB} (e1 : OExpr ctx (A -o> B)) (e2 : @OExpr ctx A RA) :
    @OExpr ctx B RB
| Lam {A RA B RB} (e: @OExpr (@CtxCons A RA ctx) B RB) :
    OExpr ctx (A -o> B)
.

Arguments Var {ctx A RA} v.
Arguments Embed {ctx A RA} a.
Arguments App {ctx A RA B RB} e1 e2.
Arguments Lam {ctx A RA B RB} e.

(***
 *** Helpers for Building OExprs
 ***)

Notation "e1 @e@ e2" :=
  (App e1 e2) (left associativity, at level 20).

(* Apply a context extension to an OVar *)
Fixpoint extendVar {ctx1 ctx2} {ext:ContextExtends ctx1 ctx2} :
  forall {A} {RA:OType A}, OVar A ctx1 -> OVar A ctx2 :=
  match ext in ContextExtendsInd _ ctx2 return
        forall A (RA:OType A), OVar A ctx1 -> OVar A ctx2
  with
  | CtxExtNil _ => fun _ _ v => v
  | CtxExtCons _ _ _ ext' =>
    fun _ _ v => OVar_S (extendVar (ext:=ext') v)
  end.

Definition mkLam {ctx A RA B RB}
           (body: (forall ctx2,
                      ContextExtends (CtxCons A ctx) ctx2 -> @OExpr ctx2 A RA) ->
                  OExpr (CtxCons A ctx) B) :
  OExpr ctx (A -o> B) :=
  @Lam ctx A RA B RB (body (fun _ ext => Var (extendVar (ext:=ext) OVar_0))).

Notation "'efun' x => e" :=
  (mkLam (fun (x : forall {ctx2 ext}, OExpr _ _) => e))
    (right associativity, at level 99).
Notation "'efun' ( x : A ) => e" :=
  (mkLam (fun (x : forall {ctx2 ext}, OExpr _ A) => e))
    (right associativity, at level 99, x at level 99).

(***
 *** Semantics of Ordered Expressions
 ***)

(* The semantics of a variable *)
Fixpoint varSemantics {A RA ctx} (v:@OVar A RA ctx) :
  CtxElem ctx -o> A :=
  match v in OVar _ ctx return CtxElem ctx -o> A with
  | OVar_0 => ctx_head_ofun
  | OVar_S v' => compose_ofun ctx_tail_ofun (varSemantics v')
  end.
Arguments varSemantics {A RA ctx} !v.

(* The semantics of an ordered expression *)
Fixpoint exprSemantics {ctx A RA} (e:@OExpr ctx A RA) : CtxElem ctx -o> A :=
  match e in @OExpr _ A RA return CtxElem ctx -o> A with
  | Var v => varSemantics v
  | Embed a => const_ofun a
  | App e1 e2 => ofun_apply (exprSemantics e1) (exprSemantics e2)
  | Lam e => ofun_curry (exprSemantics e)
  end.
Arguments exprSemantics {ctx A RA} !e.

Definition evalExpr {A RA} (e:@OExpr CtxNil A RA) : A :=
  exprSemantics e @o@ tt.
Arguments evalExpr {A RA} !e.

(***
 *** Relating Ordered Expressions
 ***)

(* Two expressions are related iff their semantics are *)
Definition oexpr_leq {ctx A RA} (e1 e2:@OExpr ctx A RA) : Prop :=
  exprSemantics e1 <o= exprSemantics e2.
Arguments oexpr_leq {ctx A RA} e1 e2 : simpl never.

(* oexpr_leq is a PreOrder *)
Instance PreOrder_oexpr_leq ctx A RA : PreOrder (@oexpr_leq ctx A RA).
Proof.
  unfold oexpr_leq; split; intro; intros.
  - reflexivity.
  - etransitivity; [ apply H | apply H0 ].
Qed.

(* Two expressions are equivalenct iff their semantics are *)
Definition oexpr_eq {ctx A RA} (e1 e2:@OExpr ctx A RA) : Prop :=
  exprSemantics e1 =o= exprSemantics e2.
Arguments oexpr_eq {ctx A RA} e1 e2 : simpl never.

(* oexpr_eq is a Equivalence *)
Instance Equivalence_oexpr_eq ctx A RA : Equivalence (@oexpr_eq ctx A RA).
Proof.
  unfold oexpr_eq; split; intro; intros.
  - reflexivity.
  - symmetry; assumption.
  - etransitivity; [ apply H | apply H0 ].
Qed.

Notation "x <e= y" :=
  (oexpr_leq x y) (no associativity, at level 70).
Notation "x =e= y" :=
  (oexpr_eq x y) (no associativity, at level 70).

(* The Embed constructor is Proper w.r.t. oleq and oexpr_leq *)
Instance Proper_Embed ctx A RA :
  Proper (oleq ==> oexpr_leq) (@Embed ctx A RA).
Proof.
  intros a1 a2 Ra; unfold oexpr_leq; simpl.
  apply Proper_const_ofun. assumption.
Qed.

(* The Embed constructor is Proper w.r.t. oeq and oexpr_eq *)
Instance Proper_Embed_equiv ctx A RA :
  Proper (oeq ==> oexpr_eq) (@Embed ctx A RA).
Proof.
  intros a1 a2 Ra. destruct Ra; split; apply Proper_Embed; assumption.
Qed.

(* The App constructor is Proper *)
Instance Proper_App ctx A RA B RB :
  Proper (oexpr_leq ==> oexpr_leq ==> oexpr_leq) (@App ctx A RA B RB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. unfold oexpr_leq; simpl.
  apply Proper_ofun_apply; assumption.
Qed.

(* The App constructor is Proper for equivalence *)
Instance Proper_App_equiv ctx A RA B RB :
  Proper (oexpr_eq ==> oexpr_eq ==> oexpr_eq) (@App ctx A RA B RB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. unfold oexpr_eq; simpl.
  apply Proper_ofun_apply_equiv; assumption.
Qed.

(* The Lam constructor is Proper *)
Instance Proper_Lam ctx A RA B RB :
  Proper (oexpr_leq ==> oexpr_leq) (@Lam ctx A RA B RB).
Proof.
  intros e1 e2 Re. unfold oexpr_leq; simpl.
  apply Proper_ofun_curry. assumption.
Qed.

(* The Lam constructor is Proper for equivalence *)
Instance Proper_Lam_equiv ctx A RA B RB :
  Proper (oexpr_eq ==> oexpr_eq) (@Lam ctx A RA B RB).
Proof.
  intros e1 e2 Re. unfold oexpr_eq; simpl.
  apply Proper_ofun_curry_equiv. assumption.
Qed.

(***
 *** Weakening for Ordered Expressions
 ***)

(* Weakening / lifting of ordered expression variables *)
Fixpoint weakenOVar w W {RW} :
  forall {ctx A RA}, @OVar A RA ctx -> OVar A (@ctxInsert w W RW ctx) :=
  match w return forall ctx A RA,
      OVar A ctx -> OVar A (ctxInsert w W ctx) with
  | 0 => fun _ _ _ v => OVar_S v
  | S w' =>
    fun ctx A RA v =>
      match v in OVar _ ctx return OVar A (ctxInsert (S w') W ctx) with
      | OVar_0 => OVar_0
      | OVar_S v' => OVar_S (weakenOVar w' W v')
      end
  end.
Arguments weakenOVar w W {RW ctx A RA} v : simpl nomatch.

(* Correctness of weakenOVar: it is equivalent to weaken_ofun *)
Lemma weakenOVar_correct w W {RW ctx A RA} (v:@OVar A RA ctx) :
  varSemantics (@weakenOVar w W RW ctx A RA v) =o=
  compose_ofun (weaken_ofun w W ctx) (varSemantics v).
Proof.
  revert ctx v; induction w; intros; [ | destruct v ]; simpl.
  - reflexivity.
  - rewrite compose_pair_snd. reflexivity.
  - rewrite compose_compose_ofun. rewrite compose_pair_fst.
    rewrite <- compose_compose_ofun. f_equiv. apply IHw.
Qed.

(* Weakening / lifting of ordered expressions *)
Fixpoint weakenOExpr w W {RW:OType W} {ctx A RA}
         (e:@OExpr ctx A RA) : OExpr (ctxInsert w W ctx) A :=
  match e in OExpr _ A return OExpr (ctxInsert w W ctx) A with
  | Var v => Var (weakenOVar w W v)
  | Embed a => Embed a
  | App e1 e2 => App (weakenOExpr w W e1) (weakenOExpr w W e2)
  | Lam e => Lam (weakenOExpr (S w) W e)
  end.

(* Correctness of weakenOExpr: it is equivalent to weaken_ofun *)
Lemma weakenOExpr_correct w W {RW ctx A RA} (e:@OExpr ctx A RA) :
  exprSemantics (@weakenOExpr w W RW ctx A RA e) =o=
  compose_ofun (weaken_ofun w W ctx) (exprSemantics e).
  revert w; induction e; intros; simpl.
  - apply weakenOVar_correct.
  - rewrite compose_f_const_ofun; try typeclasses eauto. reflexivity.
  - rewrite compose_ofun_apply; try typeclasses eauto.
    rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite compose_ofun_curry; try typeclasses eauto.
    f_equiv. apply (IHe (S w)).
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr w W RW ctx A RA :
  Proper (oexpr_leq ==> oexpr_leq) (@weakenOExpr w W RW ctx A RA).
Proof.
  intros e1 e2 Re. unfold oexpr_leq.
  etransitivity; [ apply weakenOExpr_correct | ].
  etransitivity; [ | apply weakenOExpr_correct ].
  f_equiv. assumption.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr_equiv w W RW ctx A RA :
  Proper (oexpr_eq ==> oexpr_eq) (@weakenOExpr w W RW ctx A RA).
Proof.
  intros e1 e2 Re. unfold oexpr_eq.
  etransitivity; [ apply weakenOExpr_correct | ].
  etransitivity; [ | symmetry; apply weakenOExpr_correct ].
  f_equiv. assumption.
Qed.

(***
 *** Substitution for Ordered Variables
 ***)

(* Substitution for ordered expression variables *)
Fixpoint substOVar n {ctx A RA} :
  @OVar A RA ctx -> @OExpr (ctxSuffix n ctx) (ctxNth ctx n) (ctxNthOType ctx n) ->
  OExpr (ctxDelete n ctx) A :=
  match n return
        OVar A ctx -> OExpr (ctxSuffix n ctx) (ctxNth ctx n) ->
        OExpr (ctxDelete n ctx) A
  with
  | 0 =>
    fun v =>
      match v in OVar _ ctx return
            OExpr (ctxSuffix 0 ctx) (ctxNth ctx 0) ->
            OExpr (ctxDelete 0 ctx) A
      with
      | OVar_0 => fun s => s
      | OVar_S v' => fun _ => Var v'
    end
  | S n' =>
    fun v =>
      match v in OVar _ ctx return
            OExpr (ctxSuffix (S n') ctx) (ctxNth ctx (S n')) ->
            OExpr (ctxDelete (S n') ctx) A
      with
      | OVar_0 => fun _ => Var OVar_0
      | @OVar_S _ _ B RB ctx' v' =>
        fun (s: @OExpr _ _ (ctxNthOType _ _)) =>
          weakenOExpr 0 B (substOVar n' (ctx:=ctx') v' s)
      end
  end.
Arguments substOVar !n {ctx A RA} !v s.

(* Correctness of substOVar: it is equivalent to subst_ofun *)
Lemma substOVar_correct n {ctx A RA} (v:@OVar A RA ctx) s :
  exprSemantics (substOVar n v s) =o=
  compose_ofun (subst_ofun ctx n (exprSemantics s)) (varSemantics v).
Proof.
  revert n s; induction v; intros; destruct n; simpl.
  - symmetry; apply compose_pair_snd.
  - symmetry; apply compose_pair_snd.
  - rewrite compose_compose_ofun. rewrite compose_pair_fst.
    rewrite id_compose_ofun. reflexivity.
  - etransitivity; [ apply (weakenOExpr_correct 0) | ].
    rewrite compose_compose_ofun. rewrite compose_pair_fst.
    rewrite <- compose_compose_ofun. f_equiv. apply IHv.
Qed.

(* substOVar is Proper in its s argument *)
Instance Proper_substOVar n {ctx A RA} v :
  Proper (oexpr_leq ==> oexpr_leq) (@substOVar n ctx A RA v).
Proof.
  revert ctx v; induction n; intros; destruct v; intros e1 e2 Re; simpl.
  - assumption.
  - reflexivity.
  - reflexivity.
  - apply (Proper_weakenOExpr 0). apply IHn. assumption.
Qed.

(* substOVar is Proper in its s argument *)
Instance Proper_substOVar_equiv n {ctx A RA} v :
  Proper (oexpr_eq ==> oexpr_eq) (@substOVar n ctx A RA v).
Proof.
  intros e1 e2 Re; destruct Re; split; apply Proper_substOVar; assumption.
Qed.

(***
 *** Substitution for Ordered Expressions
 ***)

(* Substitution for ordered expressions *)
Fixpoint substOExpr n {ctx A RA} (e:@OExpr ctx A RA) :
  OExpr (ctxSuffix n ctx) (ctxNth ctx n) -> OExpr (ctxDelete n ctx) A :=
  match e with
  | Var v => fun s => substOVar n v s
  | Embed a => fun _ => Embed a
  | App e1 e2 => fun s => App (substOExpr n e1 s) (substOExpr n e2 s)
  | Lam e => fun s => Lam (substOExpr (S n) e s)
  end.
Arguments substOExpr n {ctx A RA} !e.

(* Correctness of substOExpr: it is equivalent to subst_ofun *)
Lemma substOExpr_correct n {ctx A RA} (e:@OExpr ctx A RA) s :
  exprSemantics (substOExpr n e s) =o=
  compose_ofun (subst_ofun ctx n (exprSemantics s)) (exprSemantics e).
Proof.
  revert n s; induction e; intros; simpl.
  - apply substOVar_correct.
  - symmetry. apply compose_f_const_ofun.
  - etransitivity; [ | symmetry; apply compose_ofun_apply ];
      try typeclasses eauto.
    apply Proper_ofun_apply_equiv; [ apply IHe1 | apply IHe2 ].
  - etransitivity; [ | symmetry; apply compose_ofun_curry ];
      try typeclasses eauto.
    f_equiv.
    apply (IHe (S n)).
Qed.

(***
 *** OExpr Rewrite Rules
 ***)

(* The Beta rule for ordered expressions *)
Lemma OExpr_Beta ctx A RA B RB
      (e1: @OExpr (@CtxCons A RA ctx) B RB) (e2: @OExpr ctx A RA) :
  App (Lam e1) e2 =e= substOExpr 0 e1 e2.
Proof.
  unfold oexpr_eq; simpl.
  rewrite (substOExpr_correct 0 e1 e2).
  rewrite ofun_apply_ofun_curry; try typeclasses eauto.
  f_equiv.
Qed.

Hint Rewrite OExpr_Beta : osimpl.

(*
(* The OExpr for the fst function *)
Definition OFst {ctx A RA B} {RB:OTRelation B} {tp} : @OExpr ctx (A*B -o> A) _ tp :=
  Embed (tp:=tp) (@ofst A B RA RB).

(* The OExpr for the snd function *)
Definition OSnd {ctx A B} : OExpr ctx (OTpArrow (OTpPair A B) B) :=
  Embed (A:=OTpArrow (OTpPair A B) B) osnd.

(* The OExpr for the pair function *)
Definition OPair {ctx A B} : OExpr ctx (OTpArrow A (OTpArrow B (OTpPair A B))) :=
  Embed (A:=OTpArrow A (OTpArrow B (OTpPair A B))) opair.

(* Mark the above OExpr constructs as opaque *)
Typeclasses Opaque OFst OSnd OPair.
*)

Lemma OExpr_fst_pair ctx A RA B RB
      (e1: @OExpr ctx A RA) (e2: @OExpr ctx B RB) :
  App (Embed ofst) (App (App (Embed opair) e1) e2) =e= e1.
Proof.
  split; intros a1 a2 Ra; simpl; f_equiv; assumption.
Qed.

Lemma OExpr_snd_pair ctx A RA B RB
      (e1: @OExpr ctx A RA) (e2: @OExpr ctx B RB) :
  App (Embed osnd) (App (App (Embed opair) e1) e2) =e= e2.
Proof.
  split; intros a1 a2 Ra; simpl; f_equiv; assumption.
Qed.

Lemma OExpr_pair_eta ctx A (RA:OType A) B (RB:OType B) (e: OExpr ctx (A * B)) :
  (App (App (Embed opair) (App (Embed ofst) e)) (App (Embed osnd) e)) =e= e.
Proof.
  split; intros a1 a2 Ra; split; simpl; f_equiv; f_equiv; assumption.
Qed.

Hint Rewrite OExpr_fst_pair OExpr_snd_pair OExpr_pair_eta : osimpl.

Lemma OExpr_inl_elim ctx A B C `{OType A} `{OType B} `{OType C}
      (e: OExpr ctx A) f1 (f2 : OExpr ctx (B -o> C)) :
  App (App (App (Embed osum_elim) f1) f2) (App (Embed oinl) e) =e=
  App f1 e.
Proof.
  split; intros c1 c2 Rc; simpl; f_equiv; f_equiv; assumption.
Qed.

Lemma OExpr_inr_elim ctx A B C `{OType A} `{OType B} `{OType C}
      (e: OExpr ctx B) (f1 : OExpr ctx (A -o> C)) f2 :
  App (App (App (Embed osum_elim) f1) f2) (App (Embed oinr) e) =e=
  App f2 e.
Proof.
  split; intros c1 c2 Rc; simpl; f_equiv; f_equiv; assumption.
Qed.

Lemma OExpr_sum_eta ctx A B `{OType A} `{OType B} (e: OExpr ctx (A+B)) :
  App (App (App (Embed osum_elim) (Lam (App (Embed oinl) (Var OVar_0))))
           (Lam (App (Embed oinr) (Var OVar_0)))) e =e=
  e.
Proof.
  split; intros c1 c2 Rc.
  - change (osum_elim @o@ oinl @o@ oinr @o@ (exprSemantics e @o@ c1)
            <o= exprSemantics e @o@ c2).
    rewrite osum_elim_eta. rewrite Rc. reflexivity.
  - change (exprSemantics e @o@ c1
            <o= osum_elim @o@ oinl @o@ oinr @o@ (exprSemantics e @o@ c2)).
    rewrite osum_elim_eta. rewrite Rc. reflexivity.
Qed.

(* FIXME: need a more general approach to this, which would require matching g
as not having the last-bound variable free in both cases... *)
Lemma OExpr_sum_commute_Embed ctx A B C D
      `{OType A} `{OType B} `{OType C} `{OType D}
      f1 f2 (g : C -o> D) (e : OExpr ctx (A + B)) :
  (Embed osum_elim)
    @e@ (Lam (Embed g @e@ (f1 @e@ (Var OVar_0))))
    @e@ (Lam (Embed g @e@ (f2 @e@ (Var OVar_0))))
    @e@ e
  =e=
  (Embed g) @e@ ((Embed osum_elim)
                   @e@ (Lam (f1 @e@ (Var OVar_0)))
                   @e@ (Lam (f2 @e@ (Var OVar_0))) @e@ e).
Proof.
  split; intros c1 c2 Rc; simpl;
    assert (exprSemantics e @o@ c1 <o= exprSemantics e @o@ c2) as Re;
      try (apply ofun_Proper; assumption); destruct Re;
        repeat rewrite H3; repeat rewrite Rc; reflexivity.
Qed.

(*
Lemma OExpr_sum_commute ctx A B C D `{OType A} `{OType B} `{OType C} `{OType D}
      (f1 : OExpr _ (A -o> C)) (f2 : OExpr _ (B -o> C))
      (g : OExpr _ (C -o> D)) e :
  (Embed osum_elim)
    @e@ (Lam (g @e@ (f1 @e@ (Var OVar_0))))
    @e@ (Lam (g @e@ (f2 @e@ (Var OVar_0))))
    @e@ e
  =e=
  (Lam g) @e@ ((Embed osum_elim)
                 @e@ (f1 @e@ (Var OVar_0)) @e@ (f1 @e@ (Var OVar_0)) @e@ e).
*)

Hint Rewrite OExpr_inl_elim OExpr_inr_elim
     OExpr_sum_eta OExpr_sum_commute_Embed : osimpl.

(***
 *** Quoting Tactic for Ordered Expressions
 ***)

(* Specially-marked versions of fst and snd just used for quoting OExprs *)
Definition celem_head {ctx A RA}
           (celem: CtxElem (@CtxCons A RA ctx)) : A :=
  let (_,head) := celem in head.
Definition celem_tail {ctx A RA}
           (celem: CtxElem (@CtxCons A RA ctx)) : CtxElem ctx :=
  let (rest,_) := celem in rest.

Arguments celem_head {_ _ _} _ : simpl never.
Arguments celem_tail {_ _ _} _ : simpl never.

(* Typeclass for incrementally quoting functions into OExpr variables, by
peeling off the celem_tail projections one at a time and adding them as OVar_S
constructors to the input variable to build the output variable *)
Class QuotesToVar {ctx1 ctx2 A} {RA:OType A}
      (f: CtxElem ctx1 -> CtxElem ctx2)
      (vin: OVar A ctx2) (vout: OVar A ctx1) : Prop :=
  quotesToVar :
    forall c, varSemantics vin @o@ (f c) = varSemantics vout @o@ c.

Instance QuotesToVar_Base {ctx A RA}
         (v:@OVar A RA ctx) : QuotesToVar (fun c => c) v v.
Proof.
  intro; reflexivity.
Qed.

Instance QuotesToVar_Step {ctx1 ctx2 A} {RA:OType A} {B} {RB:OType B}
         (f: CtxElem ctx1 -> CtxElem (@CtxCons B RB ctx2)) vin vout
         (q: @QuotesToVar _ _ A RA f (OVar_S vin) vout) :
  QuotesToVar (fun c => celem_tail (f c)) vin vout.
Proof.
  intro. apply q.
Qed.

(* Class for quoting functions to OExprs *)
Class QuotesTo {ctx A RA} (f: CtxElem ctx -> A) (e: @OExpr ctx A RA) : Prop :=
  quotesTo : forall c, f c =o= exprSemantics e @o@ c.

(* Logically the same as QuotesTo, but we never build lambdas in this one, i.e.,
this only builds "atomic" OExprs *)
Class QuotesToAtomic {ctx A RA} (f: CtxElem ctx -> A) (e: @OExpr ctx A RA) :=
  quotesToAtomic : QuotesTo f e.

(* Quote any term of functional type to a lambda *)
Instance QuotesTo_Lam {ctx A RA B RB} (f: CtxElem ctx -> A -o> B)
         (e: @OExpr (@CtxCons A RA ctx) B RB)
         (q: QuotesTo (fun c => f (celem_tail c) @o@ (celem_head c)) e) :
  QuotesTo f (Lam e) | 2.
Proof.
  intros; split; intro; intros; simpl; rewrite H;
    rewrite <- (q (c,a2)); reflexivity.
Qed.

(* Special case: quote ofuns as lambdas, destructuring the ofun *)
Instance QuotesTo_Lam_ofun {ctx A RA B RB} (f: CtxElem ctx -> A -> B) prp
         (e: @OExpr (@CtxCons A RA ctx) B RB)
         (q: QuotesTo (fun c => f (celem_tail c) (celem_head c)) e) :
  QuotesTo (fun c => mk_ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote any non-function term as an atomic OExpr *)
Instance QuotesTo_Atomic {ctx A} {RA:OType A} (f: CtxElem ctx -> A)
         e (q: QuotesToAtomic f e) :
  QuotesTo f e | 3 := q.

(* Quote any use of celem_head as a var *)
Instance QuotesTo_Var {ctx1 ctx2 A} {RA:OType A}
         (f: CtxElem ctx1 -> CtxElem (CtxCons A ctx2)) v
         (q: QuotesToVar f OVar_0 v) :
  QuotesToAtomic (fun c => celem_head (f c)) (Var v) | 1.
Proof.
  intro. rewrite <- q. destruct (f c).
  reflexivity.
Qed.

(* Special case for an eta-reduced celem_head application *)
Instance QuotesTo_Var0 {ctx A} {RA:OType A} :
  QuotesToAtomic (@celem_head ctx A RA) (Var OVar_0) | 1.
Proof.
  intro; reflexivity.
Qed.

(* Quote applications as OExpr applications, where the function must still be
atomic but the argument need not be *)
Instance QuotesTo_App {ctx A} {RA:OType A} {B} {RB:OType B}
         (f1: CtxElem ctx -> A -o> B) (f2: CtxElem ctx -> A)
         (e1: OExpr ctx (A -o> B)) (e2: OExpr ctx A)
         (q1: QuotesToAtomic f1 e1) (q2: QuotesTo f2 e2) :
  QuotesToAtomic (fun c => (f1 c) @o@ (f2 c)) (App e1 e2) | 1.
Proof.
  intro. simpl. f_equiv.
  - apply q1.
  - apply q2.
Qed.

(* Quote ofuns in atomic position as lambdas *)
Instance QuotesToAtomic_ofun {ctx A} {RA:OType A} {B} {RB:OType B}
         (f: CtxElem ctx -> A -> B) prp
         (e: OExpr (CtxCons A ctx) B)
         (q: QuotesTo (fun c => f (celem_tail c) (celem_head c)) e) :
  QuotesToAtomic (fun c => mk_ofun (f c) (prp:=(fun z => prp z c))) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote objects that are independent of the context as embedded objects, but at
low priority *)
Instance QuotesTo_Embed {ctx A} {RA:OType A} (a:A) :
  QuotesToAtomic (fun _ => a) (@Embed ctx A RA a) | 2.
Proof.
  intro. reflexivity.
Qed.

(* Quote pairs as applications of opair *)
(*
Instance QuotesTo_pair {ctx A} {RA:OType A} {B} {RB:OType B}
         (a: CtxElem ctx -> A) (b: CtxElem ctx -> B)
         (e1: OExpr ctx A) (e2: OExpr ctx B)
         (q1: QuotesTo a e1) (q2: QuotesTo b e2) :
  QuotesToAtomic (fun c => (a c, b c)) (App (App (Embed opair) e1) e2) | 1.
Proof.
  intro. simpl. rewrite (q1 c). rewrite (q2 c). reflexivity.
Qed.
*)

(* Quote applications of fst as applications of ofst *)
(*
Instance QuotesTo_fst {ctx A} {RA:OType A} {B} {RB:OType B}
         (f: CtxElem ctx -> A * B) (e: OExpr ctx (A*B)) (q: QuotesTo f e) :
  QuotesToAtomic (fun c => fst (f c)) (App (Embed ofst) e) | 1.
Proof.
  intro. simpl. rewrite (q c). reflexivity.
Qed.

(* Quote applications of snd as applications of osnd *)
Instance QuotesTo_snd {ctx A} {RA:OType A} {B} {RB:OType B}
         (f: CtxElem ctx -> A * B) (e: OExpr ctx (A*B)) (q: QuotesTo f e) :
  QuotesToAtomic (fun c => snd (f c)) (App (Embed osnd) e) | 1.
Proof.
  intro. simpl. rewrite (q c). reflexivity.
Qed.
*)

(* Use QuotesTo to prove a relation *)
Lemma oquote_R {A} {RA:OType A} {f1 f2 : A} {e1 e2: OExpr CtxNil A}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 <e= e2 -> f1 <o= f2.
Proof.
  intro R12.
  etransitivity; [ apply (q1 tt) | ].
  etransitivity; [ | apply (q2 tt) ].
  apply R12. reflexivity.
Qed.

(* Use QuotesTo to prove an equivalence *)
Lemma oquote_eq {A} {RA:OType A} {f1 f2 : A} {e1 e2: OExpr CtxNil A}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 =e= e2 -> f1 =o= f2.
Proof.
  intro R12.
  etransitivity; [ apply (q1 tt) | ].
  etransitivity; [ | symmetry; apply (q2 tt) ].
  f_equiv. apply R12.
Qed.

(* Translate a problem about proper functions into one about OExprs, by
"quoting" both sides *)
Ltac oquote :=
  lazymatch goal with
  | |- ?e1 =o= ?e2 =>
    apply oquote_eq
  | |- ?e1 <o= ?e2 =>
    apply oquote_R
  end.

Ltac oexpr_simpl :=
  repeat (rewrite_strat (bottomup (hints osimpl ; eval simpl))).

(* This one is not as fast for some reason... *)
(*
Ltac oexpr_simpl :=
  rewrite_strat (bottomup (choice (OExpr_Beta ; eval simpl) (hints osimpl))).
 *)

(* Translate a problem about proper functions into one about OExprs by calling
oquote, simplify both sides using the osimpl rewrite database, and then try to
use reflexivity, going back to proper functions if that does not work *)
Ltac osimpl :=
  oquote; try oexpr_simpl; try reflexivity; try typeclasses eauto; simpl.

(***
 *** Unquoting
 ***)

(* Class for unquoting OVars to functions *)
Class UnQuotesToVar {ctx A} {RA:OType A}
      (v: OVar A ctx) (f: CtxElem ctx -> A) : Prop :=
  { unQuotesToVarProper : Proper (oleq ==> oleq) f;
    unQuotesToVar : forall c, f c = varSemantics v @o@ c }.

Instance UnQuotesToVar_Base A RA ctx :
  UnQuotesToVar (@OVar_0 A RA ctx) snd.
Proof.
  split.
  - typeclasses eauto.
  - intros; reflexivity.
Qed.

Instance UnQuotesToVar_Step A RA ctx B (RB:OType B) (v:OVar A ctx) f
         (q: UnQuotesToVar v f) :
  UnQuotesToVar (@OVar_S A RA B RB ctx v) (fun c => f (fst c)).
Proof.
  split.
  - intros c1 c2 Rc. apply (unQuotesToVarProper (UnQuotesToVar:=q)).
    f_equiv. assumption.
  - intros; apply q.
Qed.

(* Class for unquoting OExprs to functions *)
Class UnQuotesTo {ctx A RA} (e: @OExpr ctx A RA) (f: CtxElem ctx -> A) : Prop :=
  unQuotesTo : forall c, f c =o= exprSemantics e @o@ c.

Instance UnQuotesTo_Var ctx A {RA:OType A} (v:OVar A ctx) f
         (q: UnQuotesToVar v f) :
  UnQuotesTo (Var v) f | 1.
Proof.
  intro. rewrite (unQuotesToVar (UnQuotesToVar:=q)). reflexivity.
Qed.

Instance UnQuotesTo_Embed ctx A {RA:OType A} (a:A) :
  UnQuotesTo (@Embed ctx A RA a) (fun _ => a) | 1.
Proof.
  intro; reflexivity.
Qed.

Instance UnQuotesTo_App {ctx A} {RA:OType A} {B} {RB:OType B}
         e1 e2 (f1: CtxElem ctx -> A -o> B) (f2: CtxElem ctx -> A)
         (q1: UnQuotesTo e1 f1) (q2: UnQuotesTo e2 f2) :
  UnQuotesTo (App e1 e2) (fun c => (f1 c) @o@ (f2 c)) | 1.
Proof.
  intro. simpl. f_equiv.
  - apply (unQuotesTo (UnQuotesTo:=q1)).
  - apply (unQuotesTo (UnQuotesTo:=q2)).
Qed.

Lemma Proper_unQuotesTo {ctx A} {RA:OType A} {B} {RB:OType B}
      {e: OExpr (CtxCons A ctx) B} {f} (q: UnQuotesTo e f) c :
  Proper (oleq ==> oleq) (fun a => f (c, a)).
Proof.
  intros a1 a2 Ra.
  etransitivity; [ apply (unQuotesTo (UnQuotesTo:=q)) | ].
  etransitivity; [ | apply (unQuotesTo (UnQuotesTo:=q)) ].
  f_equiv. split; [ reflexivity | assumption ].
Qed.

Instance UnQuotesTo_Lam {ctx A} {RA:OType A} {B} {RB:OType B}
      (e: OExpr (CtxCons A ctx) B) f (q: UnQuotesTo e f) :
  UnQuotesTo (Lam e) (fun c =>
                        mk_ofun (fun a => f (c, a))
                                (prp:=Proper_unQuotesTo q c)) | 1.
Proof.
  intro; split; intros a1 a2 Ra; simpl.
  - etransitivity.
    + apply (Proper_unQuotesTo q); apply Ra.
    + apply (unQuotesTo (UnQuotesTo:=q)).
  - etransitivity.
    + apply (unQuotesTo (UnQuotesTo:=q)).
    + apply (Proper_unQuotesTo q); apply Ra.
Qed.

(* The above instance generally will not fire, because the implicit ctx argument
to UnQuotesTo is of the form (ctxInsert w W ctx), but this will generally be
already simplified away in the goal, making it hard for Coq to match. The
following instructs Coq how to do the match by supplying the w argument. *)
Instance UnQuotesTo_weakenOExpr {ctx A} {RA:OType A} w W {OW:OType W}
         (e: OExpr ctx A) f (q: UnQuotesTo e f) :
  UnQuotesTo (weakenOExpr w W e) (fun c => f (weaken_ofun w W _ @o@ c)) | 1.
Proof.
  intro. rewrite weakenOExpr_correct. simpl.
  rewrite (unQuotesTo (UnQuotesTo:=q)). reflexivity.
Qed.

(* The above instance will generally not fire because the ctxInsert implicit
argument to UnQuotesTo will already be simplified, and so Coq will not be able
to match it; this, we make an explicit extern tactic to do the matching *)
Hint Extern 1 (@UnQuotesTo _ _ _ (weakenOExpr _ _ _) _) =>
(lazymatch goal with
 | |- UnQuotesTo (weakenOExpr ?w ?W _) _ =>
   apply (UnQuotesTo_weakenOExpr w W)
 end) : typeclass_instances.

(* This instance is meant to only apply to Coq-level variables of OExpr type *)
Instance UnQuotesTo_MetaVar {ctx A} {RA:OType A} (e:OExpr ctx A) :
  UnQuotesTo e (fun c => exprSemantics e @o@ c) | 2.
Proof.
  intro. f_equiv.
Qed.

Lemma unquote_R {ctx A} {RA:OType A} {e1 e2: OExpr ctx A}
      {f1 f2 : CtxElem ctx -> A} {q1: UnQuotesTo e1 f1} {q2: UnQuotesTo e2 f2} :
  (forall c, f1 c <o= f2 c) -> e1 <e= e2.
Proof.
  intro R12.
  intros c1 c2 Rc. rewrite Rc.
  transitivity (f1 c2); [ apply (unQuotesTo (UnQuotesTo:=q1)) | ].
  transitivity (f2 c2); [ | apply (unQuotesTo (UnQuotesTo:=q2)) ].
  apply R12.
Qed.

Lemma unquote_eq {ctx A} {RA:OType A} {e1 e2: OExpr ctx A}
      {f1 f2 : CtxElem ctx -> A} {q1: UnQuotesTo e1 f1} {q2: UnQuotesTo e2 f2} :
  (forall c, f1 c =o= f2 c) -> e1 =e= e2.
Proof.
  intro R12.
  split; [ apply (unquote_R (q1:=q1) (q2:=q2))
         | apply (unquote_R (q1:=q2) (q2:=q1)) ];
  intro c; destruct (R12 c); assumption.
Qed.

(***
 *** Testing the Quote Mechanism
 ***)

Module OQuoteTest.

(* A simple test case for constant terms *)
Lemma simple_quote_test A `{OType A} a : a =o= a.
  osimpl.
Qed.

(* A simple test case with all 4 OExpr constructs, that does beta-reduction *)
Lemma beta_test A `{OType A} a : (ofun (x:A) => x) @o@ a =o= a.
  osimpl.
Qed.

(* A test case with the first projection of a product *)
Lemma product_proj1_test A `{OType A} B `{OType B} (a:A) (b:B) :
  ofst @o@ (a ,o, b) =o= a.
  osimpl.
Qed.

(* A test case with with beta-reduction and projections + eta for products *)
Lemma beta_product_test A `{OType A} B `{OType B} (p:A*B) :
  (ofun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (osnd @o@ p ,o, ofst @o@ p)
  =o= p.
  osimpl.
Qed.

Lemma double_lambda_test A `{OType A} :
  (ofun (f : A -o> A) => ofun x => f @o@ x) @o@ (ofun y => y)
  =o= ofun x => x.
  osimpl.
Qed.

(* A test case with with beta-reduction and projections for products *)
Lemma beta_product_test2 A `{OType A} B `{OType B} :
  (ofun a => ofun b => (ofun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (b ,o, a))
  =o= opair.
  (* osimpl *)
  (* NOTE: we write this out to see each step *)
  apply oquote_eq.
  oexpr_simpl.
  reflexivity.
Qed.

End OQuoteTest.


Inductive exp : Set :=
| Zero   : exp
| Succ   : exp -> exp
| T      : exp
| F      : exp
| Pred   : exp -> exp
| If     : exp -> exp -> exp -> exp
| IsZero : exp -> exp
| Plus   : exp -> exp -> exp
| And    : exp -> exp -> exp.

(*Exercicio 50*)
(*Adicionar operações de soma de números e conjunção de boleanos*)

Inductive bvalue : exp -> Prop :=
| btrue  : bvalue T
| bfalse : bvalue F.

Inductive nvalue : exp -> Prop :=
| nzero  : nvalue Zero
| nsucc  : forall n, nvalue n -> nvalue (Succ n).

Inductive value : exp -> Prop :=
| Bvalue : forall e, bvalue e -> value e
| Nvalue : forall e, nvalue e -> value e.

Hint Constructors bvalue nvalue value.

Reserved Notation "e '==>' e1" (at level 40).

Inductive step : exp -> exp -> Prop :=
| ST_If_T
  : forall e e', (If T e e') ==> e
| ST_If_F
  : forall e e', If F e e' ==> e'
| ST_If
  : forall e e' e1 e2,
    e ==> e'                ->
    If e e1 e2 ==> If e' e1 e2
| ST_Succ
  : forall e e',
    e ==> e'                ->
    (Succ e) ==> (Succ e')
| ST_Pred_Zero
  : Pred Zero ==> Zero
| ST_Pred_Succ
  : forall e,
    nvalue e         ->
    Pred (Succ e) ==> e
| ST_Pred
  : forall e e',
    e ==> e'           ->
    (Pred e) ==> (Pred e')
| ST_IsZeroZero
  : IsZero Zero ==> T
| ST_IsZeroSucc
  : forall e,
    nvalue e           ->
    IsZero (Succ e) ==> F
| ST_IsZero
  : forall e e',
    e ==> e'               ->
    (IsZero e) ==> (IsZero e')
| St_PlusZero
  : forall e,
    nvalue e   ->
    Plus Zero e ==> e
| St_PlusSucc
  : forall e e1 n,
    (nvalue e) -> (nvalue e1) ->
    e ==> e1 ->
    Plus e n ==> Succ (Plus e1 n)
| St_AndF
  : forall e,
    And F e ==> F
| ST_AndT
  : forall e,
    bvalue e   ->
    And T e ==> e
where "e '==>' e1" := (step e e1).

Hint Constructors step.

Definition normal_form e := ~ exists e', step e e'.

Definition stuck e := normal_form e /\ ~ value e.

Ltac inverts H := inversion H ; clear H ; subst.

(*Exercicio 51*)
(*Terminar a provar*)

Lemma value_is_nf' : forall e, value e -> normal_form e.
Proof.
  intros e Hv.
  unfold normal_form.
  intro contra.
  induction e.
  +
    inverts contra.
    inverts H.
  +
    inverts contra.
    inverts Hv.
    inverts H0.
    inverts H0.
    apply IHe.
    auto.
    inverts H.
    exists e'.
    auto.
  +
    inverts contra.
    inverts H.
  +
    inverts contra.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
Qed.

Ltac s :=
      match goal with
      | [ H : ex _ |- _ ] => destruct H
      | [ H : Zero ==> _ |- _] => inverts H
      | [ H : T ==> _ |- _] => inverts H
      | [ H : F ==> _ |- _] => inverts H
      | [ H : value (Pred _) |- _] => inverts H
      | [ H : bvalue (Pred _) |- _] => inverts H
      | [ H : nvalue (Pred _) |- _] => inverts H
      | [ H : value (If _ _ _) |- _] => inverts H
      | [ H : bvalue (If _ _ _) |- _] => inverts H
      | [ H : nvalue (If _ _ _) |- _] => inverts H
      | [ H : value (IsZero _) |- _] => inverts H
      | [ H : bvalue (IsZero _) |- _] => inverts H
      | [ H : nvalue (IsZero _) |- _] => inverts H
      | [ H : value (Succ _) |- _] => inverts H
      | [ H : bvalue (Succ _) |- _] => inverts H
      | [ H : nvalue (Succ _) |- _] => inverts H
      | [ H : (Succ _) ==> _ |- _ ] => inverts H
      | [ H : value (Plus _ _) |- _] => inverts H
      | [ H : bvalue (Plus _ _) |- _] => inverts H
      | [ H : nvalue (Plus _ _) |- _] => inverts H
      | [ H : value (And _ _) |- _] => inverts H
      | [ H : bvalue (And _ _) |- _] => inverts H
      | [ H : nvalue (And _ _) |- _] => inverts H
      end.

Lemma value_is_nf : forall e, value e -> normal_form e.
Proof.
  unfold normal_form ; intros e H contra ; induction e ;
    try (repeat s) ; eauto.
Qed.

Hint Resolve value_is_nf.

(*Exercicio 52*)
(*Fazer LTac para o restante dos construtores*)

Ltac s1 :=
  match goal with
  | [ H : (nvalue ?e) , H1 : ?e ==> _ |- _] =>
    apply Nvalue in H ; apply value_is_nf in H ;
    unfold normal_form in H ; apply ex_intro in H1 ; contradiction
  end.

Lemma step_deterministic
  : forall e e', e ==> e' -> forall e1, e ==> e1-> e' = e1.
Proof.
  intros e e' H ; induction H ; intros e'' H' ;
    inverts H' ; f_equal ; try repeat s ; auto ; try repeat s1.
Qed.

Reserved Notation "e '==>>' e1" (at level 40).

Inductive big_step : exp -> exp -> Prop :=
| B_Value
  : forall v, value v -> v ==>> v
| B_If_True
  : forall e e1 e11 e2,
    e ==>> T ->
    e1 ==>> e11 ->
    (If e e1 e2) ==>> e11
| B_If_False
  : forall e e1 e2 e22,
    e ==>> F ->
    e2 ==>> e22 ->
    (If e e1 e2) ==>> e22
| B_Succ
  : forall e nv,
    nvalue nv ->
    e ==>> nv ->
    (Succ e) ==>> (Succ nv)
| B_PredZero
  : forall e,
    e ==>> Zero ->
    (Pred e) ==>> Zero
| B_PredSucc
  : forall e nv,
    nvalue nv ->
    e ==>> (Succ nv) ->
    Pred e ==>> nv
| B_IsZeroZero
  : forall e,
    e ==>> Zero ->
    (IsZero e) ==>> T
| B_IsZeroSucc
  : forall e nv,
    nvalue nv ->
    e ==>> (Succ nv) ->
    (IsZero e) ==>> F
| B_PlusZero
  : forall e1 e2 n,
    nvalue n -> e1 ==>> Zero ->
    e2 ==>> n ->
    Plus Zero e2 ==>> n
| B_PlusSucc
  : forall e1 e2 n1 n2,
    nvalue n1 -> e1 ==>> (Succ n1) ->
    nvalue n2 -> e2 ==>> n2 ->
    Plus e1 e2 ==>> Succ (Plus n1 n2)
| B_AndF
  : forall e1 e2,
    e1 ==>> F ->
    And e1 e2 ==>> F
| B_AndT
  : forall e1 e2 b,
    bvalue b -> e1 ==>> T ->
    e2 ==>> b ->
    And e1 e2 ==>> b
where "e '==>>' e1" := (big_step e e1).

Hint Constructors big_step.

Ltac bs := match goal with
            | [H : T ==>> _ |- _] => inverts H
            | [H : F ==>> _ |- _] => inverts H
            | [H : Zero ==>> _ |- _] => inverts H
            | [H : (Succ _) ==>> _ |- _] => inverts H
            | [H : value _ |- _] => inverts H
            | [H : bvalue (Succ _) |- _] => inverts H
            | [H : nvalue (Succ _) |- _] => inverts H
            | [H : (Pred _) ==>> _ |- _] => inverts H
            | [H : bvalue (Pred _) |- _] => inverts H
            | [H : nvalue (Pred _) |- _] => inverts H
            | [H : (If _ _ _) ==>> _ |- _] => inverts H
            | [H : bvalue (If _ _ _) |- _] => inverts H
            | [H : nvalue (If _ _ _) |- _] => inverts H
            | [H : (IsZero _) ==>> _ |- _] => inverts H
            | [H : bvalue (IsZero _) |- _] => inverts H
            | [H : nvalue (IsZero _) |- _] => inverts H
            | [H : value (Pred _) |- _] => inverts H
            | [ IH : forall v, ?e ==>> v -> forall v', ?e ==>> v' -> _
                , H : ?e ==>> _, H1 : ?e ==>> _ |- _] =>
              apply (IH _ H) in H1
            end ; subst ; try congruence ; try f_equal ; auto.

Lemma big_step_value_succ : forall e, value (Succ e) -> nvalue e /\ e ==>> e.
Proof.
  induction e ; intros H ; inverts H ; split ; eauto ; repeat bs.
Qed.

Hint Resolve big_step_value_succ.

Ltac value_solver :=
  repeat (match goal with
          | [H : value (Pred _) |- _] => inverts H
          | [H : bvalue (Pred _) |- _] => inverts H
          | [H : nvalue (Pred _) |- _] => inverts H
          | [H : value (If _ _ _) |- _] => inverts H
          | [H : bvalue (If _ _ _) |- _] => inverts H
          | [H : nvalue (If _ _ _) |- _] => inverts H
          | [H : value (IsZero _) |- _] => inverts H
          | [H : bvalue (IsZero _) |- _] => inverts H
          | [H : nvalue (IsZero _) |- _] => inverts H
          | [H : value (Plus _ _) |- _] => inverts H
          | [H : nvalue (Plus _ _) |- _] => inverts H
          | [H : bvalue (Plus _ _) |- _] => inverts H
          | [H : value (And _ _) |- _] => inverts H
          | [H : nvalue (And _ _) |- _] => inverts H
          | [H : bvalue (And _ _) |- _] => inverts H
          | [H : Zero ==>> _ |- _] => inverts H
end).

Ltac big_step_solver :=
  match goal with
    | [H  : value (Succ _) |- _] => eapply big_step_value_succ in H; destruct H
    | [IH : forall v : exp, ?e ==>> v -> forall v': exp, ?e ==>> v' -> _,
       H1 : ?e ==>> _,
       H2 : ?e ==>> _ |- _] => specialize (IH _ H1 _ H2) ; subst
    | [ _ : _ |- Succ ?n = Succ ?n ] => auto

    | [H  : Zero = Succ _ |- _ ] => inverts H
    | [H  : Succ _ = Zero |- _ ] => inverts H
    | [H  : Succ ?v = Succ ?v' |- ?v = ?v'] => congruence
    | [H  : T = F |- _ ] => inverts H
    | [H  : F = T |- _ ] => inverts H
    | [H  : Succ _ = Succ _ |- _] => inverts H; auto
  end.

Lemma big_step_deterministic : forall e v, e ==>> v -> forall v', e ==>> v' -> v = v'.
Proof.
  induction e ; intros v H v' H' ; inverts H ; inverts H' ; value_solver ; eauto; repeat big_step_solver.
Qed.

Hint Resolve big_step_deterministic.

Reserved Notation "e '==>*' e1" (at level 40).

Inductive multi_step : exp -> exp -> Prop :=
| mstep_refl
  : forall e, e ==>* e
| mstep_step
  : forall e e1 e',
    e ==> e1   ->
    e1 ==>* e' ->
    e ==>* e'
where "e '==>*' e1" := (multi_step e e1).

Hint Constructors multi_step.
(*
Ltac multi_solver :=
  match goal with
    | [H : bvalue _ |- _] => inverts H; subst
    | [H : nvalue _ |- _] => inverts H; subst
    | [H : Zero ==>* _ |- _] => inverts H
    | [H : Zero ==> _ |- _] => inverts H
    | [_ : _ |- Zero ==>> Zero] => auto
  end.
*)
Lemma nvalue_step : forall e, nvalue e -> e ==>> e.
Proof.
  induction e; intros; auto.
Qed.

(*Exercicio 53*)
Lemma multi_step_big_step  : forall e v, value v -> e ==>* v -> e ==>> v.
Proof.
  induction e;  intros v Hv; inverts Hv; intros.
  inversion H; subst.
  inverts H0.
  inverts H1.
  inverts H0.
  inverts H1.
  inverts H0.
  auto.
  inverts H1.
Admitted.

(*Exercicio 54*)
Lemma big_step_mult_step  : forall e v, value v -> e ==>> v -> e ==>* v.
Proof.
Admitted.

Inductive type : Set :=
| TBool : type
| TNat  : type.

Reserved Notation "e '<<-' t" (at level 40).

Inductive has_type : exp -> type -> Prop :=
| T_True
  : T <<- TBool
| T_False
  : F <<- TBool
| T_Zero
  : Zero <<- TNat
| T_Succ
  : forall e,
    e <<- TNat ->
    (Succ e) <<- TNat
| T_Pred
  : forall e,
    e <<- TNat  ->
    (Pred e) <<- TNat
| T_If
  : forall e e' e'' t,
    e <<- TBool ->
    e' <<- t    ->
    e'' <<- t   ->
    (If e e' e'') <<- t
| T_IsZero
  : forall e,
    e <<- TNat ->
    (IsZero e) <<- TBool
where "e '<<-' t" := (has_type e t).

Hint Constructors has_type.

Ltac auxs :=
  match goal with
    | [H : T <<- TNat |- _] => inverts H
    | [H : F <<- TNat |- _] => inverts H
    | [H : Zero <<- TBool |- _] => inverts H
    | [H : Succ _ <<- TBool |- _] => inverts H
    | [H : Plus _ _ <<- TBool |- _] => inverts H
    | [H : And _ _ <<- TNat |- _] => inverts H
  end.

(*Exercicio 55*)
Lemma bool_canonical : forall e, e <<- TBool -> value e -> bvalue e.
Proof.
  induction e; intros; repeat bs; repeat auxs; repeat value_solver.
Qed.

(*Exercicio 56*)
Lemma nat_canonical : forall e, e <<- TNat -> value e -> nvalue e.
Proof.
  induction e; intros; repeat bs; repeat auxs; repeat value_solver.
Qed.

Theorem progress : forall e t, e <<- t -> value e \/ exists e', e ==> e'.
Proof.
  induction 1 ; try solve [left ; auto] ;
    try repeat (match goal with
                | [H : _ \/ _ |- _] => destruct H
                | [H : ex _ |- _] => destruct H
                | [H : value _ |- _] => inverts H
                | [H : bvalue _ |- _] => inverts H
                | [H : T <<- _ |- _] => inverts H
                | [H : F <<- _ |- _] => inverts H
                | [H : nvalue _ |- context[(Pred _)]] => inverts H
                | [H : nvalue _ |- context[(IsZero _)]] => inverts H
                | [H : ?e <<- TBool , H1 : nvalue ?e |- _] =>
                  inverts H1 ; inverts H
                end ; try solve [ right ; eexists ; eauto ] ; auto).
Qed.

Theorem preservation : forall e t, e <<- t -> forall e', e ==> e' -> e' <<- t.
Proof.
  induction e ; intros t He e' He' ; inverts He ; inverts He' ; repeat s ; eauto.
  +
    inverts H1 ; eauto.
    inverts H0 ; eauto.
Qed.

Theorem has_type_det : forall e t, e <<- t -> forall t', e <<- t' -> t = t'.
Proof.
  induction 1 ; intros t' Hc ; inverts Hc ; eauto.
Qed.

Lemma mult_big :
  forall e t, e <<- t -> forall v, value v -> e ==>* v -> e ==>> v.


Require Import Ring.
Require Import Field.
Require Import Setoid.
Require Import Classes.RelationClasses.
Require Import Classes.Morphisms.
Require Import Ensembles.
Require Import Vector.
Require Import Logic.FunctionalExtensionality.
Require Import Logic.PropExtensionality.

Fixpoint zipwith {A B C : Type} {n : nat}
         (f : A -> B -> C) (v1 : t A n) (v2 : t B n) : t C n
  := match v1 in t _ n return t B n -> t C n with
     | nil _ => fun _ => nil C
     | cons _ x1 _ v1' =>
       fun v2 =>
         cons _ (f x1 (hd v2)) _ (zipwith f v1' (tl v2))
     end v2.

Definition zip {A B C : Type} {n : nat} := @zipwith A B (A*B) n pair.

Lemma nil_unique {A : Type} : forall (xs : t A 0), xs = nil A.
Proof.
  apply case0.
  reflexivity.
Qed.

Module Export DEFINITIONS.
  Variable (F V : Type) (r0 r1 : F) (radd rmul rsub : F -> F -> F) (ropp : F -> F) (req : F -> F -> Prop).
  Variable (rdiv : F -> F -> F) (rinv : F -> F).

  Declare Scope field_scope.
  Delimit Scope field_scope with fieldsc.
  Open Scope field_scope.

  Global Notation "0" := r0 : field_scope.
  Global Notation "1" := r1 : field_scope.
  Global Infix "==r" := req (at level 90) : field_scope.
  Global Infix "+r" := radd (at level 50) : field_scope.
  Global Infix "*r" := rmul (at level 40) : field_scope.
  Global Infix "-r" := rsub (at level 50) : field_scope.
  Global Notation "-r" := ropp (at level 30) : field_scope.
  Global Infix "/r" := rdiv (at level 40) : field_scope.
  Global Notation "/r" := rinv (at level 30) : field_scope.

  Variable (vadd : V -> V -> V) (vsmult : F -> V -> V) (v0 : V) (veq : V -> V -> Prop).

  Declare Scope vectorspace_scope.
  Delimit Scope vectorspace_scope with vecsc.
  Open Scope vectorspace_scope.

  Notation "0" := v0 : vectorspace_scope.
  Infix "==v" := veq (at level 90) : vectorspace_scope.
  Infix "+v" := vadd (at level 50) : vectorspace_scope.
  Infix "*v" := vsmult (at level 40) : vectorspace_scope.
  Definition vopp (x : V) : V := (-r 1) *v x.
  Notation "-v" := vopp (at level 30) : vectorspace_scope.

  (*1.19*)
  Record vectorspace_theory
    : Prop
    := mk_vst
         {
           vadd_comm : forall (x y : V), x +v y ==v y +v x;
           vadd_assoc : forall (x y z : V), (x +v y) +v z ==v x +v (y +v z);
           vadd_ident : forall (x : V), x +v 0 ==v x;
           vadd_inv : forall (x : V), exists (y : V), x +v y ==v 0;
           vsmult_ident : forall (x : V), 1 *v x ==v x;
           vdistr1 : forall (a : F) (x y : V), a *v (x +v y) ==v (a *v x) +v (a *v y);
           vdistr2 : forall (a b : F) (x : V), (a +r b) *v x ==v (a *v x) +v (b *v x);
         }.

  Record vec_eq_ext : Prop
    :=
      mk_veqe {
          vadd_ext : Proper (veq ==> veq ==> veq) vadd;
          vsmult_ext : Proper (req ==> veq ==> veq) vsmult;
        }.

  Section MORPHISM.
    Variable (W G : Type) (w0 : W) (wadd : W -> W -> W) (wsmult : G -> W -> W).
    Variable (weqb : W -> W -> bool) (phi__W : W -> V) (phi__G : G -> F).
    Infix "+!" := wadd (at level 50).
    Infix "*!" := wsmult (at level 40).
    Infix "?=!" := weqb (at level 90).

    Record vectorspace_morph : Prop
      :=
        mk_vmorph {
            morph_v0 : phi__W w0 = 0;
            morph_vadd : forall u v, phi__W (u +! v) ==v phi__W u +v phi__W v;
            morph_vsmult : forall a v, phi__W (a *! v) ==v phi__G a *v phi__W v;
            morph_veq : forall u v, (u ?=! v) = true -> phi__W u ==v phi__W v;
          }.
  End MORPHISM.

  (*Identity is a morphism*)
  Variable Vsth : Equivalence veq.
  Variable veqb : V -> V -> bool.

  Hypothesis morph_veq' : forall x y, (veqb x y) = true -> x ==v y.
  Definition IDphi__V (x : V) := x.
  Definition IDphi__F (x : F) := x.

  Lemma IDmorph : vectorspace_morph V F 0 vadd vsmult veqb IDphi__V IDphi__F.
  Proof.
    destruct Vsth.
    compute in Equivalence_Reflexive.
    split; intros; compute.
    - reflexivity.
    - apply Equivalence_Reflexive.
    - apply Equivalence_Reflexive.
    - apply morph_veq'.
      apply H.
  Qed.

(*End DEFINITIONS.*)

(*Module VECTORSPACE.*)
  (*Include DEFINITIONS.*)

  (*Delimit Scope field_scope with fieldsc.*)
  Open Scope field_scope.

  Variable Fth : field_theory 0 1 radd rmul rsub ropp rdiv rinv req.
  Definition Rth := F_R Fth.

  Lemma Eqfsth : Equivalence (@eq F).
  Proof.
    split; compute; intros.
    - reflexivity.
    - rewrite H; reflexivity.
    - rewrite <- H in H0.
      apply H0.
    Qed.

  Lemma REq_ext : ring_eq_ext radd rmul ropp (@eq F).
  Proof.
    split; compute; intros; rewrite H; try (rewrite H0); reflexivity.
  Qed.

  Variable Rsth : Equivalence req.
  Variable reqe : ring_eq_ext radd rmul ropp req.

  Add Morphism radd with signature (req ==> req ==> req) as radd_ext1.
  Proof.
    intros.
    destruct reqe.
    compute in Radd_ext.
    specialize (Radd_ext x y H x0 y0 H0).
    apply Radd_ext.
  Qed.

  Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext1.
  Proof.
    intros.
    destruct reqe.
    compute in Rmul_ext.
    specialize (Rmul_ext x y H x0 y0 H0).
    apply Rmul_ext.
  Qed.

  Add Morphism ropp with signature (req ==> req) as ropp_ext1.
  Proof.
    intros.
    destruct reqe.
    compute in Ropp_ext.
    specialize (Ropp_ext x y H).
    apply Ropp_ext.
  Qed.

  Add Morphism rinv with signature (req ==> req) as finv_ext1.
  Proof.
    intros.
    destruct reqe.

  Admitted.

  Add Ring FRing : Rth.
  Add Field FField : Fth.

  Variable (vadd : V -> V -> V) (vsmult : F -> V -> V) (v0 : V) (veq : V -> V -> Prop).

  (*Delimit Scope vectorspace_scope with vecsc.*)
  Open Scope vectorspace_scope.

  Notation "0" := v0 : vectorspace_scope.
  Infix "==v" := veq (at level 90) : vectorspace_scope.
  Infix "+v" := vadd (at level 50) : vectorspace_scope.
  Infix "*v" := vsmult (at level 40) : vectorspace_scope.
  (*Definition vopp (x : V) : V := (-r 1) *v x.*)
  Notation "-v" := (@vopp F V 1 ropp vsmult) (at level 30) : vectorspace_scope.

  (*Leibniz equality leads to a setoid theory and is extensional*)
  Lemma Eqvsth : Equivalence (@eq V).
  Proof.
    split; compute; intros.
    - reflexivity.
    - rewrite H.
      reflexivity.
    - rewrite <- H in H0.
      apply H0.
    Qed.

  Lemma VEq_ext : vec_eq_ext F V (@eq F) vadd vsmult (@eq V).
  Proof.
    split; compute; intros; rewrite H; rewrite H0; reflexivity.
  Qed.

  Variable Vsth : Equivalence veq.

  Variable veqe : vec_eq_ext F V req vadd vsmult veq.

  Add Morphism vadd with signature (veq ==> veq ==> veq) as vadd_ext1.
  Proof.
    intros.
    destruct veqe.
    compute in vadd_ext0.
    specialize (vadd_ext0 x y H x0 y0 H0).
    apply vadd_ext0.
  Qed.

  Add Morphism vsmult with signature (req ==> veq ==> veq) as vsmult_ext1.
  Proof.
    intros.
    destruct veqe.
    compute in vsmult_ext0.
    specialize (vsmult_ext0 x y H x0 y0 H0).
    apply vsmult_ext0.
  Qed.

  Variable Vth : vectorspace_theory F V r0 radd vadd vsmult 0 veq.

  Lemma radd_inv_zero (x : F) : x +r (-r x) ==r 0%fieldsc.
  Proof.
    destruct Rth.
    specialize (Ropp_def x).
    rewrite <- Ropp_def.
    reflexivity.
  Qed.

  Lemma ropp_zero_zero : -r 0%fieldsc ==r 0%fieldsc.
  Proof.
    ring.
  Qed.

  Lemma add_both_sides (u v w : V) : u ==v v -> w +v u ==v w +v v.
  Proof.
    intros.
    rewrite H.
    reflexivity.
  Qed.

  Lemma subtract_both_sides (u v w : V) : w +v u ==v w +v v -> u ==v v.
  Proof.
    intros.
  Admitted.

  (*1.29*)
  Theorem zero_times_vector (x : V) :
    0%fieldsc *v x ==v 0.
  Proof.
    destruct Rth.
    rewrite <- (Radd_0_l 0%fieldsc).
    destruct Vth.
    rewrite (vdistr4 0%fieldsc 0%fieldsc x).
    specialize (vadd_inv0 (0%fieldsc *v x)).
    destruct vadd_inv0 as [y vadd_inv0].
    rewrite <- vadd_inv0.
    apply (add_both_sides _ _ (0%fieldsc *v x)).
    rewrite vsmult_ident0.
  Admitted.

  (*1.30*)
  Theorem number_times_zero (a : F) :
    a *v 0 = 0.
  Proof.
    destruct Vth.

  Admitted.

  Theorem vsmult_distr (a b : F) (x : V) : a *v (b *v x) ==v (a *r b) *v x.
  Proof.
  Admitted.

  Lemma minus_one_squared : -r 1 *r -r 1 ==r 1.
  Proof.
    ring.
  Qed.

  (*exercise 1.B.1*)
  Theorem vopp_involutive (x : V) : -v (-v x) ==v x.
  Proof.
    unfold vopp.
    rewrite vsmult_distr.
    rewrite minus_one_squared.
    destruct Vth.

  Admitted.

End VECTORSPACE.

Section SPAN.

  Variable (F V : Type) (r0 r1 : F) (radd rmul rsub : F -> F -> F) (ropp : F -> F) (req : F -> F -> Prop).
  Variable (rdiv : F -> F -> F) (rinv : F -> F).

  Declare Scope field_scope.
  Delimit Scope field_scope with fieldsc.
  Open Scope field_scope.

  Notation "0" := r0 : field_scope.
  Notation "1" := r1 : field_scope.
  Infix "==r" := req (at level 90) : field_scope.
  Infix "+r" := radd (at level 50) : field_scope.
  Infix "*r" := rmul (at level 40) : field_scope.
  Infix "-r" := rsub (at level 50) : field_scope.
  Notation "-r" := ropp (at level 30) : field_scope.
  Infix "/r" := rdiv (at level 40) : field_scope.
  Notation "/r" := rinv (at level 30) : field_scope.

  Variable (vadd : V -> V -> V) (vsmult : F -> V -> V) (v0 : V) (veq : V -> V -> Prop).

  Declare Scope vectorspace_scope.
  Delimit Scope vectorspace_scope with vecsc.
  Open Scope vectorspace_scope.

  Notation "0" := v0 : vectorspace_scope.
  Infix "==v" := veq (at level 90) : vectorspace_scope.
  Infix "+v" := vadd (at level 50) : vectorspace_scope.
  Infix "*v" := vsmult (at level 40) : vectorspace_scope.
  Notation "-v" := (@vopp F V 1 ropp vsmult) (at level 30) : vectorspace_scope.

  (*2.5*)
  Definition span {n : nat} (xs : t V n) : V -> Prop
    :=
      fun x => exists ys, x ==v fold_left vadd 0 (zipwith vsmult ys xs).

  (*2.8*)
  Definition spans {n : nat} (xs : t V n) : Prop
    :=
      span xs = Full_set V.

  (*2.5*)
  Theorem span_empty_zero : span (@nil V) = fun x => x ==v 0.
  Proof.
    apply (functional_extensionality (span (@nil V)) (fun x => x ==v 0)).
    intros x.
    unfold span.
    apply propositional_extensionality.
    split.
    - intros.
      destruct H as [ys H].
      rewrite (nil_unique ys) in H; simpl in H.
      apply H.
    - simpl.
      intros.
      exists (@nil F).
      simpl.
      apply H.
    Qed.

  Check Vth.

  (*2.10*)
  Definition finite_dimensional (V : Type) (H__vectorspace : )

End SPAN.

Section LINEAR_INDEPENDENCE.

  Variable (F V : Type) (r0 r1 : F) (radd rmul rsub : F -> F -> F) (ropp : F -> F) (req : F -> F -> Prop).
  Variable (rdiv : F -> F -> F) (rinv : F -> F).

  Declare Scope field_scope.
  Delimit Scope field_scope with fieldsc.
  Open Scope field_scope.

  Notation "0" := r0 : field_scope.
  Notation "1" := r1 : field_scope.
  Infix "==r" := req (at level 90) : field_scope.
  Infix "+r" := radd (at level 50) : field_scope.
  Infix "*r" := rmul (at level 40) : field_scope.
  Infix "-r" := rsub (at level 50) : field_scope.
  Notation "-r" := ropp (at level 30) : field_scope.
  Infix "/r" := rdiv (at level 40) : field_scope.
  Notation "/r" := rinv (at level 30) : field_scope.

  Variable (vadd : V -> V -> V) (vsmult : F -> V -> V) (v0 : V) (veq : V -> V -> Prop).

  Declare Scope vectorspace_scope.
  Delimit Scope vectorspace_scope with vecsc.
  Open Scope vectorspace_scope.

  Notation "0" := v0 : vectorspace_scope.
  Infix "==v" := veq (at level 90) : vectorspace_scope.
  Infix "+v" := vadd (at level 50) : vectorspace_scope.
  Infix "*v" := vsmult (at level 40) : vectorspace_scope.
  Notation "-v" := (vopp 1 ropp vsmult) (at level 30) : vectorspace_scope.

  (*2.17*)
  Definition linearly_independent {n : nat} (xs : t V n) : Prop :=
    forall (ys : t F n),
      fold_left vadd 0 (zipwith vsmult ys xs) ==v 0 ->
      Forall (fun y => y ==r 0%fieldsc) ys.

  (*2.17 b*)
  Theorem empty_independent : linearly_independent (@nil V).
  Proof.
    unfold linearly_independent; intros.
    specialize (nil_unique ys); intros.
    rewrite H0.
    apply Forall_nil.
  Qed.

  (*2.19*)
  Definition linearly_dependent {n : nat} (xs : t V n) : Prop :=
    exists (ys : t F n),
      Exists (fun y => y <> 0%fieldsc) ys -> fold_left vadd 0 (zipwith vsmult ys xs) ==v 0.

  Definition three_zeros : t V 3 :=
    (cons V 0 2 (cons V 0 1 (cons V 0 0 (nil V)))).
(*)
  Definition coprojection {A : Type} {n : nat} (v : t A n) (j : nat) (H : j < n) : t A (n-1) :=
    (*[x for i, x in enumerate(xs) if i != j]*)
    take (n-1) v.
*)
  Check nth_order (cons V 0 2 (cons V 0 1 (cons V 0 0 (nil V)))).
  Definition a_leq_prop := 5 <= 7.

  (*2.21*)
  Theorem linear_dependence_lemma1 {n : nat} (xs : t V n) (H : linearly_dependent xs) :
    exists (j : nat),
    forall (H0 : j <= n) (H1 : j < n),
      (@span F V vadd vsmult 0 veq j (take j H0 xs) (nth_order xs H1)).
  Proof.
    exists 1%nat.
    intros.
    induction xs.
    - inversion H0.
    - simpl.
      unfold linearly_dependent in H.
      destruct H as [ys H].
      unfold span.

  Admitted.

  (*2.23*)
  Theorem length_linearly_independent_list_leq_length_spanning_list {n m : nat} :
    forall (xs : t V n) (xs' : t V m),
      linearly_independent xs -> spans F V vadd vsmult 0 veq xs' -> n <= m.
  Proof.
    intros.
    unfold linearly_independent in H.
    unfold spans, span in H0.
  Admitted.

  Lemma fold_commute {n : nat} {a__k : t F n} {xs : t V n} {l : F} :
    fold_left vadd 0 (map (vsmult l) (zipwith vsmult a__k xs)) = vsmult l (fold_left vadd 0 (zipwith vsmult a__k xs)).
  Proof.
    generalize dependent a__k.
    induction xs; intros a__k.
    - specialize (nil_unique a__k); intros.
      rewrite H.
      simpl.
      symmetry.
      apply number_times_zero with (r0 := r0) (r1 := r1) (radd := radd) (rmul := rmul)
                                   (rsub := rsub) (ropp := ropp) (req := req) (rdiv := rdiv)
                                   (rinv := rinv) (vadd := vadd) (veq := veq); give_up.
    - simpl.
  Admitted.

  Lemma factor_out_scalar {n : nat} {a__k : t F n} {xs : t V n} : forall (l : F) (H__l : l <> 0%fieldsc),
      fold_left vadd 0 (map (vsmult l) (zipwith vsmult a__k xs)) = 0 ->
      fold_left vadd 0 (zipwith vsmult a__k xs) = 0.
  Proof.
    intros l H__l H__xsl.
    rewrite fold_commute in H__xsl.
    Admitted.

  (*exercise 2.A.8*)
  Theorem scalar_ind {n : nat} :
    forall (l : F) (H__l : l <> 0%fieldsc) (xs : t V n) (H__xs : linearly_independent xs),
      linearly_independent (map (vsmult l) xs).
  Proof.
    intros l H__l xs H__xs.
    unfold linearly_independent in *.
    intros b__k H__lx.
    specialize (H__xs b__k).
  Admitted.

  (*exercise 2.A.9*)
  (*This is actually false, counterexample is v = [2,0], [0,1] and w = [1, 2], [3, 1]*)
  Theorem sum_ind {n : nat} : forall (xs ys : t V n) (H__xs : linearly_independent xs) (H__ys : linearly_independent ys),
      linearly_independent (zipwith vadd xs ys).
  Proof.
    intros xs ys H__xs H__ys.
    unfold linearly_independent in *.
    intros b__k H__xys.
    specialize (H__xs b__k).
    apply H__xs.