From iris.program_logic Require Export ectx_language ectxi_language.
From iris_logrel.prelude Require Export base.
From iris.algebra Require Export cofe.
From iris.prelude Require Import gmap.

Module lang.
  Definition loc := positive.

  Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive expr :=
  | Var (x : var)
  | Lam (e : {bind 1 of expr})
  | App (e1 e2 : expr)
  (* Unit *)
  | Unit
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  Instance expr_dec_eq (e e' : expr) : Decision (e = e').
  Proof. solve_decision. Defined.

  Inductive val :=
  | LamV (e : {bind 1 of expr})
  | TLamV (e : {bind 1 of expr})
  | UnitV
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | FoldV (v : val)
  | LocV (l : loc).

  Instance val_dec_eq (v v' : val) : Decision (v = v').
  Proof. solve_decision. Defined.

  Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | LamV e => Lam e
    | TLamV e => TLam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | FoldV v => Fold (of_val v)
    | LocV l => Loc l
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | TLam e => Some (TLamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Fold e => v ← to_val e; Some (FoldV v)
    | Loc l => Some (LocV l)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | TAppCtx
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val).

  Notation ectx := (list ectx_item).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | TAppCtx => TApp e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    end.

  Definition state : Type := gmap loc val.

  Inductive head_step : expr → state → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ e1.[e2/] σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ e σ []
  (* Polymorphic Types *)
  | TBeta e σ :
      head_step (TApp (TLam e)) σ e σ []
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Loc l)) σ (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Loc l) e) σ (Unit) (<[l:=v]>σ) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 e2 σ2 ef :
    head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
    head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom _ σ) in
    to_val e = Some v → head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.

  Canonical Structure stateC := leibnizC state.
  Canonical Structure valC := leibnizC val.
  Canonical Structure exprC := leibnizC expr.
End lang.

(** Language *)
Program Instance heap_ectxi_lang :
  EctxiLanguage
    (lang.expr) lang.val lang.ectx_item lang.state := {|
  of_val := lang.of_val; to_val := lang.to_val;
  fill_item := lang.fill_item; head_step := lang.head_step
|}.
Solve Obligations with eauto using lang.to_of_val, lang.of_to_val,
  lang.val_stuck, lang.fill_item_val, lang.fill_item_no_val_inj,
  lang.head_ctx_step_val.

Canonical Structure lang := ectx_lang (lang.expr).

Export lang.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | _ => False
  end.
Lemma is_atomic_correct e : is_atomic e → language.atomic e.
Proof.
  intros ?; apply ectx_language_atomic.
  - destruct 1; simpl; by eauto using to_of_val.
  - intros [|Ki K] e' -> Hval%eq_None_not_Some; [done|].
    destruct Hval; apply (fill_val K e'). destruct Ki; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Hint Extern 0 (language.atomic _) => solve_atomic.
Hint Extern 0 (language.atomic _) => solve_atomic : typeclass_instances.


Require Import Common Computation.Core ADT.Core Ensembles.

Section HideADT.

  Context {extSig : ADTSig}.
  (* The extended signature *)

  Context {resConstructorIndex : Type}.
  (* The restricted set of constructor indices *)

  Context {resMethodIndex : Type}.
  (* The restricted set of method indices *)

  Variable constructorMap : resConstructorIndex -> ConstructorIndex extSig.
  (* Map from restricted to extended constructor indices *)

  Variable methodMap : resMethodIndex -> MethodIndex extSig.
  (* Map from restricted to extended method indices *)

  Definition resSig :=
    {| ConstructorIndex := resConstructorIndex;
       MethodIndex := resMethodIndex;
       ConstructorDom idx := ConstructorDom extSig (constructorMap idx);
       MethodDomCod idx := MethodDomCod extSig (methodMap idx)
    |}.
  (* The signature of the ADT with restricted constructor and method indices *)

  Definition HideADT (extADT : ADT extSig) : ADT resSig :=
    match extADT with
        {| Rep := rep;
           Constructors := extConstructors;
           Methods := extMethods
        |} =>
        Build_ADT resSig
          (fun idx => extConstructors (constructorMap idx))
          (fun idx => extMethods (methodMap idx))
    end.

End HideADT.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q R X Y : Universe, ((wd_ X Y /\ (wd_ A B /\ (wd_ P Q /\ (wd_ B C /\ (wd_ A C /\ (wd_ Q A /\ (wd_ Q C /\ (wd_ P B /\ (wd_ P C /\ (wd_ R Y /\ (col_ A R B /\ (col_ X Y R /\ (col_ A P Q /\ (col_ B P Q /\ (col_ Q A C /\ col_ P B C))))))))))))))) -> col_ A B P)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D T X Y Z M1 Z1 : Universe, ((wd_ B D /\ (wd_ C D /\ (wd_ D T /\ (wd_ T X /\ (wd_ A D /\ (wd_ B C /\ (wd_ C T /\ (wd_ B T /\ (wd_ A B /\ (wd_ A C /\ (wd_ A T /\ (wd_ Y X /\ (wd_ Y T /\ (wd_ Y Z1 /\ (wd_ T Z /\ (wd_ Y M1 /\ (wd_ B Z1 /\ (wd_ A Z1 /\ (wd_ X Z1 /\ (wd_ M1 Z1 /\ (col_ A B M1 /\ (col_ T Y Z /\ (col_ A B Y /\ (col_ Y M1 Z1 /\ (col_ Y T X /\ (col_ B D C /\ col_ A D T)))))))))))))))))))))))))) -> col_ A B Z1)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Works in 8.9.1, submitted by jakobbotsh *)

Require Hurkens.

Module TypeNequivSmallType.
Import Hurkens.

Section Paradox.

(* I feel like this version of the paradox should already by in
   Hurkens.v but can't find it, there's only the version with A=U *)

Definition U := Type.
Variable A:U.

Variable down : U -> A.
Variable up : A -> U.
Hypothesis up_down : forall (X:U), up (down X) = X.

Theorem paradox : False.
Proof.
  Generic.paradox p.
  (** Large universe *)
  + exact U.
  + exact (fun X=>X).
  + cbn. exact (fun X F => forall x:X, F x).
  + cbn. exact (fun _ _ x => x).
  + cbn. exact (fun _ _ x => x).
  + exact (fun F => forall x:A, F (up x)).
  + cbn. exact (fun _ f => fun x:A => f (up x)).
  + cbn. intros * f X.
    specialize (f (down X)).
    rewrite up_down in f.
    exact f.
  (** Small universe *)
  + exact A.
  (** The interpretation of [A] as a universe is [U]. *)
  + cbn. exact up.
  + cbn. exact (fun _ F => down (forall x, up (F x))).
  + cbn. exact (fun _ F => down (forall x, up (F x))).
  + cbn. exact (down False).
  + rewrite up_down in p.
    exact p.
  + cbn. easy.
  + cbn. intros ? f X.
    destruct (up_down X). cbn.
    reflexivity.
  + cbn. intros ? ? f.
    rewrite up_down.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down in f.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down.
    exact f.
  + cbn. intros ? ? f.
    rewrite up_down in f.
    exact f.
Qed.

End Paradox.

End TypeNequivSmallType.

Inductive foo (A:Type) := bar X : foo X -> foo A | nonempty.
Arguments nonempty {_}.

Notation U := TypeNequivSmallType.U.

Definition A : U := foo nat.

Definition down : U -> A := fun u => bar nat u nonempty.

Definition up : A -> U := fun a => match a with bar _ u _ => u | nonempty => nat end.

Lemma up_down : forall (X:U), up (down X) = X.
Proof.
  reflexivity.
Qed.

Definition contender_final : nat := 7.

Lemma n_lt_contender_final :
  forall n, n < contender_final.
Proof (match TypeNequivSmallType.paradox A down up up_down with end).

Print Assumptions n_lt_contender_final.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e254m127x2e240m1_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Cat.
Require Import Category.Instance.Cat.Cartesian.
Require Import Category.Instance.Sets.

Generalizable All Variables.

#[local] Set Transparent Obligations.

Definition pairing {A B : Type} (p : A * B) : p = (fst p, snd p) :=
  match p with (x, y) => eq_refl end.

#[export]
Program Instance Cat_Closed : @Closed Cat Cat_Cartesian := {
  exponent_obj := @Fun;         (* the internal hom is a functor category *)
  exp_iso := fun A B C =>
    {| to :=
       {| morphism := fun F : A × B ⟶ C =>
          {| fobj := fun x : A =>
             {| fobj := fun y : B => F (x, y)
              ; fmap := fun J K (f : J ~{B}~> K) =>
                  fmap[F] (@id A x, f) |}
           ; fmap := fun J K (f : J ~{A}~> K) =>
             {| transform := fun L : B =>
                  fmap[F] (f, @id B L) |} |} |}
     ; from :=
       {| morphism := fun F : A ⟶ [B, C] =>
          {| fobj := fun x : A × B => F (fst x) (snd x)
           ; fmap := fun J K (f : J ~{A × B}~> K) =>
               fmap (snd f) ∘ transform[fmap[F] (fst f)] _ |} |} |}
}.
Next Obligation.
  proper; apply fmap_respects.
  split; simpl; cat.
Qed.
Next Obligation.
  rewrite <- fmap_comp; simpl.
  apply fmap_respects; split; simpl; cat.
Qed.
Next Obligation.
  rewrite <- !fmap_comp.
  apply fmap_respects; simpl; cat; simpl; cat.
Qed.
Next Obligation.
  rewrite <- !fmap_comp.
  apply fmap_respects; simpl; cat.
Qed.
Next Obligation.
  proper; simpl; cat;
  rewrites; reflexivity.
Qed.
Next Obligation.
  simpl; intros.
  rewrite <- fmap_comp.
  apply fmap_respects; cat; simpl; cat.
Qed.
Next Obligation.
  proper.
  - isomorphism; simpl.
    + transform; simpl; intros.
      * apply x0.
      * simpl.
        rewrite e.
        rewrite !comp_assoc.
        rewrite iso_to_from; cat.
      * simpl.
        rewrite e.
        rewrite !comp_assoc.
        rewrite iso_to_from; cat.
    + transform; simpl; intros.
      * apply x0.
      * simpl.
        rewrite e.
        rewrite <- !comp_assoc.
        rewrite iso_to_from; cat.
      * simpl.
        rewrite e.
        rewrite <- !comp_assoc.
        rewrite iso_to_from; cat.
    + simpl; cat; apply iso_to_from.
    + simpl; cat; apply iso_from_to.
  - apply e.
Qed.
Next Obligation.
  proper.
  rewrite H.
  comp_left.
  destruct F; simpl in *.
  apply fmap_respects.
  assumption.
Qed.
Next Obligation.
  simpl; cat.
  destruct F; simpl in *.
  rewrite fmap_id; cat.
Qed.
Next Obligation.
  symmetry.
  rewrite naturality.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (fmap[F o1] h2)).
  rewrite <- fmap_comp.
  rewrite naturality.
  rewrite comp_assoc.
  destruct F; simpl in *.
  rewrite <- !fmap_comp.
  rewrite naturality.
  reflexivity.
