(* Test vectors from <https://tools.ietf.org/html/rfc7748#section-5.2>,
   with hex values converted to decimal using python like this:
   > int.from_bytes(binascii.unhexlify('deadbeef'), 'little') *)
Require Import Coq.NArith.BinNatDef.
Require Import Coq.ZArith.BinIntDef.
Require Import Coq.PArith.BinPosDef.
Require Import Spec.ModularArithmetic Spec.MxDH Crypto.Util.Decidable.
Definition F := F (2^255 - 19).
Definition a : F := F.of_Z _ 486662.
Definition a24 : F := ((a - F.of_Z _ 2) / F.of_Z _ 4)%F.
Definition cswap {T} (swap:bool) (a b:T) := if swap then (b, a) else (a, b).
Definition monty s : F -> F := @MxDH.montladder F F.zero F.one F.add F.sub F.mul F.inv a24 cswap 255 (BinNat.N.testbit_nat s).

Example one_basepoint : F.to_Z (monty 1 (F.of_Z _ 9)) = 9%Z.
Proof. vm_decide_no_check. Qed.

Example testvector_one : F.to_Z (monty
   31029842492115040904895560451863089656472772604678260265531221036453811406496%N
   (F.of_Z _ 34426434033919594451155107781188821651316167215306631574996226621102155684838%Z)) = 37325765543539916631701301279660700968428932651319597985674090122993663859395%Z.
Proof. vm_decide_no_check. Qed.

Example testvector_two : F.to_Z (monty
   35156891815674817266734212754503633747128614016119564763269015315466259359304%N
   (F.of_Z _ 8883857351183929894090759386610649319417338800022198945255395922347792736741%Z)) = 39566196721700740701373067725336211924689549479508623342842086701180565506965%Z.
Proof. vm_decide_no_check. Qed.


Require Import Classical Equiv EquivFacts Msg NonEquiv Sty Tac TL TLFacts Var
  Wf WfFacts.

Lemma NSequiv_not_Tl_bisim :
  forall S S' eta c c',
  Wf S ->
  Wf S' ->
  NSequiv S S' ->
  ~ Tl_bisim (tl eta S c) (tl eta S' c').
Proof.
  introv Hwf Hwf' Hnsequiv. induction Hnsequiv; introv Hcontra; try solve
    [ inverts2 Hcontra; false
    | inverts2 Hcontra; eapply IHHnsequiv; eauto with wf
    ].
  - erewrite tl_mu_subst in Hcontra.
    * eapply IHHnsequiv; eauto with wf.
    * auto with wf.
  - erewrite tl_mu_subst in Hcontra.
    * eapply IHHnsequiv; eauto with wf.
    * auto with wf.
  - destruct S; destruct S'; simpl in *; solve
      [inverts2 Hcontra | false | auto with wf].
Unshelve.
  all: auto with wf.
Qed.

Theorem trace_bisim_equivalence_alt :
  forall S S' eta
  (Swf : Wf S)
  (S'wf : Wf S'),
  Tl_bisim (tl eta S (Wf_Contractive Swf)) (tl eta S' (Wf_Contractive S'wf)) ->
  Sequiv S S'.
Proof.
  intros S S' eta Swf Swf'. apply contrapositive.
  rewrite <- NSequiv_iff_not_Sequiv; trivial. apply NSequiv_not_Tl_bisim; auto.
Qed.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export dynamic_semantics.
Require Export semantics_util.
Require Export terms_util2.
Require Export list_util.

(**

   In the dynamic semantics of terms we derived terms without
   knowing that they're actually derivable.  Here we prove that
   they're actually derivable.

   Definitions and lemmas from this file are used in US lemmas proofs.

   Also, this file needs some cleaning up because it contains some old
   definitions that are not used anymore.

 *)

Definition DumKVar : KVariable := variable "".
Definition DumVR : (KVariable * R) := (DumKVar, DumR).
Definition S2R :=  state -> R.

Lemma partial_derive_st_test_2 :
  forall f v s,
    partial_derive f [v,v] s
    = Derive_n
        (fun r => f (upd_state s v r))
        2
        (s v).
Proof.
  introv; simpl.
  apply Derive_ext; introv.
  rewrite upd_state_same.
  apply Derive_ext; introv.
  rewrite upd_state_twice; auto.
Qed.

Lemma partial_derive_st_test_3 :
  forall f v s,
    partial_derive f [v,v,v] s
    = Derive_n
        (fun r => f (upd_state s v r))
        3
        (s v).
Proof.
  introv; simpl.
  apply Derive_ext; introv.
  rewrite upd_state_same.
  apply Derive_ext; introv.
  rewrite upd_state_same.
  rewrite upd_state_twice; auto.
  apply Derive_ext; introv.
  rewrite upd_state_twice; auto.
Qed.

Lemma partial_derive_st_const :
  forall c l st,
    (0 < List.length l)%nat -> partial_derive (fun _ => c) l st = 0%R.
Proof.
  induction l; introv h; simpl in *; try omega.
  destruct (deq_nat (List.length l) 0); subst.
  { destruct l; simpl in *; ginv.
    rewrite Derive_const; auto. }
  { rewrite (Derive_ext _ (fun _ => 0%R));
      try (introv; apply IHl; omega).
    apply Derive_const. }
Qed.

Lemma partial_derive_st_const0 :
  forall (l : list KAssignable) (st : state),
    partial_derive (fun _ : state => 0%R) l st = 0%R.
Proof.
  destruct l; introv.
  { simpl; auto. }
  { apply partial_derive_st_const; simpl; omega. }
Qed.

Lemma partial_derive_st_plus :
  forall l st L R,
    (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k L)
    -> (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k R)
    -> partial_derive (fun s => (L s + R s)%R) l st
       = (partial_derive L l st
          + partial_derive R l st)%R.
Proof.
  induction l; introv dL dR; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_plus; auto.
  { apply (dL (List.length l)); auto. }
  { apply (dR (List.length l)); auto. }
Qed.

Lemma partial_derive_st_plus_sublist :
  forall l st L R,
    (forall v k, sublist (v :: k) l -> ex_partial_derive L v k)
    -> (forall v k, sublist (v :: k) l -> ex_partial_derive R v k)
    -> partial_derive (fun s => (L s + R s)%R) l st
       = (partial_derive L l st
          + partial_derive R l st)%R.
Proof.
  induction l; introv dL dR; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].

  rewrite Derive_plus; auto.

  { apply dL.
    apply sublist_refl. }

  { apply dR.
    apply sublist_refl. }
Qed.

Lemma ex_nth_partial_derive_st_big_sum :
   forall (vs : list KAssignable) n (F : state -> KAssignable -> R),
    (forall v k, (k <= n)%nat -> List.In v vs -> ex_nth_partial_derive_st k (fun s => F s v))
    -> ex_nth_partial_derive_st n (fun s => big_sum vs (F s)).
Proof.
  induction vs; simpl; introv imp len; unfold ex_partial_derive_st_l.

  { destruct (deq_nat n 0) as [d|d]; subst; simpl in *.

    {
      destruct l; allsimpl; ginv.
      apply @ex_derive_const.
    }

    {
      eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_const;omega|].
      apply @ex_derive_const.
    }
  }

  {
    eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_plus|].

    { introv w; auto.
      apply imp; auto; try omega. }

    { introv w1.
      apply IHvs; introv w2 w3.
      apply imp; auto; try omega. }

    { apply @ex_derive_plus.
      { apply (imp a (List.length l)); auto; try omega. }
      { apply (IHvs (List.length l)); auto.
        introv h1 h2; apply imp; tcsp; try omega. }
    }
  }
Qed.

Definition DumKAssign : KAssignable := KAssignVar (variable "").

Definition lastv (l : list KAssignable) : KAssignable :=
  last l DumKAssign.

Lemma lastv_snoc :
  forall v l,
    lastv (snoc l v) = v.
Proof.
  unfold lastv; induction l; simpl; auto.
  rewrite IHl.
  destruct l; simpl; auto.
Qed.
Hint Rewrite lastv_snoc : core.

Lemma partial_derive_st_S :
  forall f l st,
    (0 < List.length l)%nat
    -> partial_derive f l st
       = partial_derive
           (fun s =>
              Derive
                (fun x => f (upd_state s (lastv l) x))
                (s (lastv l)))
           (removelast l)
           st.
Proof.
  induction l as [l ind] using list_ind_len; introv len.
  destruct (snoc_cases l) as [h|h]; exrepnd; subst; simpl in *; try omega.
  autorewrite with core in *.
  destruct k as [|v l]; simpl in *; auto.
  apply Derive_ext; introv.
  rewrite ind; autorewrite with core; try omega; auto.
Qed.

Lemma length_removelast :
  forall {T} (l : list T), List.length (removelast l) = Nat.pred (List.length l).
Proof.
  induction l; simpl; auto.
  destruct l; simpl; auto.
Qed.

Lemma ex_nth_partial_derive_st_add_Derive :
  forall n F v,
    ex_nth_partial_derive_st (S n) F
    -> ex_nth_partial_derive_st
         n
         (fun s => Derive (fun x => F (upd_state s v x)) (s v)).
Proof.
  introv d len.
  pose proof (d st (snoc l v) v0) as q.
  autorewrite with core in *.
  autodimp q hyp.
  eapply ex_derive_ext in q;
    [|introv;apply partial_derive_st_S;autorewrite with core;omega].
  simpl in q.
  eapply ex_derive_ext;[clear q|exact q].
  introv; simpl.
  autorewrite with core in *; auto.
Qed.

Lemma ex_all_partial_derive_st_add_Derive :
  forall F v,
    ex_all_partial_derive_st F
    -> ex_all_partial_derive_st
         (fun s => Derive (fun x => F (upd_state s v x)) (s v)).
Proof.
  introv d len.
  apply (ex_nth_partial_derive_st_add_Derive n); auto.
Qed.

Lemma upd_state_var_eq :
  forall s v r a,
    upd_state_var s v r a
    = if KAssignable_dec a (KAssignVar v)
      then r
      else s a.
Proof.
  sp.
Qed.

Lemma upd_state_var_eq2 :
  forall s v r w,
    upd_state_var s v r (KAssignVar w)
    = if KVariable_dec w v
      then r
      else s (KAssignVar w).
Proof.
  introv; rewrite upd_state_var_eq; repeat (dest_cases w); subst; tcsp.
Qed.

(* Can we do without function extensionality here?
   Use lists instead of functions? *)
Lemma upd_state_swap :
  forall st a1 r1 a2 r2,
    upd_state (upd_state st a1 r1) a2 r2
    = if KAssignable_dec a1 a2
      then upd_state st a2 r2
      else upd_state (upd_state st a2 r2) a1 r1.
Proof.
  introv.
  unfold upd_state.
  apply functional_extensionality; introv.
  destruct (KAssignable_dec x a2) as [d1|d1]; subst; tcsp;
    destruct (KAssignable_dec a1 a2) as [d2|d2]; subst; tcsp;
      try (destruct (KAssignable_dec a2 a2) as [d3|d3]; subst; tcsp);
      try (destruct (KAssignable_dec a2 a1) as [d4|d4]; subst; tcsp);
      try (destruct (KAssignable_dec x a1) as [d5|d5]; subst; tcsp);
      try (destruct (KAssignable_dec x a2) as [d6|d6]; subst; tcsp).
Qed.

Lemma upd_state_var_swap :
  forall st a1 r1 a2 r2,
    upd_state_var (upd_state_var st a1 r1) a2 r2
    = if KVariable_dec a1 a2
      then upd_state_var st a2 r2
      else upd_state_var (upd_state_var st a2 r2) a1 r1.
Proof.
  introv.
  unfold upd_state_var.
  rewrite upd_state_swap.
  destruct (KVariable_dec a1 a2) as [d1|d1];
    destruct (KAssignable_dec (KAssignVar a1) (KAssignVar a2)) as [d2|d2];
    subst; tcsp.
  inversion d2; tcsp.
Qed.

Lemma upd_state_eq2 :
  forall s v r w,
    upd_state s v r w
    = if KAssignable_dec w v
      then r
      else s w.
Proof.
  introv; unfold upd_state; auto.
Qed.

Lemma partial_derive_st_ext2 :
  forall f g l v w,
    (forall a, v a = w a)
    -> (forall s1 s2, (forall a, s1 a = s2 a) -> f s1 = g s2)
    -> partial_derive f l v = partial_derive g l w.
Proof.
  induction l; introv exts imp; simpl; auto.
  rewrite exts.
  apply Derive_ext; introv.
  apply IHl; auto.
  introv.
  unfold upd_state; dest_cases w.
Qed.

Lemma partial_derive_st_add_upd :
  forall F l st v r,
    ~ (List.In v l)
    -> partial_derive F l (upd_state st v r)
       = partial_derive (fun s => F (upd_state s v r)) l st.
Proof.
  induction l; introv h; simpl in *; auto.
  apply not_or in h; repnd.
  rewrite (upd_state_eq2 st v r a).
  dest_cases w.
  apply Derive_ext; introv; simpl.
  rewrite upd_state_swap.
  dest_cases w.
Qed.

Lemma partial_derive_st_add_upd2 :
  forall F l s v,
    ~ List.In v l
    -> partial_derive F l (upd_state s v (s v))
       = partial_derive (fun s => F (upd_state s v (s v))) l s.
Proof.
  induction l; introv h; simpl in *; auto.
  apply not_or in h; repnd.
  rewrite (upd_state_eq2 s v (s v) a); dest_cases w; GC.
  apply Derive_ext; introv; simpl.
  rewrite upd_state_swap.
  dest_cases w; subst.
  pose proof (IHl (upd_state s a t) v) as q; autodimp q hyp.
  rewrite upd_state_eq2 in q; dest_cases w.
Qed.

Lemma ex_nth_partial_derive_st_ext :
  forall n F G,
    (forall s, F s = G s)
    -> ex_nth_partial_derive_st n F
    -> ex_nth_partial_derive_st n G.
Proof.
  introv imp d len; simpl.
  eapply ex_derive_ext;[|apply d;exact len].
  simpl; introv.
  apply partial_derive_st_ext; auto.
