(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool ssrfun TestSuite.ssr_mini_mathcomp.

Lemma test1 : forall x y (f : nat -> nat), f (x + y).+1 = f (y + x.+1).
by move=> x y f; rewrite [_.+1](addnC x.+1).
Qed.

Lemma test2 : forall x y f, x + y + f (y + x) + f (y + x) = x + y + f (y + x) + f (x + y).
by move=> x y f; rewrite {2}[in f _]addnC.
Qed.

Lemma test2' : forall x y f, true && f (x * (y + x)) = true && f(x * (x + y)).
by move=> x y f; rewrite [in f _](addnC y).
Qed.

Lemma test2'' : forall x y f, f (y + x) + f(y + x) + f(y + x)  = f(x + y) + f(y + x) + f(x + y).
by move=> x y f; rewrite {1 3}[in f _](addnC y).
Qed.

(* patterns catching bound vars not supported *)
Lemma test2_1 : forall x y f, true && (let z := x in f (z * (y + x))) = true && f(x * (x + y)).
by move=> x y f; rewrite [in f _](addnC x). (* put y when bound var will be OK *)
Qed.

Lemma test3 : forall x y f, x + f (x + y) (f (y + x) x) = x + f (x + y) (f (x + y) x).
by move=> x y f; rewrite [in X in (f _ X)](addnC y).
Qed.

Lemma test3' : forall x y f, x = y -> x + f (x + x) x + f (x + x) x =
                                      x + f (x + y) x + f (y + x) x.
by move=> x y f E; rewrite {2 3}[in X in (f X _)]E.
Qed.

Lemma test3'' : forall x y f, x = y -> x + f (x + y) x + f (x + y) x =
                                       x + f (x + y) x + f (y + y) x.
by move=> x y f E; rewrite {2}[in X in (f X _)]E.
Qed.

Lemma test4 : forall x y f, x = y -> x + f (fun _ : nat => x + x) x + f (fun _ => x + x) x =
                                     x + f (fun _       => x + y) x + f (fun _ => y + x) x.
by move=> x y f E; rewrite {2 3}[in X in (f X _)]E.
Qed.

Lemma test4' : forall x y f, x = y -> x + f (fun _ _ _ : nat => x + x) x =
                                      x + f (fun _ _ _       => x + y) x.
by move=> x y f E; rewrite {2}[in X in (f X _)]E.
Qed.

Lemma test5 : forall x y f, x = y -> x + f (y + x) x + f (y + x) x =
                                     x + f (x + y) x + f (y + x) x.
by move=> x y f E; rewrite {1}[X in (f X _)]addnC.
Qed.

Lemma test3''' : forall x y f, x = y -> x + f (x + y) x + f (x + y) (x + y) =
                                        x + f (x + y) x + f (y + y) (x + y).
by move=> x y f E; rewrite {1}[in X in (f X X)]E.
Qed.

Lemma test3'''' : forall x y f, x = y -> x + f (x + y) x + f (x + y) (x + y) =
                                         x + f (x + y) x + f (y + y) (y + y).
by move=> x y f E; rewrite [in X in (f X X)]E.
Qed.

Lemma test3x : forall x y f, y+y = x+y -> x + f (x + y) x + f (x + y) (x + y) =
                                         x + f (x + y) x + f (y + y) (y + y).
by move=> x y f E; rewrite -[X in (f X X)]E.
Qed.

Lemma test6 : forall x y (f : nat -> nat), f (x + y).+1 = f (y.+1 + x).
by move=> x y f; rewrite [(x + y) in X in (f X)]addnC.
Qed.

Lemma test7 : forall x y (f : nat -> nat), f (x + y).+1 = f (y + x.+1).
by move=> x y f; rewrite [(x.+1 + y) as X in (f X)]addnC.
Qed.

Lemma manual x y z (f : nat -> nat -> nat) : (x + y).+1 + f (x.+1 + y) (z + (x + y).+1) = 0.
Proof.
rewrite [in f _]addSn.
match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 => idtac end.
rewrite -[X in _ = X]addn0.
match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + 0 => idtac end.
rewrite -{2}[in X in _ = X](addn0 0).
match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + (0 + 0) => idtac end.
rewrite [_.+1 in X in f _ X](addnC x.+1).
match goal with |- (x + y).+1 + f (x + y).+1 (z + (y + x.+1)) = 0 + (0 + 0) => idtac end.
rewrite [x.+1 + y as X in f X _]addnC.
match goal with |- (x + y).+1 + f (y + x.+1) (z + (y + x.+1)) = 0 + (0 + 0) => idtac end.
Admitted.

Goal (exists x : 'I_3, x > 0).
apply: (ex_intro _ (@Ordinal _ 2 _)).
Admitted.

Goal (forall y, 1 < y < 2 -> exists x : 'I_3, x > 0).
move=> y; case/andP=> y_gt1 y_lt2; apply: (ex_intro _ (@Ordinal _ y _)).
 by apply: leq_trans y_lt2 _.
by move=> y_lt3; apply: leq_trans _ y_gt1.
Qed.

Goal (forall x y : nat, forall P : nat -> Prop, x = y -> True).
move=> x y P E.
have: P x -> P y by suff: x = y by move=> ?; congr (P _).
Admitted.

Goal forall a : bool, a -> true && a || false && a.
by move=> a ?; rewrite [true && _]/= [_ && a]/= orbC [_ || _]//=.
Qed.

Goal forall a : bool, a -> true && a || false && a.
by move=> a ?; rewrite [X in X || _]/= [X in _ || X]/= orbC [false && a as X in X || _]//=.
Qed.

Variable a : bool.
Definition f x := x || a.
Definition g x := f x.

Goal a -> g false.
by move=> Ha; rewrite [g _]/f orbC Ha.
Qed.

Goal a -> g false || g false.
move=> Ha; rewrite {2}[g _]/f orbC Ha.
match goal with |- (is_true (false || true || g false)) => done end.
Qed.

Goal a -> (a && a || true && a) && true.
by move=> Ha; rewrite -[_ || _]/(g _) andbC /= Ha [g _]/f.
Qed.

Goal a -> (a || a) && true.
by move=> Ha; rewrite -[in _ || _]/(f _) Ha andbC /f.
Qed.


(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Require Import Maps.
Require Import Smallstep.
Require Import MoreStlc.

(* ################################################################# *)
(** * Core Definitions *)

(* ----------------------------------------------------------------- *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | TTop   : ty
  | TBase  : id -> ty
  | TArrow : ty -> ty -> ty
  (* record types *)
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tproj : tm -> id -> tm
  (* record terms *)
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTTop :
        well_formed_ty TTop
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

(** Substitution and reduction are as before. *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if beq_id x y then s else t
  | tabs y T t1 =>  tabs y T (if beq_id x y then t1
                             else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr2 => trcons i (subst x s t1) (subst x s tr2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ----------------------------------------------------------------- *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_rnil : value trnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (trcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' =>
      if beq_id i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' =>
      if beq_id i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr ==> tr' ->
        (tproj tr i) ==> (tproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

(* ################################################################# *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ================================================================= *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: TTop
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    TArrow S1 S2 <: TArrow T1 T2
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (TRCons i T1 T2) ->
    TRCons i T1 T2 <: TRNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    TRCons i S1 Sr2 <: TRCons i T1 Tr2
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (TRCons i1 T1 (TRCons i2 T2 Tr3)) ->
    i1 <> i2 ->
       TRCons i1 T1 (TRCons i2 T2 Tr3)
    <: TRCons i2 T2 (TRCons i1 T1 Tr3)

where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

(* ================================================================= *)
(** ** Examples *)

Module Examples.

Notation x := (Id 0).
Notation y := (Id 1).
Notation z := (Id 2).
Notation j := (Id 3).
Notation k := (Id 4).
Notation i := (Id 5).
Notation A := (TBase (Id 6)).
Notation B := (TBase (Id 7)).
Notation C := (TBase (Id 8)).

Definition TRcd_j  :=
  (TRCons j (TArrow B B) TRNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  TRCons k (TArrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (TArrow C TRcd_kj)
          (TArrow C TRNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_2 :
  subtype (TArrow TTop TRcd_kj)
          (TArrow (TArrow C C) TRcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_3 :
  subtype (TArrow TRNil (TRCons j A TRNil))
          (TArrow (TRCons k B TRNil) TRNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_4 :
  subtype (TRCons x A (TRCons y B (TRCons z C TRNil)))
          (TRCons z C (TRCons y B (TRCons x A TRNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples.

(* ================================================================= *)
(** ** Properties of Subtyping *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  - (* TRCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (beq_id i i0)...  inversion H0; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve_by_invert.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (beq_id i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (beq_idP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (beq_idP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars (rcd_types_match_informal)  *)
(** Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* FILL IN HERE *)
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (TArrow V1 V2) ->
     exists U1, exists U2,
       (U=(TArrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (TArrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in TArrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- tapp t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- tproj t i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- trnil \in TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- trcons i t tr \in TRCons i T Tr

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ================================================================= *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star  *)
Definition trcd_kj :=
  (trcons k (tabs z A (tvar z))
           (trcons j (tabs z B (tvar z))
                      trnil)).

Example typing_example_0 :
  has_type empty
           (trcons k (tabs z A (tvar z))
                     (trcons j (tabs z B (tvar z))
                               trnil))
           TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars  *)
Example typing_example_1 :
  has_type empty
           (tapp (tabs x TRcd_j (tproj (tvar x) j))
                   (trcd_kj))
           (TArrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Example typing_example_2 :
  has_type empty
           (tapp (tabs z (TArrow (TArrow C C) TRcd_j)
                           (tproj (tapp (tvar z)
                                            (tabs x C (tvar x)))
                                    j))
                   (tabs z (TArrow C C) trcd_kj))
           (TArrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples2.

(* ================================================================= *)
(** ** Properties of Typing *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  induction Htyp; intros; subst; try solve_by_invert.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (beq_id i i0).
    + (* i is first *)
      inversion H1. subst. exists t...
    + (* i in tail *)
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Progress *)

(** **** Exercise: 3 stars (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (TArrow T1 T2) ->
     value s ->
     exists x, exists S1, exists s2,
        s = tabs x S1 s2.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t ==> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 ==> t1'] for some term [t1'].  Then [t1 t2 ==>
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 ==> t2'] for some term [t2'].  Then [t1 t2 ==>
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 ==>
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr ==>
        tr'] for some term [tr'], then [tr.i ==> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i ==> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then [{i=t1, tr}
          ==> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr ==> tr'] for some term [tr'].  Then [{i=t1,
            tr} ==> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (tvar x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (tvar x) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  - (* T_Var *)
    exists T...
  - (* T_Sub *)
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (tapp t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (TArrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tapp t1 t2) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  - (* T_App *)
    exists T1...
  - (* T_Sub *)
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (tabs x S1 t2) T ->
     (exists S2, subtype (TArrow S1 S2) T
              /\ has_type (update Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tabs x S1 t2) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (tproj t1 i) Ti ->
  exists T, exists Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (tproj t1 i) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Proj *)
    assert (well_formed_ty Ti) as Hwf.
    { (* pf of assertion *)
      apply (wf_rcd_lookup i T Ti)...
      apply has_type__wf in H... }
    exists T. exists Ti...
  - (* T_Sub *)
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U. exists Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (trcons i ti tr) T ->
  exists Si, exists Sr,
    subtype (TRCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (trcons i ti tr) as t.
  induction Hty;
    inversion Heqt; subst...
  - (* T_Sub *)
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri. exists Rr...
  - (* T_RCons *)
    assert (well_formed_ty (TRCons i T Tr)) as Hwf.
    { (* pf of assertion *)
      apply has_type__wf in Hty1.
      apply has_type__wf in Hty2... }
    exists T. exists Tr...  Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (tabs x S1 s2) (TArrow T1 T2) ->
     subtype T1 S1
  /\ has_type (update empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (tproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (trcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold update, t_update. destruct (beq_idP x x0)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  - (* T_Abs *)
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold update, t_update in Hctx.
    rewrite false_beq_id in Hctx...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  - (* tvar *)
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (beq_idP x y)...
    + (* x=y *)
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      destruct (subtype__wf _ _ Hsub)...
  - (* tapp *)
    destruct (typing_inversion_app _ _ _ _ Htypt)
      as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  - (* tabs *)
    rename i into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (TArrow T1 T2)... apply T_Abs...
    destruct (beq_idP x y).
    + (* x=y *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x)...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z)...
      subst.  rewrite false_beq_id...
  - (* tproj *)
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  - (* trnil *)
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  - (* trcons *)
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (TRCons i Ti Tr)...
    apply T_RCons...
    + (* record_ty Tr *)
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    + (* record_tm ([x:=v]t2) *)
      inversion Hrcdt2; subst; simpl...  Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  - (* T_Proj *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t ==> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr ==> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

(** $Date: 2016-07-13 12:41:41 -0400 (Wed, 13 Jul 2016) $ *)


Require Import Coq.micromega.Psatz.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.StrongInduction.
Require Import Logic.lib.Stream.SigStream.

Definition fin_stream {A: Type} (h: list A) : stream A.
  exists (fun n => nth_error h n).
  intros.
  rewrite nth_error_None_iff in H0 |- *.
  lia.
Defined.

Definition inf_stream {A: Type} (h: nat -> A) : stream A.
  exists (fun n => Some (h n)).
  intros.
  congruence.
Defined.

Lemma fin_stream_fin {A: Type}: forall l: list A, is_fin_stream (fin_stream l).
Proof.
  intros.
  exists (length l).
  simpl.
  rewrite nth_error_None_iff; auto.
Qed.

Lemma inf_stream_inf {A: Type}: forall f: nat -> A, is_inf_stream (inf_stream f).
Proof.
  intros; hnf; intros.
  simpl.
  congruence.
Qed.

Lemma fin_stream_n_stream {A: Type}: forall l: list A, is_n_stream (length l) (fin_stream l).
Proof.
  intros.
  split.
  + simpl.
    apply nth_error_None_iff; lia.
  + intros.
    simpl.
    rewrite nth_error_None_iff; lia.
Qed.

Definition empty_stream {A: Type}: stream A := fin_stream nil.

Definition empty_stream_spec {A: Type}: forall n, @empty_stream A n = None.
Proof.
  intros.
  simpl.
  destruct n; auto.
Qed.

Lemma empty_stream_is_empty {A: Type}: is_empty_stream (@empty_stream A).
Proof.
  split.
  + apply empty_stream_spec.
  + intros; lia.
Qed.

Program Definition stream_map {A B: Type} (f: A -> B) (h: stream A): stream B :=
  fun n => match h n return option B with
           | Some a => Some (f a)
           | None => None
           end.
Next Obligation.
  pose proof proj2_sig h x y H.
  change (proj1_sig h) with (stream_get h) in H1.
  destruct (h x), (h y); try congruence.
  specialize (H1 eq_refl); congruence.
Qed.

Lemma stream_map_spec {A B: Type}: forall (f: A -> B) (h: stream A) (n: nat),
  stream_map f h n =
  match h n return option B with
  | Some a => Some (f a)
  | None => None
  end.
Proof.
  intros; simpl; auto.
Qed.

Lemma stream_map_empty_stream {A B: Type}: forall (f: A -> B),
  stream_map f empty_stream = empty_stream.
Proof.
  intros.
  stream_extensionality n.
  rewrite stream_map_spec, !empty_stream_spec.
  auto.
Qed.

Lemma stream_map_n_stream {A B: Type}: forall (f: A -> B) (h: stream A) (n: nat),
  is_n_stream n h <-> is_n_stream n (stream_map f h).
Proof.
  intros.
  split; intro.
  + destruct H; split.
    - rewrite stream_map_spec, H; auto.
    - intros; specialize (H0 n' H1).
      destruct (h n') eqn:HH; rewrite stream_map_spec, HH; congruence.
  + destruct H; split.
    - destruct (h n) eqn:HH; rewrite stream_map_spec, HH in H; congruence.
    - intros; specialize (H0 n' H1).
      destruct (h n') eqn:HH; rewrite stream_map_spec, HH in H0; congruence.
Qed.

Lemma stream_map_inf_stream {A B: Type}: forall (f: A -> B) (h: stream A),
  is_inf_stream h <-> is_inf_stream (stream_map f h).
Proof.
  intros.
  split; intro.
  + hnf; intros.
    specialize (H n).
    destruct (h n) eqn:HH; rewrite stream_map_spec, HH; congruence.
  + hnf; intros; specialize (H n).
    destruct (h n) eqn:HH; rewrite stream_map_spec, HH in H; congruence.
Qed.

Lemma stream_map_fin_stream {A B: Type}: forall (f: A -> B) (h: stream A),
  is_fin_stream h <-> is_fin_stream (stream_map f h).
Proof.
  intros.
  rewrite !is_fin_stream_spec.
  apply Morphisms_Prop.ex_iff_morphism; intros ?.
  apply stream_map_n_stream; auto.
Qed.

Lemma stream_map_at_least_n_stream {A B: Type}: forall (f: A -> B) (h: stream A) (n: nat),
  is_at_least_n_stream n h <-> is_at_least_n_stream n (stream_map f h).
Proof.
  intros.
  rewrite !at_least_n_stream_spec.
  apply Morphisms_Prop.or_iff_morphism.
  + apply Morphisms_Prop.ex_iff_morphism; intro.
    apply Morphisms_Prop.and_iff_morphism; [reflexivity |].
    apply stream_map_n_stream; auto.
  + apply stream_map_inf_stream; auto.
Qed.

Lemma stream_map_at_most_n_stream {A B: Type}: forall (f: A -> B) (h: stream A) (n: nat),
  is_at_most_n_stream n h <-> is_at_most_n_stream n (stream_map f h).
Proof.
  intros.
  rewrite !at_most_n_stream_spec.
  apply Morphisms_Prop.ex_iff_morphism; intro.
  apply Morphisms_Prop.and_iff_morphism; [reflexivity |].
  apply stream_map_n_stream; auto.
Qed.

Program Definition fstn_stream {A: Type} (n: nat) (h: stream A) : stream A :=
  fun m => if le_lt_dec n m then None else h m.
Next Obligation.
  destruct (le_lt_dec n x), (le_lt_dec n y); try congruence.
  + lia.
  + apply (stream_sound1 h x y); auto; lia.
Qed.

Definition skipn_stream {A: Type} (n: nat) (h: stream A) : stream A.
  exists (fun m => h (m + n)).
  intros.
  revert H0; apply (stream_sound1 h).
  lia.
Defined.

Lemma fstn_stream_Some {A: Type}: forall n m (h: stream A), m < n -> (fstn_stream n h) m = h m.
Proof.
  intros; simpl.
  destruct (le_lt_dec n m); auto; lia.
Qed.

Lemma fstn_stream_None {A: Type}: forall n m (h: stream A), n <= m -> (fstn_stream n h) m = None.
Proof.
  intros; simpl.
  destruct (le_lt_dec n m); auto; lia.
Qed.

Lemma fstn_stream_is_n_stream {A: Type}: forall n (h: stream A),
  is_at_least_n_stream n h ->
  is_n_stream n (fstn_stream n h).
Proof.
  intros.
  hnf in H.
  split.
  + rewrite fstn_stream_None by auto; auto.
  + intros.
    rewrite fstn_stream_Some by lia.
    apply H; lia.
Qed.

Lemma fstn_stream_eq {A: Type}: forall n (h: stream A),
  is_at_most_n_stream n h ->
  fstn_stream n h = h.
Proof.
  intros.
  hnf in H.
  stream_extensionality m.
  destruct (lt_dec m n).
  + rewrite fstn_stream_Some by lia; auto.
  + rewrite fstn_stream_None by lia.
    symmetry.
    apply (stream_sound1 h n m); auto; lia.
Qed.

Lemma fstn_stream_is_fin_stream {A: Type}: forall n (h: stream A),
  is_fin_stream (fstn_stream n h).
Proof.
  intros.
  destruct (at_most_n_stream_or_at_least_Sn_stream h n).
  + rewrite fstn_stream_eq by auto.
    eapply at_most_n_stream_is_fin_stream; eauto.
  + eapply at_most_n_stream_is_fin_stream.
    apply fstn_stream_is_n_stream.
    eapply at_least_n_stream_mono; [| eauto].
    lia.
Qed.

(*
Lemma fstn_stream_is_n_stream_inf {A: Type}: forall m (h: stream A),
  is_inf_stream h ->
  is_n_stream m (fstn_stream m h).
Proof.
  intros.
  split.
  + rewrite fstn_stream_None by auto; auto.
  + intros.
    rewrite fstn_stream_Some by lia.
    apply H.
Qed.

Lemma fstn_stream_is_n_stream' {A: Type}: forall n m (h: stream A),
  n <= m ->
  is_n_stream n h ->
  is_n_stream n (fstn_stream m h).
Proof.
  intros.
  destruct H0.
  split.
  + destruct (lt_dec n m).
    - rewrite fstn_stream_Some by auto; auto.
    - rewrite fstn_stream_None by lia; auto.
  + intros.
    rewrite fstn_stream_Some by lia.
    apply H1; lia.
Qed.
*)
Lemma skipn_stream_spec {A: Type}: forall n m (h: stream A), (skipn_stream n h) m = h (m + n).
Proof.
  intros; simpl.
  auto.
Qed.

Lemma skipn_stream_empty {A: Type}: forall n (h: stream A),
  is_at_most_n_stream n h ->
  skipn_stream n h = empty_stream.
Proof.
  intros.
  stream_extensionality m.
  rewrite skipn_stream_spec.
  hnf in H.
  rewrite (stream_sound1 h n (m + n)) by (auto; lia).
  rewrite empty_stream_spec.
  auto.
Qed.

Definition partial_stream_len {A: Type} (h: stream A) (n: nat): option nat :=
  match h n with
  | Some _ => None
  | None => Some
    ((fix f (m: nat): nat :=
       match h m with
       | Some _ => S m
       | None => match m with
                 | 0 => 0
                 | S m0 => f m0
                 end
       end) n)
  end.

Lemma partial_stream_len_mono1: forall {A: Type} (h: stream A) (x y: nat), x <= y -> partial_stream_len h y = None -> partial_stream_len h x = None.
Proof.
  intros.
  unfold partial_stream_len in *.
  destruct (h y) eqn:?H; try congruence.
  pose proof (stream_sound2 h x y H) as [? ?]; [eauto |].
  rewrite H2; auto.
Qed.

Lemma partial_stream_len_mono2: forall {A: Type} (h: stream A) (x y n: nat), x <= y -> partial_stream_len h x = Some n -> partial_stream_len h y = Some n.
Proof.
  intros.
  unfold partial_stream_len in *.
  destruct (h x) eqn:?H; try congruence.
  pose proof (stream_sound1 h x y H H1).
  inversion H0.
  rewrite H2, H4; clear H0.
  f_equal.
  revert n H4; induction H; intros; auto.
  pose proof (stream_sound1 h x m H H1).
  specialize (IHle H0 _ H4).
  rewrite IHle; clear IHle.
  rewrite H2; auto.
Qed.

Lemma partial_stream_len_Some {A: Type}: forall (h: stream A) (n m: nat),
  n <= m ->
  is_n_stream n h ->
  partial_stream_len h m = Some n.
Proof.
  intros.
  unfold partial_stream_len.
  destruct H0.
  rewrite (stream_sound1 h n m H) by auto.
  f_equal.
  remember (m - n) as d.
  replace m with (d + n) by lia.
  clear Heqd H m.
  induction d.
  + simpl.
    destruct n; rewrite H0; auto.
    specialize (H1 n (le_n _)).
    destruct (h n) eqn:?H; [| congruence].
    destruct n; rewrite H; auto.
  + simpl.
    rewrite (stream_sound1 h n (S (d + n))) by (auto; lia).
    auto.
Qed.

Lemma partial_stream_len_None {A: Type}: forall (h: stream A) (m: nat),
  is_at_least_n_stream (S m) h ->
  partial_stream_len h m = None.
Proof.
  intros.
  unfold partial_stream_len.
  specialize (H m (le_n _)).
  destruct (h m); auto; congruence.
Qed.

Program Definition stream_app {A: Type} (h1 h2: stream A): stream A :=
  fun n: nat =>
    match partial_stream_len h1 n return option A with
    | None => h1 n
    | Some m => h2 (n - m)
    end.
Next Obligation.
  destruct (partial_stream_len h1 x) eqn:?H.
  + pose proof H1.
    apply (partial_stream_len_mono2 h1 x y n) in H1; [| lia].
    rewrite H1.
    apply (stream_sound1 h2 (x - n) (y - n)); auto.
    lia.
  + unfold partial_stream_len in H1.
    rewrite H0 in H1.
    congruence.
Qed.

Lemma stream_app_spec1 {A: Type}: forall (h1 h2: stream A) (m: nat),
  is_at_least_n_stream (S m) h1 ->
  stream_app h1 h2 m = h1 m.
Proof.
  intros.
  simpl.
  rewrite partial_stream_len_None by auto.
  auto.
Qed.

Lemma stream_app_spec1' {A: Type}: forall (h1 h2: stream A) (m: nat) a,
  h1 m = Some a ->
  stream_app h1 h2 m = Some a.
Proof.
  intros.
  rewrite stream_app_spec1; auto.
  hnf; intros.
  intro.
  rewrite (stream_sound1 h1 n' m) in H by (auto; lia).
  congruence.
Qed.

Lemma stream_app_spec2 {A: Type}: forall (h1 h2: stream A) (n m: nat),
  is_n_stream n h1 ->
  stream_app h1 h2 (m + n) = h2 m.
Proof.
  intros.
  simpl.
  erewrite partial_stream_len_Some; [| | eassumption]; [| lia].
  f_equal; lia.
Qed.

Lemma stream_app_empty_stream {A: Type}: forall (h: stream A),
  stream_app h empty_stream = h.
Proof.
  intros.
  stream_extensionality n.
  destruct (at_most_n_stream_or_at_least_Sn_stream h n).
  + rewrite at_most_n_stream_spec in H.
    destruct H as [m [? ?]].
    replace n with ((n - m) + m) at 1 by lia.
    rewrite (stream_app_spec2 _ _ m) by auto.
    destruct H0.
    rewrite (stream_sound1 h m n) by (auto; lia).
    rewrite empty_stream_spec; auto.
  + apply stream_app_spec1; auto.
Qed.

Lemma stream_app_fstn_skipn {A: Type}: forall (h: stream A) (n: nat),
  stream_app (fstn_stream n h) (skipn_stream n h) = h.
Proof.
  intros.
  destruct (at_most_n_stream_or_at_least_n_stream h n).
  + rewrite fstn_stream_eq by auto.
    rewrite skipn_stream_empty by auto.
    apply stream_app_empty_stream.
  + stream_extensionality m.
    destruct (lt_dec m n).
    - rewrite stream_app_spec1.
      * rewrite fstn_stream_Some by auto.
        auto.
      * apply fstn_stream_is_n_stream in H.
        rewrite at_least_n_stream_spec; left; exists n.
        split; [lia | auto].
    - replace m with ((m - n) + n) at 1 by lia.
      rewrite (stream_app_spec2 _ _ n).
      * rewrite skipn_stream_spec.
        f_equal; lia.
      * apply fstn_stream_is_n_stream; auto.
Qed.

Lemma stream_map_stream_app {A B: Type}: forall (f: A -> B) (h1 h2: stream A),
  stream_map f (stream_app h1 h2) = stream_app (stream_map f h1) (stream_map f h2).
Proof.
  intros.
  stream_extensionality n.
  destruct (at_most_n_stream_or_at_least_Sn_stream h1 n).
  + rewrite at_most_n_stream_spec in H.
    destruct H as [m [? ?]].
    replace n with ((n - m) + m) by lia.
    rewrite stream_map_spec.
    rewrite stream_app_spec2 by auto.
    rewrite stream_app_spec2 by (apply stream_map_n_stream; auto).
    rewrite stream_map_spec.
    reflexivity.
  + rewrite stream_app_spec1 by (apply stream_map_at_least_n_stream; auto).
    rewrite stream_map_spec.
    rewrite stream_app_spec1 by auto.
    rewrite stream_map_spec.
    auto.
Qed.

Lemma stream_app_fstn_stream {A: Type}: forall (h1 h2: stream A) (n: nat),
  is_n_stream n h1 ->
  fstn_stream n (stream_app h1 h2) = h1.
Proof.
  intros.
  stream_extensionality m.
  destruct (lt_dec m n).
  + rewrite fstn_stream_Some by auto.
    rewrite stream_app_spec1; auto.
    rewrite at_least_n_stream_spec; left; exists n.
    split; [lia | auto].
  + rewrite fstn_stream_None by lia.
    destruct H as [? _].
    rewrite (stream_sound1 h1 n m) by (auto; lia).
    auto.
Qed.

Lemma stream_app_skipn_stream {A: Type}: forall (h1 h2: stream A) (n: nat),
  is_n_stream n h1 ->
  skipn_stream n (stream_app h1 h2) = h2.
Proof.
  intros.
  stream_extensionality m.
  rewrite skipn_stream_spec.
  rewrite stream_app_spec2; auto.
Qed.

Fixpoint partial_stream_clen {A: Type} (h: nat -> stream A) (n: nat): nat * nat :=
  match n with
  | 0 => (0, 0)
  | S n => let (k, m) := partial_stream_clen h n in
           match h k (S m) with
           | Some _ => (k, S m)
           | None => (S k, 0)
           end
  end.

Fixpoint partial_stream_clen' {A: Type} (h: nat -> stream A) (n: nat): option (nat * nat) :=
  let (k, m) := partial_stream_clen h n in
  match n with
  | 0 => match h k m with
         | Some _ => Some (k, m)
         | None => None
         end
  | S n => match h k m, partial_stream_clen' h n with
           | Some _, Some _ => Some (k, m)
           | _, _ => None
           end
  end.

Lemma partial_stream_clen'_None_iff {A: Type}: forall (h: nat -> stream A) (n: nat),
  match partial_stream_clen' h n return option A with
  | Some (k, m) => h k m
  | None => None
  end = None <->
  partial_stream_clen' h n = None.
Proof.
  intros.
  induction n.
  + destruct (partial_stream_clen' h 0) as [[? ?] |] eqn:?H; [| tauto].
    simpl in H.
    destruct ((h 0) 0) eqn:?H; [| congruence].
    inversion H; subst.
    rewrite H0.
    split; intro; congruence.
  + Opaque partial_stream_clen.
    simpl.
    Transparent partial_stream_clen.
    destruct (partial_stream_clen h (S n)); auto.
    destruct ((h n0) n1) eqn:?H, (partial_stream_clen' h n); auto; try tauto.
    rewrite H.
    split; intro; congruence.
Qed.

Lemma partial_stream_clen_inf0 {A: Type}: forall (h: nat -> stream A) (n: nat),
  is_inf_stream (h 0) ->
  partial_stream_clen h n = (0, n).
Proof.
  intros.
  induction n.
  + simpl.
    destruct ((h 0) 0) eqn:?H; auto.
  + simpl.
    rewrite IHn.
    destruct ((h 0) (S n)) eqn:?H; auto.
    specialize (H (S n)); congruence.
Qed.

Lemma partial_stream_clen'_inf0 {A: Type}: forall (h: nat -> stream A) (n: nat),
  is_inf_stream (h 0) ->
  partial_stream_clen' h n = Some (0, n).
Proof.
Opaque partial_stream_clen.
  intros.
  induction n.
  + simpl.
    rewrite partial_stream_clen_inf0 by auto.
    destruct ((h 0) 0) eqn:?H; auto.
    specialize (H 0); congruence.
  + simpl.
    rewrite partial_stream_clen_inf0 by auto.
    rewrite IHn.
    destruct ((h 0) (S n)) eqn:?H; auto.
    specialize (H (S n)); congruence.
Transparent partial_stream_clen.
Qed.

Lemma partial_stream_clen_fin0_left {A: Type}: forall (h: nat -> stream A) (n m: nat),
  n < m ->
  is_n_stream m (h 0) ->
  partial_stream_clen h n = (0, n).
Proof.
  intros.
  revert m H0 H; induction n; intros.
  + simpl.
    destruct ((h 0) 0) eqn:?H; auto.
  + destruct m; [lia |].
    simpl.
    rewrite (IHn (S m)) by (auto; lia).
    destruct ((h 0) (S n)) eqn:?H; auto.
    pose proof (proj2 H0 (S n) H).
    congruence.
Qed.

Lemma partial_stream_clen'_fin0_left {A: Type}: forall (h: nat -> stream A) (n m: nat),
  n < m ->
  is_n_stream m (h 0) ->
  partial_stream_clen' h n = Some (0, n).
Proof.
Opaque partial_stream_clen.
  intros.
  revert m H0 H; induction n; intros.
  + simpl.
    rewrite (partial_stream_clen_fin0_left _ _ m) by auto.
    destruct ((h 0) 0) eqn:?H; auto.
    pose proof (proj2 H0 0 H); congruence.
  + destruct m; [lia |].
    simpl.
    rewrite (partial_stream_clen_fin0_left _ _ (S m)) by auto.
    rewrite (IHn (S m) H0) by lia.
    destruct ((h 0) (S n)) eqn:?H; auto.
    pose proof (proj2 H0 (S n) H); congruence.
Transparent partial_stream_clen.
Qed.

Lemma partial_stream_clen'_left {A: Type}: forall (h: nat -> stream A) (n: nat),
  is_at_least_n_stream (S n) (h 0) ->
  partial_stream_clen' h n = Some (0, n).
Proof.
  intros.
  rewrite at_least_n_stream_spec in H.
  destruct H as [[m [? ?]] |].
  + eapply partial_stream_clen'_fin0_left; eauto.
  + apply partial_stream_clen'_inf0; auto.
Qed.

Lemma partial_stream_clen_fin0_right {A: Type}: forall (h: nat -> stream A) (n m: nat),
  n > 0 ->
  is_n_stream n (h 0) ->
  partial_stream_clen h (m + n) =
  match partial_stream_clen (fun k => h (S k)) m with
  | (k1, k2) => (S k1, k2)
  end.
Proof.
  intros.
  destruct n; [lia |].
  induction m.
  + simpl.
    rewrite (partial_stream_clen_fin0_left _ _ (S n)) by (auto; lia).
    rewrite (proj1 H0).
    auto.
  + simpl.
    rewrite IHm.
    destruct (partial_stream_clen (fun k : nat => h (S k)) m).
    destruct ((h (S n0)) (S n1)); auto.
Qed.

Lemma partial_stream_clen'_fin0_right {A: Type}: forall (h: nat -> stream A) (n m: nat),
  n > 0 ->
  is_n_stream n (h 0) ->
  partial_stream_clen' h (m + n) =
  match partial_stream_clen' (fun k => h (S k)) m with
  | Some (k1, k2) => Some (S k1, k2)
  | None => None
  end.
Proof.
Opaque partial_stream_clen.
  intros.
  destruct n; [lia |].
  induction m.
  + simpl.
    change (partial_stream_clen h (S n)) with (partial_stream_clen h (0 + S n)).
    rewrite (partial_stream_clen_fin0_right _ _ 0) by (auto; lia).
    rewrite (partial_stream_clen'_fin0_left _ _ (S n)) by (auto; lia).
    destruct (partial_stream_clen (fun k : nat => h (S k)) 0).
    destruct ((h (S n0)) n1); auto.
  + simpl.
    change (partial_stream_clen h (S (m + S n))) with (partial_stream_clen h (S m + S n)).
    rewrite (partial_stream_clen_fin0_right _ _ (S m)) by (auto; lia).
    rewrite IHm.
    destruct (partial_stream_clen (fun k : nat => h (S k)) (S m)); auto.
    destruct ((h (S n0)) n1); auto.
    destruct (partial_stream_clen' (fun k : nat => h (S k)) m) as [[? ?] |]; auto.
Transparent partial_stream_clen.
Qed.

Program Definition stream_capp {A: Type} (h: nat -> stream A): stream A :=
  fun n: nat =>
    match partial_stream_clen' h n return option A with
    | Some (k, m) => h k m
    | None => None
    end.
Next Obligation.
  assert (x <= y) by lia; clear H.
  rewrite partial_stream_clen'_None_iff in H0 |- *.
  induction H1; auto.
  clear H0 H1 x.
  Opaque partial_stream_clen.
  simpl.
  Transparent partial_stream_clen.
  destruct (partial_stream_clen h (S m)) as [k n].
  rewrite IHle.
  destruct (h k n); auto.
Qed.

Lemma stream_capp_spec1 {A: Type}: forall (h: nat -> stream A) (m: nat),
  is_at_least_n_stream (S m) (h 0) ->
  stream_capp h m = h 0 m.
Proof.
  intros.
  simpl.
  rewrite partial_stream_clen'_left by auto.
  auto.
Qed.

Lemma stream_capp_spec1' {A: Type}: forall (h: nat -> stream A) (m: nat) a,
  h 0 m = Some a ->
  stream_capp h m = Some a.
Proof.
  intros.
  rewrite stream_capp_spec1; auto.
  hnf; intros.
  intro.
  rewrite (stream_sound1 (h 0) n' m) in H by (auto; lia).
  congruence.
Qed.

Lemma stream_capp_spec2 {A: Type}: forall (h: nat -> stream A) (n m: nat),
  n > 0 ->
  is_n_stream n (h 0) ->
  stream_capp h (m + n) = stream_capp (fun n => h (S n)) m.
Proof.
  intros.
  simpl.
  rewrite (partial_stream_clen'_fin0_right _ _ m H H0).
  destruct (partial_stream_clen' (fun n0 : nat => h (S n0)) m) as [[? ?] |]; auto.
Qed.

Lemma stream_capp_empty0 {A: Type}: forall (h: nat -> stream A),
  is_empty_stream (h 0) ->
  is_empty_stream (stream_capp h).
Proof.
  intros.
  split; [| intros; lia].
  simpl.
  destruct H as [? _].
  rewrite H.
  auto.
Qed.

Lemma stream_capp_cons {A: Type}: forall (h: nat -> stream A),
  ~ is_empty_stream (h 0) ->
  stream_capp h = stream_app (h 0) (stream_capp (fun n => h (S n))).
Proof.
  intros.
  stream_extensionality m.
  destruct (at_most_n_stream_or_at_least_Sn_stream (h 0) m).
  + rewrite at_most_n_stream_spec in H0.
    destruct H0 as [n [? ?]].
    replace m with (m - n + n) by lia.
    rewrite stream_capp_spec2;
      [| destruct (Nat.eq_dec n 0); [subst; tauto | lia] | auto].
    rewrite stream_app_spec2 by auto.
    auto.
  + rewrite stream_capp_spec1 by auto.
    rewrite stream_app_spec1 by auto.
    auto.
Qed.

Lemma stream_map_stream_capp {A B: Type}: forall (f: A -> B) (h: nat -> stream A),
  stream_map f (stream_capp h) = stream_capp (fun n => stream_map f (h n)).
Proof.
  intros.
  stream_extensionality n.
  revert h; strong_induction n.
  intros.

  destruct (classic (is_empty_stream (h 0))).
  {
    clear IH.
    pose proof proj1 (stream_map_n_stream f (h 0) 0) H.
    apply stream_capp_empty0 in H.
    apply (stream_map_n_stream f) in H.
    apply (stream_capp_empty0 (fun n : nat => stream_map f (h n))) in H0.
    destruct H as [H _], H0 as [H0 _].
    rewrite (stream_sound1 _ 0 n) by (auto; lia).
    rewrite (stream_sound1 _ 0 n) by (auto; lia).
    reflexivity.
  }

  destruct (at_most_n_stream_or_at_least_Sn_stream (h 0) n).
  + rewrite at_most_n_stream_spec in H0.
    destruct H0 as [m [? ?]].
    replace n with (n - m + m) by lia.
    rewrite stream_capp_spec2;
      [| destruct (Nat.eq_dec m 0); [subst; tauto | lia]
       | apply stream_map_n_stream; auto].
    rewrite stream_capp_cons by auto.
    rewrite stream_map_stream_app.
    rewrite stream_app_spec2 by (apply stream_map_n_stream; auto).
    apply IH.
    destruct (Nat.eq_dec m 0); [| lia].
    subst; tauto.
  + rewrite stream_capp_cons by auto.
    rewrite stream_capp_spec1 by (apply stream_map_at_least_n_stream; auto).
    rewrite stream_map_stream_app.
    rewrite stream_app_spec1 by (apply stream_map_at_least_n_stream; auto).
    auto.
Qed.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Export XPath.
Require Export XPathInduction.
Require Import XPathGrammar.

(* simple test to determine if a path is absolute or relative *)
(* it is relative if the result depends from the contextual node, absolute otherwise *)
(* note that this definition justifies considering ⊥ as an absolute path, just as  ⋀ *)
(* this is also required for consistency .... as shown by  ⋀/a ∩ ⋀/b which must be *)
(* considered as abolute whereas equivalent to ⊥ *)
(* one can consider it extends the usual "semantics" of absolute path, understood as *)
(* "a path starting from the root node" *)
(* JYVD , 07/19/2004 *)
Fixpoint absolute (p:XPath) : Prop :=
  match p with
  | ⊥ => True
  | ⋀ => True
  | p1 ⎮ p2 => absolute p1 /\ absolute p2
  | inter p1 p2 => absolute p1 /\ absolute p2
  | slash p1 p2 => absolute p1
  | qualif p  q  => absolute p
  | step a n => False
  end
.

Theorem absolute_decidable: forall p:XPath, (absolute p) \/ ~(absolute p).
induction p.
left;simpl;trivial.
left;simpl;trivial.
simpl.
elim IHp1;elim IHp2;intros.
left;split;trivial.
right;intro;elim H1;intros H2 H3;apply H;exact H3.
right;intro;elim H1;intros H2 H3;apply H0;exact H2.
right;intro;elim H1;intros H2 H3;apply H0;exact H2.

simpl.
elim IHp1;elim IHp2;intros.
left;split;trivial.
right;intro;elim H1;intros H2 H3;apply H;exact H3.
right;intro;elim H1;intros H2 H3;apply H0;exact H2.
right;intro;elim H1;intros H2 H3;apply H0;exact H2.

simpl;exact IHp1.
simpl;exact IHp.
simpl;right;intro H;trivial.
Qed.

(*
Fixpoint inter_axis (a1 a2:Axis) {a1: struct} : (Option Axis) :=

Fixpoint inter_comp (p1 p2:XPath) {struct:p1} : XPath :=
match p1,p2 with
| void, _ => void
| _,void  => void
| top, top => top
| (step a1 n1), (step a2 n2) =>
	match (inter_axis n1 n2) with
        | (Some a) => match (inter_ntest n1 n2) with
                              | (Some n) => (step a n)
                              | _ => void
                              end
         | _ => void
         end
| (slash p1 (step child n1)), (slash p2 (step descendant n2)) =>
       match (inter_ntest n1 n2) with
       | (Some n) => (slash (inter_comp p1 p2) (step a n))
       | _ => void
       end
end
.
*)

Inductive Pequiv: XPath -> XPath -> Prop :=

  | equ_qual:
      forall p: XPath,
      Pequiv p (p[_true])
  | equ_void_qual_L:
      forall q : XQualif,
      Pequiv (⊥[q]) (⊥)
  | equ_void_qual_R:
      forall p: XPath,
      Pequiv (p[_false]) (⊥)
  | equ_void_slash_L:
      forall p: XPath,
      Pequiv (⊥/p) (⊥)
  | equ_void_slash_R:
      forall p: XPath,
      Pequiv (p/⊥) (⊥)

  | equ_self_slash_L: forall p:XPath, Pequiv p (∙/p)
  | equ_self_slash_R: forall p:XPath, Pequiv p (p/∙)
  | equ_top_slash:
      forall p:XPath,
      (absolute p) -> Pequiv (p/⋀) (⋀[# p])
  | equ_top_qualif_top:
      forall p:XPath,
      Pequiv (p[# ⋀]) p

  (* commutativity *)
  | comm_union:  forall p1 p2 : XPath,  Pequiv (p1 ⎮ p2) (p2 ⎮ p1)
  | comm_inter:  forall p1 p2 : XPath,  Pequiv (p1 ∩ p2) (p2 ∩ p1)

  (* associativity *)
  | assoc_slash:
      forall p1 p2 p3 : XPath,
      Pequiv ((p1/p2)/p3) (p1/(p2/p3))
  | assoc_union:
      forall p1 p2 p3 : XPath,
      Pequiv ( ( p1 ⎮ p2) ⎮ p3) ( p1 ⎮ ( p2 ⎮p3))
  | assoc_inter:
      forall p1 p2 p3 : XPath,
      Pequiv ((p1 ∩ p2) ∩ p3) (p1 ∩ (p2 ∩ p3))
  | assoc_qual:
      forall p : XPath,
      forall q1 q2 : XQualif,
      Pequiv (p[q1][q2])  (p[q1 and q2])
(*      Pequiv (qualif (qualif p q1) q2) (qualif p (and q1 q2)) *)

  (* structural congruence *)

  | equ_s_slash_L: forall p1 p2 p3:XPath,
    Pequiv p1 p2 -> Pequiv (p1/p3) (p2/p3)
  | equ_s_slash_R: forall p1 p2 p3:XPath,
    Pequiv p1 p2 -> Pequiv (p3/p1) (p3/p2)

  | equ_s_union_L: forall p1 p2 p3:XPath,
    Pequiv p1 p2 -> Pequiv ( p1 ⎮ p3) ( p2 ⎮ p3)
  | equ_s_union_R: forall p1 p2 p3:XPath,
    Pequiv p1 p2 -> Pequiv ( p3 ⎮ p1) ( p3 ⎮ p2)

  | equ_s_inter_L: forall p1 p2 p3:XPath,
    Pequiv p1 p2 -> Pequiv (p1 ∩ p3) (p2 ∩ p3)
  | equ_s_inter_R: forall p1 p2 p3:XPath,
    Pequiv p1 p2 -> Pequiv ( p3 ∩ p1) ( p3 ∩ p2)

  | equ_s_qualif_L:
      forall p1 p2:XPath,
      forall q:XQualif,
      Pequiv p1 p2 ->
      Pequiv (p1[q]) (p2[q])

  | equ_s_qualif_R:
      forall p:XPath,
      forall q1 q2:XQualif,
      Qequiv q1 q2 ->
      Pequiv (p[q1]) (p[q2])

  (* distribution *)
  | equ_d_slash_union_L:
      forall p1 p2 p:XPath,
      Pequiv ((p1 ⎮ p2)/p) ( (p1/p) ⎮ (p2/p))
  | equ_d_slash_union_R:
      forall p1 p2 p:XPath,
      Pequiv (p/(p1 ⎮ p2)) ((p/p1) ⎮ (p/p2))
  | equ_d_inter_union_L:
      forall p1 p2 p:XPath,
      Pequiv ( (p1 ⎮ p2) ∩ p) (( p1 ∩ p) ⎮ ( p2 ∩ p))
  | equ_d_inter_union_R:
      forall p1 p2 p:XPath,
      Pequiv ( p ∩ (p1 ⎮ p2)) (( p ∩ p1) ⎮ ( p ∩ p2))

with Preduce:  XPath -> XPath -> Prop :=
  | red_d_slash_inter_L:
      forall p1 p2 p:XPath,
      Preduce ((p1 ∩ p2)/p) ( (p1/p)  ∩ (p2/p))
  | red_d_slash_inter_R:
      forall p1 p2 p:XPath,
      Preduce (p/(p1 ∩ p2)) ((p/p1) ∩ (p/p2))
   | red_gen:
      forall p1 p2 :XPath,
      (Pequiv p1 p2) -> (Preduce p1 p2)

with Qequiv:  XQualif -> XQualif -> Prop :=

  (* computation like *)
  | equ_or_false_L:
      forall q : XQualif,
      Qequiv (q or _false) q
  | equ_or_false_R:
      forall q : XQualif,
      Qequiv (_false or q) q
  | equ_or_true_L:
      forall q : XQualif,
      Qequiv (q or _true) _true
  | equ_or_true_R:
      forall q : XQualif,
      Qequiv (_true or q) _true
  | equ_not_true:  Qequiv (not _true) _false
  | equ_not_false: Qequiv (not _false) _true

  | equ_and_true_L:
      forall q : XQualif,
      Qequiv (q and _true) q
  | equ_and_true_R:
      forall q : XQualif,
      Qequiv (_true and q) q
  | equ_and_false_L:
      forall q : XQualif,
      Qequiv (q and _false) _false
  | equ_and_false_R:
      forall q : XQualif,
      Qequiv (_false and q) _false

  | equ_not_not:
      forall q: XQualif,
      Qequiv (not (not q)) q

  | equ_not_or:
      forall q1 q2: XQualif,
      Qequiv (not (q1 or q2)) ((not q1) and (not q2) )

  (* commutativity *)
  | comm_and:  forall q1 q2 : XQualif,  Qequiv (q1 and q2) (q2 and q1)
  | comm_or:   forall q1 q2 : XQualif,  Qequiv (q1 or q2) (q2 or q1)

  (* associativity *)
  | assoc_and:
      forall q1 q2 q3 : XQualif,
      Qequiv ((q1 and q2) and q3) (q1 and (q2 and q3))
  | assoc_or:
      forall q1 q2 q3 : XQualif,
      Qequiv ((q1 or q2) or q3) (q1 or (q2 or q3))

  (* structural congruence *)

  | equ_s_and_L: forall q1 q2 q3:XQualif,
    Qequiv q1 q2 -> Qequiv (q1 and q3) (q2 and q3)
  | equ_s_and_R: forall q1 q2 q3:XQualif,
    Qequiv q1 q2 -> Qequiv (q3 and q1) (q3 and q2)

  | equ_s_or_L: forall q1 q2 q3:XQualif,
    Qequiv q1 q2 -> Qequiv (q1 or q3) (q2 or q3)
  | equ_s_or_R: forall q1 q2 q3:XQualif,
    Qequiv q1 q2 -> Qequiv (q3 or q1) (q3 or q2)

  | equ_s_not: forall q1 q2:XQualif,
    Qequiv q1 q2 -> Qequiv (not q1) (not q2)

  | equ_s_leq_L:
      forall p1 p2 p3:XPath,
      Pequiv p1 p2 ->
      Qequiv (p1 ⊑ p3) (p2 ⊑ p3)
  | equ_s_leq_R:
      forall p1 p2 p3:XPath,
      Pequiv p2 p3 ->
      Qequiv (p1 ⊑ p2) (p1 ⊑ p3)
 .

Notation "p1 ⇽⇾ p2" := (Pequiv p1 p2) (at level 90, no associativity) : Xrel.
Notation "p1 ⇾ p2" := (Preduce p1 p2) (at level 90, no associativity) : Xrel.
Notation "q1 ⇐⇒ q2" := (Qequiv q1 q2) (at level 90, no associativity) : Xrel.

Require Import XPathSemantics.
Require Import XPathSemanticsEquivalences.

Open Scope Xrel.

(* Pequiv and Qequiv must be equivalence relations *)
Axiom Pequiv_reflexive: forall p:XPath, (p ⇽⇾ p).
Axiom Qequiv_reflexive: forall q:XQualif,  q ⇐⇒ q.

Axiom Pequiv_symmetric: forall p1 p2:XPath, (p1 ⇽⇾ p2) = (p2 ⇽⇾ p1).
Axiom Qequiv_symmetric: forall q1 q2:XQualif, (q1 ⇐⇒ q2)=(q2 ⇐⇒ q1).

Axiom Pequiv_transitive: forall p1 p2 p3:XPath, p1 ⇽⇾ p2 -> p2 ⇽⇾ p3 -> p1 ⇽⇾ p3.
Axiom Qequiv_transitive: forall q1 q2 q3:XQualif, q1 ⇐⇒ q2 -> q2 ⇐⇒ q3 -> q1 ⇐⇒ q3.

(*
Ltac solvePEqu :=
  match goal with
  (Pequiv ?p1 (slash dot ?p2)) => apply
  (Pequiv ?p1 ?p2) => constructor
  end
  with
  solveQequ :=
  match goal with
  end
  .
*)
 (* Open Scope Xp.
Open Scope Xq. *)


Require Import Basics Types MyLemmas Diagram Colimit MyTacs HIT.Truncations.

Section TruncatedColimit.

  Definition is_m_universal (m:trunc_index) {G: graph} {D: diagram G} {X:Type} (C: cocone D X)
    := forall (Y: TruncType m), IsEquiv (@postcompose_cocone G D X C Y).

  Record is_m_colimit (m:trunc_index) {G: graph} (D: diagram G) (Q: Type) :=
    {is_m_colimit_C :> cocone D Q;
     is_m_colimit_H : is_m_universal m is_m_colimit_C}.

  Variable (G:graph). Variable (D:diagram G).
  Variable (Q:Type).
  Variable (ColimQ : is_colimit D Q).
  Variable (m:trunc_index).

  Definition tr_diagram : diagram G.
  Proof.
    simple refine (Build_diagram _ _ _).
    - intro i; exact (Trunc m (D i)).
    - intros i j f. cbn. simple refine (Trunc_rec _). intro x. exact (tr (diagram1 D f x)).
  Defined.

  Definition tr_cocone : cocone tr_diagram (Trunc m Q).
  Proof.
    simple refine (Build_cocone _ _).
    - intro i. simple refine (Trunc_rec _). intro x. apply tr.
      exact (ColimQ i x).
    - intros i j f. simple refine (Trunc_ind _ _).
      intro a. cbn. apply ap. exact (qq ColimQ i j f a).
  Defined.

  Lemma tr_cocone_to_cocone {X:TruncType m} (C: cocone tr_diagram X)
    : cocone D X.
  Proof.
    simple refine (Build_cocone _ _).
    - intros i x. exact (C i (tr x)).
    - intros i j g x. cbn. exact (qq C i j g (tr x)).
  Defined.

  Lemma cocone_to_tr_cocone {X:TruncType m} (C: cocone D X)
    : cocone (tr_diagram) X.
  Proof.
    simple refine (Build_cocone _ _).
    - intro i. simple refine (Trunc_rec _). intro x.
      exact (C i x).
    - intros i j g. simple refine (Trunc_ind _ _).
      intro a; exact (qq C i j g a).
  Defined.

  Lemma cocone_eq_tr_cocone {X:TruncType m}
    : cocone D X <~> cocone (tr_diagram) X.
  Proof.
    simple refine (equiv_adjointify (cocone_to_tr_cocone) (tr_cocone_to_cocone) _ _).
    - intro C. simple refine (path_cocone _ _).
      intros i. simple refine (Trunc_ind _ _).
      intro a. reflexivity.
      intros i j g. simple refine (Trunc_ind _ _).
      intro a. cbn. rewrite concat_1p; rewrite concat_p1. reflexivity.
    - intro C. simple refine (path_cocone _ _).
      intros i x. reflexivity.
      intros i j g x. cbn.
      rewrite concat_1p; rewrite concat_p1. reflexivity.
  Defined.

  (* The following diagram commute :  *)
  (* ||Q|| -> X -----> cocone ||D|| X *)
  (*       |                 ^        *)
  (*       |                 |        *)
  (*       v                 |        *)
  (*    Q -> X  -----> cocone D X     *)
  (*                                  *)

  Lemma compose_cocone_m_cocone {X:TruncType m}
    : cocone_to_tr_cocone o (@postcompose_cocone _ D Q ColimQ X) o (λ f:Trunc m Q -> X, (λ x, (f (tr x))) : Q -> X)
      = @postcompose_cocone _ tr_diagram (Trunc m Q) tr_cocone X.
  Proof.
    cbn.
    apply path_forall; intro f.
    simple refine (path_cocone _ _).
    - intros i; simple refine (Trunc_ind _ _).
      intro a; reflexivity.
    - intros i j g; simple refine (Trunc_ind _ _).
      intro a; cbn. rewrite concat_p1; rewrite concat_1p.
      rewrite ap_compose. reflexivity.
  Defined.

  Lemma tr_colimit : is_m_colimit m (tr_diagram) (Trunc m Q).
  Proof.
    simple refine (Build_is_m_colimit _ _ _ _ tr_cocone _).
    intro X.
    simple refine (isequiv_adjointify _ _ _).
    - intro C. simple refine (Trunc_rec _).
      apply (equiv_inv _ (IsEquiv := is_colimit_H ColimQ X) (tr_cocone_to_cocone C)).
    - intro C.
      rewrite <- compose_cocone_m_cocone; cbn.
      rewrite eisretr.
      exact (eisretr _ (IsEquiv := equiv_isequiv (cocone_eq_tr_cocone (X:=X))) C).
    - intro C.
      rewrite <- compose_cocone_m_cocone.
      pose (r := eissect _ (IsEquiv := equiv_isequiv (cocone_eq_tr_cocone (X:=X))) (postcompose_cocone ColimQ (λ x : Q, C (tr x)))); cbn in r; rewrite r; clear r.
      rewrite eissect.
      apply path_forall; simple refine (Trunc_ind _ _).
      intro a; reflexivity.
  Defined.

End TruncatedColimit.


Require Import Bool.
Require Import List.
Require Import Omega.
Require Import Classical.
Require Import FinFun.
Require Import FunctionalExtensionality.

From mathcomp
Require Import ssreflect.

Require Import Utility.
Require Import Cell.
Require Import Concentric.
Require Import Tactic.

Import ListNotations.

Section Rotation.
  Open Scope Z_scope.
  Open Scope list_scope.

  Definition rotate (p : Z * Z) : Z * Z := mat_mul mat2_pi_over_2 p.

  Definition rotate' (p : Z * Z) : Z * Z := mat_mul mat2_pi_over_2' p.

  Definition rotate_st (st : State) : State :=
    fun (x y : Z) => let (x', y') := rotate (x, y) in st x' y'.

  Definition rotate_st' (st : State) : State :=
    fun (x y : Z) => let (x', y') := rotate' (x, y) in st x' y'.

  CoFixpoint rotate_run (r : Run) : Run :=
    RCons (rotate_st (hd r)) (rotate_run (tl r)).

  Lemma rot_reduction (st : State) (x y : Z)
    : rotate_st st x y = st y (-x).
  Proof.
    rewrite /rotate_st/rotate/mat_mul/mat2_pi_over_2/nth/fst/snd.
    repeat rewrite Z.mul_0_l.
    rewrite Z.mul_1_l.
    rewrite Z.add_0_l.
    rewrite Z.add_0_r.
    rewrite (Z.mul_opp_l 1 x).
    rewrite Z.mul_1_l.
    by [].
  Qed.

  Lemma rotation_is_bijective : Bijective rotate_st.
  Proof.
    rewrite /Bijective.
    exists rotate_st'.
    split.
    -move=> st.
      have s0: rotate_st st = fun (x y : Z) => st y (-x).
      rewrite /rotate_st/rotate/mat_mul/mat2_pi_over_2/nth/fst/snd.
      apply functional_extensionality.
      move=> x.
      apply functional_extensionality.
      move=> y.
      repeat rewrite Z.mul_0_l.
      rewrite Z.mul_1_l.
      rewrite Z.add_0_l.
      rewrite Z.add_0_r.
      rewrite (Z.mul_opp_l 1 x).
      by rewrite Z.mul_1_l.
      rewrite s0.
      rewrite /rotate_st'/rotate'/mat_mul/mat2_pi_over_2'/nth/fst/snd.
      apply functional_extensionality.
      move=> x.
      apply functional_extensionality.
      move=> y.
      rewrite Z.add_0_l.
      rewrite Z.add_0_r.
      rewrite (Z.mul_opp_l 1 y).
      rewrite Z.opp_involutive.
      by repeat rewrite Z.mul_1_l.
    -move=> st.
      have s0: rotate_st' st = fun (x y : Z) => st (-y) x.
      rewrite /rotate_st'/rotate'/mat_mul/mat2_pi_over_2'/nth/fst/snd.
      apply functional_extensionality.
      move=> x.
      apply functional_extensionality.
      move=> y.
      repeat rewrite Z.mul_0_l.
      rewrite Z.mul_1_l.
      rewrite Z.add_0_l.
      rewrite Z.add_0_r.
      rewrite -(Zopp_mult_distr_l 1 y).
      by rewrite Z.mul_1_l.
      rewrite s0.
      rewrite /rotate_st/rotate/mat_mul/mat2_pi_over_2/nth/fst/snd.
      apply functional_extensionality.
      move=> x.
      apply functional_extensionality.
      move=> y.
      rewrite Z.mul_1_l.
      rewrite Z.add_0_l.
      rewrite Z.add_0_r.
      rewrite -(Zopp_mult_distr_l 1 x).
      rewrite Z.opp_involutive.
      by repeat rewrite Z.mul_1_l.
  Qed.

  Lemma convert_inclusion (c : CellState) (st : State) (x y : Z)
    : In c [st y (- x + 1); st y (- x - 1); st (y - 1) (- x); st (y + 1) (- x)] <-> In c [st (y - 1) (- x); st (y + 1) (- x); st y (- x - 1); st y (- x + 1)].
  Proof.
    split.
    -move=> s0.
      case: s0 => [ s0 | s0 ].
      right. right. right. by left.
      case: s0 => [ s0 | s0 ].
      right. right. by left.
      case: s0 => [ s0 | s0 ].
      by left.
      case: s0 => [ s0 | s0 ].
      right. by left.
      case: s0.
    -move=> s0.
      case: s0 => [ s0 | s0 ].
      right. right. by left.
      case: s0 => [ s0 | s0 ].
      right. right. right. by left.
      case: s0 => [ s0 | s0 ].
      right. by left.
      case: s0 => [ s0 | s0 ].
      by left.
      case: s0.
  Qed.

  Lemma convert_inclusion2 (c : CellState) (st : State) (x y : Z)
    : In c [st x (y + 1); st x (y - 1); st (x - 1) y; st (x + 1) y]
    <-> In c [st (x - 1) y; st (x + 1) y; st x (y - 1); st x (y + 1)].
  Proof.
    split.
    -move=> s0.
      case: s0 => [ s0 | s0 ].
      right. right. right. by left.
      case: s0 => [ s0 | s0 ].
      right. right. by left.
      case: s0 => [ s0 | s0 ].
      by left.
      case: s0 => [ s0 | s0 ].
      right. by left.
      case: s0.
    -move=> s0.
      case: s0 => [ s0 | s0 ].
      right. right. by left.
      case: s0 => [ s0 | s0 ].
      right. right. right. by left.
      case: s0 => [ s0 | s0 ].
      right. by left.
      case: s0 => [ s0 | s0 ].
      by left.
      case: s0.
  Qed.

  Theorem trans_preservation_at_rot (st st' : State)
    : trans st st' <-> trans (rotate_st st) (rotate_st st').
  Proof.
    split.
    -move=> tr.
      rewrite /trans in tr.
      move=> x y.
      specialize (tr y (-x)).
      case: tr => [ s0 | ctrans ].
      +left.
        rewrite /rotate_st/rotate/mat_mul/mat2_pi_over_2/nth/fst/snd.
        repeat rewrite Z.mul_0_l.
        rewrite Z.mul_1_l.
        rewrite Z.add_0_l.
        rewrite Z.add_0_r.
        rewrite (Z.mul_opp_l 1 x).
        by rewrite Z.mul_1_l.
      +right.
        rewrite /rule_existence.
        rewrite rot_reduction.
        rewrite (rot_reduction st (x - 1) y).
        rewrite Z.opp_sub_distr.
        rewrite (rot_reduction st (x + 1) y).
        have s0: -(x + 1) = -x - 1. by omega. rewrite s0. clear s0.
        rewrite (rot_reduction st x (y - 1)).
        rewrite (rot_reduction st x (y + 1)).
        rewrite (rot_reduction st').
        remember [st y (- x + 1); st y (- x - 1); st (y - 1) (- x); st (y + 1) (- x)] as nbs.
        destruct_ctrans ctrans.
        *apply convert_inclusion in in0.
          rewrite Heqnbs.
          by constructor.
        *apply convert_inclusion in in0.
          apply (WtoTmp0 nbs alt).
          by subst.
        *apply convert_inclusion in in0.
          apply (WtoTmp1 nbs alt).
          by subst.
        *constructor.
        *constructor.
        *case: in0 => in0 in1.
          apply convert_inclusion in in0.
          apply convert_inclusion in in1.
          apply (TmptoDef0 nbs alt alt' i).
          rewrite Heqnbs.
          by subst.
        *case: in0 => in0 in1.
          apply convert_inclusion in in0.
          apply convert_inclusion in in1.
          apply (TmptoDef1 nbs alt alt' i).
          rewrite Heqnbs.
          by subst.
        *case: in0 => in0 in1.
          apply convert_inclusion in in0.
          apply convert_inclusion in in1.
          apply (TmptoDef2 nbs alt alt' i).
          rewrite Heqnbs.
          by subst.
    -move=> tr.
      rewrite /trans in tr.
      move=> x y.
      specialize (tr (-y) x).
      rewrite /rotate_st/rotate/mat_mul/mat2_pi_over_2/nth/fst/snd in tr.
      rewrite /rule_existence in tr.
      repeat rewrite Z.mul_0_l in tr.
      repeat rewrite Z.mul_1_l in tr.
      repeat rewrite Z.add_0_l in tr.
      repeat rewrite Z.add_0_r in tr.
      rewrite (Z.mul_opp_opp 1 y) in tr.
      rewrite Z.mul_1_l in tr.
      have s0: -1 * (- y - 1) = y + 1. by omega.
      have s1: -1 * (- y + 1) = y - 1. by omega.
      rewrite s0 s1 in tr. clear s0 s1.
      case: tr => [ s0 | ctrans ].
      +by left.
      +right.
        rewrite /rule_existence.
        remember [st (x - 1) y; st (x + 1) y; st x (y - 1); st x (y + 1)] as nbs.
        destruct_ctrans ctrans.
        *apply convert_inclusion2 in in0.
          rewrite Heqnbs.
          by constructor.
        *apply convert_inclusion2 in in0.
          apply (WtoTmp0 nbs alt).
          by subst.
        *apply convert_inclusion2 in in0.
          apply (WtoTmp1 nbs alt).
          by subst.
        *by constructor.
        *by constructor.
        *case: in0 => in0 in1.
          apply convert_inclusion2 in in0.
          apply convert_inclusion2 in in1.
          apply (TmptoDef0 nbs alt alt' i).
          rewrite Heqnbs.
          by subst.
        *case: in0 => in0 in1.
          apply convert_inclusion2 in in0.
          apply convert_inclusion2 in in1.
          apply (TmptoDef1 nbs alt alt' i).
          rewrite Heqnbs.
          by subst.
        *case: in0 => in0 in1.
          apply convert_inclusion2 in in0.
          apply convert_inclusion2 in in1.
          apply (TmptoDef2 nbs alt alt' i).
          rewrite Heqnbs.
          by subst.
  Qed.

  Theorem pred_preservation_at_rot (P : Run -> State -> State -> Prop)
    : (forall (r : Run) (st : State), exists (st' : State),
    P r st st') -> forall (r : Run) (st : State), exists (st' : State),
    P (rotate_run r) (rotate_st st) (rotate_st st').
  Proof.
    move=> s0 r st.
    specialize (s0 (rotate_run r) (rotate_st st)).
    destruct s0.
    move: x H => st' s0.
    move: (rotation_is_bijective) => s1.
    rewrite /Bijective in s1.
    destruct s1.
    move: x H => rot s1.
    case: s1 => s1 s2.
    exists (rot st').
    by rewrite (s2 st').
  Qed.

  Close Scope list_scope.
  Close Scope Z_scope.

End Rotation.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * DiffieHellman.v : An instance of the protocol for proving
 equality of preimages under two special homomorphisms, that proves
 well-formedness of Diffie-Hellman triples *)

Require Import PreimageEq.
Require Import LtIrrelevance.

Set Implicit Arguments.

(** Parameters *)
Module Type DH_PARAMETERS.

 (** A group [H] of prime order [q] with a generator [g] *)
 Declare Module H : GROUP.

 Parameter q : nat -> Z.

 Parameter q_prime : forall k, prime (q k).

 Parameter q_order : forall k, length (H.elems k) = Zabs_nat (q k).

 Parameter g : forall k, H.t k.

 Parameter g_gen : forall k (x:H.t k), exists a, x = H.pow (g k) a.

 Parameter g_order : forall k, H.pow (g k) (Zabs_nat (q k)) = H.e k.

 (** The exponent of the second component of the DH triple *)
 Parameter b : nat -> nat.

End DH_PARAMETERS.

(** The homomorphism, obtained as a composition of homomorphisms
   [phi_1 : Zq -> H, phi_1(x) = g^x] and
   [phi_2 : Zq -> H, phi_2(x) = g^(x.b)]
*)
Module DH_Homomorphism (DHP:DH_PARAMETERS).

 Import DHP.

 Lemma q_pos : forall k, 0 < Zabs_nat (q k).
 Proof.
  intro k.
  assert (H:=prime_ge_2 _ (q_prime k)).
  change 0 with (Zabs_nat 0).
  apply Zabs_nat_lt.
  auto with zarith.
 Qed.

 (** The Zq group *)
 Module Zq <: GROUP.

  Open Scope nat_scope.

  Definition t k := {x : nat | x < Zabs_nat (q k)}.

  (** The group is finite and non-empty *)
  Definition elems_aux n : list {x | x < n} -> list {x | x < S n} :=
   map (fun s : {x | x < n} =>
    match s with
     exist x H => exist (fun x => x < S n) x (le_S (S x) n H)
    end).

  Fixpoint elems' n : list {x | x < n} :=
   match n return list {x | x < n} with
    | O => nil
    | S n0 => exist (fun x => x < S n0) n0 (le_n (S n0)) :: elems_aux (elems' n0)
   end.

  Definition elems k := elems' (Zabs_nat (q k)).

  Lemma elems_not_nil : forall k, elems k <> nil.
  Proof.
   intro k; unfold elems, elems'.
   assert (0 < Zabs_nat (q k)).
   change 0%nat with (Zabs_nat 0).
   apply Zabs_nat_lt.
   generalize (prime_ge_2 _ (q_prime k)).
   auto with zarith.
   induction (Zabs_nat (q k)).
   omega.
   discriminate.
  Qed.

  Lemma elems_full : forall k (x:t k), In x (elems k).
  Proof.
   unfold elems, elems', t; intro k.
   induction (Zabs_nat (q k)); destruct x.
   elimtype False; omega.
   inversion l; subst.
   constructor.
   rewrite (lt_eq l (le_n (S n))); trivial.

   constructor 2.
   rewrite (lt_eq l (le_S (S x) n H0)); clear l.
   assert (H:=IHn (exist _ x H0)); clear IHn.
   apply in_map with (f:=
    (fun s : {x | x < n} =>
     match s with
      exist x H => exist (fun x => x < S n) x (le_S (S x) n H)
     end)) in H.
   trivial.
  Qed.

  Lemma elems_nodup : forall k, NoDup (elems k).
  Proof.
   intro k; unfold elems, elems'.
   induction (Zabs_nat (q k)); constructor.

   clear IHn; intro.
   unfold elems_aux in H.
   rewrite in_map_iff in H; destruct H as [x [H0 H1] ]; destruct x.
   injection H0; intro; subst; clear H0.
   omega.

   apply NoDup_map_inj with (2:=IHn).
   intros x y _ _ H; destruct x; destruct y; inversion H; subst.
   rewrite (lt_eq l l0); trivial.
  Qed.

  (** Equality is decidable *)
  Definition eqb k (x y:t k) :=
   match x, y with
    | exist n _, exist m _ => nat_eqb n m
   end.

  Lemma eqb_spec : forall k (x y:t k), if eqb x y then x = y else x <> y.
  Proof.
   intros k (n,Hn) (m,Hm).
   unfold eqb.
   generalize (nat_eqb_spec n m); case (nat_eqb n m); intro Heq.
   subst; rewrite (lt_eq Hm Hn); trivial.
   intro H; elim Heq; injection H; trivial.
  Qed.

  (** Identity element *)
  Definition e k : t k := exist _ 0 (q_pos k).

  (** Operations: product, inverse *)
  Definition mul : forall k, t k -> t k -> t k.
   intros k (n,Hn) (m,Hm).
   case (le_gt_dec (Zabs_nat (q k)) (n + m)); intro Hlt.
   exists (n + m - (Zabs_nat (q k))); auto with *.
   exists (n + m); exact Hlt.
  Defined.

  Definition inv : forall k, t k -> t k.
   intros k (n,Hn).
   case (eq_nat_dec n 0); intro Heq.
   exists 0; apply q_pos.
   exists (Zabs_nat (q k) - n); auto with *.
  Defined.

  (** Specification *)

  Ltac prove_mul_eq :=
   repeat match goal with
    |- context [le_gt_dec ?x ?y] => case (le_gt_dec x y)
    | _ => intros;
      (elimtype False; omega) ||
      match goal with
       |- exist _ ?a ?Ha = exist _ ?b ?Hb =>
         generalize Ha Hb; assert (H:a = b) by omega; rewrite H;
         intros p1 p2; rewrite (lt_eq p1 p2); trivial
      end
   end.

  Lemma mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
  Proof.
   intros k (n,Hn) (m,Hm) (p,Hp); unfold mul.
   prove_mul_eq.
  Qed.

  Lemma mul_e_l : forall k (x:t k), mul (e k) x = x.
  Proof.
   intros k (n,Hn); unfold e, mul.
   prove_mul_eq.
  Qed.

  Lemma mul_inv_l : forall k (x:t k), mul (inv x) x = e k.
  Proof.
   intros k (n,Hn); unfold e, mul, inv.
   case (eq_nat_dec n 0); intro; subst; prove_mul_eq.
  Qed.

  Lemma mul_comm : forall k (x y:t k), mul x y = mul y x.
  Proof.
   intros k (n,Hn) (m,Hm); unfold mul.
   prove_mul_eq.
  Qed.

  (* Power *)
  Fixpoint pow (k:nat) (x:t k) (n:nat) : t k :=
   match n with
   | O => e k
   | S n => mul x (pow x n)
   end.

  Fixpoint powZ (k:nat) (x:t k) (n:Z) {struct n}: t k :=
   match n with
   | Z0 => pow x 0
   | Zpos p => pow x (nat_of_P p)
   | Zneg p => inv (pow x (nat_of_P p))
   end.

  (* Cost *)
  Definition order_poly : polynomial := H.order_poly.

  Lemma order_size_nat : forall k,
   size_nat (length (elems k)) < peval order_poly k.
  Proof.
   intro k.
   replace (length (elems k)) with (Zabs_nat (q k)).
   rewrite <- q_order.
   apply H.order_size_nat.
   unfold elems; induction (Zabs_nat (q k)).
   trivial.
   rewrite IHn at 1.
   simpl; unfold elems_aux; rewrite map_length; trivial.
  Qed.

  Definition cost_mul k (x y:t k) : nat := size_nat (proj1_sig y).

  Definition cost_pow k (x:t k) (n:Z) : nat :=
   size_nat (proj1_sig x) * (size_Z (q k)).

  Definition cost_inv k (x:t k) : nat := size_nat (proj1_sig x).

  Definition cost_mul_poly : polynomial := H.order_poly.
  Definition cost_pow_poly : polynomial := pmult H.order_poly H.order_poly.
  Definition cost_inv_poly : polynomial := H.order_poly.

  Lemma cost_mul_poly_spec : forall k (x y:t k),
   cost_mul x y <= peval cost_mul_poly k.
  Proof.
   intros k x (n,Hn).
   unfold cost_mul; simpl.
   apply le_trans with (size_Z (q k)).
   apply size_nat_monotonic; apply lt_le_weak; trivial.
   unfold size_Z.
   rewrite <- q_order.
   apply le_Sn_le.
   apply H.order_size_nat.
  Qed.

  Lemma cost_pow_poly_spec : forall k (x:t k) (n:Z),
   cost_pow x n <= peval cost_pow_poly k.
  Proof.
   intros k (a,Ha) n.
   unfold cost_pow, cost_pow_poly; simpl.
   rewrite pmult_spec.
   apply mult_le_compat.
   apply le_trans with (size_Z (q k)).
   apply size_nat_monotonic; apply lt_le_weak; trivial.
   unfold size_Z; rewrite <- q_order.
   apply le_Sn_le; apply H.order_size_nat.
   unfold size_Z; rewrite <- q_order.
   apply le_Sn_le; apply H.order_size_nat.
  Qed.

  Lemma cost_inv_poly_spec : forall k (x:t k),
   cost_inv x <= peval cost_inv_poly k.
  Proof.
   intros k (a,Ha).
   unfold cost_inv; simpl.
   apply le_trans with (size_Z (q k)).
   apply size_nat_monotonic; apply lt_le_weak; trivial.
   unfold size_Z; rewrite <- q_order.
   apply le_Sn_le; apply H.order_size_nat.
  Qed.

 End Zq.

 Module HP := Group_Properties H.
 Import HP.

 Module HM1 <: HOMOMORPHISM Zq H.

  Open Scope nat_scope.

  Definition phi k (x:Zq.t k) : H.t k :=
   match x with
    exist a _ => H.pow (g k) a
   end.

  Definition cost_phi k (x:Zq.t k) :=
   match x with
    | exist a _ => H.cost_pow (g k) (Z_of_nat a)
   end.

  Definition cost_phi_poly : polynomial := H.cost_pow_poly.

  Lemma cost_phi_poly_spec : forall k (x:Zq.t k),
   cost_phi x <= peval cost_phi_poly k.
  Proof.
   intros k (a,Ha); apply H.cost_pow_poly_spec.
  Qed.

  Lemma phi_homo : forall k (x y:Zq.t k),
   phi (Zq.mul x y) = H.mul (phi x) (phi y).
  Proof.
   intros k (n,Hn) (m,Hm); unfold phi; simpl.
   rewrite HP.mul_pow_plus.
   case (le_gt_dec (Zabs_nat (q k)) (n + m)).
   intros.
   assert (H:n + m = n + m - Zabs_nat (q k) + Zabs_nat (q k)) by omega.
   rewrite H at 2.
   rewrite <- HP.mul_pow_plus, g_order, mul_e_r; trivial.
   trivial.
  Qed.

  (* [phi] is a special homomorphism *)
  Definition special_v k := q k.

  Lemma special_v_spec : forall k, special_v k <> 0%Z.
  Proof.
   intro k; unfold special_v.
   generalize (prime_ge_2 _ (q_prime k)).
   auto with zarith.
  Qed.

  Definition special_v_poly : polynomial := H.order_poly.

  Lemma size_nat_special_v : forall k,
   size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.
  Proof.
   intro k; unfold special_v.
   apply lt_le_weak.
   rewrite <- q_order.
   apply H.order_size_nat.
  Qed.

  Definition cost_special_v (k:nat) := 1.

  Definition cost_special_v_poly : polynomial := 1.

  Lemma cost_special_v_poly_spec : forall k,
   cost_special_v k <= peval cost_special_v_poly k.
  Proof.
   intro k; unfold cost_special_v_poly; rewrite pcst_spec; trivial.
  Qed.

  Definition special_u k (x:H.t k) : Zq.t k := Zq.e k.

  Definition cost_special_u k (x:H.t k) := 1.

  Definition cost_special_u_poly : polynomial := 1.

  Lemma cost_special_u_poly_spec : forall k (x:H.t k),
   cost_special_u x <= peval cost_special_u_poly k.
  Proof.
   intro k; unfold cost_special_u_poly; rewrite pcst_spec; trivial.
  Qed.

  Lemma phi_special : forall k (y:H.t k),
   phi (special_u y) = H.powZ y (special_v k).
  Proof.
   intros; simpl; unfold special_v.
   replace (q k) with (Z_of_nat (Zabs_nat (q k))).
   rewrite HP.powZ_pow.
   destruct (g_gen y) as [a Heq]; rewrite Heq.
   rewrite HP.pow_pow, mult_comm, <- HP.pow_pow.
   rewrite g_order, pow_e; trivial.
   rewrite inj_Zabs_nat, Zabs_eq; trivial.
   generalize (prime_ge_2 _ (q_prime k)).
   auto with zarith.
  Qed.

 End HM1.

 Module HM2 <: HOMOMORPHISM Zq H.

  Open Scope nat_scope.

  Definition phi k (x:Zq.t k) : H.t k :=
   match x with
    exist a _ => H.pow (g k) (a * b k)
   end.

  Definition cost_phi k (x:Zq.t k) :=
   match x with
    | exist a _ => H.cost_pow (g k) (Z_of_nat (a * b k))
   end.

  Definition cost_phi_poly : polynomial := H.cost_pow_poly.

  Lemma cost_phi_poly_spec : forall k (x:Zq.t k),
   cost_phi x <= peval cost_phi_poly k.
  Proof.
   intros k (a,Ha); apply H.cost_pow_poly_spec.
  Qed.

  Lemma phi_homo : forall k (x y:Zq.t k),
   phi (Zq.mul x y) = H.mul (phi x) (phi y).
  Proof.
   intros k (a,Ha) (c,Hc); unfold phi; simpl.
   rewrite HP.mul_pow_plus.
   case (le_gt_dec (Zabs_nat (q k)) (a + c)).
   intros.
   replace (a * (b k) + c * (b k)) with
    ((a + c) * (b k) - Zabs_nat (q k) * (b k) + Zabs_nat (q k) * (b k)).
   rewrite mult_minus_distr_r.
   rewrite <- HP.mul_pow_plus, <- pow_pow, g_order, pow_e, mul_e_r; trivial.
   rewrite plus_comm.
   rewrite le_plus_minus_r; [ring | ].
   apply mult_le_compat_r; omega.

   rewrite mult_plus_distr_r; trivial.
  Qed.

  (* [phi] is a special homomorphism *)
  Definition special_v k := q k.

  Lemma special_v_spec : forall k, special_v k <> 0%Z.
  Proof.
   intro k; unfold special_v.
   generalize (prime_ge_2 _ (q_prime k)).
   auto with zarith.
  Qed.

  Definition special_v_poly : polynomial := H.order_poly.

  Lemma size_nat_special_v : forall k,
   size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.
  Proof.
   intro k; unfold special_v.
   apply lt_le_weak.
   rewrite <- q_order.
   apply H.order_size_nat.
  Qed.

  Definition cost_special_v (k:nat) := 1.

  Definition cost_special_v_poly : polynomial := 1.

  Lemma cost_special_v_poly_spec : forall k,
   cost_special_v k <= peval cost_special_v_poly k.
  Proof.
   intro k; unfold cost_special_v_poly; rewrite pcst_spec; trivial.
  Qed.

  Definition special_u k (x:H.t k) : Zq.t k := Zq.e k.

  Definition cost_special_u k (x:H.t k) := 1.

  Definition cost_special_u_poly : polynomial := 1.

  Lemma cost_special_u_poly_spec : forall k (x:H.t k),
   cost_special_u x <= peval cost_special_u_poly k.
  Proof.
   intro k; unfold cost_special_u_poly; rewrite pcst_spec; trivial.
  Qed.

  Lemma phi_special : forall k (y:H.t k),
   phi (special_u y) = H.powZ y (special_v k).
  Proof.
   intros; simpl; unfold special_v.
   replace (q k) with (Z_of_nat (Zabs_nat (q k))).
   rewrite HP.powZ_pow.
   destruct (g_gen y) as [a Heq]; rewrite Heq.

   rewrite HP.pow_pow, mult_comm, <- HP.pow_pow.
   rewrite g_order, pow_e; trivial.
   rewrite inj_Zabs_nat, Zabs_eq; trivial.
   generalize (prime_ge_2 _ (q_prime k)).
   auto with zarith.
  Qed.

 End HM2.

 Module EPC_DH : EP_CONSTRAINTS Zq H H HM1 HM2.

  Lemma special_u_same : forall k (x1 x2:H.t k),
   HM1.special_u x1 = HM2.special_u x2.
  Proof.
   trivial.
  Qed.

  Lemma special_v_same : HM1.special_v = HM2.special_v.
  Proof.
   trivial.
  Qed.

 End EPC_DH.

 Module HM := EP_Homomorphism Zq H H HM1 HM2 EPC_DH.

End DH_Homomorphism.

(** Instantiation with a challenge set of maximal size *)
Declare Module DHP : DH_PARAMETERS.

Module DHH := DH_Homomorphism DHP.

Module CS := Largest_Challenge_Set DHH.Zq DHH.HM.H DHH.HM.

Module S := SigmaPhi.SigmaPhi DHH.Zq DHH.HM.H DHH.HM CS.


Set Implicit Arguments.

Require Import Coq.Structures.Equalities.

Require Import Common.Types.
Require Import Wildcard.Wildcard.

Import Wildcard.

Create HintDb wildcard.

Section Lemmas.

  Variable A : Type.
  Variable eq_dec : (forall (x y : A), { x = y } + { x <> y }).

  Hint Unfold inter inter is_empty is_exact.
  Hint Constructors Wildcard.

  Ltac destruct_eq x y :=
    destruct (eq_dec x y).

  Lemma inter_all_r : forall x, inter eq_dec x WildcardAll = x.
  Proof with auto with wildcard.
    intros.
    destruct x...
  Qed.

  Lemma inter_all_l : forall x, inter eq_dec WildcardAll x = x.
  Proof with auto with wildcard.
    intros.
    destruct x...
  Qed.

  Lemma inter_exact_eq : forall v,
    inter eq_dec (WildcardExact v) (WildcardExact v) = WildcardExact v.
  Proof with auto.
    intros.
    autounfold.
    destruct_eq v v...
    unfold not in n.
    contradiction (n eq_refl).
  Qed.

  Lemma inter_exact_neq : forall v v',
    v <> v' ->
    inter eq_dec (WildcardExact v) (WildcardExact v') = WildcardNone.
  Proof with auto.
    intros.
    autounfold.
    destruct_eq v v'...
    contradiction.
  Qed.

  Lemma inter_none_r : forall x,
    inter eq_dec x WildcardNone = WildcardNone.
  Proof.
    intros.
    destruct x; auto.
  Qed.

  Lemma inter_none_l : forall y,
    inter eq_dec WildcardNone y = WildcardNone.
  Proof.
    intros.
    destruct y; auto.
  Qed.

  Hint Rewrite inter_all_l inter_all_r.
  Hint Rewrite inter_exact_neq inter_exact_eq.
  Hint Rewrite inter_none_l inter_none_r.

  Lemma inter_comm : forall x y,
    inter eq_dec x y = inter eq_dec y x.
  Proof with auto.
    intros.
    destruct x; destruct y...
    destruct_eq a a0; subst;
      autorewrite with core using (subst;auto)...
  Qed.

  Lemma inter_assoc : forall x y z,
    inter eq_dec x (inter eq_dec y z) = inter eq_dec (inter eq_dec x y) z.
  Proof with auto.
    intros.
    destruct x; destruct y; destruct z...
    destruct_eq a a0; destruct_eq a a1; destruct_eq a0 a1; subst;
      autorewrite with core using (subst;auto)...
    destruct_eq a a0; subst; autorewrite with core using (subst;auto)...
    destruct_eq a a0; subst; autorewrite with core using (subst;auto)...
    destruct_eq a a0; subst; autorewrite with core using (subst;auto)...
    destruct_eq a a0; subst; autorewrite with core using (subst;auto)...
  Qed.

  Definition is_empty_false_distr_l : forall x y,
    is_empty (inter eq_dec x y) = false ->
    is_empty x = false.
  Proof with auto.
    intros.
    destruct x; destruct y...
  Qed.

  Definition is_empty_false_distr_r : forall x y,
    is_empty (inter eq_dec x y) = false ->
    is_empty y = false.
  Proof with auto.
    intros.
    destruct x; destruct y...
  Qed.

  Lemma exact_match_inter_l : forall x y,
    is_exact x = true ->
    is_empty (inter eq_dec x y) = false ->
    inter eq_dec x y = x.
  Proof with auto.
    intros.
    destruct x; simpl in H; try solve [ inversion H ].
    destruct y; simpl in H0; try solve [ inversion H0 ].
    autounfold in *.
    remember (eq_dec a a0) as H1.
    destruct H1...
    inversion H0.
    intuition.
  Qed.

  Lemma exact_match_inter_r : forall x y,
    is_exact y = true ->
    is_empty (inter eq_dec x y) = false ->
    inter eq_dec x y = y.
  Proof with auto.
    intros.
    rewrite -> inter_comm in *...
    apply exact_match_inter_l...
  Qed.

  Lemma is_empty_true_l : forall x y,
    is_empty x = true ->
    is_empty (inter eq_dec x y) = true.
  Proof with auto with wildcard.
    intros.
    destruct x...
    inversion H.
    inversion H.
    autorewrite with core using (subst;auto)...
  Qed.

  Lemma is_empty_true_r : forall x y,
    is_empty y = true ->
    is_empty (inter eq_dec x y) = true.
  Proof with auto.
    intros.
    rewrite -> inter_comm.
    apply is_empty_true_l...
  Qed.

 Lemma is_exact_split_l :
    forall f  (x : A) (y : Wildcard A),
      inter f (WildcardExact x) y = WildcardExact x \/
      inter f (WildcardExact x) y = WildcardNone.
  Proof with auto.
    intros.
    destruct y...
    unfold inter.
    destruct (f x a)...
  Qed.

  Lemma is_exact_split_r :
    forall f (y : Wildcard A) (x : A),
      inter f y (WildcardExact x)  = WildcardExact x \/
      inter f y (WildcardExact x)  = WildcardNone.
  Proof with auto.
    intros.
    destruct y...
    unfold inter.
    destruct (f a x)...
    subst...
  Qed.

End Lemmas.

Hint Rewrite inter_all_l inter_all_r : wildcard.
Hint Rewrite inter_exact_eq : wildcard.
Hint Rewrite inter_none_l inter_none_r : wildcard.
Hint Rewrite inter_assoc : wildcard.
Hint Rewrite is_empty_false_distr_l is_empty_false_distr_r : wildcard.
Hint Resolve exact_match_inter_l exact_match_inter_r : wildcard.
Hint Resolve inter_exact_neq is_empty_true_l is_empty_true_r : wildcard.