Qed.
Next Obligation.
  proper; simpl.
  - isomorphism.
    + apply x0.
    + apply (from (x0 _)).
    + srewrite (iso_to_from (x0 x1)); cat.
    + srewrite (iso_from_to (x0 x1)); cat.
  - simpl.
    rewrite e.
    do 2 comp_right.
    apply naturality.
Qed.
Next Obligation.
  constructive; simpl.
  - transform; simpl; intros.
    + exact id.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
  - transform; simpl; intros.
    + exact id.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
    + destruct x; simpl in *.
      rewrite fmap_id; cat.
  - simpl; cat.
  - destruct x; simpl in *.
    rewrite fmap_id; cat.
  - destruct x; simpl in *; cat.
Qed.
Next Obligation.
  constructive; simpl.
  - rewrite <- pairing.
    exact id.
  - rewrite <- pairing.
    exact id.
  - destruct x0; simpl; cat.
  - destruct x0; simpl; cat.
  - destruct f; simpl; cat.
    rewrite <- fmap_comp.
    apply fmap_respects; simpl; cat.
Qed.
Next Obligation.
  constructive; simpl.
  - rewrite <- pairing.
    exact id.
  - rewrite <- pairing.
    exact id.
  - destruct x; simpl; cat.
  - destruct x; simpl; cat.
  - destruct f; simpl; cat.
    rewrite <- fmap_comp.
    apply fmap_respects; simpl; cat.
Qed.


Require Import String. Import StringSyntax.

(* Is this relevant? *)

Add LoadPath  "/local/res/josh/coq" as Ling.

(* First compile BS.v as follows.
 /Applications/CoqIDE_8.13.1.app/Contents/Resources/bin/coqc -Q . Ling -vos BSm2.v

Josh has put in changes from BSm.v.
*)

From Ling Require Import BSm2.
Import Ling.

(* muddy, copulatives *)

Definition muddy : AP := et "muddy".
Definition is : (DP \ S) / AP := fun x y => x y.

(* Generalized bind *)
Definition gbind {a b c : Cat} (x : a || b -- c) : a || (c >> b) -- c :=
  fun k => x (fun y => k y y).

(*
 This is the type of a structured antecedent. S[DP\S] encodes a propositional and
 a predicate antecedent.
*)

Notation "x [ y ]" := (Struct y x) (at level 30, format "x [ y ]").

(* The recursive focus stuff is cut.

The category of the structured binder is

S || S[DP \ S] >> S
--
S

indicating power to bind a S[DP \ S] pronoun. The category of [BEN did ---] should be

S[DP \ S] >> S || S
--
S

*)

(* Copied from focus.v renaming focus to foc. *)

Parameter (alt : Prop -> ((interp DP) -> Prop) -> (interp DP) -> Prop).

Definition foc (x : DP) : ((S >> S) || S -- S)|| S -- DP :=
  fun k => (fun f => (fun p => (f (alt p k x)) /\ k x)).

(* Example with focus anaphora. This should be modified to parasitic focus-vp anaphora. *)

Check lower ((gbind (lift (ari <: (is :> muddy)))) <|
      ((lift and) |> (lower ((foc ben)  <| (lift (is :> muddy)))))).

Eval compute in lower ((gbind (lift (ari <: (is :> muddy)))) <|
      ((lift and) |> (lower ((foc ben)  <| (lift (is :> muddy)))))).

(*

Guess the semantics of BEN_F_did.

  BEN_F_did equires a structured antecedent, providing a propositional and a VP
  antecedent.
*)

Definition BEN_F_did : ((S[DP \ S] >> S) || S -- S) :=
      fun (f : Prop -> Prop)
      (x : (E -> Prop) * ((E -> Prop) -> Prop))
    => f
         (alt ((snd x) (fst x)) (fun y : E => (fst x) y)
            ben) /\
       (fst x) ben.

(*
(S[DP \ S] >> S) || S
--
S
*)

Definition ALICE_F_did : ((S[DP \ S] >> S) || S -- S) :=
      fun (f : Prop -> Prop)
      (x : (E -> Prop) * ((E -> Prop) -> Prop))
    => f
         (alt ((snd x) (fst x)) (fun y : E => (fst x) y)
            alice) /\
       (fst x) alice.

Check ALICE_F_did.

(*
Define an operator that applies to VP to create the structured antecedent.
This has the two towers strategy, where the result for the lower tower
is a tower.
*)

(* TODO: generalize to DP \ DP \ S, .... *)

(* TODO: generalize ant to apply to a tower, not just DP \ S *)
(* allow ant to apply to not just S on the left, but like DP >> S *)

Definition ant (f : DP \ S) : (S || (S[DP \ S] >> S) -- S)|| S -- (DP \ S) :=
    fun c => (fun k =>
       k (c f)
         (f, c)).

Eval compute in lower ((lift john) <| (ant (kissed ben))).
(*
fun k : Prop ->
             (E -> Prop) * ((E -> Prop) -> Prop) -> Prop
       =>
       k (eet "kiss" (e "john") (e "ben"))
         (fun x : E => eet "kiss" x (e "ben"),
         fun a : E -> Prop => a (e "john"))
     :
S || S[DP \ S] >> S
--
S

*)

Definition john_kissed_ben_and_ALICE_F_did :=
 lower ((lower ((lift john) <| (ant (kissed ben)))) <| ((lift and) |> ALICE_F_did)).

Eval compute in john_kissed_ben_and_ALICE_F_did.

(*
     = (eet "kiss" (e "john") (e "ben") /\
        alt (eet "kiss" (e "john") (e "ben"))
          (fun y : E => eet "kiss" y (e "ben"))
          (e "alice")) /\
       eet "kiss" (e "alice") (e "ben")
     : S

In the above, ALICE_F_did is a primitive, rather than being derived compositionally. Fixing this is
the next step.

It should be done in a way that 'did' contributes a simple VP antecedent, or one with one or more pronouns.

*)

Definition did : ((DP \ S) >> S) || S -- (DP \ S) := fun k => k.

(* FOC turns a structured anaphor into a regular one, adding the alt operator along the way. *)

Definition FOC (a : DP) : (S[DP \ S] >> S) || ((DP \ S) >> S) -- DP :=
  fun (k : DP -> (DP \ S) >> S)
      (ana : S[DP \ S]) =>
    k a (fst ana) /\
    alt ((snd ana) (fst ana)) (fun y => (fst ana) y) a.

Check (FOC alice <| did).
Definition compositional_version' := lower ((lower ((lift john) <| (ant (kissed ben)))) <| ((lift and) |> (FOC alice <| did))).

Eval compute in compositional_version'.

Goal john_kissed_ben_and_ALICE_F_did <-> compositional_version'.
  firstorder.
Qed.

(* TODO's:

   - Generalize to other variable versions,
       NP:
       "A short man ate ice cream, and a TALL one did as well."

       no variables:
       "John praised his mother, and BEN praised his mother too."

   - Enforce only structured anaphors:
      - maybe disallow BIND on (DP \ S)? And only allow structured anaphoric bind
      - block plain VP anaphors across S's
           - Maybe add a typeclass constraint on cleft/cright (|> / <|) that blocks this propogation

   - Do covariance / sloppy identity in this framework
      - covariance:
        ARI knows he is muddy, but ben doesn't know this.
        -> ben doesn't know ben is muddy
        -> ben doesn't know ari is muddy

*)


(* begin hide *)

From ITree Require Import
     Basics.Basics
     Core.Subevent.

From CTree Require Import
  CTree
  Eq.

Import CTreeNotations.
Open Scope ctree_scope.

(* end hide *)