Qed.

      (*
Lemma ex_nth_partial_derive_st_add_upd :
  forall n F v,
    ex_nth_partial_derive_st n F
    -> ex_nth_partial_derive_st n (fun s => F (upd_state_var s v (s (KAssignVar v)))).
Proof.
  introv d len; simpl.

  destruct (in_dec KVariable_dec v l) as [d1|d1].

  {
    (* v in l *)

  }

  {

    (* not (v in l) *)

    eapply ex_derive_ext;[introv;apply partial_derive_st_add_upd2;auto|]; simpl.
    eapply ex_derive_ext;[introv;rewrite upd_state_var_swap;reflexivity|]; simpl.
    dest_cases w; subst; simpl.
    { eapply ex_derive_ext;[introv;rewrite (upd_state_var_same st v t);reflexivity|]; simpl.
      apply d; auto. }
    { eapply ex_derive_ext;[introv;rewrite (upd_state_var_eq2 st v0 t v);dest_cases w|]; simpl.
      pose proof (d (upd_state_var st v (st (KAssignVar v))) l v0) as q; simpl in q.
      rewrite upd_state_var_eq2 in q; dest_cases w; GC.
      apply q; auto.
    }

Lemma partial_derive_st_upd_in :
  forall l F st v,
    List.In v l
    -> partial_derive_st (fun s => F (upd_state_var s v (s (KAssignVar v)))) l st
       = 0.
Proof.
  induction l; introv h; simpl in *; auto; tcsp; repndors; subst.

  {

Lemma partial_derive_st_upd_same :
  forall F v r s l,
    partial_derive_st
      (fun s => F (upd_state_var s v (s (KAssignVar v))))
      l
      (upd_state_var s v r)
    = partial_derive_st
        (fun s => F (upd_state_var s v r))
        l
        s.
Proof.
  induction l; introv; simpl; auto.

  {
    rewrite upd_state_var_same.
    rewrite upd_state_var_twice; auto.
  }

  {
    apply Derive_ext; introv.
    rewrite upd_state_var_swap.
    dest_cases w.
  }
Qed.
Hint Rewrite partial_derive_st_upd_same : core.
    erewrite Derive_ext;
      [|introv;rewrite partial_derive_st_upd_same;reflexivity].
    apply Derive_const.
  }

  {
    match goal with
    | [ H : _ = _ |- _ ] => apply inj_pair2_eq_dec in H
    end; subst; tcsp; try (apply deq_nat).
    erewrite Derive_ext;
      [|introv;apply IHl;auto].
    apply Derive_const.
  }
Qed.

    eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_upd_in;auto|].
    apply ex_derive_const.
  }

  {
    eapply ex_derive_ext;[introv;apply partial_derive_st_add_upd;auto|].
    eapply ex_derive_ext;[introv;rewrite upd_state_var_swap;reflexivity|].
    dest_cases w; subst.
    { apply ex_derive_const. }
    { apply d.  }
  }
Qed.
       *)

Lemma length_removelast_cons :
  forall {T} (v : T) l,
    List.length (removelast (v :: l)) = List.length l.
Proof.
  induction l; simpl in *; auto.
  rewrite <- IHl.
  destruct l; simpl; auto.
Qed.
Hint Rewrite @length_removelast_cons.

Lemma ex_nth_partial_derive_st_mult :
  forall (L R : state -> R) n,
    (forall k, (k <= n)%nat -> ex_nth_partial_derive_st k L)
    -> (forall k, (k <= n)%nat -> ex_nth_partial_derive_st k R)
    -> ex_nth_partial_derive_st n (fun st => (L st * R st)%R).
Proof.
  introv dL dR; simpl.
  revert L R dL dR.
  induction n as [n IHn] using comp_ind; introv dL dR len.
  destruct n.

  {
    destruct l; simpl in *; ginv.
    apply ex_derive_mult.
    { apply (dL 0%nat (le_n 0) st []); simpl; auto. }
    { apply (dR 0%nat (le_n 0) st []); simpl; auto. }
  }

  {
    eapply ex_derive_ext;
      [introv;symmetry;apply partial_derive_st_S;omega
      |].
    simpl.

    eapply ex_derive_ext; simpl;
      [introv; symmetry;
       apply partial_derive_st_ext;
       introv;apply Derive_mult
      |].

    { apply (dL 0%nat (Peano.le_0_n _) s []); tcsp. }
    { apply (dR 0%nat (Peano.le_0_n _) s []); tcsp. }

    {
      simpl.
      eapply ex_derive_ext; simpl;
        [introv; symmetry;apply partial_derive_st_plus;simpl
        |];[| |].

      {
        introv h.
        rewrite length_removelast in h.
        apply IHn; clear IHn; try omega.
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dL; try omega. }
        { introv w; simpl.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dR; try omega. }
      }

      {
        introv h; simpl.
        rewrite length_removelast in h.
        apply IHn; clear IHn; try omega.
        { introv w.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dL; try omega. }
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dR; try omega. }
      }

      simpl.
      apply @ex_derive_plus; simpl.

      {
        destruct l as [|k l]; simphyps; try omega; ginv.
        pose proof (IHn (List.length l)) as q; autodimp q hyp.
        apply (q (fun s =>
                    Derive
                      (fun x0 =>
                         L (upd_state s (lastv (k :: l)) x0))
                      (s (lastv (k :: l))))
                 (fun s =>
                    R
                      (upd_state s (lastv (k :: l))
                                 (s (lastv (k :: l))))));
          autorewrite with core in *; auto.
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dL; try omega. }
        { introv w.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dR; try omega. }
      }

      {
        destruct l as [|k l]; simphyps; try omega; ginv.
        pose proof (IHn (List.length l)) as q; autodimp q hyp.
        apply (q (fun s =>
                    L (upd_state s (lastv (k :: l))
                                 (s (lastv (k :: l)))))
                 (fun s =>
                    Derive
                      (fun x0 =>
                         R (upd_state s (lastv (k :: l)) x0))
                      (s (lastv (k :: l)))));
          autorewrite with core in *; auto.
        { introv w.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dL; try omega. }
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dR; try omega. }
      }
    }
  }
Qed.

Lemma ex_all_partial_derive_st_read :
  forall x, ex_all_partial_derive_st (fun S => S x).
Proof.
  introv; introv.
  induction n; introv len; unfold ex_partial_derive_st_l.

  { destruct l; simpl in *; ginv.
    unfold upd_state_var, upd_state.
    dest_cases w; subst;
      [apply @ex_derive_id|apply @ex_derive_const].
  }

  { eapply ex_derive_ext;
      [introv;symmetry;apply partial_derive_st_S;omega|].
    simpl.
    unfold upd_state_var, upd_state at 1.
    dest_cases w; subst.

    { eapply ex_derive_ext;
        [introv;symmetry;apply partial_derive_st_ext;introv;apply Derive_id|].
      simpl.
      destruct (deq_nat n 0); subst; simpl.
      { repeat (destruct l; simpl in *; ginv).
        apply @ex_derive_const. }
      eapply ex_derive_ext;
        [introv;symmetry;apply partial_derive_st_const;rewrite length_removelast;omega|].
      apply @ex_derive_const.
    }

    { eapply ex_derive_ext;
        [introv; symmetry;apply partial_derive_st_ext;introv;apply Derive_const|].
      simpl.
      destruct (deq_nat n 0); subst; simpl.
      { repeat (destruct l; simpl in *; ginv).
        apply @ex_derive_const. }
      eapply ex_derive_ext;
        [introv;symmetry;apply partial_derive_st_const;rewrite length_removelast;omega|].
      apply @ex_derive_const.
    }
  }
Qed.

Lemma partial_derive_st_KAssignVar_prop1 :
  forall F l st v,
    ~ List.In v l
    -> partial_derive (fun s => Derive (F s) (s v)) l st
       = partial_derive (fun s => Derive (F s) (st v)) l st.
Proof.
  induction l; introv nin; simpl in *; auto.
  apply not_or in nin; repnd.
  apply Derive_ext; introv.
  rewrite (IHl (upd_state st a t) v); auto; clear IHl.
  apply partial_derive_st_ext; introv.
  rewrite upd_state_eq2.
  dest_cases w.
Qed.

Lemma ex_all_partial_derive_st_differential :
  forall vs T,
    ex_all_partial_derive_st T
    -> ex_all_partial_derive_st
         (fun v : state =>
            big_sum
              vs
              (fun x : KAssignable =>
                 (v (KD x)
                  *
                  Derive (fun X => T (upd_state v x X)) (v x)))%R).
Proof.
  introv dT; introv.
  apply ex_nth_partial_derive_st_big_sum; introv w i.

  apply ex_nth_partial_derive_st_mult.

  {
    introv lk.
    apply ex_all_partial_derive_st_read.
  }

  introv lk len; simpl.
  pose proof (dT (S k0) st (snoc l v) v0) as h; simpl in h.
  autorewrite with core in *; autodimp h hyp;[].
  eapply ex_derive_ext in h;
    [|introv;apply partial_derive_st_S; autorewrite with core; try omega].
  simpl in *; autorewrite with core in *.
  auto.
Qed.

Lemma ex_all_partial_derive_st_constant :
  forall c, ex_all_partial_derive_st (fun _ => c).
Proof.
  introv len; unfold ex_partial_derive_st_l; simpl.
  destruct l.
  { simpl; apply @ex_derive_const. }
  { apply (@ex_derive_ext
             Hierarchy.R_AbsRing
             Hierarchy.R_NormedModule
             (fun _ => 0%R)).
    { introv.
      rewrite partial_derive_st_const; simpl; try omega; auto. }
    { simpl; apply @ex_derive_const. }
  }
Qed.

Lemma ex_all_partial_derive_st_plus :
  forall (L R : state -> R),
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st R
    -> ex_all_partial_derive_st (fun st => (L st + R st)%R).
Proof.
  introv d1 d2 len; simpl in *.
  eapply ex_derive_ext;
    [introv;symmetry;apply partial_derive_st_plus; auto|].
  apply @ex_derive_plus;[apply (d1 n)|apply (d2 n)];auto.
Qed.

(*
   This shows that [ex_partial_derive_st_func] might not be that bogus after all.
 *)
Lemma ex_partial_derive_st_func_plus_vector : ex_partial_derive_st_func plus_vector.
Proof.
  introv d; introv.
  unfold plus_vector; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_all_partial_derive_st (fun s : state => G s t)) ->
                   ex_all_partial_derive_st
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => (G s h + G s h0)%R
                        | @Vector.cons _ _ _ _ => 0%R
                        end))).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp;[repeat constructor|].

  apply ex_all_partial_derive_st_plus; auto.
Qed.

Lemma ex_partial_derive_st_l_pt_plus :
  forall (L R : state -> R) v l,
    (forall w l', sublist (w :: l') (v :: l) -> ex_partial_derive L w l')
    -> (forall w l', sublist (w :: l') (v :: l) -> ex_partial_derive R w l')
    -> ex_partial_derive (fun st => (L st + R st)%R) v l.
Proof.
  introv d1 d2; introv; simpl in *.
  eapply ex_derive_ext;
    [introv;symmetry;apply partial_derive_st_plus_sublist; auto|].
  simpl.
  apply @ex_derive_plus; simpl;[apply d1|apply d2];apply sublist_refl.
Qed.

(*
  Similar to [ex_partial_derive_st_func_plus_vector].  We show that
  [ex_partial_derive_st_func] make at least sense for Rplus.
 *)
Lemma ex_partial_derive_st_func_sub_plus_vector :
  smooth_fun_T plus_vector.
Proof.
  introv d cond.
  unfold plus_vector; simpl.
  revert cond.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t w l',
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       sublist (w :: l') (v :: l) ->
                       ex_partial_derive (fun s : state => G s t) w l') ->
                   ex_partial_derive
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => (G s h + G s h0)%R
                        | @Vector.cons _ _ _ _ => 0%R
                        end) v l)).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.

  apply ex_partial_derive_st_l_pt_plus; auto; introv ss;
    [apply h1|apply h2]; auto; repeat constructor.
Qed.

(* This is a generalization of plus_vector *)
Definition bin2vec (f : R -> R -> R) : Vector.t R 2%nat -> R :=
  fun v : Vector.t R 2%nat =>
    match v with
    | Vector.cons x 1 (Vector.cons y 0 Vector.nil) => f x y
    | _ => R0
    end.

(* This is a generalization of ex_partial_derive_st_func_plus_vector *)
Lemma ex_partial_derive_st_func_bin2vec :
  forall f,
    (forall (L R : state -> R),
        ex_all_partial_derive_st L
        -> ex_all_partial_derive_st R
        -> ex_all_partial_derive_st (fun st => f (L st) (R st)))
    -> ex_partial_derive_st_func (bin2vec f).
Proof.
  introv cond d; introv.
  unfold bin2vec; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_all_partial_derive_st (fun s : state => G s t)) ->
                   ex_all_partial_derive_st
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => f (G s h) (G s h0)
                        | @Vector.cons _ _ _ _ => 0%R
                        end))).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp.
  repeat constructor.
Qed.

Lemma partial_derive_st_opp :
  forall l st L,
    (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k L)
    -> partial_derive (fun s => - (L s)) l st
       = - partial_derive L l st.
Proof.
  induction l; introv dL; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_opp; auto.
Qed.

Lemma partial_derive_st_opp_sublist :
  forall l st L,
    (forall v k, sublist (v :: k) l -> ex_partial_derive L v k)
    -> partial_derive (fun s => - L s) l st
       = - partial_derive L l st.
Proof.
  induction l; introv dL; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_opp; auto.
Qed.

Lemma ex_all_partial_derive_st_neg :
  forall L,
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st (fun s => - (L s)).
Proof.
  introv dL len.
  eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_opp;auto|];[].
  apply @ex_derive_opp.
  apply (dL n); auto.
Qed.

Lemma partial_derive_st_minus :
  forall l st L R,
    (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k L)
    -> (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k R)
    -> partial_derive (fun s => (L s - R s)%R) l st
       = (partial_derive L l st
          - partial_derive R l st)%R.
Proof.
  induction l; introv dL dR; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_minus; auto;[apply (dL (List.length l))|apply (dR (List.length l))];try omega.
Qed.

Lemma ex_all_partial_derive_st_minus :
  forall L R,
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st R
    -> ex_all_partial_derive_st (fun s => (L s - R s)%R).
Proof.
  introv d1 d2 len; simpl in *.
  eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_minus; auto|].
  apply @ex_derive_minus;[apply (d1 n)|apply (d2 n)]; auto.