(*|
Helper inductive: [epsilon_det t t'] judges that [t' ≡ Guard* t]
|*)
  Inductive epsilon_det {E C X} `{B1 -< C}: relation (ctree E C X) :=
  | epsilon_det_id : forall t t', t ≅ t' -> epsilon_det t t'
  | epsilon_det_tau : forall t t' t'',
      epsilon_det t t' -> t'' ≅ Guard t -> epsilon_det t'' t'.

(*|
Helper inductive: [productive t] judges that [t]'s head constructor is not a [BrD]
|*)
  Inductive productive {E C X} : ctree E C X -> Prop :=
  | prod_ret {r t} (EQ: t ≅ Ret r) : productive t
  | prod_vis {Y} {e : E Y} {k t} (EQ: t ≅ Vis e k) : productive t
  | prod_tau {X} {c: C X} {k t} (EQ: t ≅ BrS c k) : productive t.

(*|
Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a path made of [BrD] branches.
|*)
  Inductive epsilon_ {E C X} : ctree' E C X -> ctree' E C  X -> Prop :=
  | EpsilonId : forall t t', t ≅ t' -> epsilon_ (observe t) (observe t')
  | EpsilonBr : forall X (c: C X) k x t, epsilon_ (observe (k x)) t -> epsilon_ (BrDF c k) t.

  Definition epsilon {E C X} (t t' : ctree E C X) := epsilon_ (observe t) (observe t').

  Section epsilon_det_theory.

    #[global] Instance epsilon_det_equ {E C X} `{Tau: B1 -< C}:
    Proper (equ eq ==> equ eq ==> flip impl) (@epsilon_det E C X _).
    Proof.
      cbn. intros.
      revert x H. induction H1; intros.
      - econstructor. now rewrite H0, H1.
      - eapply epsilon_det_tau. apply IHepsilon_det. apply H0. reflexivity. rewrite H2. apply H.
    Qed.

    #[global] Instance epsilon_det_equ' {E C X} `{Tau: B1 -< C}:
      Proper (equ eq ==> equ eq ==> impl) (@epsilon_det E C X _).
    Proof.
      cbn. intros. rewrite <- H, <- H0. apply H1.
    Qed.

    #[global] Instance epsilon_det_refl {E C X} `{HasB1: B1 -< C} :
      Reflexive (@epsilon_det E C X _).
    Proof.
      now left.
    Qed.

    Lemma epsilon_det_bind {E C X Y} `{Tau: B1 -< C}: forall (t t' : ctree E C X) (k : X -> ctree E C Y),
        epsilon_det t t' ->
        epsilon_det (t >>= k) (t' >>= k).
    Proof.
      intros. induction H.
      - rewrite H. constructor. reflexivity.
      - rewrite H0. setoid_rewrite bind_guard. eapply epsilon_det_tau. apply IHepsilon_det. reflexivity.
    Qed.

    Lemma epsilon_det_bind_ret_l {E C X Y} `{Tau: B1 -< C}: forall (t : ctree E C X) t' (k : X -> ctree E C Y) x,
        epsilon_det t (Ret x) ->
        epsilon_det (k x) t' ->
        epsilon_det (t >>= k) t'.
    Proof.
      intros. remember (Ret x) as R. revert t' k x HeqR H0. induction H; intros; subst.
      - subst. rewrite H, bind_ret_l. apply H0.
      - rewrite H0. setoid_rewrite bind_guard.
        eapply epsilon_det_tau. 2: reflexivity. eapply IHepsilon_det. reflexivity. apply H1.
    Qed.

    Lemma epsilon_det_bind_ret_l_equ {E C X Y} `{Tau: B1 -< C}:
      forall (t : ctree E C X) (k : X -> ctree E C Y) x,
        epsilon_det t (Ret x) ->
        x <- t;; k x ≅ t;; k x.
    Proof.
      intros. remember (Ret x) as R. induction H; subst.
      - rewrite H. rewrite !bind_ret_l. reflexivity.
      - rewrite H0. rewrite !bind_guard. apply br_equ. intro. apply IHepsilon_det. reflexivity.
    Qed.

    Lemma epsilon_det_trans {E C X} `{Stuck: B0 -< C} `{Tau: B1 -< C} :
      forall l (t t' t'' : ctree E C X),
        epsilon_det t t' -> trans l t' t'' -> trans l t t''.
    Proof.
      intros. induction H.
      - now rewrite H.
      - apply IHepsilon_det in H0. apply trans_guard in H0. now rewrite <- H1 in H0.
    Qed.

    Lemma sbisim_epsilon_det {E C X} `{Stuck: B0 -< C} `{Tau: B1 -< C}:
      forall (t t' : ctree E C X), epsilon_det t t' -> t ~ t'.
    Proof.
      intros. induction H.
      - now rewrite H.
      - rewrite H0. rewrite sb_guard. apply IHepsilon_det.
    Qed.

  End epsilon_det_theory.

  Section productive_theory.

    #[global] Instance productive_equ : forall {E C X}, Proper (equ eq ==> impl) (@productive E C X).
    Proof.
      cbn. intros. inv H0; rewrite H in *.
      - eapply prod_ret; eauto.
      - eapply prod_vis; eauto.
      - eapply prod_tau; eauto.
    Qed.

    #[global] Instance productive_equ' : forall {E C X}, Proper (equ eq ==> flip impl) (@productive E C X).
    Proof.
      cbn. intros. rewrite <- H in H0. apply H0.
    Qed.

    #[local] Hint Constructors productive : trans.

    Lemma ctree_case_productive : forall {E C X} (t: ctree E C X),
      productive t \/ exists X (c : C X) k, t ≅ BrD c k.
    Proof.
      intros. setoid_rewrite (ctree_eta t). desobs t; etrans.
      destruct vis; etrans.
    Qed.

    Lemma productive_br {E C X Y} : forall vis c (k : Y -> ctree E C X),
      productive (Br vis c k) -> vis = true.
    Proof.
      intros. inv H; inv_equ. reflexivity.
    Qed.

    Lemma productive_brD : forall {E C X Y} (c : C Y) (k : Y -> ctree E C X),
      ~ productive (BrD c k).
    Proof.
      intros ** ?. inversion H; inv_equ.
    Qed.

    Lemma productive_bind : forall {E C X Y} t (k : Y -> ctree E C X), productive (t >>= k) -> productive t.
    Proof.
      intros. inversion H; inv_equ; subst.
      - apply ret_equ_bind in EQ as (? & ? & ?). subs. now eapply prod_ret.
      - apply vis_equ_bind in EQ as [(? & ?) | (? & ? & ?)]; subs.
        + now eapply prod_ret.
        + now eapply prod_vis.
      - apply br_equ_bind in EQ as [(? & ?) | (? & ? & ?)]; subs.
        + now eapply prod_ret.
        + now eapply prod_tau.
    Qed.

  End productive_theory.

  #[global] Hint Constructors productive : trans.
  #[global] Hint Resolve productive_brD : trans.

  Section epsilon_theory.

    #[global] Instance epsilon_equ_ {E C X} :
    Proper (going (equ eq) ==> going (equ eq) ==> impl) (@epsilon_ E C X).
    Proof.
      cbn. intros.
      revert y y0 H H0. induction H1; intros.
      - pose (EpsilonId (go y) (go y0)). cbn in e. apply e.
        rewrite <- H0, <- H1, H. reflexivity.
      - destruct H. step in H. inv H. invert.
        econstructor.
        apply IHepsilon_.
        + constructor.
          rewrite <- !ctree_eta. apply REL.
        + apply H0.
    Qed.

    #[global] Instance epsilon_equ_' {E C X} :
      Proper (going (equ eq) ==> going (equ eq) ==> flip impl) (@epsilon_ E C X).
    Proof.
      cbn. intros. now rewrite <- H, <- H0 in H1.
    Qed.

    #[global] Instance epsilon_equ {E C X} : Proper (equ eq ==> equ eq ==> iff) (@epsilon E C X).
    Proof.
      unfold epsilon. split; intros.
      - now rewrite <- H, <- H0.
      - now rewrite H, H0.
    Qed.

    #[global] Instance epsilon_refl {E C X} :
      Reflexive (@epsilon E C X).
    Proof.
      now left.
    Qed.

    Lemma epsilon_br {E C X Y} : forall (t' : ctree E C X) k (c : C Y) x,
      epsilon (k x) t' -> epsilon (BrD c k) t'.
    Proof.
      intros. eright. apply H.
    Qed.

    Lemma epsilon_case {E C X} : forall (t t' : ctree E C X),
      epsilon t t' ->
      t ≅ t' \/ exists Y (c : C Y) k x, t ≅ BrD c k /\ epsilon (k x) t'.
    Proof.
      intros * EPS.
      inversion EPS; [left | right].
      - setoid_rewrite ctree_eta. now rewrite <- H, H1, H0.
      - subst. exists X0, c, k, x. split; auto. now rewrite H, <- ctree_eta.
    Qed.

    Lemma epsilon_trans {E C X} `{Stuck: B0 -< C} : forall (t t' : ctree E C X),
        epsilon t t' -> forall l t'', trans l t' t'' -> trans l t t''.
    Proof.
      intros. red in H. rewrite ctree_eta. rewrite ctree_eta in H0.
      genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'.
      induction H.
      - rewrite H. apply H0.
      - apply IHepsilon_ in H0. eapply trans_brD in H0. apply H0. rewrite <- ctree_eta. reflexivity.
    Qed.

    Lemma epsilon_fwd : forall {E C X} (t : ctree E C X) k x (c : C X),
        epsilon t (BrD c k) -> epsilon t (k x).
    Proof.
      intros. red in H. red.
      genobs t ot. clear t Heqot.
      remember (observe (BrD c k)) as oc.
      revert c k x Heqoc. induction H.
      - intros. rewrite H, Heqoc. cbn. eapply EpsilonBr. econstructor. reflexivity.
      - intros. subst. eapply EpsilonBr. eapply IHepsilon_. reflexivity.
    Qed.

    Lemma trans_epsilon {E C X} `{Stuck: B0 -< C} l (t t'' : ctree E C X) : trans l t t'' -> exists t',
          epsilon t t' /\ productive t' /\ trans l t' t''.
    Proof.
      intros. do 3 red in H.
      setoid_rewrite (ctree_eta t). setoid_rewrite (ctree_eta t'').
      genobs t ot. genobs t'' ot''. clear t Heqot t'' Heqot''.
      induction H; intros.
      - destruct IHtrans_ as (? & ? & ? & ?).
        rewrite <- ctree_eta in H0. eapply EpsilonBr in H0.
        exists x0. etrans.
      - eexists. split; [| split ].
        + left. reflexivity.
        + eapply prod_tau. reflexivity.
        + rewrite <- H, <- ctree_eta. etrans.
      - eexists. split; [| split ].
        + left. reflexivity.
        + eapply prod_vis. reflexivity.
        + rewrite <- H, <- ctree_eta. etrans.
      - eexists. split; [| split ].
        + left. reflexivity.
        + eapply prod_ret. reflexivity.
        + rewrite br0_always_stuck. etrans.
    Qed.

    Lemma trans_val_epsilon {E C X}  `{Stuck: B0 -< C}  : forall x (t t' : ctree E C X),
        trans (val x) t t' -> epsilon t (Ret x) /\ t' ≅ stuckD.
    Proof.
      intros. apply trans_epsilon in H as (? & ? & ? & ?).
      inv H0.
      - rewrite EQ in H, H1. inv_trans. subst. auto.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans.
    Qed.

    Lemma trans_tau_epsilon {E C X}  `{Stuck: B0 -< C} : forall (t t' : ctree E C X),
        trans tau t t' -> exists X (c: C X) k x, epsilon t (BrS c k) /\ t' ≅ k x.
    Proof.
      intros. apply trans_epsilon in H as (? & ? & ? & ?).
      inv H0.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans.
        do 2 eexists.
        exists k. exists x0.
        eauto.
    Qed.

    Lemma trans_obs_epsilon {E C X Y} `{Stuck: B0 -< C} : forall (t t' : ctree E C X) e (x : Y),
        trans (obs e x) t t' -> exists k, epsilon t (Vis e k) /\ t' ≅ k x.
    Proof.
      intros. apply trans_epsilon in H as (? & ? & ? & ?).
      inv H0.
      - rewrite EQ in H1. inv_trans.
      - rewrite EQ in H1. inv_trans. subst. etrans.
      - rewrite EQ in H1. inv_trans.
    Qed.

    Lemma productive_epsilon {E C X} : forall (t t' : ctree E C X),
        productive t -> epsilon t t' -> t ≅ t'.
    Proof.
      intros. setoid_rewrite ctree_eta.
      inversion H; subst; rewrite (ctree_eta t) in EQ; inversion H0; subst.
      - now rewrite H3.
      - rewrite <- H1 in EQ. step in EQ. inv EQ.
      - now rewrite H3.
      - rewrite <- H1 in EQ. step in EQ. inv EQ.
      - now rewrite H3.
      - rewrite <- H1 in EQ. step in EQ. inv EQ.
    Qed.

    Lemma epsilon_transitive {E C X} : forall (t u v : ctree E C X),
      epsilon t u -> epsilon u v -> epsilon t v.
    Proof.
      intros. red in H.
      rewrite (ctree_eta t). rewrite (ctree_eta u) in H0.
      genobs t ot. genobs u ou. clear t Heqot u Heqou.
      revert v H0. induction H; intros.
      - subs. apply H0.
      - setoid_rewrite <- ctree_eta in IHepsilon_.
        eright. now apply IHepsilon_.
    Qed.

    Lemma epsilon_bind_l {E C X Y} : forall t t' (k : Y -> ctree E C X),
      epsilon t t' -> epsilon (t >>= k) (t' >>= k).
    Proof.
      intros. setoid_rewrite (ctree_eta t). setoid_rewrite (ctree_eta t').
      red in H. genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'.
      induction H.
      - subs. reflexivity.
      - rewrite bind_br. eright. rewrite (ctree_eta (k0 x)). apply IHepsilon_.
    Qed.

    Lemma epsilon_bind_ret {E C X Y} : forall t (k : Y -> ctree E C X) v,
      epsilon t (Ret v) -> epsilon (t >>= k) (k v).
    Proof.
      intros. rewrite <- (bind_ret_l v k).
      now apply epsilon_bind_l.
    Qed.

    Lemma epsilon_bind {E C X Y} : forall t u (k : Y -> ctree E C X) v,
      epsilon t (Ret v) -> epsilon (k v) u -> epsilon (t >>= k) u.
    Proof.
      intros. eapply epsilon_bind_ret in H.
      eapply epsilon_transitive; eassumption.
    Qed.

    Lemma epsilon_det_epsilon {E C X} `{Stuck: B0 -< C} `{Tau: B1 -< C} : forall (t t' : ctree E C X),
        epsilon_det t t' -> epsilon t t'.
    Proof.
      intros. induction H.
      - now left.
      - rewrite H0. now right.
    Qed.

    Lemma ss_epsilon_l {E F C D X Y L R} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u : ctree F D Y) :
      (forall t0, epsilon t t0 -> productive t0 -> ss L R t0 u) ->
      ss L R t u.
    Proof.
      intros. cbn. intros. apply trans_epsilon in H0 as (? & ? & ? & ?).
      red in H0.
      setoid_rewrite (ctree_eta t) in H. genobs t ot. clear t Heqot.
      rewrite (ctree_eta x) in H1, H2. genobs x ox. clear x Heqox.
      induction H0.
      - apply H in H1 as ?. 2: { rewrite H0. now left. }
        apply H3 in H2. apply H2.
      - apply IHepsilon_; auto. intros. apply H; auto. eright. apply H3.
    Qed.

    Lemma ss_epsilon_r {E F C D X Y L R} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u u0 : ctree F D Y) :
      epsilon u u0 ->
      ss L R t u0 ->
      ss L R t u.
    Proof.
      intros. cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?).
      eapply epsilon_trans in H1; eauto.
    Qed.

    Lemma ssim_epsilon_l {E F C D X Y L} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u : ctree F D Y) :
      (forall t0, epsilon t t0 -> productive t0 -> ssim L t0 u) ->
      ssim L t u.
    Proof.
      intros. step. apply ss_epsilon_l.
      intros. apply H in H1. now step in H1. assumption.
    Qed.

    Lemma ssim_epsilon_r {E F C D X Y L} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
        (t : ctree E C X) (u u0 : ctree F D Y) :
      epsilon u u0 ->
      ssim L t u0 ->
      ssim L t u.
    Proof.
      intros. cbn. intros.
      step in H0. step. eapply ss_epsilon_r in H0; eauto.
    Qed.

    Lemma ssim_ret_epsilon {E F C D X Y L} `{HasB0: B0 -< C} `{HasB0': B0 -< D} :
      forall r (u : ctree F D Y),
      Respects_val L ->
      (Ret r : ctree E C X) (≲L) u ->
      exists r', epsilon u (Ret r') /\ L (val r) (val r').
    Proof.
      intros * RV SIM *.
      step in SIM. specialize (SIM (val r) stuckD (trans_ret _)).
      destruct SIM as (l' & u' & TR & _ & EQ).
      apply RV in EQ as ?. destruct H as [? _]. specialize (H (Is_val _)). inv H.
      apply trans_val_invT in TR as ?. subst.
      apply trans_val_epsilon in TR as []. eauto.
    Qed.

    Lemma ssim_vis_epsilon {E F C D X Y Z L} `{HasB0: B0 -< C} `{HasB0': B0 -< D} :
      forall e (k : Z -> ctree E C X) (u : ctree F D Y),
      Respects_val L ->
      Respects_tau L ->
      Vis e k (≲L) u ->
      forall x, exists Z' (e' : F Z') k' y, epsilon u (Vis e' k') /\ k x (≲L) k' y /\ L (obs e x) (obs e' y).
    Proof.
      intros * RV RT SIM *.
      step in SIM. cbn in SIM. specialize (SIM (obs e x) (k x) (trans_vis _ _ _)).
      destruct SIM as (l' & u'' & TR & SIM & EQ).
      apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR).
      destruct PROD.
      1: {
        subs. inv_trans. subst.
        apply RV in EQ. destruct EQ as [_ ?]. specialize (H (Is_val _)). inv H.
      }
      2: {
        subs. inv_trans. subst.
        apply RT in EQ. destruct EQ as [_ ?]. specialize (H eq_refl). inv H.
      }
      subs. inv_trans. subst.
      eexists _, _, _, _. etrans.
    Qed.

    Lemma ssim_brS_epsilon {E F C D X Y Z L} `{HasB0: B0 -< C} `{HasB0': B0 -< D} :
      forall c (k : Z -> ctree E C X) (u : ctree F D Y),
      Respects_tau L ->
      L tau tau ->
      BrS c k (≲L) u ->
      forall x, exists Z' (c' : D Z') k' y, epsilon u (BrS c' k') /\ k x (≲L) k' y.
    Proof.
      intros * RT HL SIM *.
      step in SIM. cbn in SIM. specialize (SIM tau (k x) (trans_brS _ _ _)).
      destruct SIM as (l' & u'' & TR & SIM & EQ).
      apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR).
      destruct PROD.
      1: {
        subs. inv_trans. subst.
        apply RT in EQ. destruct EQ as [? _]. specialize (H eq_refl). inv H.
      }
      1: {
        subs. inv_trans. subst.
        apply RT in EQ. destruct EQ as [? _]. specialize (H eq_refl). inv H.
      }
      subs. inv_trans. subst.
      eexists _, _, _, _. etrans.
    Qed.

  End epsilon_theory.

#[global] Hint Resolve epsilon_trans : trans.


(**  CS 4240 FINAL PROJECT    **)

(** Here we implement a very simple database data structure and a few SQL-like
commands to go with it. The database is simply a list of columns (which
we define). A column is a function from "header" to some list (either a list
of nats or a list of strings. For simplicity sake, we assume there are only
two possible data types for the entries of this database, nat and string).
Thus, again, a column is just a list of all the entries in said column.
The commands we implement are
   1. insert - insert a row of data into the table
   2. select - select a row of data to be passed to some other function
   3. drop_row - drop a row from the table
   4. drop_column - drop a column from the table
   5. merge - merges two tables    **)

Require Export List.
Require Export String.
Open Scope string_scope.
Open Scope list_scope.
Require Import Ascii.
Require Import Arith.

(** This is the header data type. Headers are represented as nats  **)

Record col_header: Set := make_header {
  get_header_str: string
}.

(**  column data type. it is a function from [nat] to [list nat] in which the
    nat is essentially the "header" of the column and the list is all the
    entries in that column  **)
Inductive column :=
  | make_col_nat : col_header -> list nat -> column
  | make_col_string : col_header -> list string -> column.

(** table data type. it is just a list of columns  **)
Definition table := list column.

Example header1 := make_header "id numbers".
Example header2 := make_header "names".
Example column1 := make_col_nat header1 (1::2::3::nil).
Example column2 := make_col_string header2 ("John"::"Millie"::"Herbert"::nil).
Example table1 := column1::column2::nil.

(**  database data type. Is essentially just a list of rows  **)
Definition db := list table.

(** Insert into a column. If the column is a string type, the function
will attempt to insert the string parameter. If column is nat, then the nat **)
Definition colinsert (dbcol : column) (X: nat) (Y: string) : column :=
 match dbcol with
 | make_col_nat header listnat => make_col_nat header (X::listnat)
 | make_col_string header liststring => make_col_string header (Y::liststring)
 end.

Example minicolumn1 := make_col_nat header1 (4::nil).
Example minicolumn2 := make_col_string header2 ("Roxanne"::nil).
Example minitable1 := minicolumn1::minicolumn2::nil.

(** Insert a table of size one (such as minitable1, above) into a preexisting table **)
Fixpoint insert (dbtable sizeonetable : table) : table :=
 match dbtable with
 | nil => dbtable
 | cons h t =>
  match h with
  | make_col_nat mainheader mainlistnat =>
   match sizeonetable with
   | nil => dbtable
   | cons oh ot =>
    match oh with
    | make_col_nat oheader olistnat =>
     match olistnat with
     | _ :: _ :: _ => dbtable
     | nil => dbtable
     | cons val nil => (colinsert h val "null")::(insert t ot)
     end
    | make_col_string oheader oliststring => dbtable
    end
   end
  | make_col_string mainheader mainliststring =>
   match sizeonetable with
   | nil => dbtable
   | cons oh ot =>
    match oh with
    | make_col_string oheader oliststring =>
     match oliststring with
     | _ :: _ :: _ => dbtable
     | nil => dbtable
     | cons val nil => (colinsert h 0 val)::(insert t ot)
     end
    | make_col_nat oheader olistnat => dbtable
    end
   end
  end
 end.

Compute insert table1 minitable1.

(** A string equivalency function, necessary for checking names of fields against parameters, found from stack overflow **)
Fixpoint beq_str (sa sb : string) {struct sb}: bool :=
   match sa, sb with
 | EmptyString, EmptyString  => true
 | EmptyString, String b sb' => false
 | String a sa', EmptyString => false
 | String a sa', String b sb'=> match (ascii_dec a b) with
                                | left _ => beq_str sa' sb'
                                | right _ => false
                                end
 end.

(** Takes in a table and a field name, and drops the column of the given name **)
Fixpoint dropcolumn(dbtable: table)(s: string) : table :=
  match dbtable with
  | nil => nil
  | cons h t => match h with
            | make_col_string head list =>
              if (beq_str (get_header_str head) s) then t else h::(dropcolumn t s)
            | make_col_nat hnat lnat =>
              if (beq_str (get_header_str hnat) s) then t else h::(dropcolumn t s)
end
end.

Check (get_header_str header1).
Compute (get_header_str header1).
Compute dropcolumn table1 "names".

(** A helper function for selectWhere. Finds the index of the given value among a list of nats **)
Fixpoint getNatIndex (natlist: list nat) (value: nat) (index: nat) : nat :=
  match natlist with
  | h'::t' => if (beq_nat value h') then index
              else getNatIndex t' value (S (index))
  | nil => index
  end.

(** A helper function for selectWhere. Finds the index of the given value among a list of strings **)
Fixpoint getStringIndex (stringlist: list string) (value: string) (index: nat) : nat :=
  match stringlist with
  | h'::t' => if (beq_str value h') then index
              else getStringIndex t' value (S (index))
  | nil => index
  end.

(** A helper function for selectWhere. Calls the two functions above to find the index of the
given value from the entire table **)
Fixpoint selectIndex (table: table)(field : string)(natval: nat)(stringval: string): nat :=
 match table with
 | cons h t =>
  match h with
  | make_col_nat natheader natlist =>
   if (beq_str (get_header_str natheader) field)
   then getNatIndex natlist natval 0
   else selectIndex t field natval stringval
  | make_col_string stringheader stringlist =>
   if (beq_str (get_header_str stringheader) field)
   then getStringIndex stringlist stringval 0
   else selectIndex t field natval stringval
  end
 | nil => 0
 end.

(** A helper function for selectWhere. Returns the value, from a list of nats, at a given index. Used to help build
the return value for selectWhere **)
Fixpoint natElemAt (list: list nat) (index: nat): nat :=
 match list with
 | h::t => match index with
          | 0 => h
          | S n => natElemAt t n
          end
 | nil => 0
 end.

(** A helper function for selectWhere. Returns the value, from a list of strings, at a given index. Used to help build
the return value for selectWhere **)
Fixpoint stringElemAt (list: list string) (index: nat): string :=
 match list with
 | h::t => match index with
          | 0 => h
          | S n => stringElemAt t n
          end
 | nil => "no valid string"
 end.

Compute selectIndex table1 "id numbers" 5 "John".
Compute stringElemAt ("Bob"::"Rick"::"Matt"::nil) 1.

Compute selectIndex table1 "id numbers" 3 "test".
Compute selectIndex table1 "names" 3 "Herbert".

(** selectWhere. Takes in the full table, a second table (to recurse over), the field, a natval and a stringval.
The function will only use one of the natval or stringval, depending on the given field's type. **)

Fixpoint selectWhere (table: table)(rec_table: list column)(field: string)(natval: nat)(stringval: string): list column :=
 match rec_table with
 | cons h t =>
  match h with
  | make_col_nat natheader natlist =>
                 make_col_nat natheader ((natElemAt natlist (selectIndex table field natval stringval))::nil)::(selectWhere table t field natval stringval)
  | make_col_string stringheader stringlist =>
                 make_col_string stringheader ((stringElemAt stringlist (selectIndex table field natval stringval))::nil)::(selectWhere table t field natval stringval)
  end
 | nil => nil
 end.

Compute selectWhere table1 table1 "id numbers" 3 "test".
(** Two of the same tables are initially passed in to the function for the following reason:
 in 'Compute selectWhere table1 table1 "id numbers" 3 "Millie"' above, we iterate over the columns in the second
table1, replacing them with columns of height=1. This changes the index of id number 3 from 2 to 0 in the resulting table,
and thus, we would end up using the name at index 0... not the one we want. By supplying a second table to the function,
we have an unaltered reference from which we can derive the proper indicies. **)

(** helper function for the merge command that takes two columns and checks to see if
they have the same header. If they do, they will be combined into one column in the merge
function that follows **)

Definition combine_cols(c1 c2: column) : column :=
  match c1, c2 with
  | make_col_nat h1 l1, make_col_nat h2 l2 =>
        if (beq_str (get_header_str h1)(get_header_str h2)) then make_col_nat h1 (l1++l2)
        else c1
  | make_col_string h1 l1, make_col_string h2 l2 =>
        if (beq_str (get_header_str h1)(get_header_str h2)) then make_col_string h1 (l1++l2)
        else c1
  | make_col_nat _ _, make_col_string _ _ => c1
  | make_col_string _ _, make_col_nat _ _ => c1
end.

(** Merge command. Takes two tables and combines columns of the two seperate tables
 that have the same header **)

Fixpoint merge (t1 t2: table) : table :=
  match t1, t2 with
    | nil, nil => nil
    | nil, _ => t2
    | _, nil => t1
    | h::t, h'::t' =>
      match h, h' with
      | make_col_nat h1 l1, make_col_nat h2 l2 => (combine_cols h h')::(merge t t')
      | make_col_string h1 l1, make_col_string h2 l2 => (combine_cols h h')::(merge t t')
      | make_col_string _ _, make_col_nat _ _ => merge t t'
      | make_col_nat _ _, make_col_string _ _ => merge t t'
end
end.

Example table2 := column1::column2::nil.

(** This should merge the columns of table1 and table2 that have the same
headings. Thus, there will be the same number of columns in the resulting
table as the two that are being merged, but all of the data from each
table will be in one table.  **)

Compute merge table1 table2.

(** This will drop the column titled "id numbers" from table1. As a result
table1 will be left with one column, "names" **)
Compute dropcolumn table1 "id numbers".

(** the following code was found online and used as a sort function (used in drop rows)**)
Fixpoint leqb (m n : nat) {struct m} : bool :=
  match m with
  | 0 => true
  | S m => match n with
           | 0 => false
           | S n => leqb m n
           end
  end.

Eval compute in leqb 3 4.
Eval compute in leqb 4 3.

Fixpoint insert1 (n:nat)(ms : list nat) {struct ms} : list nat :=
  match ms with
  | nil => n::nil
  | m::ms' => if leqb n m
              then n::ms
              else m::(insert1 n ms')
  end.

Eval compute in insert1 3 (1::2::4::nil).

Fixpoint sort (ms : list nat) : list nat :=
  match ms with
  | nil => nil
  | m::ms' => insert1 m (sort ms')
  end.

Eval compute in sort (4::2::3::1::nil).

(** end of sorting code from internet**)

Fixpoint drop_row_in_list {X:Type} (l: list X) (index : nat) (count: nat) : list X :=
                           match l with
                                | nil => nil
                                | cons h t => if (beq_nat index count) then t else h::(drop_row_in_list t index (count+1))
                                  end.

Definition drop_row_in_col (c: column) (index : nat) : column :=
                   match c with
                        | make_col_nat h ln => make_col_nat h (drop_row_in_list ln index 1)
                        | make_col_string h2 ls => make_col_string h2 (drop_row_in_list ls index 1)
                      end.

Fixpoint drop_a_row (t : table) (index : nat) : table :=
             match t with
               | nil => t
               | cons current_col other_cols => (drop_row_in_col current_col index)::(drop_a_row other_cols index)
                end.

Fixpoint drop_rows_impl (t: table) (indexes : list nat) (drop_number: nat) : table :=
          match indexes with
                | nil => t
                | cons head tail => drop_rows_impl (drop_a_row t (head - drop_number)) tail (drop_number + 1)
                end.

Definition drop_rows (t: table) (indexes: list nat) : table :=
          drop_rows_impl t (sort indexes) 0.

(**some examples to show the drop rows functionality**)
Example c1 := make_col_nat header1 (1::2::3::4::5::nil).
Example c2 := make_col_string header2 ("alpha"::"beta"::"charlie"::"delta"::"echo"::nil).

Example table_test := c1::c2::nil.

Compute table_test.

Compute drop_rows table_test (2::3::nil).
Compute drop_rows table_test (1::5::3::nil).
Compute drop_rows table_test (4::5::3::nil).
Compute drop_rows table_test (nil).

(**end of examples to test drop rows functionality**)

(* the following functions are to implement get_rows, which we do by calling drop_rows on all
of the rows that aren't passed to get_rows*)

(*boolean function to determine if a given nat is in a given list of nats, used in the xor function*)
Fixpoint contains (l: list nat) (n: nat) : bool :=
                match l with
                     | nil => false
                     | h::t => if (beq_nat h n) then true else (contains t n)
                     end.

(*xor takes two lists of nats and returns the list of nats that are in either but not both.
we use this function in our implementation of get_rows, which we do by dropping all the rows that
we don't want to get*)

Fixpoint xor (l1: list nat) (l2: list nat) : list nat :=
                    match l1 with
                         | nil => nil
                         | h::t => if (contains l2 h) then xor t l2 else h::(xor t l2)
                           end.

(*demonstrating the xor functionality*)

Compute xor (1::2::5::7::2::1::8::nil) (1::2::4::1::6::8::nil).

(*helper function for length_impl*)

Fixpoint length_impl {X : Type} (l: list X) (start: nat) : nat :=
       match l with
         | nil => start
         | h::tail => length_impl tail (start + 1)
          end.

(*function to determine the length of a table, where the length is defined as the number of rows*)

Definition length (t: table) : nat :=
            match t with
                | nil => 0
                | h::t => match h with
                              | make_col_nat hd1 ln1 => length_impl ln1 0
                              | make_col_string hd2 ln2 => length_impl ln2 0
                              end
                  end.

(*helper function for length_list*)

Fixpoint length_list_impl (n : nat) (count: nat) : list nat :=
           match n with
               | O => nil
               | S n' => (count::(length_list_impl n' (count+1)))
                  end.

(*function to create a list nat from 1 to the specified length with every nat in between*)
Definition length_list (n: nat) : list nat :=
              length_list_impl n 1.

(*demonstrating the above functionality*)

Compute length_list 10.
Compute length table_test.

(*the get_rows function is implemented using the drop_rows function. We use the xor function to
 produce a list of nats that represent all of the rows you don't want to get, and simply drop those rows
to produces to the desired new table*)

Definition get_rows (t: table) (indexes: list nat) : table :=
        drop_rows t (xor (length_list (length t)) (indexes)).

(**same as dropping all the rows you don't want to get**)

(*demonstrating the functionality of get_rows*)
Compute get_rows table_test (1::3::5::nil).

(*the following several functions are all to implement an innerjoin, which takes two tables,
 a join column from the first table, and a join column from the second table, and produces a
new table which consists of rows comprised of all column types from the first and second tables.
For all rows in the new table, the values of the columns from the specified join columns are equal.
This implementation is designed to join on a single column from each table*)

(*function to take two rows and combine them into a larger row. treating a row as a table, and assuming its of length 1*)
Fixpoint merge_rows (t1: table) (t2: table) : table :=
                match t1, t2 with
               | nil, nil => nil
               | nil, _ => t2
               | _, nil => t1
               | h::tail, _ => h::(merge_rows (tail) (t2))
                end.

(*demonstrating the functionality of merge_rows*)
Example header3 := make_header "age".
Example c5 := make_col_nat header3 (30::nil).
Example c6 := make_col_nat header1 (2::nil).
Example c7 := make_col_string header2 ("steve"::nil).
Example header4 := make_header "eye_color".
Example c8 := make_col_string header4 ("brown"::nil).

Example row :=  c5::c7::nil.
Example row2 := c6::c8::nil.

Compute row.
Compute row2.
Compute merge_rows row row2.

(*natprod is the same as we defined it in class*)
Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

(** similar to getNatIndex, except it returns a list of all of the indices where the given nat value is equal
to a value in the list of strings**)

Fixpoint getNatIndices (natlist: list nat) (value: nat) (index: nat) : list nat :=
  match natlist with
  | h'::t' => if (beq_nat value h') then index::(getNatIndices t' value (index + 1))
              else getNatIndices t' value (S (index))
  | nil => nil
  end.

(** similar to getStringIndex, except it returns a list of all of the indices where the given string value is equal
to a value in the list of strings**)
Fixpoint getStringIndices (stringlist: list string) (value: string) (index: nat) : list nat :=
  match stringlist with
  | h'::t' => if (beq_str value h') then index::(getStringIndices t' value (index + 1))
              else getStringIndices t' value (S (index))
  | nil => nil
  end.

(*function to take list of natprods and return a list of nats, where the nats are the
second values from each natprod in the given list of natprods. *)

Fixpoint get_second_val (l : list natprod) : list nat :=
                  match l with
                      | nil => nil
                      | (pair h t)::tail => t::(get_second_val tail)
                        end.

(*function to take a given nat and list of nats, and return a list of natprods
equal to the length of the given list of nats, in which the first element of every natprod
is the given nat and the second value is the value from the given list of nats that is at the
position in the list as the new list. for example, stich 1, 1::2::4::nil would yeild (1,1)::(1,2)::1,4)::nil*)

Fixpoint stitch (n: nat) (l : list nat) : list natprod :=
        match l with
          | nil => nil
          | h::t => (pair n h)::(stitch n t)
           end.

(*function to combine two natprod's, based on the function app that we defined in class*)

Fixpoint appNatProd (l1 l2 : list natprod)
                : (list natprod) :=
  match l1 with
  | nil  => l2
  | cons h t => cons h (app t l2)
  end.

(*the following four function are the helper functions and functions for getting the tuples
that tell us which rows to merge together from the specified columns. There's a version for
both constructors of columns, one of which relies on getNatIndices and the other on getStringIndices.
The value 1 is passed to both functions as the starting index, because the first row in a table is
considered row 1*)

Fixpoint get_tuples_from_list_nat_impl (l1: list nat) (l2: list nat) (index: nat) : list natprod :=

                         match l1 with
                              | nil => nil
                              | h::t =>  match (getNatIndices l2 h 1) with
                                          | nil => get_tuples_from_list_nat_impl t l2 (index+1)
                                          | _ => appNatProd(stitch index (getNatIndices l2 h 1)) (get_tuples_from_list_nat_impl t l2 (index+1))
                                                              end
                                end.

Definition get_tuples_from_list_nat (l1: list nat) (l2: list nat) : list natprod :=
                    get_tuples_from_list_nat_impl l1 l2 1.

Fixpoint get_tuples_from_list_string_impl (l1: list string) (l2: list string) (index: nat) : list natprod :=

                         match l1 with
                              | nil => nil
                              | h::t =>  match (getStringIndices l2 h 1) with
                                          | nil => get_tuples_from_list_string_impl t l2 (index+1)
                                          | _ => appNatProd(stitch index (getStringIndices l2 h 1)) (get_tuples_from_list_string_impl t l2 (index+1))
                                                              end
                                end.

Definition get_tuples_from_list_string (l1: list string) (l2: list string) : list natprod :=
                    get_tuples_from_list_string_impl l1 l2 1.

(* at the heart of the implenetation of inner join, get_tuples take two columns and returns the list
of pairs that represent which rows should be merged together in the new table, based on the equivalency of
values in the specified columns to join on *)

Definition get_tuples (col1: column) (col2: column) : list natprod:=
                    match col1 with
                         | make_col_nat hd1 ln1 => match col2 with
                                                         | make_col_nat hd2 ln2 => get_tuples_from_list_nat ln1 ln2
                                                         | _ => nil
                                                        end
                         | make_col_string hd3 ln3 => match col2 with
                                                         | make_col_string hd4 ln4 => get_tuples_from_list_string ln3 ln4
                                                         | _ => nil
                                                          end
                                     end.

(*demonstrating the functionality of get_tuples*)

Example c9 := make_col_nat header1 (3::2::2::4::1::nil).

Compute c1.
Compute c9.
Compute get_tuples c1 c9.

(*this function is the implementation of inner join. The function relies on being passed the
list of natprods that tell which rows to join together. For example, (1,2) would mean row 1 from
the first table and row 2 from the second. It merges the specified rows from each table using the
function merge_rows, and puts all these rows together into a single table using the function merge*)

Fixpoint do_inner_join (t1: table) (t2: table) (key: list natprod) : table :=
          match key with
           | nil => nil
           | (pair r1 r2)::ktail => merge (merge_rows (get_rows t1 (r1::nil)) (get_rows t2 (r2::nil))) (do_inner_join t1 t2 ktail)
              end.

(*final inner join function, which simply calls the function do_inner_join, which is passed the list of
  natprods produced from calling the function get_tuples on the two columns chosen to join on*)

Definition inner_join (t1: table) (t2: table) (col1 : column) (col2 : column) : table :=
                     do_inner_join t1 t2 (get_tuples (col1) (col2)).

(*Example of inner join working. In this example, table A has names and ID numbers, and table B has
names and dates (represented simply as strings), the inner join joins on the column for names in each. Notice that Mike appears in the resulting table twice,
as one would expect with an inner join, because he is in table B twice. *)

Example names_header := make_header "Names".
Example ID_header := make_header "ID".
Example date_header := make_header "Date".

Example A_names := make_col_string names_header ("Mike"::"Kyle"::"Adam"::"Ricky"::"Morty"::nil).
Example A_id := make_col_nat ID_header (1::2::3::4::5::nil).

Example B_names := make_col_string names_header ("Mike"::"Steve"::"Mike"::"Bob"::"Kyle"::nil).
Example B_date := make_col_string date_header ("1/1/2014"::"2/1/2014"::"3/1/2014"::"4/1/2014"::"5/1/2014"::nil).

Example table_A := A_names::A_id::nil.
Example table_B := B_names::B_date::nil.

Compute table_A.
Compute table_B.

Compute inner_join table_A table_B A_names B_names.

(*the below work is to implement a natural join, which we represent as an extention of an inner join,
where the columns to join on from each table are not manually entered, but rather are determined automatically
based on the which column in each table has the same column header as another column in the other table*)

(*our representation of a null header and null column, since some of the helper functions are required
to return a column header or null and there is no null constructor for either of those*)

Definition NULL_Header := make_header "NULL".
Definition NULL_Col := make_col_string NULL_Header nil.

(*function to return a list of the column headers in a given table. This is necessary for use in later
functions to compare two lists of headers (instead of tables directly) to determine which column header, and
 ultimately what column, should be joined on in a natural join*)

Fixpoint get_table_headers (t: table) : list col_header :=
            match t with
              | nil => nil
              | col_head::col_tail => match col_head with
                                       | make_col_nat hd1 ln1 => hd1::(get_table_headers col_tail)
                                       | make_col_string hd2 ln2 => hd2::(get_table_headers col_tail)
                                           end
              end.

(*function to determine whether two headers are equal. We define headers as equal if they are created
 using the same string (make_header is the only possible constructor for a header*)

Definition beq_header (h1: col_header) (h2: col_header) : bool :=
               match h1 with
                    | make_header string1 => match h2 with
                                                  | make_header string2 => beq_str string1 string2
                                                             end
                    end.

(*boolean function to determine whether or not a column header is in a list of column headers.
 this function is neccessary to implement the logic of the function that chooses which column header
 corresponds to the column to join on in a natural join*)

Fixpoint contains_header (h: col_header) (lh: list col_header) : bool :=
                              match lh with
                                 | nil => false
                                 | head::tail => if(beq_header h head) then true else contains_header h tail
                                end.

(*function that implements the logic of automatically choosing which column to join on in a natural join.
 A special "NULL_Header" was created in the event that there was no appropriate column to join on, since
the function has to return a column header. It relies on the logic of contains_header, and essentially choose
 a column header from the first list that also appears in the second list. This will only work as in intentioned
when there is a single common header in the two lists*)

Fixpoint get_natural_header (lh1: list col_header) (lh2: list col_header) : col_header :=
               match lh1 with
                 | nil => NULL_Header
                 | h::t => if(contains_header h lh2) then h else get_natural_header t lh2
                     end.

(*function to get a column in a table with a specified header, which is necessary for the get_natural_col
 function, and ultimately a natural join, to work*)

Fixpoint get_col_from_header (t : table) (head:col_header) : column :=
                              match t with
                               | nil => NULL_Col
                               | c1::ct => match c1 with
                                            | make_col_nat hd ln => if(beq_header hd head) then c1 else get_col_from_header ct head
                                            | make_col_string hd ln => if(beq_header hd head) then c1 else get_col_from_header ct head
                                                     end
                                 end.

(*function to return which column to join on in a natural join. relies on get_natural_headers to do the implementation,
 and using the function get_table_headers to get a list of table headers from a table*)

Definition get_natural_col (t1 : table) (t2: table) : column :=
           get_col_from_header t1 (get_natural_header (get_table_headers t1) (get_table_headers t2)).

(*below is the natural join function. it essentially calls inner join, and automatically
 determines the two parameters that specify which columns to join on using a helper function
  get_natural col. This is designed for there being only one overlapping column in the two tables,
  and is not built to handle multiple columns with equal headers*)

Definition natural_join (t1: table) (t2: table) : table :=
           inner_join t1 t2 (get_natural_col t1 t2) (get_natural_col t2 t1).

Compute table_A.
Compute table_B.
Compute inner_join table_A table_B A_names B_names.
Compute natural_join table_A table_B.
(* notice that the results for the inner join and natural join are the same,
but for natural join the function automatically determined which columns to join on
whereas they had to be specified in inner_join. *)

(*the following functions are to implement another query function, which returns all the rows
in a given table, where the values in a specified column meet a specified condition. There are two
different functions, one for use when the column is composed of strings, and the other nats.*)

Fixpoint leq_bool (n: nat) (n2: nat) : bool :=
                match n with
                     | O => true
                     | S n' => match n2 with
                                   | O => false
                                   | S n2' => leq_bool n' n2'
                                      end
                       end.

Fixpoint getNatIndices' (eq: nat->nat->bool) (l: list nat) (value: nat) (index: nat) : list nat :=
  match l with
  | h'::t' => if (eq h' value) then index::(getNatIndices' eq t' value (index + 1))
              else getNatIndices' eq t' value (S (index))
  | nil => nil
  end.

Fixpoint getStringIndices' (eq: string->string->bool) (l: list string) (value: string) (index: nat) : list nat :=
  match l with
  | h'::t' => if (eq h' value) then index::(getStringIndices' eq t' value (index + 1))
              else getStringIndices' eq t' value (S (index))
  | nil => nil
  end.

Example l1 := length_list 10.
Compute l1.
Compute getNatIndices' leq_bool l1 6 1.

Definition getWhereNat (t: table) (c: column) (f: nat->nat->bool) (value: nat) : table :=
                    match c with
                          | make_col_nat head1 ln => get_rows t (getNatIndices' f ln value 1)
                          | _ => nil
                        end.

Compute table_test.
Compute getWhereNat table_test c1 leq_bool 3.

Definition getWhereString (t: table) (c: column) (f: string->string->bool) (value: string) : table :=
                    match c with
                          | make_col_string head1 ls => get_rows t (getStringIndices' f ls value 1)
                          | _ => nil
                        end.


(** This file implements boolsets as functions into Prop. *)
From stdpp Require Export prelude.
From stdpp Require Import options.

Record boolset (A : Type) : Type := BoolSet { boolset_car : A → bool }.
Arguments BoolSet {_} _ : assert.
Arguments boolset_car {_} _ _ : assert.

Instance boolset_top {A} : Top (boolset A) := BoolSet (λ _, true).
Instance boolset_empty {A} : Empty (boolset A) := BoolSet (λ _, false).
Instance boolset_singleton `{EqDecision A} : Singleton A (boolset A) := λ x,
  BoolSet (λ y, bool_decide (y = x)).
Instance boolset_elem_of {A} : ElemOf A (boolset A) := λ x X, boolset_car X x.
Instance boolset_union {A} : Union (boolset A) := λ X1 X2,
  BoolSet (λ x, boolset_car X1 x || boolset_car X2 x).
Instance boolset_intersection {A} : Intersection (boolset A) := λ X1 X2,
  BoolSet (λ x, boolset_car X1 x && boolset_car X2 x).
Instance boolset_difference {A} : Difference (boolset A) := λ X1 X2,
  BoolSet (λ x, boolset_car X1 x && negb (boolset_car X2 x)).
Instance boolset_top_set `{EqDecision A} : TopSet A (boolset A).
Proof.
  split; [split; [split| |]|].
  - by intros x ?.
  - by intros x y; rewrite <-(bool_decide_spec (x = y)).
  - split; [apply orb_prop_elim | apply orb_prop_intro].
  - split; [apply andb_prop_elim | apply andb_prop_intro].
  - intros X Y x; unfold elem_of, boolset_elem_of; simpl.
    destruct (boolset_car X x), (boolset_car Y x); simpl; tauto.
  - done.
Qed.
Instance boolset_elem_of_dec {A} : RelDecision (∈@{boolset A}).
Proof. refine (λ x X, cast_if (decide (boolset_car X x))); done. Defined.

Typeclasses Opaque boolset_elem_of.
Global Opaque boolset_empty boolset_singleton boolset_union
  boolset_intersection boolset_difference.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Vocabularies *)

Set Implicit Arguments.

Require Import Relations Morphisms.
Require Import Sumbool.
Require List.
Require Import ZArith.
Require Import hpattern vgtac.
Require Import TStr.

Notation "A &&& B" := (sumbool_and _ _ _ _ A B)
                        (at level 80, right associativity) : sumbool.
Notation "A ||| B" := (sumbool_or _ _ _ _ A B)
                        (at level 85, right associativity) : sumbool.
Notation "~~ A" := (sumbool_not _ _ A)
                        (at level 75, right associativity) : sumbool.

Definition default {A : Type} (def : A) (opt_v : option A) : A :=
  match opt_v with
    | Some v => v
    | None => def
  end.

Definition opt_eq {A : Type} (req : relation A) : relation (option A) :=
  fun opt_x opt_y =>
    match opt_x, opt_y with
      | Some x, Some y => req x y
      | None, None => True
      | _, _ => False
    end.

Definition list_fold {A C : Type} (f : A -> C -> C) (l : list A) (acc : C)
           : C :=
  List.fold_left (fun acc x => f x acc) l acc.

Fixpoint list_fold2_def {A B C : Type} (f : A -> B -> C -> C)
         (l1 : list A) (l2 : list B) (acc default : C) : C :=
  match l1, l2 with
    | nil, nil => acc
    | (a :: l1')%list, (b :: l2')%list =>
      list_fold2_def f l1' l2' (f a b acc) default
    | _, _ => default
  end.

Fixpoint list_fold2 {A B C : Type} (f : A -> B -> C -> C)
         (l1 : list A) (l2 : list B) (acc : C) : C :=
  match l1, l2 with
    | nil, nil => acc
    | (a :: l1')%list, (b :: l2')%list =>
      list_fold2 f l1' l2' (f a b acc)
    | _, _ => acc
  end.

Definition nat_eqb x y := if eq_nat_dec x y then true else false.

Definition print {A : Type} (_ : A) : unit := tt.
Extract Constant print => "fun _ -> ()".

Definition print2 {A B : Type} (_ : A) (_ : B) : unit := tt.
Extract Constant print2 => "fun _ _ -> ()".

Definition print_when_false {A B : Type} (print : A -> unit) (print_arg : A)
           (step : B -> bool) (arg : B) : bool := step arg.
Extract Constant print_when_false =>
"fun print print_arg step arg ->
 if step arg then true else (print print_arg; false)".

Definition small_step {A B : Type} (f : A -> B) (arg : A) : B := f arg.

Axiom physical_eq : forall (A : Type) (x y : A), bool.
Extract Constant physical_eq => "( == )".
Axiom physical_eq_prop :
  forall A (x y : A) (Heq : physical_eq x y = true), x = y.
Axiom structural_eq : forall {A : Type} (x y : A), bool.
Extract Constant structural_eq => "( = )".
Axiom structural_eq_prop :
  forall A (x y : A) (Heq : structural_eq x y = true), x = y.
Axiom invalid_arg : forall {A : Type} (msg : string_t), A.
Extract Constant invalid_arg => "invalid_arg".

Definition string_lengthZ s := Z.of_nat (S (String.length s)).

Ltac dest_if_dec :=
match goal with
  | [H : context [if ?x then _ else _] |- _] => destruct x; try by auto
  | [ |- context [if ?x then _ else _] ] => destruct x; try by auto
end.

Ltac dest_if :=
match goal with
  | [H : context [if ?cond then _ else _] |- _] =>
    let cond' := fresh "cond" in
    remember cond as cond'; destruct cond'; try by auto
end.

Ltac dest_bool :=
  repeat match goal with
           | [H: andb _ _ = true |- _] => apply Bool.andb_true_iff in H
         end.

Ltac dest_trivial_match :=
match goal with
  | [H: Some _ = match ?x with None => None | _ => _ end |- _ ] =>
    let cond := fresh "cond" in
    remember x as cond; destruct cond; try by auto
  | [H: match ?x with Some _ => _ | None => False end |- _ ] =>
    let cond := fresh "cond" in
    remember x as cond; destruct cond; try by auto
  | [H: match ?x with Some _ => _ | None => false end = true |- _ ] =>
    let cond := fresh "cond" in
    remember x as cond; destruct cond; try by auto
end.

Definition monotone (C A : Type) le gamma :=
  forall (c: C) (x y: A) (Hx: gamma c x) (Hle: le x y), gamma c y.

Definition c_div (x y : Z) : Z :=
  (if Z_ge_dec x 0 then x / y else (- (-x / y)))%Z.

Lemma c_div_monotone :
  forall l u (Hlu : (l <= u)%Z) x (Hx : (0 <= x)%Z), (c_div l x <= c_div u x)%Z.
Proof.
i. unfold c_div.
destruct (Z_eq_dec x 0); [|assert (0 < x)%Z as Hx'; [omega|]]; subst.
- do 4 rewrite Zdiv_0_r; s.
  destruct (Z_ge_dec l 0); destruct (Z_ge_dec u 0); by auto.
- destruct (Z_ge_dec l 0).
  + destruct (Z_ge_dec u 0); [|omega].
    apply Z_div_le; omega.
  + destruct (Z_ge_dec u 0).
    * apply Z.le_trans with 0%Z.
      { apply Z.opp_le_mono; rewrite Z.opp_involutive; s.
        apply Z_div_pos; omega. }
      { apply Z_div_pos; omega. }
    * apply Z.opp_le_mono. do 2 rewrite Z.opp_involutive.
      apply Z_div_le; omega.
Qed.

Lemma list_fold_mor T (t_eq : T -> T -> Prop) U :
  Proper
    ((@Logic.eq U ==> t_eq ==> t_eq) ==> @Logic.eq (list U) ==> t_eq ==> t_eq)
    list_fold.
Proof.
intros f1 f2 Hf l1 l2 Hl i1 i2 Hi; unfold list_fold; subst.
generalize i1 i2 Hi.
induction l2.
- by auto.
- simpl List.fold_left; i; apply IHl2.
  by apply Hf.
Qed.

Lemma list_fold_mor2 T (t_eq : T -> T -> Prop) U (u_eq : U -> U -> Prop) :
  Proper
    ((u_eq ==> t_eq ==> t_eq) ==> SetoidList.eqlistA u_eq ==> t_eq ==> t_eq)
    list_fold.
Proof.
intros f1 f2 Hf l1 l2 Hl i1 i2 Hi; unfold list_fold; subst.
generalize i1 i2 Hi; clear i1 i2 Hi.
induction Hl.
- i; by s.
- simpl List.fold_left; i. apply IHHl.
  by apply Hf.
Qed.

Lemma list_map_mor T U (t_eq : T -> T -> Prop) (u_eq : U -> U -> Prop) :
  Proper
    ((t_eq ==> u_eq) ==> SetoidList.eqlistA t_eq ==> SetoidList.eqlistA u_eq)
    (@List.map T U).
Proof.
intros f1 f2 Hf l1 l2 Hl.
induction Hl.
- s. by constructor.
- s. constructor; [by apply Hf|by auto].
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

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

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand &  Vincent Rahli & Mark Bickford

*)

Require Import sequents_tacs.
Require Import subst_tacs.
Require Import cequiv_tacs.
Require Import tactics2.
Require Import sequents_equality.
Require Import sequents_tacs2.
Require Import per_props.
Require Import lsubst_hyps.

Lemma tequality_image {p} :
  forall lib (A1 A2 F1 F2 : @CTerm p),
    tequality lib
              (mkc_image A1 F1)
              (mkc_image A2 F2)
    <=>
    (tequality lib A1 A2
     # equality lib F1 F2 mkc_base
    ).
Proof.
  intros.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold tequality, nuprl in teq; exrepnd.
    inversion teq0; subst; try not_univ.
    allunfold_per.
    computes_to_value_isvalue.
    unfold tequality; sp.
    + exists eqa; sp.
    + apply equality_in_base_iff; spcast; auto.

  - Case "<-".
    introv e; exrepnd.
    rename e0 into teqa; rename e into teqb.
    unfold tequality in teqa; exrepnd.
    rename eq into eqa.
    exists (per_image_eq lib eqa F1).
    apply CL_image; fold (@nuprl p lib).
    unfold per_image.
    exists eqa A1 A2 F1 F2; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_image))).
    apply equality_in_base in teqb; spcast; auto.
Qed.

Lemma equality_image {p} :
  forall lib (A1 A2 F1 F2 : @CTerm p) i,
    equality lib (mkc_image A1 F1)
             (mkc_image A2 F2)
             (mkc_uni i)
    <=>
    (equality lib A1 A2 (mkc_uni i)
     #  equality lib F1 F2 mkc_base).
Proof.
  introv.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold equality, nuprl in teq; exrepnd.
    inversion teq1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    rename eqa into eqi.
    ioneclose; subst; try not_univ.

    destruct H as [eqa H]; exrepnd.
    computes_to_value_isvalue; GC.
    dands.

    exists eq; sp.
    allrw.
    exists eqa; sp.
    apply equality_in_base_iff; spcast; auto.

  - Case "<-".
    intro eqs.
    destruct eqs as [eqa eqb].
    unfold equality in eqa; exrepnd.
    inversion eqa1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    allfold (@nuprli p lib j0).

    exists eq; sp.
    allrw.

    exists (per_image_eq lib eqa F1).
    unfold nuprli.
    apply CL_image; fold (@nuprli p lib j0).
    unfold per_image.
    exists eqa.

    exists A1 A2 F1 F2; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_image))).
    apply equality_in_base_iff; auto.
Qed.

(**

<<
   H, x : Image (A,f), J |- C ext e

     By imageElimination w

     H, [w:A],  J[f w\x] |- C[f w\x] ext e
>>

 *)

Definition rule_image_elimination {p}
           (A f C e : NTerm)
           (x w : NVar)
           (H J : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_image A f)) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        ((snoc H (mk_hhyp w A))
           ++ (lsubst_hyps [(x, mk_apply f (mk_var w))] J))
        (mk_concl (lsubst  C [(x, mk_apply f (mk_var w))] ) e)
    ]
    [].

(* Lemma hyps_functionality_app {o} :
   forall lib,
   forall s1 s2 : @CSub o,
   forall H1 H2 : @bhyps o,
      (length s1 = length H1) ->
      (hyps_functionality lib (s1 ++ s2) (H1 ++ H2) <=>
        (hyps_functionality lib s1 H1 # hyps_functionality lib s2 H2)).
Proof.
   intro. intro.  remember (length s1). revert Heqn. induction n; intro; intro; induction H1; introv leneq; inversion leneq.
   simpl. split; intros; dands; repnd; auto.

   simpl. *)

Hint Rewrite @nh_vars_hyps_app : core.
Hint Rewrite @nh_vars_hyps_snoc : core.

Lemma rule_image_elimination_true {p} :
  forall lib,
  forall A f C e : NTerm,
  forall x w : NVar,
  forall H J: @barehypotheses p,
    rule_true lib
         (rule_image_elimination
                 A f C e x w H J).
Proof.
   unfold rule_image_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
    (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.
  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_image A f)) ++ J))) as ce2.
  - clear hyp1.
    autorewrite with core in *. allsimpl.
    apply covered_snoc_app_weak.
    auto.
  - exists ce2.

 (* we now start proving the sequent *)
  vr_seq_true.
  rw  @similarity_app in sim; exrepnd.
  rw @similarity_snoc in sim5; exrepnd.
  allsimpl.
  lsubst_tac.
  dup sim5 as eqimg.
  apply equality_in_mkc_image in sim5.
  destruct sim5 as [tA imeq].
  apply equal_in_image_prop in imeq.
  exrepnd.
   subst.
  vr_seq_true  in hyp1.

  pose proof (hyp1 (snoc s1a0 (w, a1) ++ s1b) (snoc s2a0 (w, a1) ++ s2b)) as hh.
  clear hyp1.
  dimp hh.
  + (*  hyp functionality *)
     clear hh.
     introv sim.
     apply similarity_app in sim; exrepnd; subst.
     apply similarity_snoc in sim9; exrepnd; subst.
     spcast.
     autorewrite with core in *.
     allrw @length_snoc; cpx.
     apply app_split in sim0; allrw @length_snoc; cpx; try omega.
     repnd; subst.
     apply snoc_inj in sim5.
     repnd; ginv; subst.
     pose proof (eqh (snoc s2a1 (x, t2) ++ s2b0)) as eqhh.
     autodimp eqhh xx.
     * apply similarity_app.
       eexists; eexists; eexists; eexists; dands; eauto;
       try (allrw length_snoc; omega).
       apply similarity_snoc; simpl.
        eexists; eexists;eexists; eexists. exists w0 p0; dands; eauto.
       lsubst_tac; auto.

     assert (forall J,
             forall a b : hypothesis,
             !LIn w (dom_csub s1a1) ->
             !LIn w (free_vars f) ->
             !LIn w (hyps_free_vars J) ->
             !LIn x (dom_csub s1a1) ->
             (LIn (a,b)
                (combine (substitute_hyps (snoc s1a1 (w, t0))
                          (lsubst_hyps [(x, mk_apply f (mk_var w))] J))
                         (substitute_hyps (snoc s1a1 (x, t1)) J))) ->
                 (cequiv lib (htyp a) (htyp b))).
       { induction J0; introv wns1a1 wnf wnJ xfresh I; simpl in I. destruct I. repndors.
        - destruct a; ginv; simpl.
          eapply cequiv_rw_l_eauto; [apply alpha_eq_sym; apply combine_sub_nest | ].
          unfold lsubst_sub; allsimpl.
          pose proof @lsubst_cequiv_congr.

(* UNIFINISHED *)

Abort.

(* [17] ============ IMAGE EQUALITY ============ *)

  (*
   H |-image(A1,f1) = image(A2,f2) in Type

     By imageEquality ()

     H |- f1 = f2 in Base
     H |- A1 = A2 in Type
 *)
Definition rule_image_equality {p}
           (A1 A2 f1 f2 : NTerm)
           (i : nat)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_image A1 f1)
                      (mk_image A2 f2)
                      (mk_uni i))))
    [ mk_baresequent H (mk_conclax (mk_equality f1 f2 mk_base)),
      mk_baresequent H (mk_conclax (mk_equality A1 A2 (mk_uni i)))
    ]
    [].