Qed.

Lemma ex_all_partial_derive_st_mult :
  forall (L R : state -> R),
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st R
    -> ex_all_partial_derive_st (fun st => (L st * R st)%R).
Proof.
  introv dL dR; introv; simpl.
  apply ex_nth_partial_derive_st_mult; introv w; auto.
Qed.

Lemma ex_derive_all_n_implies_ex_derive :
  forall F,
    ex_derive_all_n F
    -> ex_derive_all F.
Proof.
  introv h; introv.
  pose proof (h 1%nat pt) as w; auto.
Qed.

Lemma implies_ex_derive_all_n_Derive :
  forall F,
    ex_derive_all_n F
    -> ex_derive_all_n (Derive F).
Proof.
  introv h; introv.
  pose proof (h (S n) pt) as q.
  apply ex_derive_n_S_implies in q; auto.
  pose proof (h 1%nat pt) as w; auto.
Qed.

Lemma ex_derive_partial_derive_st_comp :
  forall (F : R -> R) (A : state -> R) st v l,
    ex_all_partial_derive_st A
    -> ex_derive_all_n F
    -> ex_derive_R
         (fun X =>
            partial_derive
              (fun s => F (A s))
              l
              (upd_state st v X))
         (st v).
Proof.
  introv.
  remember (List.length l) as n.
  revert F A st v l Heqn.
  induction n as [n IHn] using comp_ind; introv e dA dF; subst.
  destruct l as [|k l].

  {
    simpl.
    apply @ex_derive_comp.
    { apply ex_derive_all_n_implies_ex_derive in dF; apply dF. }
    apply (dA 0%nat st []); simpl; auto.
  }

  {
    eapply ex_derive_ext;
      [introv;symmetry;
       apply (partial_derive_st_S (fun s : state => F (A s)));
       simpl; try omega|].
    remember (k :: l) as L.
    simpl.

    eapply ex_derive_ext; simpl;
      [introv; symmetry;
       apply partial_derive_st_ext;
       introv;apply Derive_comp
      |].

    { apply ex_derive_all_n_implies_ex_derive in dF; apply dF. }

    { apply (dA 0%nat s []); simpl; auto. }

    {
      simpl.
      apply (ex_nth_partial_derive_st_mult _ _ (List.length (removelast L)));auto.
      { introv w; apply ex_nth_partial_derive_st_add_Derive; auto. }
      { introv w len.
        rewrite HeqL in w; autorewrite with core in *.
        apply (IHn k0);auto;[subst; simpl; try omega| |].

        { eapply ex_all_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|]; auto. }

        { apply implies_ex_derive_all_n_Derive; auto. }
      }
    }
  }
Qed.

Lemma ex_partial_derive_st_func_l_plus_vector : ex_partial_derive_st_func_l plus_vector.
Proof.
  introv d; introv.
  unfold plus_vector; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_partial_derive_st_l (fun s : state => G s t) st l v) ->
                   ex_partial_derive_st_l
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => (G s h + G s h0)%R
                        | @Vector.cons _ _ _ _ => 0%R
                        end) st l v)).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp;[repeat constructor|].

  pose proof (ex_all_partial_derive_st_plus (fun s => G s x) (fun s => G s y)) as h.
  repeat (autodimp h hyp);[| |eapply h; eauto].

Abort.

Lemma ex_all_partial_derive_st_funcOf :
  forall f m (args : Vector.t Term m) (I : interpretation),
    (forall t I,
        Vector.In t args
        -> ex_all_partial_derive_st (fun s => dynamic_semantics_term I s t))
    -> ex_all_partial_derive_st
         (fun s =>
            interp_fun_f
              m
              (I (SymbolFunction f m))
              (Vector.map (dynamic_semantics_term I s) args)).
Proof.
  introv ih.
  remember (I (SymbolFunction f m)) as pF; simpl in pF.
  destruct pF as [F sm]; simpl.
  clear dependent f.
  introv len; subst.
  apply sm; clear sm; try (exact (KTdot 0)); auto.
  introv i ss; introv; simpl in *.
  pose proof (ih t I i (length l') (upd_state s w pt) l' w eq_refl) as q.
  unfold ex_partial_derive_st_l in q; simpl in q.
  autorewrite with core in q.
  eapply ex_derive_ext;[|exact q];clear q; simpl; introv.
  autorewrite with core; auto.
Qed.

Lemma ex_all_partial_derive_st_dynamic_semantics_term :
  forall (t : Term) (I : interpretation),
    ex_all_partial_derive_st (fun s => dynamic_semantics_term I s t).
Proof.
  term_ind t Case; introv; simpl.

  { Case "KTdot".
    apply ex_all_partial_derive_st_constant.
  }

  { Case "KTfuncOf".
    apply ex_all_partial_derive_st_funcOf; auto.
  }

  { Case "KTnumber".
    apply ex_all_partial_derive_st_constant.
  }

  { Case "KTread".
    apply ex_all_partial_derive_st_read.
  }

  { Case "KTneg".
    apply ex_all_partial_derive_st_neg;auto.
  }

  { Case "KTplus".
    apply ex_all_partial_derive_st_plus;auto.
  }

  { Case "KTminus".
    apply ex_all_partial_derive_st_minus;auto.
  }

  { Case "KTtimes".
    apply ex_all_partial_derive_st_mult;auto.
  }

  { Case "KTdifferential".
    apply (ex_all_partial_derive_st_differential _ (fun s => dynamic_semantics_term I s t)); auto.
  }
Qed.
Hint Resolve ex_all_partial_derive_st_dynamic_semantics_term : core.

Lemma ex_partial_derive_st_pt_dynamic_semantics_term :
  forall (t : Term) (I : interpretation),
    ex_partial_derive_st_pt (fun s => dynamic_semantics_term I s t).
Proof.
  introv.
  apply ex_partial_derive_st_pt_eq_all; eauto 3 with core.
Qed.
Hint Resolve ex_partial_derive_st_pt_dynamic_semantics_term : core.


Require Import Utils.

Module Type CTXTYP.

Parameter Tp : Type->Type.

Parameter tpTp : forall G,Tp G->G->Type.
Implicit Arguments tpTp [G].
Coercion tpTp : Tp >-> Funclass.

Parameter tpMap : forall G G' (f:G'->G),Tp G->Tp G'.
Implicit Arguments tpMap [G G'].

Parameter tpMapEq : forall G G' (f:G'->G) (T:Tp G),(fun g=>T (f g)) = tpMap f T.
Implicit Arguments tpMapEq [G G'].

End CTXTYP.

Module Context (Import Typ : CTXTYP).

(* Semantic contexts *)

Inductive CtxS : Type->Type :=
	empCtxS : CtxS unit |
	extCtxS G : CtxS G->forall T:Tp G,CtxS (sigT T).
Implicit Arguments extCtxS [G].

Inductive Ctx : Type := ctx G (s:CtxS G).
Implicit Arguments ctx [G].

Definition ctxTp G := match G with ctx G _ => G end.
Coercion ctxTp : Ctx >-> Sortclass.

Definition ctxSc (G:Ctx) : CtxS G := match G with ctx _ s => s end.

Definition empCtx := ctx empCtxS.
Definition extCtx G T := ctx (extCtxS (ctxSc G) T).

Definition IsExtCtx G := match G with
	ctx _ empCtxS => False |
	ctx _ (extCtxS _ _ _) => True
end.

Definition ctxInit G := match G with
	ctx _ empCtxS => empCtx |
	ctx _ (extCtxS _ s _) => ctx s
end.

Definition ctxTop G : forall ne:IsExtCtx G,Tp (ctxInit G).
	destruct G.
	destruct s;simpl;intro.

	destruct ne.

	exact T.
Defined.
Implicit Arguments ctxTop [G].

Fixpoint ctxLenS G (s:CtxS G) := match s with
	empCtxS => O |
	extCtxS _ s _ => S (ctxLenS _ s)
end.
Implicit Arguments ctxLenS [G].

Definition ctxLen G := ctxLenS (ctxSc G).

Definition extCtxUnfold G : forall ne:IsExtCtx G,G = extCtx (ctxInit G) (ctxTop ne).
	destruct G.
	destruct s;simpl;intro.

	destruct ne.

	reflexivity.
Defined.
Implicit Arguments extCtxUnfold [G].

Definition extCtxInj G1 G2 : forall T1 T2 (e:extCtx G1 T1 = extCtx G2 T2),
existT Tp G1 T1 = existT Tp G2 T2.
	destruct G1 as (G1,s1).
	destruct G2 as (G2,s2).
	simpl.
	intros.
	generalize I.
	apply (tr (fun Gx=>forall ne:IsExtCtx Gx,_ = existT _ _ (ctxTop ne)) e).
	simpl.
	intro.
	reflexivity.
Defined.
Implicit Arguments extCtxInj [G1 G2 T1 T2].

(* Strongly typed de Bruijn indexes *)

(*
Inductive AtCtx : forall G:Ctx,nat->Tp G->Type :=
	topCtx G T : AtCtx (extCtx G T) O (tpMap (@projT1 _ _) T) |
	popCtx G n T : AtCtx G n T->forall T',AtCtx (extCtx G T') (S n) (tpMap (@projT1 _ _) T).
*)

Inductive PopCtx G (T':G->Type) P : Tp (sigT T')->Type :=
	mkPopCtx T : P T->PopCtx G T' P (tpMap (@projT1 _ _) T).
Implicit Arguments PopCtx [G].
Implicit Arguments mkPopCtx [G].

Fixpoint AtCtxS G (s:CtxS G) n := match s in CtxS G return forall T:Tp G,Type with
	empCtxS => fun T=>Empty_set |
	extCtxS _ s T' => match n with
		O => eq (tpMap (@projT1 _ _) T') |
		S n => PopCtx T' (AtCtxS _ s n)
	end
end.
Implicit Arguments AtCtxS [G].

Definition AtCtx G := AtCtxS (ctxSc G).

Definition topCtx G T : AtCtx (extCtx G T) O (tpMap (@projT1 _ _) T) := eq_refl _.

Definition popCtx G n T (a:AtCtx G n T) T' : AtCtx (extCtx G T') (S n) (tpMap (@projT1 _ _) T) :=
	mkPopCtx _ _ _ a.
Implicit Arguments popCtx [G n T].

Definition atCtxIndS (P:forall G n T,AtCtx G n T->Type)
	(top:forall G T,P _ _ _ (topCtx G T))
	(pop:forall G n T (a:AtCtx G n T) (IHa:P _ _ _ a) T',P _ _ _ (popCtx a T'))
: forall G (s:CtxS G) n T (a:AtCtx (ctx s) n T),P _ _ _ a.
	refine (fix atCtxIndS G s n := match s in CtxS G return forall T (a:AtCtx (ctx s) n T),P _ _ _ a with
		empCtxS => _ |
		extCtxS _ s _ => _
	end);clear G s;simpl;intro.

	intro.
	destruct a.

	destruct n;unfold AtCtx;simpl;intro;destruct a.
		exact (top (ctx s0) _).

		exact (pop _ _ _ _ (atCtxIndS _ _ _ _ _) _).
Defined.

Definition AtCtx_rect (P:forall G n T,AtCtx G n T->Type)
	(top:forall G T,P _ _ _ (topCtx G T))
	(pop:forall G n T (a:AtCtx G n T) (IHa:P _ _ _ a) T',P _ _ _ (popCtx a T'))
G := match G return forall n T (a:AtCtx G n T),P _ _ _ a with ctx _ s => atCtxIndS P top pop _ s end.
Implicit Arguments AtCtx_rect [G n T].

Inductive ExAtCtx G n : Type := exAtCtx T (a:AtCtx G n T).
Implicit Arguments exAtCtx [G n T].

Definition xa_T G n (xa:ExAtCtx G n) := match xa with exAtCtx T _ => T end.
Implicit Arguments xa_T [G n].

Definition xa_a G n (xa:ExAtCtx G n) : AtCtx G n (xa_T xa) := match xa with exAtCtx _ a => a end.
Implicit Arguments xa_a [G n].

Definition atCtxUniq G n T1 (a1:AtCtx G n T1) : forall T2 (a2:AtCtx G n T2),
exAtCtx a1 = exAtCtx a2.
	induction a1 as [| ? ? T1] using AtCtx_rect;intros.

	destruct a2.
	reflexivity.

	change (PopCtx T' (AtCtx G n) T2) in a2.
	destruct a2 as (T2,a2).
	exact (tr (fun xa=>_ = exAtCtx (popCtx (xa_a xa) T')) (IHa1 _ a2) (eq_refl _)).
Defined.
Implicit Arguments atCtxUniq [G n T1 T2].

Definition ctxProj G n T (a:AtCtx G n T) : forall g,T g.
	induction a using AtCtx_rect.

	apply (tr (fun X=>forall g,X g) (tpMapEq (@projT1 _ T) T)).
	exact (@projT2 _ _).

	apply (tr (fun X=>forall g,X g) (tpMapEq (@projT1 _ T') T)).
	exact (fun g=>IHa (projT1 g)).
Defined.
Implicit Arguments ctxProj [G n T].

(*
Remark ctxProj_top G T : ctxProj (topCtx G T) = @projT2 _ _.
	reflexivity.
Qed.

Definition ctxProj_pop G n := match G
return forall T (a:AtCtx G n T) T',(fun g=>ctxProj a (projT1 g)) = ctxProj (popCtx a T')
	with ctx _ _ => fun _ _ _=>eq_refl _ end.
Implicit Arguments ctxProj_pop [G n T].

Definition atCtxEta G n : forall T (a:AtCtx G n T),AtCtx G n (fun g=>T g).
	destruct G.
	unfold AtCtx.
	simpl.
	intro.
	destruct s as [| ? ? T'].

	simpl.
	exact (fun x=>x).

	destruct n;simpl;intro;destruct a.
		reflexivity.

		exact (mkPopCtx _ _ _ a).
Defined.
Implicit Arguments atCtxEta [G n T].

Definition ctxProj_Eta G n : forall T (a:AtCtx G n T),(fun g=>ctxProj a g) = ctxProj (atCtxEta a).
	destruct G.
	unfold AtCtx.
	simpl ctxSc.
	simpl ctxTp.
	intro.
	destruct s as [| ? ? T'].

	simpl AtCtxS.
	intro.
	destruct a.

	destruct n;simpl AtCtxS;intro;destruct a;reflexivity.
Defined.
Implicit Arguments ctxProj_Eta [G n T].
*)

(* Iterated context extension *)

Inductive ExtCtx GL : nat->Ctx->Type :=
	extOCtx : ExtCtx GL O GL |
	extSCtx n G : ExtCtx GL n G->forall T:G->Type,ExtCtx GL (S n) (extCtx G T).
Implicit Arguments extSCtx [GL n G].

Definition extSCtxInv GL n G T (xg:ExtCtx GL (S n) (extCtx G T)) (P:forall n G T,ExtCtx GL n (extCtx G T)->Type)
	(xgS:forall xg:ExtCtx GL n G,P _ _ _ (extSCtx xg T))
: P _ _ _ xg.
	pose (P' n Gx (xg:ExtCtx GL n Gx) := forall ne:IsExtCtx Gx,
		P _ _ _ (tr (ExtCtx GL n) (extCtxUnfold ne) xg)).
	assert (Peq := match G as G return forall T xg,P (S n) G T xg = P _ (ctx (ctxSc G)) _ xg
		with ctx _ _ => fun _ _=>eq_refl _ end T).
	apply (tr (fun C=>C) (eq_sym (Peq _))).
	generalize I.
	change (P' _ _ xg).
	refine (match xg as xg in ExtCtx _ Sn Gx return (Sn = S n)->(extCtx G T = Gx)->P' _ _ xg with
		extOCtx => fun e=>match O_S _ e with end |
		extSCtx _ _ xg0 _ => fun Hn HG=>_
	end (eq_refl _) (eq_refl _)).
	revert xg0.
	apply (tr (fun _=>_) (eq_sym (Sinj Hn))).
	apply (tr (fun GT=>forall xg,P' _ _ (extSCtx xg (projT2 GT))) (extCtxInj HG)).
	simpl.
	intros ? ?.
	simpl.
	exact (tr (fun C=>C) (Peq _) (xgS _)).
Defined.
Implicit Arguments extSCtxInv [GL n G T].

Definition extSCtxInvEq GL n G P := match G
return forall T (xg:ExtCtx GL n G) xgS,xgS xg = extSCtxInv (extSCtx xg T) P xgS
	with ctx _ _ => fun _ _ _=>eq_refl _ end.
Implicit Arguments extSCtxInvEq [GL n G T].

(*
Inductive ExtSCtx P : Ctx->Type := mkExtSCtx G : P G->forall T,ExtSCtx P (extCtx G T).
Implicit Arguments mkExtSCtx [P G].

Fixpoint ExtCtx GL n : Ctx->Type := match n with
	O => eq GL |
	S n => ExtSCtx (ExtCtx GL n)
end.

Definition extOCtx GL : ExtCtx GL O GL := eq_refl _.
Definition extSCtx GL n G (xg:ExtCtx GL n G) T : ExtCtx GL (S n) (extCtx G T) := mkExtSCtx xg _.
Implicit Arguments extSCtx [GL n G].

Definition ExtCtx_rect GL (P:forall n G,ExtCtx GL n G->Type)
	(xgO:P _ _ (extOCtx GL))
	(xgS:forall n G (xg:ExtCtx GL n G) (IHxg:P _ _ xg) T,P _ _ (extSCtx xg T))
: forall n G (xg:ExtCtx GL n G),P _ _ xg.
	refine (fix ExtCtx_rect n G := match n return forall xg:ExtCtx GL n G,P _ _ xg with
		O => _ |
		S _ => _
	end);simpl;intro;destruct xg.

	exact xgO.

	exact (xgS _ _ _ (ExtCtx_rect _ _ _) _).
Defined.
Implicit Arguments ExtCtx_rect [GL n G].

Definition extSCtxInv P G T (xg:ExtSCtx P (extCtx G T)) (C:forall G T,ExtSCtx P (extCtx G T)->Type)
	(xgS:forall xg:P G,C _ _ (mkExtSCtx xg T))
: C _ _ xg.
	pose (C' Gx xg := forall ne:IsExtCtx Gx,C _ _ (tr (ExtSCtx P) (extCtxUnfold ne) xg)).
	assert (HC : forall G T xg,C G T xg = C (ctx (ctxSc G)) T xg).
		exact (fun G=>match G with ctx _ _ => fun _ _=>eq_refl _ end).
	apply (tr (fun X=>X) (eq_sym (HC _ _ _))).
	generalize I.
	change (C' _ xg).
	refine (match xg as xg in ExtSCtx _ Gx return (extCtx G T = Gx)->C' Gx xg with
		mkExtSCtx _ xg _ => _ end (eq_refl _)).
	clear xg.
	intro.
	revert xg0.
	apply (tr (fun s=>forall xg:P (projT1 s),C' _ (mkExtSCtx xg (projT2 s))) (extCtxInj H)).
	clear G0 T0 H.
	simpl.
	intros ? ?.
	simpl.
	exact (tr (fun X=>X) (HC _ _ _) (xgS xg)).
Defined.
Implicit Arguments extSCtxInv [P G T].

Definition extSCtxInvEq P G C := match G
return forall T (xg:P G) xgS,xgS xg = extSCtxInv (mkExtSCtx xg T) C xgS
	with ctx _ _ => fun _ _ _=>eq_refl _ end.
Implicit Arguments extSCtxInvEq [P G T].
*)

(*
(* Induction on the number of added entries *)
Definition extCtxNInd D (GL:Ctx D) (P:forall n G,ExtCtx GL n G->Type)
	(xgO:P _ _ (extOCtx GL))
	(xgS:forall n,(forall G (xg:ExtCtx GL n G),P _ _ xg)->
		forall G (xg:ExtCtx GL n G) T,P _ _ (extSCtx xg T))
: forall n G (xg:ExtCtx GL n G),P _ _ xg.
	refine (fix extCtxNInd n G := match n with
		O => fun xg=>_ |
		S _ => fun xg=>_
	end).

	exact (extOCtxInv xg _ xgO).

	exact (extSCtxInv xg _ (xgS _ (extCtxNInd _))).
Defined.
Implicit Arguments extCtxNInd [D GL n G].
*)

Fixpoint unExt GL n G (xg:ExtCtx GL n G) : G->GL := match xg with
	extOCtx => fun g=>g |
	extSCtx _ _ xg _ => fun g=>unExt _ _ _ xg (projT1 g)
end.
Implicit Arguments unExt [GL n G].

Definition extAtCtxInd GL P (C:forall n G P',ExtCtx (extCtx GL P) n G->AtCtx G n P'->Type)
	(xgO:C _ _ _ (extOCtx _) (topCtx GL P))
	(xgS:forall n G P' xg (a:AtCtx G n P') T,C _ _ _ xg a->C _ _ _ (extSCtx xg T) (popCtx a T))
n G (xg:ExtCtx (extCtx GL P) n G) : forall P' (a:AtCtx G n P'),C _ _ _ xg a.
	induction xg;unfold AtCtx;simpl;intros;destruct a.

	exact xgO.

	exact (xgS _ _ _ _ _ _ (IHxg _ _)).
Defined.
Implicit Arguments extAtCtxInd [GL P n G P'].

Inductive ExtCtxComp GL' n G : Type := mkExtCtxComp G' (xg':ExtCtx GL' n G') (f':G'->G).
Implicit Arguments mkExtCtxComp [GL' n G G'].

Definition xc_G' GL' n G (xc:ExtCtxComp GL' n G) := match xc with mkExtCtxComp G' _ _ => G' end.
Implicit Arguments xc_G' [GL' n G].

Definition xc_xg' GL' n G (xc:ExtCtxComp GL' n G) : ExtCtx GL' n (xc_G' xc) := match xc with mkExtCtxComp _ xg' _ => xg' end.
Implicit Arguments xc_xg' [GL' n G].

Definition xc_f' GL' n G (xc:ExtCtxComp GL' n G) : xc_G' xc->G := match xc with mkExtCtxComp _ _ f' => f' end.
Implicit Arguments xc_f' [GL' n G].

Definition extCtxComp GL n G (xg:ExtCtx GL n G) (GL':Ctx) (f:GL'->GL) : ExtCtxComp GL' n G.
	induction xg.

	exact (mkExtCtxComp (extOCtx _) f).

	exact (mkExtCtxComp (extSCtx (xc_xg' IHxg) _)
		(fun (g:sigT (fun g=>T (_ g)))=>existT _ (xc_f' IHxg (projT1 g)) (projT2 g))).
Defined.
Implicit Arguments extCtxComp [GL n G].

Definition xcBump GL P l G (xg:ExtCtx GL l G) := extCtxComp xg (extCtx GL P) (@projT1 _ _).
Implicit Arguments xcBump [GL l G].

Definition ctxBump GL P l G (xg:ExtCtx GL l G) := xc_G' (xcBump P xg).
Implicit Arguments ctxBump [GL l G].

Definition xgBump GL P l G (xg:ExtCtx GL l G) : ExtCtx _ l (ctxBump P xg) := xc_xg' (xcBump P xg).
Implicit Arguments xgBump [GL l G].

Definition elBump GL P l G (xg:ExtCtx GL l G) T (t:forall g,T g) (g:ctxBump P xg) :=
	t (xc_f' (xcBump P xg) g).
Implicit Arguments elBump [GL l G T].

Definition atBumpLo GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd n l) : AtCtx (ctxBump P xg) n (elBump P xg T).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);simpl;intro.

	apply (extSCtxInv xg).
	clear xg.
	intro.
	reflexivity.

	revert T a IHa.
	apply (extSCtxInv xg).
	clear xg.
	intros.
	change (AtCtx (extCtx (ctxBump P xg) (elBump P xg T')) (S n) (fun g=>elBump P xg T (projT1 g))).
	apply popCtx.
	exact (IHa _ Ho xg).
Defined.
Implicit Arguments atBumpLo [GL l G n T].

Definition atBumpHi GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd l (S n)) : AtCtx (ctxBump P xg) (S n) (elBump P xg T).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	unfold ctxBump.
	simpl.
	apply (popCtx a).

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G n) T) in a.
	destruct a.
	change (AtCtx (extCtx (ctxBump P xg) (elBump P xg T')) (S (S n)) (fun g=>elBump P xg T (projT1 g))).
	apply popCtx.
	exact (IHxg _ Ho _ a).
Defined.
Implicit Arguments atBumpHi [GL l G n T].

Definition ctxProj_BumpLo GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd n l) :
elBump P xg (ctxProj a) = ctxProj (atBumpLo P xg a Ho).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	revert Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T.
	destruct G.
	simpl.
	intros.
	reflexivity.

	revert T a IHa Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T'.
	destruct G.
	simpl ctxTp.
	intros.
	change (elBump P (extSCtx xg T') (ctxProj (popCtx a T')) =
		ctxProj (popCtx (atBumpLo P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atBumpLo P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHa _ Ho xg)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_BumpLo [GL l G n T].

Definition ctxProj_BumpHi GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd l (S n)) :
elBump P xg (ctxProj a) = ctxProj (atBumpHi P xg a Ho).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros ? ?.
	revert P.
	destruct GL as (GL,?).
	simpl ctxTp.
	intros.
	reflexivity.

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G n) T) in a.
	destruct a.
	change (elBump P (extSCtx xg T') (ctxProj (popCtx a T')) =
		ctxProj (popCtx (atBumpHi P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>elBump P (extSCtx xg T') X = _) (ctxProj_pop a T')).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atBumpHi P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHxg _ Ho _ a)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_BumpHi [GL l G n T].

Definition xcSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) (p:forall g,P g) :=
	extCtxComp xg GL (fun g=>existT _ g (p g)).
Implicit Arguments xcSubst [GL P l G].

Definition ctxSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) p := xc_G' (xcSubst xg p).
Implicit Arguments ctxSubst [GL P l G].

Definition xgSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) p : ExtCtx GL l (ctxSubst xg p) :=
	xc_xg' (xcSubst xg p).
Implicit Arguments xgSubst [GL P l G].

Definition elSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) T (t:forall g,T g) p
	(g:ctxSubst xg p) := t (xc_f' (xcSubst xg p) g).
Implicit Arguments elSubst [GL P l G T].

Definition atSubstLt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G n T) (Ho:ltd n l) p :
AtCtx (ctxSubst xg p) n (elSubst xg T p).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	apply (extSCtxInv xg).
	clear xg.
	intro.
	unfold ctxSubst.
	simpl.
	apply topCtx.

	revert T a IHa.
	apply (extSCtxInv xg).
	clear xg.
	intros.
	change (AtCtx (extCtx (ctxSubst xg p) (elSubst xg T' p)) (S n) (fun g=>elSubst xg T p (projT1 g))).
	apply popCtx.
	exact (IHa _ Ho xg).
Defined.
Implicit Arguments atSubstLt [GL P l G n T].

Definition atSubstGt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G (S n) T) (Ho:ltd l (S n)) p :
AtCtx (ctxSubst xg p) n (elSubst xg T p).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	change (PopCtx P (AtCtx GL n) T) in a.
	destruct a.
	exact (atCtxEta a).

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G (S n)) T) in a.
	destruct a.
	change (AtCtx (extCtx (ctxSubst xg p) (elSubst xg T' p)) (S n) (fun g=>elSubst xg T p (projT1 g))).
	apply popCtx.
	exact (IHxg _ Ho _ a).
Defined.
Implicit Arguments atSubstGt [GL P l G n T].

Definition elMBump GL P n G P' (xg:ExtCtx (extCtx GL P) n G) (a:AtCtx G n P') (p:forall g,P g) : forall g,P' g.
	revert P' a.
	induction xg;intros ? ?.

	destruct a.
	exact (fun g=>p (projT1 g)).

	change (PopCtx T (AtCtx G n) P') in a.
	destruct a as (P',?).
	exact (fun g=>IHxg _ a (projT1 g)).
Defined.
Implicit Arguments elMBump [GL P n G P'].

Definition ctxProj_SubstLt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G n T) (Ho:ltd n l) p :
elSubst xg (ctxProj a) p = ctxProj (atSubstLt xg a Ho p).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	revert Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T.
	destruct G.
	simpl.
	intros.
	reflexivity.

	revert T a IHa Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T'.
	destruct G.
	simpl ctxTp.
	intros.
	change (elSubst (extSCtx xg T') (ctxProj (popCtx a T')) p =
		ctxProj (popCtx (atSubstLt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atSubstLt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHa _ Ho xg)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_SubstLt [GL P l G n T].

Definition ctxProj_SubstGt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G (S n) T) (Ho:ltd l (S n)) p :
elSubst xg (ctxProj a) p = ctxProj (atSubstGt xg a Ho p).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	change (PopCtx P (AtCtx GL n) T) in a.
	destruct a.
	change (elSubst (extOCtx (extCtx GL P)) (ctxProj (popCtx a P)) p = ctxProj (atCtxEta a)).
	apply (tr (fun X=>elSubst (extOCtx _) X p = _) (ctxProj_pop a P)).
	apply (tr (fun X=>_ = X) (ctxProj_Eta a)).
	reflexivity.

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G (S n)) T) in a.
	destruct a.
	change (elSubst (extSCtx xg T') (ctxProj (popCtx a T')) p =
		ctxProj (popCtx (atSubstGt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>elSubst (extSCtx xg T') X p = _) (ctxProj_pop a T')).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atSubstGt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHxg _ Ho _ a)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_SubstGt [GL P l G n T].

Definition ctxProj_SubstEq GL P n G P' (xg:ExtCtx (extCtx GL P) n G) (a:AtCtx G n P') p :
elSubst xg (ctxProj a) p = elSubst xg (elMBump xg a p) p.
	apply extAtCtxInd with (xg := xg) (a := a);clear n G P' xg a.

	reflexivity.

	intros ? ?.
	destruct G.
	simpl ctxTp.
	intros.
	change ((fun g:ctxSubst (extSCtx xg T) p=>elSubst xg (ctxProj a) p (projT1 g)) =
		(fun g=>elSubst xg (elMBump xg a p) p (projT1 g))).
	apply (tr (fun X=>_ = fun g:ctxSubst (extSCtx xg T) p=>X (projT1 g)) H).
	reflexivity.
Defined.
Implicit Arguments ctxProj_SubstEq [GL P n G P'].

(* Stuff for substituting one variable for another *)

Fixpoint atMBump GL l G n T (xg:ExtCtx GL l G) (a:AtCtx GL n T) : ExAtCtx G (l + n) := match xg with
	extOCtx => exAtCtx a |
	extSCtx _ _ xg T' => exAtCtx (popCtx (xa_a (atMBump _ _ _ _ _ xg a)) T')
end.
Implicit Arguments atMBump [GL l G n T].

Definition atMBumpTEq GL a b P G (b':AtCtx GL b P) (xg:ExtCtx (extCtx GL P) a G) :
forall P' (a':AtCtx G a P'),xa_T (atMBump xg (popCtx b' P)) = P'.
	induction xg as [| a];intros ? ?;simpl.

	destruct a'.
	reflexivity.

	change (PopCtx T (AtCtx G a) P') in a'.
	destruct a' as (P',a').
	apply (tr (fun _=>_) (IHxg _ a')).
	reflexivity.
Defined.
Implicit Arguments atMBumpTEq [GL a b P G P'].

Definition ctxProj_MBump GL a b P G P' (b':AtCtx GL b P) (xg:ExtCtx (extCtx GL P) a G) (a':AtCtx G a P') :
ctxProj (tr (AtCtx G _) (atMBumpTEq b' xg a') (xa_a (atMBump xg (popCtx b' P)))) = elMBump xg a' (ctxProj b').
	apply extAtCtxInd with (xg := xg) (a := a');clear a G P' xg a'.

	revert P b'.
	destruct GL as (GL,?).
	intros.
	reflexivity.

	intros a ?.
	destruct G.
	simpl ctxTp.
	intros ? ? a' ? ?.
	simpl elMBump.
	apply (tr (fun t=>_ = fun g=>t (projT1 g)) H).
	simpl atMBumpTEq.
	refine (match atMBumpTEq b' xg a' as teq
		return ctxProj (tr (AtCtx (extCtx (ctx s) _) _) (tr _ teq _) _) =
			fun g=>ctxProj (tr _ teq _) (projT1 g)
		with eq_refl => _ end).
	clear P' a' H.
	simpl tr.
	reflexivity.
Defined.
Implicit Arguments ctxProj_MBump [GL a b P G P'].

End Context.


Require Import VST.progs.conclib.
Require Import VST.progs.ghosts.
Require Import RelationClasses.

Section ListMaps.

Context {A B : Type} {A_eq : EqDec A} {d : Inhabitant B}.

Definition map_Znth i (L : A -> option (list B)) k := option_map (fun v => Znth i v) (L k).

Lemma map_Znth_single : forall i (k : A) (v : list B),
  map_Znth i (singleton k v) = singleton k (Znth i v).
Proof.
  intros; unfold map_Znth, singleton; extensionality.
  if_tac; auto.
Qed.

Lemma map_Znth_add : forall (m1 m2 : A -> option (list B)) i,
  map_Znth i (map_add m1 m2) = map_add (map_Znth i m1) (map_Znth i m2).
Proof.
  intros; unfold map_add, map_Znth; extensionality.
  destruct (m1 x); auto.
Qed.

Lemma map_Znth_eq : forall (L : A -> option (list B)) k vs (Hlength : forall vs', L k = Some vs' -> Zlength vs' = Zlength vs)
  (Hnz : vs <> []) (Hall : forall i, 0 <= i < Zlength vs -> map_Znth i L k = Some (Znth i vs)),
  L k = Some vs.
Proof.
  intros.
  destruct (L k) eqn: Hk.
  specialize (Hlength _ eq_refl).
  apply f_equal, list_Znth_eq'; auto.
  rewrite Hlength; intros j Hj; specialize (Hall _ Hj).
  unfold map_Znth in Hall; rewrite Hk in Hall; inv Hall; auto.
  { lapply (Hall 0).
    unfold map_Znth; rewrite Hk; discriminate.
    { pose proof (Zlength_nonneg vs).
      destruct (eq_dec (Zlength vs) 0); [|omega].
      apply Zlength_nil_inv in e; subst; contradiction. } }
Qed.

Lemma map_Znth_upd : forall (m : A -> option (list B)) k v i,
  map_Znth i (map_upd m k v) = map_upd (map_Znth i m) k (Znth i v).
Proof.
  intros; unfold map_Znth, map_upd; extensionality.
  if_tac; auto.
Qed.

Lemma map_incl_Znth : forall (m1 m2 : A -> option (list B)) i, map_incl m1 m2 ->
  map_incl (map_Znth i m1) (map_Znth i m2).
Proof.
  unfold map_Znth; repeat intro.
  destruct (m1 k) eqn: Hm1; [|discriminate].
  rewrite (H _ _ Hm1); auto.
Qed.

End ListMaps.

Section Logs.
(* A log is a map from nat, and a finite log has a latest element. *)

Context {B : Type}.

Local Close Scope Z.

Definition log_latest s (v1 : nat) (v2 : B) := s v1 = Some v2 /\ forall v', v1 < v' -> s v' = None.

Lemma log_latest_singleton : forall v1 v2, log_latest (singleton v1 v2) v1 v2.
Proof.
  unfold singleton; split.
  - rewrite eq_dec_refl; auto.
  - intros; if_tac; auto; omega.
Qed.

Lemma log_incl_latest : forall k1 k2 v1 v2 log1 log2 (Hincl : map_incl log1 log2)
  (Hv1 : log1 k1 = Some v1) (Hlatest : log_latest log2 k2 v2), k1 <= k2.
Proof.
  intros.
  destruct (lt_dec k2 k1); [|omega].
  destruct Hlatest as (? & Hlatest).
  specialize (Hlatest _ l).
  specialize (Hincl _ _ Hv1); rewrite Hincl in Hlatest; discriminate.
Qed.

Lemma log_latest_upd : forall log v1 v2 v1' v2', log_latest log v1 v2 -> v1 < v1' ->
  map_incl log (map_upd log v1' v2') /\ log_latest (map_upd log v1' v2') v1' v2'.
Proof.
  intros; destruct H as (? & Hlast); unfold map_upd; split.
  - repeat intro; if_tac; auto.
    subst; rewrite (Hlast v1') in *; auto; discriminate.
  - split; [rewrite eq_dec_refl; auto|].
    intros v' ?; lapply (Hlast v'); [|omega].
    intro; if_tac; auto; omega.
Qed.

Lemma log_latest_inj : forall log v1 v2 v1' v2' (H1 : log_latest log v1 v2) (H1' : log_latest log v1' v2'),
  v1 = v1' /\ v2 = v2'.
Proof.
  intros.
  assert (log v1 = Some v2) as Hv1 by (apply H1).
  assert (log v1' = Some v2') as Hv1' by (apply H1').
  pose proof (log_incl_latest _ _ _ _ _ _ (map_incl_refl log) Hv1 H1').
  pose proof (log_incl_latest _ _ _ _ _ _ (map_incl_refl log) Hv1' H1).
  assert (v1 = v1') by omega; subst.
  destruct H1 as [H1 _], H1' as [H1' _].
  rewrite H1 in H1'; inv H1'; auto.
Qed.

Lemma log_latest_add : forall m1 m2 k1 k2 (v1 v2 : B)
  (Hlatest1 : log_latest m1 k1 v1) (Hlatest2 : log_latest m2 k2 v2),
  log_latest (map_add m1 m2) (max k1 k2) (if lt_dec k1 k2 then v2 else v1).
Proof.
  unfold log_latest, map_add; intros.
  destruct Hlatest1 as (Hv1 & Hk1), Hlatest2 as (Hv2 & Hk2).
  destruct (lt_dec k1 k2).
  - rewrite max_r by omega.
    rewrite Hk1 by auto; split; auto.
    intros; rewrite Hk1, Hk2; auto; omega.
  - rewrite max_l, Hv1 by omega; split; auto.
    intros; rewrite Hk1, Hk2; auto; omega.
Qed.

Lemma log_latest_upd_list : forall l (m : nat -> option B) k v k' v' (Hm : log_latest m k v)
  (Hlast : last l (k, v) = (k', v')) (Hlt : k <= k') (Hordered : Forall (fun '(k, v) => k <= k') l),
  log_latest (map_upd_list m l) k' v'.
Proof.
  intros.
  destruct (nil_dec l).
  { subst; inv Hlast; auto. }
  rewrite (app_removelast_last (k, v) n).
  rewrite map_upd_list_app; simpl.
  rewrite Hlast; split.
  - unfold map_upd; rewrite eq_dec_refl; auto.
  - intros; unfold map_upd.
    if_tac; [omega|].
    apply map_upd_list_out.
    + eapply Hm; omega.
    + rewrite in_map_iff; intros ((?, ?) & ? & ?); simpl in *; subst.
      rewrite Forall_forall in Hordered; exploit Hordered; [apply In_removelast; eauto|].
      simpl; omega.
Qed.

End Logs.

Lemma map_Znth_log_latest : forall {B} {d : Inhabitant B} m k (v : list B) i, log_latest m k v ->
  log_latest (map_Znth i m) k (Znth i v).
Proof.
  unfold log_latest, map_Znth; intros.
  destruct H as [-> H]; split; auto.
  intros; rewrite H; auto.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Set Implicit Arguments.

Require Import Behavior.
Require Import Expr.

Local Open Scope behavior.
Local Open Scope tla.

Definition refines (A C : Type)
  (m : C -> A)    (* Projection from "concrete" to "abstract" states *)
  (P : Expr A)    (* "Abstract" specification *)
  (Q : Expr C)    (* "Concrete" specification *)
  := valid (Q `=> map m P).

Theorem refines_refl :
  forall (A : Type) (P : Expr A),
    refines (fun x => x) P P.
Proof.
  unfold refines, valid. simpl.
  intros.
  rewrite map_id.
  assumption.
Qed.

Theorem refines_trans :
  forall (A B C : Type) (m1 : B -> A) (m2 : C -> B) P Q R,
    refines m1 P Q ->
    refines m2 Q R ->
    refines (fun x => m1 (m2 x)) P R.
Proof.
  unfold refines, valid. simpl.
  intros A B C m1 m2 P Q R HQP HRQ s H.
  rewrite <- map_map.
  rewrite map_eval.
  apply HQP.
  rewrite <- map_eval.
  apply HRQ.
  assumption.
Qed.

Theorem refinement_preserves_invariant :
  forall (A C : Type)
         (m : C -> A)
         (P : Expr A)
         (Q : Expr C)
         (I : Predicate A),
    refines m P Q ->
    valid (P `=> [] `I) ->
    valid (Q `=> [] map m `I).
Proof.
  unfold refines, valid. simpl. unfold shift. simpl.
  intros A C m P Q I Hrefines Hinv s H n.
  specialize (Hinv (fun x => m (s x))).
  apply Hinv.
  rewrite <- map_eval.
  intuition.
Qed.

Lemma refine_conj :
  forall (A C : Type) s (m : C -> A) Pa Pc Qa Qc,
    eval (Qc `=> map m Qa) s ->
    eval (Pc `=> map m Pa) s ->
    eval (Pc `/\ Qc) s ->
    eval (map m (Pa `/\ Qa)) s.
Proof. firstorder. Qed.

Theorem refine_predicate :
  forall (A C : Type) (m : C -> A) (Pa : Predicate A) (Pc : Predicate C),
    (forall x, Pc x -> Pa (m x)) ->
    refines m `Pa `Pc.
Proof. firstorder. Qed.

Theorem refine_always :
  forall (A C : Type) (m : C -> A) P Q,
    refines m P Q ->
    refines m ([]P) ([]Q).
Proof. firstorder. Qed.
(*
Theorem refine_box :
  forall (A C : Type) (m : C -> A) (ra : Action A) (rc : Action C),
    (forall x y, rc x y -> ra (m x) (m y)) ->
    refines m ([ra]) ([rc]).
Proof.
  unfold refines, valid. simpl.
  intros.
  intuition; auto using f_equal.
Qed.
*)
Theorem refine_always_box :
  forall (A C : Type) (m : C -> A) (ra : Action A) (rc : Action C),
    (forall x y, rc x y -> ra (m x) (m y)) ->
    refines m ([][ra]) ([][rc]).
Proof.
  intros.
  unfold refines, valid. intros s. simpl.
  intros H0 n. specialize H0 with n.
  destruct H0 as [H0|H0]; [left; auto | right; rewrite H0; trivial].
Qed.
(*
Theorem refine_skip_skip :
  forall (A C : Type) (m : C -> A),
    refines m SKIP SKIP.
Proof.
  unfold refines, valid. simpl.
  auto using f_equal.
Qed.
 *)

Lemma disj_pw_impl :
  forall P1 Q1 P2 Q2 : Prop,
    (P1 -> P2) ->
    (Q1 -> Q2) ->
    (P1 \/ Q1) ->
    (P2 \/ Q2).
Proof. firstorder. Qed.


Require Import Reals.
Require Import Psatz.

(**********************)
(** Unitary Programs **)
(**********************)

(* Note: We only support application of 1-, 2-, and 3-qubit unitaries.
   We could instead allow something more general (e.g. application of
   an arbitrary unitary to a list of arguments), but this would make
   proofs longer for little added benefit. *)
Inductive ucom (U: nat -> Set) (dim : nat) : Set :=
| useq :  ucom U dim -> ucom U dim -> ucom U dim
| uapp1 : U 1 -> nat -> ucom U dim
| uapp2 : U 2 -> nat -> nat -> ucom U dim
| uapp3 : U 3 -> nat -> nat -> nat -> ucom U dim.

(* Set the dimension argument to be implicit. *)
Arguments useq {U dim}.
Arguments uapp1 {U dim}.
Arguments uapp2 {U dim}.
Arguments uapp3 {U dim}.

Declare Scope ucom_scope.
Delimit Scope ucom_scope with ucom.
Local Open Scope ucom.
Notation "p1 ; p2" := (useq p1 p2) (at level 50) : ucom_scope.

(** Example Gate Set **)

(* The gate set below is used for computing the semantics of programs. The
   R rotation unitary allows for easy description of any single-qubit gate
   and CNOT is the standard two-qubit gate. *)
Inductive base_Unitary : nat -> Set :=
  | U_R                  : R -> R -> R -> base_Unitary 1
  | U_CNOT               : base_Unitary 2.

Definition base_ucom := ucom base_Unitary.

(* Some useful shorthands. *)
Definition U_H := U_R (PI/2) 0 PI.
Definition U_X := U_R PI 0 PI.
Definition U_Y := U_R PI (PI/2) (PI/2).
Definition U_Z := U_R 0 0 PI.
Definition H {dim} n : base_ucom dim := uapp1 U_H n.
Definition X {dim} n : base_ucom dim := uapp1 U_X n.
Definition Y {dim} n : base_ucom dim := uapp1 U_Y  n.
Definition Z {dim} n : base_ucom dim := uapp1 U_Z n.
Definition ID {dim} n : base_ucom dim := uapp1 (U_R 0 0 0) n.
Definition SKIP {dim} : base_ucom dim := ID 0.
Definition Rx {dim} θ n : base_ucom dim := uapp1 (U_R θ (-(PI/2)) (PI/2)) n.
Definition Ry {dim} θ n : base_ucom dim := uapp1 (U_R θ 0 0) n.
Definition Rz {dim} λ n : base_ucom dim := uapp1 (U_R 0 0 λ) n.
Definition T {dim} n : base_ucom dim := Rz (PI / 4) n.
Definition TDAG {dim} n : base_ucom dim := Rz (- (PI / 4)) n.
Definition P {dim} n : base_ucom dim := Rz (PI / 2) n.
Definition PDAG {dim} n : base_ucom dim := Rz (- (PI / 2)) n.
Definition CNOT {dim} m n : base_ucom dim := uapp2 U_CNOT m n.
Definition CZ {dim} m n : base_ucom dim :=
  H n ; CNOT m n ; H n.
Definition SWAP {dim} m n : base_ucom dim :=
  CNOT m n; CNOT n m; CNOT m n.
Definition U1 {dim} a n : base_ucom dim := uapp1 (U_R 0 0 a) n.
Definition U2 {dim} a b n : base_ucom dim := uapp1 (U_R (PI / 2) a b) n.
Definition U3 {dim} a b c n : base_ucom dim := uapp1 (U_R a b c) n.

(* Standard Toffoli decomposition *)
Definition CCX {dim} a b c : base_ucom dim :=
  H c ; CNOT b c ; TDAG c ; CNOT a c ;
  T c ; CNOT b c ; TDAG c ; CNOT a c ;
  CNOT a b ; TDAG b ; CNOT a b ;
  T a ; T b ; T c ; H c.

(* CCZ is the same as CCX, but without the Hadamards *)
Definition CCZ {dim} a b c : base_ucom dim :=
  CNOT b c ; TDAG c ; CNOT a c ;
  T c ; CNOT b c ; TDAG c ; CNOT a c ;
  CNOT a b ; TDAG b ; CNOT a b ;
  T a ; T b ; T c.

(*************************)
(** Well Typed Circuits **)
(*************************)

Inductive uc_well_typed {U dim} : ucom U dim -> Prop :=
| WT_seq : forall c1 c2, uc_well_typed c1 -> uc_well_typed c2 -> uc_well_typed (c1; c2)
| WT_app1 : forall u n, n < dim -> uc_well_typed (uapp1 u n)
| WT_app2 : forall u m n, m < dim -> n < dim -> m <> n -> uc_well_typed (uapp2 u m n)
| WT_app3 : forall u m n p, m < dim -> n < dim -> p < dim ->
    m <> n -> n <> p -> m <> p -> uc_well_typed (uapp3 u m n p).

(* No ucom is well-typed for dim = 0. *)
Lemma uc_well_typed_implies_dim_nonzero : forall {U dim} (c : ucom U dim),
  uc_well_typed c -> dim > 0.
Proof.
  intros U dim c WT.
  induction WT; try apply (Nat.lt_lt_0 n); assumption.
Qed.

(* Equivalent boolean version *)
Fixpoint uc_well_typed_b {U dim} (c : ucom U dim) : bool :=
  match c with
  | c1 ; c2 => uc_well_typed_b c1 && uc_well_typed_b c2
  | uapp1 _ n => n <? dim
  | uapp2 _ m n => (m <? dim) && (n <? dim) && (negb (m =? n))
  | uapp3 _ m n p => (m <? dim) && (n <? dim) && (p <? dim) &&
      (negb (m =? n)) && (negb (n =? p)) && (negb (m =? p))
  end.

Lemma uc_well_typed_b_equiv : forall {U dim} (c : ucom U dim),
  uc_well_typed_b c = true <-> uc_well_typed c.
Proof.
  intros U dim c. split; intros H.
  - induction c;
    constructor;
    simpl in H;
    repeat match goal with
    | H : (_ && _)%bool = true |- _ => apply Bool.andb_true_iff in H as [? ?]
    | H : (_ <? _) = true |- _ => apply Nat.ltb_lt in H
    | H : negb (_ =? _) = true |- _ => apply Bool.negb_true_iff in H;
                                     apply Nat.eqb_neq in H
    end;
    try apply IHc1;
    try apply IHc2;
    assumption.
  - induction H; subst; simpl;
    repeat match goal with
    | |- (_ && _)%bool = true => apply Bool.andb_true_iff; split
    | |- (_ <? _) = true => apply Nat.ltb_lt
    | |- negb (_ =? _) = true => apply Bool.negb_true_iff; apply Nat.eqb_neq
    end;
    try apply IHuc_well_typed1;
    try apply IHuc_well_typed2;
    assumption.
Qed.

Local Close Scope ucom.

(**********************)
(** General Programs **)
(**********************)

Declare Scope com_scope.
Delimit Scope com_scope with com.
Local Open Scope com_scope.

Inductive com (U: nat -> Set) (dim : nat) : Set :=
| skip : com U dim
| seq : com U dim -> com U dim -> com U dim
| uc : ucom U dim -> com U dim
| meas : nat -> com U dim -> com U dim -> com U dim.

Arguments skip {U dim}.
Arguments seq {U dim}.
Arguments uc {U dim}.
Arguments meas {U dim}.

Definition from_ucom {U dim} (c : ucom U dim) : com U dim := uc c.
Coercion from_ucom : ucom >-> com.

Notation "p1 ; p2" := (seq p1 p2) (at level 50) : com_scope.
Notation "'mif' n 'then' p1 'else' p2" := (meas n p1 p2) (at level 40) : com_scope.
Notation "'measure' n" := (meas n skip skip) (at level 40) : com_scope.
Notation "'reset' n" := (meas n (X n) skip) (at level 40) : com_scope.
Notation "n <- 1" := (meas n skip (X n)) (at level 20) : com_scope.
Notation "n <- 0" := (reset n) (at level 20) : com_scope.

Definition base_com := com base_Unitary.

(* Well-typedness for non-unitary programs. *)
Inductive c_well_typed {U dim} : com U dim -> Prop :=
| WT_skip : c_well_typed skip
| WT_cseq : forall c1 c2, c_well_typed c1 -> c_well_typed c2 -> c_well_typed (c1; c2)
| WT_uc : forall u, uc_well_typed u -> c_well_typed (uc u)
| WT_meas : forall n c1 c2, n < dim -> c_well_typed c1 -> c_well_typed c2 -> c_well_typed (meas n c1 c2).

(*****************************)
(** Higher-level Constructs **)
(*****************************)

Fixpoint crepeat {U dim} (k : nat) (p : com U dim) : com U dim :=
  match k with
  | 0    => skip
  | S k' => p ; crepeat k' p
  end.

Fixpoint while {U dim} (max_iters : nat) (n : nat) (p : com U dim) : com U dim :=
  match max_iters with
  | 0        => skip
  | S iters' => mif n then p ; while iters' n p else skip
  end.


(* Finite maps for labels *)

Require Import Coq.Strings.Ascii Coq.NArith.NArith Coq.Strings.String Coq.Structures.OrderedType Coq.FSets.FMapAVL.

Require Import Bedrock.Nomega Bedrock.Labels.

Local Open Scope string_scope.
Local Open Scope N_scope.

Definition ascii_lt (a1 a2 : ascii) := N_of_ascii a1 < N_of_ascii a2.

Fixpoint string_lt (s1 s2 : string) : bool :=
  match s1, s2 with
    | "", String _ _ => true
    | String _ _, "" => false
    | String a1 s1', String a2 s2' => match (N_of_ascii a1) ?= (N_of_ascii a2) with
                                        | Datatypes.Lt => true
                                        | Gt => false
                                        | Datatypes.Eq => string_lt s1' s2'
                                      end
    | _, _ => false
  end.

Section CompSpec.
  Variables (A : Type) (eq lt : A -> A -> Prop)
    (x y : A) (c : comparison).

  Hypothesis H : CompSpec eq lt x y c.

  Theorem Comp_eq : (forall z, lt z z -> False)
    -> x = y -> c = Datatypes.Eq.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.

  Theorem Comp_lt : (forall z z', lt z z' -> eq z z' -> False)
    -> (forall z z', lt z z' -> lt z' z -> False)
    -> lt x y -> c = Datatypes.Lt.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.

  Theorem Comp_gt : (forall z z', lt z' z -> eq z z' -> False)
    -> (forall z z', lt z z' -> lt z' z -> False)
    -> lt y x -> c = Datatypes.Gt.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.
End CompSpec.

Implicit Arguments Comp_eq [A eq0 lt x y c].
Implicit Arguments Comp_lt [A eq0 lt x y c].
Implicit Arguments Comp_gt [A eq0 lt x y c].

Theorem Nlt_irrefl' : forall n : N, n < n -> False.
  exact Nlt_irrefl.
Qed.

Theorem Nlt_irrefl'' : forall n n' : N, n = n' -> n < n' -> False.
  intros; subst; eapply Nlt_irrefl'; eauto.
Qed.

Theorem Nlt_notboth : forall x y, x < y -> y < x -> False.
  intros; eapply Nlt_irrefl'; eapply Nlt_trans; eauto.
Qed.

Hint Immediate Nlt_irrefl' Nlt_irrefl'' Nlt_notboth.

Ltac rewr' := eauto; congruence || eapply Nlt_trans; eassumption.

Ltac rewr := repeat match goal with
                      | [ _ : context[?X ?= ?Y] |- _ ] => specialize (Ncompare_spec X Y); destruct (X ?= Y); inversion 1
                    end; simpl in *; (rewrite (Comp_eq (@Ncompare_spec _ _)); rewr')
  || (rewrite (Comp_lt (@Ncompare_spec _ _)); rewr')
    || (rewrite (Comp_gt (@Ncompare_spec _ _)); rewr').

Theorem string_lt_trans : forall s1 s2 s3, string_lt s1 s2 = true
  -> string_lt s2 s3 = true
  -> string_lt s1 s3 = true.
  induction s1; simpl; intuition; destruct s2; destruct s3; simpl in *; try congruence; rewr.
Qed.

Section hide_hints.
  Hint Resolve string_lt_trans.

  Theorem string_lt_irrel : forall s, string_lt s s = false.
    induction s; simpl; intuition rewr.
  Qed.

  Hint Rewrite string_lt_irrel : LabelMap.

  Lemma string_tail_neq : forall a1 a2 s1 s2,
    N_of_ascii a1 = N_of_ascii a2
    -> (String a1 s1 = String a2 s2 -> False)
    -> (s1 = s2 -> False).
    intros.
    apply (f_equal ascii_of_N) in H.
    repeat rewrite ascii_N_embedding in H.
    congruence.
  Qed.

  Hint Immediate string_tail_neq.

  Theorem string_lt_sym : forall s1 s2, s1 <> s2
    -> string_lt s1 s2 = false
    -> string_lt s2 s1 = true.
    induction s1; destruct s2; simpl; intuition; rewr.
  Qed.

  Hint Resolve string_lt_sym.

  Definition label'_lt (l1 l2 : label') : bool :=
    match l1, l2 with
      | Global _, Local _ => true
      | Local _, Global _ => false
      | Global s1, Global s2 => string_lt s1 s2
      | Local n1, Local n2 => match n1 ?= n2 with
                                | Datatypes.Lt => true
                                | _ => false
                              end
    end.

  Theorem label'_lt_trans : forall l1 l2 l3, label'_lt l1 l2 = true
    -> label'_lt l2 l3 = true
    -> label'_lt l1 l3 = true.
    induction l1; simpl; intuition; destruct l2; destruct l3; simpl in *; try congruence; eauto; rewr.
  Qed.

  Hint Immediate label'_lt_trans.

  Theorem label'_lt_irrel : forall l, label'_lt l l = false.
    induction l; simpl; intuition; autorewrite with LabelMap; auto; rewr.
  Qed.

  Hint Rewrite label'_lt_irrel : LabelMap.

  Theorem label'_lt_sym : forall l1 l2, l1 <> l2
    -> label'_lt l1 l2 = false
    -> label'_lt l2 l1 = true.
    induction l1; destruct l2; simpl; intuition.
    eapply string_lt_sym; eauto; congruence.
    rewr.
  Qed.

  Hint Resolve label'_lt_sym.

  Definition label'_eq : forall x y : label', {x = y} + {x <> y}.
    decide equality; apply string_dec || apply N_eq_dec.
  Defined.
End hide_hints.

Module LabelKey.
  Definition t := label.

  Definition eq := @eq t.
  Definition lt (l1 l2 : label) := string_lt (fst l1) (fst l2) = true
    \/ (fst l1 = fst l2 /\ label'_lt (snd l1) (snd l2) = true).

  Theorem eq_refl : forall x : t, eq x x.
    congruence.
  Qed.

  Theorem eq_sym : forall x y : t, eq x y -> eq y x.
    congruence.
  Qed.

  Theorem eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    congruence.
  Qed.

  Section hide_hints.
    Hint Resolve string_lt_trans.
    Hint Rewrite string_lt_irrel : LabelMap.
    Hint Immediate string_tail_neq.
    Hint Resolve string_lt_sym.
    Hint Immediate label'_lt_trans.
    Hint Rewrite label'_lt_irrel : LabelMap.
    Hint Resolve label'_lt_sym.
    Hint Rewrite string_lt_irrel label'_lt_irrel : LabelMap.

    Theorem lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
      unfold lt; intuition (congruence || eauto).
    Qed.

    Theorem lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
      unfold lt, eq; intuition; subst; autorewrite with LabelMap in *; discriminate.
    Qed.

    Definition compare' (x y : t) : comparison :=
      if string_lt (fst x) (fst y)
        then Datatypes.Lt
        else if string_dec (fst x) (fst y)
          then if label'_lt (snd x) (snd y)
            then Datatypes.Lt
            else if label'_eq (snd x) (snd y)
              then Datatypes.Eq
              else Gt
          else Gt.

    Lemma label_eq : forall x y : label, fst x = fst y
      -> snd x = snd y
      -> x = y.
      destruct x; destruct y; simpl; congruence.
    Qed.

    Hint Immediate label_eq.

    Definition compare (x y : t) : Structures.OrderedType.Compare lt eq x y.
      refine (match compare' x y as c return c = compare' x y -> Structures.OrderedType.Compare lt eq x y with
                | Datatypes.Lt => fun _ => Structures.OrderedType.LT _
                | Datatypes.Eq => fun _ => Structures.OrderedType.EQ _
                | Gt => fun _ => Structures.OrderedType.GT _
              end (refl_equal _)); abstract (unfold compare', eq, lt in *;
                repeat match goal with
                         | [ H : context[if ?E then _ else _] |- _ ] => let Heq := fresh "Heq" in case_eq E; (intros ? Heq || intro Heq);
                           rewrite Heq in H; try discriminate
                       end; intuition).
    Defined.

    Definition eq_dec x y : { eq x y } + { ~ eq x y }.
      refine (if string_dec (fst x) (fst y)
        then if label'_eq (snd x) (snd y)
          then left _ _
          else right _ _
        else right _ _); abstract (unfold eq in *; destruct x; destruct y; simpl in *; congruence).
    Defined.
  End hide_hints.
End LabelKey.

Module LabelMap := FMapAVL.Make(LabelKey).

Remove Hints LabelMap.E.eq_sym LabelMap.E.eq_refl LabelMap.E.eq_trans LabelMap.E.lt_not_eq LabelMap.E.lt_trans
  LabelMap.Raw.Proofs.L.PX.eqk_refl LabelMap.Raw.Proofs.L.PX.eqk_sym
  LabelMap.Raw.Proofs.L.PX.eqk_trans
  LabelMap.Raw.Proofs.PX.eqk_refl LabelMap.Raw.Proofs.PX.eqk_sym LabelMap.Raw.Proofs.PX.eqk_trans
  LabelMap.Raw.Proofs.L.PX.eqke_refl LabelMap.Raw.Proofs.L.PX.eqke_sym LabelMap.Raw.Proofs.L.PX.eqke_trans
  LabelMap.Raw.Proofs.PX.eqke_refl LabelMap.Raw.Proofs.PX.eqke_sym LabelMap.Raw.Proofs.PX.eqke_trans
  LabelMap.Raw.Proofs.L.PX.MO.lt_eq LabelMap.Raw.Proofs.L.PX.MO.eq_lt LabelMap.Raw.Proofs.L.MX.lt_eq
  LabelMap.Raw.Proofs.L.MX.eq_lt LabelMap.Raw.Proofs.PX.MO.lt_eq LabelMap.Raw.Proofs.PX.MO.eq_lt
  LabelMap.Raw.Proofs.MX.lt_eq LabelMap.Raw.Proofs.MX.eq_lt
  LabelMap.Raw.Proofs.L.PX.eqk_ltk LabelMap.Raw.Proofs.L.PX.ltk_eqk LabelMap.Raw.Proofs.L.PX.ltk_trans
  LabelMap.Raw.Proofs.PX.eqk_ltk LabelMap.Raw.Proofs.PX.ltk_eqk LabelMap.Raw.Proofs.PX.ltk_trans
  LabelMap.Raw.Proofs.L.PX.MO.lt_antirefl
  LabelMap.Raw.Proofs.L.MX.lt_antirefl LabelMap.Raw.Proofs.PX.MO.lt_antirefl LabelMap.Raw.Proofs.MX.lt_antirefl
  LabelMap.Raw.Proofs.L.PX.eqk_not_ltk LabelMap.Raw.Proofs.L.PX.ltk_not_eqke
  LabelMap.Raw.Proofs.L.PX.ltk_not_eqk LabelMap.Raw.Proofs.L.PX.MO.lt_not_gt
  LabelMap.Raw.Proofs.L.PX.MO.eq_not_gt LabelMap.Raw.Proofs.L.PX.MO.eq_neq
  LabelMap.Raw.Proofs.L.PX.MO.neq_eq LabelMap.Raw.Proofs.L.PX.MO.eq_le
  LabelMap.Raw.Proofs.L.PX.MO.le_eq LabelMap.Raw.Proofs.L.PX.MO.eq_not_lt
  LabelMap.Raw.Proofs.L.PX.MO.gt_not_eq LabelMap.Raw.Proofs.L.MX.lt_not_gt
  LabelMap.Raw.Proofs.L.MX.eq_not_gt LabelMap.Raw.Proofs.L.MX.eq_neq
  LabelMap.Raw.Proofs.L.MX.neq_eq LabelMap.Raw.Proofs.L.MX.eq_le
  LabelMap.Raw.Proofs.L.MX.le_eq LabelMap.Raw.Proofs.L.MX.eq_not_lt
  LabelMap.Raw.Proofs.L.MX.gt_not_eq LabelMap.Raw.Proofs.PX.eqk_not_ltk
  LabelMap.Raw.Proofs.PX.ltk_not_eqke LabelMap.Raw.Proofs.PX.ltk_not_eqk
  LabelMap.Raw.Proofs.PX.MO.lt_not_gt LabelMap.Raw.Proofs.PX.MO.eq_not_gt
  LabelMap.Raw.Proofs.PX.MO.eq_neq LabelMap.Raw.Proofs.PX.MO.neq_eq
  LabelMap.Raw.Proofs.PX.MO.eq_le LabelMap.Raw.Proofs.PX.MO.le_eq
  LabelMap.Raw.Proofs.PX.MO.eq_not_lt LabelMap.Raw.Proofs.PX.MO.gt_not_eq
  LabelMap.Raw.Proofs.MX.lt_not_gt LabelMap.Raw.Proofs.MX.eq_not_gt
  LabelMap.Raw.Proofs.MX.eq_neq LabelMap.Raw.Proofs.MX.neq_eq
  LabelMap.Raw.Proofs.MX.eq_le LabelMap.Raw.Proofs.MX.le_eq
  LabelMap.Raw.Proofs.MX.eq_not_lt LabelMap.Raw.Proofs.MX.gt_not_eq
  LabelMap.Raw.Proofs.L.PX.Sort_Inf_NotIn LabelMap.Raw.Proofs.PX.Sort_Inf_NotIn
  LabelMap.Raw.Proofs.L.PX.Inf_eq LabelMap.Raw.Proofs.L.PX.MO.Inf_lt
  LabelMap.Raw.Proofs.L.MX.Inf_lt LabelMap.Raw.Proofs.PX.Inf_eq
  LabelMap.Raw.Proofs.PX.MO.Inf_lt LabelMap.Raw.Proofs.MX.Inf_lt
  LabelMap.Raw.Proofs.L.PX.Inf_lt LabelMap.Raw.Proofs.L.PX.MO.Inf_lt
  LabelMap.Raw.Proofs.L.MX.Inf_lt LabelMap.Raw.Proofs.PX.Inf_lt
  LabelMap.Raw.Proofs.PX.MO.Inf_lt LabelMap.Raw.Proofs.MX.Inf_lt
  LabelMap.Raw.InRight LabelMap.Raw.InLeft LabelMap.Raw.InRoot
  LabelMap.Raw.Proofs.L.PX.InA_eqke_eqk LabelMap.Raw.Proofs.L.PX.MO.In_eq
  LabelMap.Raw.Proofs.L.PX.MO.ListIn_In LabelMap.Raw.Proofs.L.MX.In_eq
  LabelMap.Raw.Proofs.L.MX.ListIn_In LabelMap.Raw.Proofs.PX.InA_eqke_eqk
  LabelMap.Raw.Proofs.PX.MO.In_eq LabelMap.Raw.Proofs.PX.MO.ListIn_In
  LabelMap.Raw.Proofs.MX.In_eq LabelMap.Raw.Proofs.MX.ListIn_In
  LabelMap.Raw.Proofs.L.PX.In_inv_3 LabelMap.Raw.Proofs.PX.In_inv_3
  LabelMap.Raw.Proofs.L.PX.In_inv_2 LabelMap.Raw.Proofs.PX.In_inv_2
  LabelMap.Raw.MapsRight LabelMap.Raw.MapsLeft
  LabelMap.Raw.MapsRoot LabelMap.Raw.Proofs.L.PX.MO.Sort_NoDup
  LabelMap.Raw.Proofs.L.MX.Sort_NoDup LabelMap.Raw.Proofs.PX.MO.Sort_NoDup
  LabelMap.Raw.Proofs.MX.Sort_NoDup
  LabelMap.Raw.BSLeaf LabelMap.Raw.BSNode LabelMap.Raw.Leaf LabelMap.Raw.Node.

Require Coq.FSets.FMapFacts.
Module LabelFacts := FMapFacts.WFacts_fun(LabelKey)(LabelMap).


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Infrastructure.

Require Import List. Import ListNotations.
Require Import Strings.String.

Lemma Typing_chk: forall G e A,
  Typing G e Inf A ->
  exists B, Typing G e Chk B.
Proof.
  introv Typ.
  inductions Typ; eauto.
Qed.

Lemma Typing_chk2: forall G e A,
  Typing G e Chk A ->
  exists B, Typing G e Inf B.
Proof.
  introv Typ.
  inductions Typ; eauto.
Qed.

(* Common Lemmas *)
Lemma Typing_regular_1 : forall e G dir A,
    Typing G e dir A -> lc_exp e.
Proof.
  intros e G dir A H.
  induction H;
    eauto.
Qed.

Lemma Typing_regular_2 : forall G e dir T,
    Typing G e dir T -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Lemma Typing_weaken : forall G E F e dir T,
    Typing (E ++ G) e dir T ->
    uniq (E ++ F ++ G) ->
    Typing (E ++ F ++ G) e dir T.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply Typ_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma Typing_weakening : forall (E F : ctx) e dir T,
    Typing E e dir T ->
    uniq (F ++ E) ->
    Typing (F ++ E) e dir T.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply~ Typing_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma fv_in_dom: forall G e dir T,
    Typing G e dir T -> fv_exp e [<=] dom G.
Proof.
  intros G e dir T H.
  induction H; simpl; try fsetdec.
  - Case "typing_var".
    apply binds_In in H0.
    fsetdec.
  - Case "typing_abs".
    pick fresh x.
    assert (Fx : fv_exp (open_exp_wrt_exp e (e_var_f x)) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (open_exp_wrt_exp e (e_var_f x))) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma value_no_fv : forall v dir T,
    Typing [] v dir T -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (fv_in_dom [] v).
  intuition eauto.
Qed.

Lemma subst_value : forall v dir T z u,
    Typing [] v dir T -> subst_exp u z v = v.
Proof.
  intros v dir T z u Typ.
  lets* Fv: value_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma Typing_subst_1 : forall (E F : ctx) e u dir S T (z : atom),
    Typing (F ++ [(z,S)] ++ E) e dir T ->
    Typing E u Inf S ->
    Typing (F ++ E) ([z ~> u] e) dir T.
Proof.
  intros.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  induction H; intros F Eq; subst; simpl; autos*;
    lets Lc  : Typing_regular_1 H0;
    lets Uni : Typing_regular_2 H0.
  -
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    apply~ Typing_weakening.
    solve_uniq.
  -
    pick fresh x and apply Typ_abs; eauto.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
Qed.

Lemma typing_c_subst_simpl : forall E e u dir S T z,
  Typing ([(z,S)] ++ E) e dir T ->
  Typing E u Inf S ->
  Typing E ([z ~> u] e) dir T.
Proof.
  intros E e u dir S T z H1 H2.
  rewrite_env (nil ++ E).
  eapply Typing_subst_1.
    simpl_env. apply H1.
    apply H2.
Qed.

Lemma principle_inf: forall v A,
  value v -> Typing nil v Inf A -> (principal_type v) = A .
Proof.
  introv Val Typ.
  gen A.
  induction Val; introv  Typ; try solve [inverts* Typ].
Qed.

(* stronger than inf unique *)
Lemma Typing_strenthening : forall G e A1 A2,
    []  ⊢ e ⇒ A1 ->
    G ⊢ e ⇒ A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2 G.
  inductions Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    inverts H0.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
Qed.

Lemma inference_unique : forall G e A1 A2,
    Typing G e Inf A1 ->
    Typing G e Inf A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2.
  induction Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
Qed.


 Require Import Coq.Arith.Arith .
Require Import Coq.Bool.Bool .
Require Export Coq.Strings.String .
Require Import Coq.Logic.FunctionalExtensionality .
Require Import Coq.Lists.List .
Import ListNotations.
Require Import Coq.Logic.ProofIrrelevance.
Require Import ZArith.

(* A: tuple constructors*)
Record person := mkPerson{
  pname: string
}.

Record staff := mkStaff {
  sp : person;
  jobTitle: string
}.

Record faculty := mkFaculty{
  fp: person;
  rank: string
  fpapers: list string;
}.

Record student := mkStudent{
  stname: string;
  spapers: list string;
}.

(* B: tuple constructors*)
Record staff' := mkStaff'{
  sname : string;
  sjobTitle: string;
}.

Record faculty' := mkFaculty'{
  fname : string;
  frank: string;
}.

Export ListNotations.

(* Staff to Person *)
Definition staff_toPerson (s:staff) : person := sp s.
Definition staff_toPersonList (sl: list staff) := map staff_toPerson sl.

(* Staff to Staff' *)
Definition staff_toStaff' (s:staff) : staff' :=
  match s with
  |mkStaff (mkPerson i n) j => mkStaff' i n j
end.
Definition staff_toStaff'List (sl: list staff) := map staff_toStaff' sl.

(* Faculty to Person *)
Definition faculty_toPerson (f:faculty) : person := fp f.
Definition faculty_toPersonList (fl: list faculty) := map faculty_toPerson fl.

(* Faculty to Faculty' *)
Definition faculty_toFaculty' (f:faculty) : faculty' :=
  match f with
  |mkFaculty (mkPerson i n) j => mkFaculty' i n j
end.
Definition faculty_toFaculty'List (fl: list faculty) := map faculty_toFaculty' fl.

(* Staff' to Person *)
Definition staff'_toPerson (s':staff') : person :=
  match s' with
  |mkStaff' i n _ => mkPerson i n
end.
Definition staff'_toPersonList (sl': list staff') := map staff'_toPerson sl'.

(* Faculty' to Person *)
Definition faculty'_toPerson (f':faculty') : person :=
  match f' with
  |mkFaculty' i n _ => mkPerson i n
end.
Definition faculty'_toPersonList (fl': list faculty') := map faculty'_toPerson fl'.

(* Staff' to Staff *)
Definition staff'_toStaff (s': staff') : staff :=
 match s' with
  |mkStaff' i n j => mkStaff (mkPerson i n) j
end.
Definition staff'_toSaffList (sl': list staff') := map staff'_toStaff sl'.

(* Faculty' to Faculty *)
Definition faculty'_toFaculty (f': faculty') : faculty :=
 match f' with
  |mkFaculty' i n r => mkFaculty (mkPerson i n) r
end.
Definition faculty'_toFacultyList (fl': list faculty') :=
map faculty'_toFaculty fl'.

Definition disjoint {A: Type}(l m:list A) := forall a:A, In a l -> ~ In a m.

Definition abstract (super: list person) (sub1: list person) (sub2: list person):=
 super = sub1 ++ sub2 /\ disjoint sub1 sub2.

(* A: database constructor *)
Record class_diagram := mkCD{
  person_list: list person;
  staff_list: list staff;
  faculty_list: list faculty;
  abstract_inh: abstract person_list (map sp staff_list) (map fp faculty_list);

  v_staff'_list:= (staff_toStaff'List staff_list);
  v_faculty'_list := (faculty_toFaculty'List faculty_list)
}.

(* B: database constructor *)
Record class_diagram' := mkCD'{
  staff'_list: list staff';
  faculty'_list: list faculty';
  constraint': disjoint (staff'_toPersonList staff'_list) (faculty'_toPersonList faculty'_list);

  v_staff_list:= (staff'_toSaffList staff'_list);
  v_faculty_list:= (faculty'_toFacultyList faculty'_list);
  v_person_list:= (staff'_toPersonList staff'_list) ++ (faculty'_toPersonList faculty'_list);
}.

Lemma staff'List: forall sl': list staff',
staff'_toPersonList sl' = staff_toPersonList (staff'_toSaffList sl').
Proof.
intros.
induction sl'.
- reflexivity.
- simpl. f_equal.
  + destruct a as [sid sname sjobTitle]. simpl. reflexivity.
  + assumption.
Qed.

Lemma faculty'List: forall fl': list faculty',
faculty'_toPersonList fl' = faculty_toPersonList (faculty'_toFacultyList fl').
Proof.
intros.
induction fl'.
- reflexivity.
- simpl. f_equal.
  + destruct a as [fid fname frank]. simpl. reflexivity.
  + assumption.
Qed.

Lemma reconstructStaffList : forall sl: list staff,
sl = staff'_toSaffList (staff_toStaff'List sl).
Proof.
induction sl as [|s sl].
-reflexivity.
- rewrite IHsl. simpl. replace (staff'_toStaff (staff_toStaff' s)) with s.
  + f_equal. rewrite <- IHsl. assumption.
  + destruct s as [[i n] j]. reflexivity.
Qed.

Lemma reconstructFacultyList : forall fl: list faculty,
fl = faculty'_toFacultyList (faculty_toFaculty'List fl).
Proof.
induction fl as [|f fl].
-reflexivity.
- rewrite IHfl. simpl. replace (faculty'_toFaculty (faculty_toFaculty' f)) with f.
  + f_equal. rewrite <- IHfl. assumption.
  + destruct f as [[i n] r]. reflexivity.
Qed.

Lemma staffPerson: forall sl: list staff,
(staff_toPersonList sl) = (staff'_toPersonList (staff_toStaff'List sl)).
Proof.
induction sl as [| s sl].
reflexivity.
simpl.
f_equal.
- destruct s as [[pid pname] jobTitle]. simpl. reflexivity.
- assumption.
Qed.

Lemma facultyPerson: forall fl: list faculty,
(faculty_toPersonList fl) =
    (faculty'_toPersonList (faculty_toFaculty'List fl)).
Proof.
induction fl as [| f fl].
reflexivity.
simpl.
f_equal.
- destruct f as [[pid pname] rank]. simpl. reflexivity.
- assumption.
Qed.

Lemma toCD'Const: forall pl sl fl,
abstract pl sl fl->
         disjoint (staff'_toPersonList (staff_toStaff'List sl))
  (faculty'_toPersonList (faculty_toFaculty'List fl)).
Proof.
intros.
unfold abstract in H.
inversion H.
rewrite <- staffPerson.
rewrite <- facultyPerson.
assumption.
Qed.

Definition toCD' (cd:class_diagram) : class_diagram' :=
  match cd with
  | mkCD pl sl fl abs vsl' vfl' => mkCD' vsl' vfl' (toCD'Const pl sl fl abs)
end.

Definition toCD'_Def (cd: class_diagram) : class_diagram'.
Proof.
destruct cd as [pl sl fl abs vsl' vfl'].
refine{|staff'_list:=vsl';  faculty'_list:=vfl'|}.
unfold abstract in abs.
inversion abs.
unfold vsl', vfl'.
rewrite <- staffPerson.
rewrite <- facultyPerson.
assumption.
Defined.

Lemma staff'Person: forall sl': list staff',
(staff'_toPersonList sl') = (staff_toPersonList (staff'_toSaffList sl')).
Proof.
induction sl' as [| s' sl'].
reflexivity.
simpl.
f_equal.
- destruct s' as [sid sname jobTitle']. simpl. reflexivity.
- assumption.
Qed.

Lemma faculty'Person: forall fl': list faculty',
(faculty'_toPersonList fl') = (faculty_toPersonList (faculty'_toFacultyList fl')).
Proof.
induction fl' as [| f' fl'].
reflexivity.
simpl.
f_equal.
- destruct f' as [fid fname rank']. simpl. reflexivity.
- assumption.
Qed.

Lemma toCDConst: forall sl' fl',
disjoint (staff'_toPersonList sl')
  (faculty'_toPersonList fl') -> abstract (staff'_toPersonList sl' ++
       faculty'_toPersonList fl') (staff'_toSaffList sl')
   (faculty'_toFacultyList fl').
Proof.
intros.
unfold abstract.
split.
- rewrite <- staff'List.
  rewrite <- faculty'List.
  reflexivity.
- rewrite <- staff'Person.
  rewrite <- faculty'Person.
  assumption.
Qed.

Definition toCD (cd':class_diagram') : class_diagram :=
  match cd' with
  | mkCD' sl' fl' disj' vsl vfl vpl => mkCD vpl vsl vfl (toCDConst sl' fl' disj')
end.

Definition toCD_Def (cd': class_diagram') : class_diagram.
Proof.
destruct cd' as [sl' fl' disj' vsl vfl vpl].
refine{|person_list:= vpl; staff_list:= vsl; faculty_list:= vfl |}.
unfold abstract.
split.
- unfold vpl, vsl, vfl.
  rewrite <- staff'List.
  rewrite <- faculty'List.
  reflexivity.
- unfold vsl, vfl.
  rewrite <- staff'Person.
  rewrite <- faculty'Person.
  assumption.
Defined.

(** Th1: CD -> CD' -> CD **)

Definition transportAbstract (fn : list person -> list staff -> list faculty -> Type)
  {p1 p2: list person} {s1 s2 : list staff} {f1 f2: list faculty} :
  p1 = p2 -> s1 = s2 -> f1 = f2 -> fn p1 s1 f1-> fn p2 s2 f2.
Proof.
  intros H1 H2 H3.
  rewrite <- H1; rewrite <- H2; rewrite <- H3.
  firstorder.
Defined.

Lemma eqConst (cd1 cd2 : class_diagram)
      (p: person_list cd1 = person_list cd2)
      (q : staff_list cd1 = staff_list cd2)
      (r : faculty_list cd1 = faculty_list cd2) :
  transportAbstract abstract p q r  (abstract_inh cd1) = abstract_inh cd2 ->
  cd1 = cd2.
Proof.
  destruct cd1; destruct cd2.
  simpl in * |- *.
  destruct p.
  destruct q.
  destruct r.
  intros [].
  reflexivity.
Qed.

Lemma eqPersonList: forall cd,
person_list cd = person_list (toCD (toCD' cd)).
Proof.
intros.
unfold toCD, toCD'.
destruct cd as [pl sl fl abs].
unfold person_list.
unfold abstract in abs.
inversion abs.
rewrite <- staffPerson.
rewrite <- facultyPerson.
assumption.
Qed.

Lemma eqStaffList: forall cd,
  staff_list cd = staff_list (toCD (toCD' cd)).
Proof.
intros.
unfold toCD, toCD'.
destruct cd as [pl sl fl abs].
unfold staff_list.
apply reconstructStaffList.
Qed.

Lemma eqFacultyList: forall cd,
 faculty_list cd = faculty_list (toCD (toCD' cd)).
Proof.
intros.
unfold toCD, toCD'.
destruct cd as [pl sl fl abs].
unfold faculty_list.
apply reconstructFacultyList.
Qed.

Theorem th1: forall cd:class_diagram,
  cd = toCD (toCD' cd).
Proof.
intros cd.
pose proof (eqConst cd (toCD (toCD' cd))).
apply (H (eqPersonList cd) (eqStaffList cd) (eqFacultyList cd) ).
apply proof_irrelevance.
Qed.

(** Th2: CD' -> CD -> CD' **)

Definition disjointCast (sl': list staff') (fl': list faculty'):=
disjoint (staff'_toPersonList sl') (faculty'_toPersonList fl').

Definition transportDisjoint (fn : list staff' -> list faculty' -> Type)
  {s1 s2 : list staff'} {f1 f2: list faculty'} :
   s1 = s2 -> f1 = f2 -> fn s1 f1-> fn s2 f2.
Proof.
  intros H1 H2.
  rewrite <- H1; rewrite <- H2.
  firstorder.
Defined.

Lemma eqConst' (cd1 cd2 : class_diagram')
      (p : staff'_list cd1 = staff'_list cd2)
      (q : faculty'_list cd1 = faculty'_list cd2) :
  transportDisjoint disjointCast p q (constraint' cd1) = constraint' cd2 ->
  cd1 = cd2.
Proof.
  destruct cd1; destruct cd2.
  simpl in * |- *.
  destruct p.
  destruct q.
  intros [].
  reflexivity.
Qed.

Lemma reconstructStaffList' : forall sl': list staff',
sl' = staff_toStaff'List (staff'_toSaffList sl').
Proof.
induction sl' as [|s' sl'].
-reflexivity.
- rewrite IHsl'. simpl. replace (staff_toStaff' (staff'_toStaff s')) with s'.
  + f_equal. rewrite <- IHsl'. assumption.
  + destruct s' as [i n j]. reflexivity.
Qed.

Lemma reconstructFacultyList' : forall fl': list faculty',
fl' = faculty_toFaculty'List (faculty'_toFacultyList fl').
Proof.
induction fl' as [|f' fl'].
-reflexivity.
- rewrite IHfl'. simpl. replace (faculty_toFaculty' (faculty'_toFaculty f')) with f'.
  + f_equal. rewrite <- IHfl'. assumption.
  + destruct f' as [i n r]. reflexivity.
Qed.

Lemma eqStaffList': forall cd',
  staff'_list cd' = staff'_list (toCD' (toCD cd')).
Proof.
intros.
unfold toCD, toCD'.
destruct cd' as [sl' fl' disj'].
unfold staff'_list.
apply reconstructStaffList'.
Qed.

Lemma eqFacultyList': forall cd',
 faculty'_list cd' = faculty'_list (toCD' (toCD cd')).
Proof.
intros.
unfold toCD, toCD'.
destruct cd' as [sl' fl' disj'].
unfold faculty'_list.
apply reconstructFacultyList'.
Qed.

Theorem th2: forall cd':class_diagram',
  cd' = toCD' (toCD cd').
Proof.
intros cd'.
pose proof (eqConst' cd' (toCD' (toCD cd'))).
apply (H (eqStaffList' cd') (eqFacultyList' cd') ).
apply proof_irrelevance.
Qed.