(* [17] ============ IMAGE MEMBER EQUALITY ============ *)

  (*
   H |-f a1 = f a2 in image(A,f)

     By imageMemberEquality ()

     H |- a1 = a2 in A
     H |- f = f in Base
 *)
Definition rule_image_member_equality {p}
           (A f a1 a2 : NTerm)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_apply f a1)
                      (mk_apply f a2)
                      (mk_image A f)
                      )))
    [ mk_baresequent H (mk_conclax (mk_equality a1 a2 A)),
      mk_baresequent H (mk_conclax (mk_equality f f mk_base))
    ]
    [].

Lemma rule_image_member_equality_true {p} :
  forall lib,
  forall A f a1 a2 : NTerm,
  forall H : @barehypotheses p,
    rule_true lib
         (rule_image_member_equality
                 A f a1 a2 H).
Proof.
   unfold rule_image_member_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
    (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom p (nh_vars_hyps H)).
   (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply tequality_mkc_equality_implies in h0.
  apply tequality_mkc_equality_implies in h2.
  repnd.
  generalize (teq_and_eq_if_equality lib (mk_image A f) (mk_apply f a1) (mk_apply f a2) s1 s2 H
              wT w1 w2 c1 c4 c2 c6 cT cT0 eqh sim
              ); intro k; lsubst_tac; apply k; clear k; auto.

  - apply tequality_image; dands; auto; destruct h2 as [xx | yy]; auto.
    spcast. apply equality_respects_cequivc; auto.
  - clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply tequality_mkc_equality_implies in hyp3.
  repnd.
  assert ((lsubstc f w0 s1 c1) ~=~( lib)(lsubstc f w0 s2 c0)) by
  ( destruct hyp3 as [xx | yy];
  try (apply equality_in_base in xx); auto).
  spcast.
  generalize_lsubstc_terms f1.
  generalize_lsubstc_terms a11.
  generalize_lsubstc_terms f2.
  generalize_lsubstc_terms a22.
  generalize_lsubstc_terms A1.
  revert hyp1.
  generalize_lsubstc_terms a21.
  revert hyp0.
  generalize_lsubstc_terms a12.
  generalize_lsubstc_terms A2.
  introv teq eq.
  apply tequality_mkc_equality_implies in teq.
  repnd.
  dimp teq1.
  assert (equality lib a11 a22  A1) as eq2.
  + eapply equality_trans with (t2 := a12).
    { destruct teq; auto; spcast. apply equality_respects_cequivc; auto. eapply equality_refl. eauto. }
    { eapply tequality_preserving_equality; [exact hyp |apply tequality_sym;auto ]. }
  +  apply equality_in_mkc_image; dands.
  * eapply tequality_refl; eauto.
  * eapply eq_in_image_eq; [exact eq2 | spcast | spcast]; eauto 3 with slow.
    apply implies_cequivc_apply; auto; apply cequivc_sym; auto.
Qed.

Lemma rule_image_equality_true {p} :
  forall lib,
  forall A1 A2 f1 f2 : NTerm,
  forall i : nat,
  forall H : @barehypotheses p,
    rule_true lib
         (rule_image_equality
                 A1 A2 f1 f2
                 i
                 H).
Proof.
  unfold rule_image_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  inversion wg as [ wfh wfc ]; allsimpl.
  inversion wfc as [ wtt wte ]; allsimpl; clear wfc.
  generalize (hyps (mk_baresequent H (mk_conclax (mk_equality f1 f2 mk_base)))
                   (inl eq_refl))
             (hyps (mk_baresequent H (mk_conclax (mk_equality A1 A2 (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destruct ws1 as [ ws1 ws1' ]; allsimpl.
  destruct ws2 as [ ws2 ws2' ]; allsimpl.
  destruct ws1 as [ wh1 wc1 ]; allsimpl.
  destruct ws2 as [ wh2 wc2 ]; allsimpl.
  destruct ws1' as [ ct1 ce1 ]; allsimpl.
  destruct ws2' as [ ct2 ce2 ]; allsimpl.
  allunfold @closed_type; allsimpl.
  allunfold @closed_extract; allsimpl;
  GC.

  allunfold @closed_type; allunfold @closed_extract; allunfold @nh_vars_hyps; allsimpl.

  assert (covered (@mk_axiom p) (vars_hyps (filter is_nh H))) as ce by prove_seq.
  exists ce.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  allrw @sequent_true_eq_VR.
  rw @VR_sequent_true_all; simpl; introv sim eqh.
  intros.
  lsubst_tac.
  assert ( tequality lib (mkc_uni i) (mkc_uni i)) as Z by
   (apply tequality_mkc_uni).
  assert (wf_term (mk_image A1 f1)) as wfa by (apply wf_image; auto).
  assert (wf_term (mk_image A2 f2)) as wfb by (apply wf_image; auto).

  pose proof (teq_and_eq_if_equality lib (@mk_uni p i) (mk_image A1 f1) (mk_image A2 f2)
              s1 s2 H wT wfa wfb c1 c0 c2 c3 cT cT0 eqh sim) as X.
  lsubst_tac.
  allrw @member_eq;
  allrw <- @member_equality_iff.
  apply X; auto.
  introv hfun ss.
  lsubst_tac.
  clear dependent s1.
  clear dependent s2.
  rename s0 into s1.
  rename s3 into s2.
  apply equality_image.
  rw @VR_sequent_true_ex in hyp1; rw @VR_sequent_true_ex in hyp2. allsimpl.
  generalize (hyp1 s1 s2) (hyp2 s1 s2); clear hyp1 hyp2; intros hyp1 hyp2.
  repeat (dest_imp hyp1 h); repeat (dest_imp hyp2 h); exrepnd.
  lsubst_tac.
  allrw @member_eq;
  allrw <- @member_equality_iff.
  rw @tequality_mkc_equality in hyp0; rw @tequality_mkc_equality in hyp3; repnd.
  dands; auto.
  - generalize_lsubstc_terms A11.
    generalize_lsubstc_terms A22.
    revert hyp0. generalize_lsubstc_terms A21.
    revert hyp9. generalize_lsubstc_terms A12.
    introv aa.
    assert (equality lib A11 A12 (mkc_uni i)) as eq1 by
      ( destruct aa; auto;
        spcast; apply equality_respects_cequivc; auto;
         eapply equality_refl; eauto).
    assert (equality lib A21 A11 (mkc_uni i)) by
      (apply equality_sym; auto).
    introv bb.
    assert (equality lib A21 A22 (mkc_uni i)) as eq2 by
      (destruct bb; auto;
        spcast; apply equality_respects_cequivc; auto;
         eapply equality_refl; eauto).
    eapply equality_trans; [exact hyp2 | auto].

  - allrw @equality_in_base_iff.
    revert hyp3. revert hyp6.
    generalize_lsubstc_terms f11.
    generalize_lsubstc_terms f12.
    generalize_lsubstc_terms f21.
    generalize_lsubstc_terms f22.
    introv aa.
    assert ((f11) ~=~( lib)(f12)) as e1 by
     (destruct aa; auto; apply equality_in_base in H0; auto).
    introv bb.
    assert ((f21) ~=~( lib)(f22)) as e2 by
     (destruct bb; auto; apply equality_in_base in H0; auto).
    spcast.
    eapply cequivc_trans; [exact hyp1| auto].
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)