(* Source language (currently missing: T ::=  T1 /\ T2 | { z => T^z }):

  DSubSup (D<:>)
  T ::= Top | Bot | t.Type | { Type: S..U } | (z: T) -> T^z
  t ::= x | { Type = T } | lambda x:T.t | t t *)
Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

(* ### Syntax ### *)

Definition id := nat.

(* term variables occurring in types, both languages share the same variables definition *)
Inductive var : Type :=
| varF : id -> var (* free, in concrete environment *)
| varB : id -> var (* locally-bound variable *)
.

(* An environment is a list of values, indexed by decrementing ids. *)

Fixpoint indexr {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l' =>
      if (beq_nat n (length l')) then Some a else indexr n l'
  end.

Module D.

Inductive ty : Type :=
| TTop : ty
| TBot : ty
(* (z: T) -> T^z *)
| TAll : ty -> ty -> ty
(* We generalize x.Type to tm.type for arbitrary terms tm.  *)
| TSel : tm -> ty
(* { Type: S..U } *)
| TMem : ty(*S*) -> ty(*U*) -> ty
| TBind  : ty -> ty (* Recursive binder: { z => T^z },
                         where z is locally bound in T *)
| TAnd : ty -> ty -> ty (* Intersection Type: T1 /\ T2 *)

with tm : Type :=
(* x -- free variable, matching concrete environment *)
| tvar : var -> tm
(* { Type = T } *)
| ttyp : ty -> tm
(* lambda x:T.t *)
| tabs : ty -> tm -> tm
(* t t *)
| tapp : tm -> tm -> tm
(* unpack(e) { x => ... } *)
| tunpack : tm -> tm -> tm
.

Inductive vl : Type :=
(* a closure for a lambda abstraction *)
| vabs : list vl (*H*) -> ty -> tm -> vl
(* a closure for a first-class type *)
| vty : list vl (*H*) -> ty -> vl
.

Definition tenv := list ty. (* Gamma environment: static *)
Definition venv := list vl. (* H environment: run-time *)

(* ### Representation of Bindings ### *)

Inductive closed: nat(*B*) -> nat(*F*) -> ty -> Prop :=
| cl_top: forall b f,
    closed b f TTop
| cl_bot: forall b f,
    closed b f TBot
| cl_all: forall b f T1 T2,
    closed b f T1 ->
    closed (S b) f T2 ->
    closed b f (TAll T1 T2)
(* Now we have mutually recursive definitions for closedness on types and terms! *)
| cl_sel_tm: forall b f t,
    closed_tm b f t ->
    closed b f (TSel t)
| cl_mem: forall b f T1 T2,
    closed b f T1 ->
    closed b f T2 ->
    closed b f (TMem T1 T2)
| cl_bind: forall b f T,
    closed (S b) f T ->
    closed b f (TBind T)
| cl_and: forall b f T1 T2,
    closed b f T1 ->
    closed b f T2 ->
    closed b f (TAnd T1 T2)

with closed_tm: nat(*B*) -> nat(*F*) -> tm -> Prop :=
| cl_tvarb: forall b f x,
    b > x ->
    closed_tm b f (tvar (varB x))
| cl_tvarf: forall b f x,
    f > x ->
    closed_tm b f (tvar (varF x))
| cl_ttyp:  forall b f ty,
    closed b f ty ->
    closed_tm b f (ttyp ty)
| cl_tabs:  forall b f ty tm,
    closed b f ty ->
    closed_tm (S b) f tm ->
    closed_tm b f (tabs ty tm)
| cl_tapp:  forall b f tm1 tm2,
    closed_tm b f tm1 ->
    closed_tm b f tm2 ->
    closed_tm b f (tapp tm1 tm2)
| cl_tunpack: forall b f tm1 tm2,
    closed_tm b f tm1 ->
    closed_tm (S b) f tm2 ->
    closed_tm b f (tunpack tm1 tm2)
.

(* open define a locally-nameless encoding wrt to TVarB type variables. *)
(* substitute term u for all occurrences of (varB k) *)
Fixpoint open_rec (k: nat) (u: tm) (T: ty) { struct T }: ty :=
  match T with
    | TTop        => TTop
    | TBot        => TBot
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TSel tm => TSel (open_rec_tm k u tm)
    | TMem T1 T2  => TMem (open_rec k u T1) (open_rec k u T2)
    | TBind T => TBind (open_rec (S k) u T)
    | TAnd T1 T2 => TAnd (open_rec k u T1) (open_rec k u T2)
  end

with open_rec_tm (k: nat) (u: tm) (t: tm) { struct t }: tm :=
       match t with
       | tvar (varF x) => tvar (varF x)
       | tvar (varB x) =>
         if beq_nat k x then u else (tvar (varB x))
       | ttyp ty => ttyp (open_rec k u ty)
       | tabs ty tm => tabs (open_rec k u ty) (open_rec_tm (S k) u tm)
       | tapp tm1 tm2 => tapp (open_rec_tm k u tm1) (open_rec_tm k u tm2)
       | tunpack tm1 tm2 => tunpack (open_rec_tm k u tm1) (open_rec_tm (S k) u tm2)
       end.

(* for backwards compatibility  *)
Definition open u T := open_rec 0 (tvar u) T.
Definition open_tm u t := open_rec_tm 0 (tvar u) t.

Definition open' u T := open_rec 0 u T.
Definition open_tm' u t := open_rec_tm 0 u t.

(* ### Type Formation & Assignment ### *)
Inductive ctx_wf: tenv -> Set :=
| wf_empty:
    ctx_wf []
| wf_cons: forall Gamma T,
    ty_wf Gamma T ->
    ctx_wf Gamma ->
    ctx_wf (T :: Gamma)  (* TODO untangle*)

with ty_wf: tenv -> ty -> Set :=
| wf_top: forall Gamma,
    ty_wf Gamma TTop
| wf_bot: forall Gamma,
    ty_wf Gamma TBot
| wf_mem: forall Gamma T1 T2,
    ty_wf Gamma T1 ->
    ty_wf Gamma T2 ->
    ty_wf Gamma (TMem T1 T2)
| wf_all: forall Gamma T1 T2,
    ty_wf Gamma T1 ->
    ty_wf (T1::Gamma) (open (varF (length Gamma)) T2) ->
    ty_wf Gamma (TAll T1 T2)
| wf_sel: forall Gamma e T1 T2,
    ty_wf Gamma T1 -> (* redundant, but needed for induction(?) *)
    ty_wf Gamma T2 ->
    has_type Gamma e (TMem T1 T2) ->
    ty_wf Gamma (TSel e)

with has_type : tenv -> tm -> ty -> Set :=
| t_var: forall x Gamma T1,
    ctx_wf Gamma ->
    indexr x Gamma = Some T1 ->
    (* ty_wf Gamma T1 -> *)
    has_type Gamma (tvar (varF x)) T1

(*
(* pack a recursive type  *)
| t_var_pack : forall G1 x T1 T1',
           (* has_type G1 (tvar x) T1' -> *)
           indexr x G1 = Some (open (varF x) T1) ->
           T1' = (open (varF x) T1) ->
           closed 1 0 (length G1) T1 ->
           has_type G1 (tvar (varF x)) (TBind T1)
(* unpack a recursive type: unpack(x:{z=>T^z}) { x:T^x => ... }  *)
| t_unpack: forall Gamma x y T1 T1' T2,
           has_type Gamma x (TBind T1) ->
           T1' = (open (varF (length Gamma)) T1) ->
           has_type (T1'::Gamma) y T2 ->
           closed 0 0 (length Gamma) T2 ->
           has_type Gamma (tunpack x y) T2
 *)

(* type selection intro and elim forms *)
| t_seli: forall Gamma e a T1,
          has_type Gamma a T1 ->
          has_type Gamma e (TMem T1 TTop) ->
          has_type Gamma a (TSel e)

| t_sele: forall Gamma e a T1,
          has_type Gamma a (TSel e) ->
          has_type Gamma e (TMem TBot T1) ->
          has_type Gamma a T1

(* intersection typing *)
(*
| t_and : forall Gamma x T1 T2,
           has_type Gamma (tvar x) T1 ->
           has_type Gamma (tvar x) T2 ->
           has_type Gamma (tvar x) (TAnd T1 T2)
*)

| t_typ: forall Gamma T1,
           ty_wf Gamma T1 ->
           has_type Gamma (ttyp T1) (TMem T1 T1)

| t_app: forall Gamma f x T1 T2,
    has_type Gamma f (TAll T1 T2) ->
    has_type Gamma x T1 ->
    has_type Gamma (tapp f x) (open' x T2)

(*
| t_dapp:forall Gamma f x T1 T2 T,
           has_type Gamma f (TAll T1 T2) ->
           has_type Gamma (tvar (varF x)) T1 ->
           T = open (varF x) T2 ->
           closed 0 0 (length Gamma) T ->
           has_type Gamma (tapp f (tvar (varF x))) T
*)
| t_abs: forall Gamma y T1 T2,
           ty_wf Gamma T1 ->
           has_type (T1::Gamma) y (open (varF (length Gamma)) T2) ->
           has_type Gamma (tabs T1 y) (TAll T1 T2)
(*
| t_sub: forall Gamma e T1 T2,
           has_type Gamma e T1 ->
            stp Gamma [] T1 T2 ->
           has_type Gamma e T2
*)
.

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
      | tvar (varF x) => Some (indexr x env)
      (* remove varH *)
        (* | tvar (varH x) => Some None *)
        | tvar (varB x) => Some None
        | ttyp T       => Some (Some (vty env T))
        | tabs T y     => Some (Some (vabs env T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 _ ey)) =>
                  teval n (vx::env2) ey
              end
          end
        | tunpack ex ey =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              teval n (vx::env) ey
          end
      end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

End D.

Declare Scope cc_scope.

Require Import FunInd.
Require Import Recdef.

Module CC.

Inductive sort : Type :=
| Typ : nat -> sort
.

Definition sort_succ (s: sort): sort :=
  match s with
    Typ n => Typ (S n)
  end.

Inductive tm : Type :=
| Sort : sort -> tm
| TTop : tm (* TODO really needed? *)
| TBot : tm (* TODO really needed? *)
| TAll : tm -> tm -> tm
| TSig : tm -> tm -> tm
| tvar : var -> tm
| tabs : tm -> tm -> tm
| tapp : tm -> tm -> tm
| tsig : tm -> tm -> tm
| tfst : tm -> tm
| tsnd : tm -> tm
.

Inductive vl : Type :=
(* a closure for a lambda abstraction *)
| vabs : list vl (*H*) -> tm -> tm -> vl (* TODO: do we need to ensure that a proper type is put into the first tm arg?  *)
| vsig : vl -> vl -> vl
.

Definition tenv := list tm.
Definition venv := list vl.

Module Notations.

  (* \star *)
Notation "⋆" := (Sort (Typ 0)) : cc_scope.

End Notations.

Import Notations.
Open Scope cc_scope.

Fixpoint open_rec (k: nat) (u: tm) (T: tm) { struct T }: tm :=
  match T with
  | Sort U      => Sort U
  | TTop        => TTop
  | TBot        => TBot
  | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
  | TSig T1 T2  => TSig (open_rec k u T1) (open_rec (S k) u T2)
  | tvar (varF x) => tvar (varF x)
  | tvar (varB x) =>
    if beq_nat k x then u else (tvar (varB x))
  | tabs ty tm => tabs (open_rec k u ty) (open_rec (S k) u tm)
  | tapp tm1 tm2 => tapp (open_rec k u tm1) (open_rec k u tm2)
  | tsig tm1 tm2 => tsig (open_rec k u tm1) (open_rec k u tm2)
  | tfst tm => tfst (open_rec k u tm)
  | tsnd tm => tsnd (open_rec k u tm)
  end.

Definition open u T := open_rec 0 (tvar u) T.
Definition open' t T := open_rec 0 t T.

Fixpoint subst (x: nat) (u: tm) (t: tm) : tm :=
  match t with
  | Sort s => Sort s
  | TTop => TTop
  | TBot => TBot
  | TAll t1 t2 => TAll (subst x u t1) (subst x u t2)
  | TSig t1 t2 => TSig (subst x u t1) (subst x u t2)
  | tvar (varF y) =>
    if beq_nat x y then u else (tvar (varF y))
  | tvar (varB y) => tvar (varB y)
  | tabs t1 t2 => tabs (subst x u t1) (subst x u t2)
  | tapp t1 t2 => tapp (subst x u t1) (subst x u t2)
  | tsig t1 t2 => tsig (subst x u t1) (subst x u t2)
  | tfst t => tfst (subst x u t)
  | tsnd t => tsnd (subst x u t)
  end.

Inductive closed: nat(*B*) -> nat(*F*) -> tm -> Prop :=
| cl_sort: forall b f U,
    closed b f (Sort U)
| cl_top: forall b f,
    closed b f TTop
| cl_bot: forall b f,
    closed b f TBot
| cl_all: forall b f T1 T2,
    closed b f T1 ->
    closed (S b) f T2 ->
    closed b f (TAll T1 T2)
| cl_sig: forall b f T1 T2,
    closed b f T1 ->
    closed (S b) f T2 ->
    closed b f (TSig T1 T2)
| cl_tvarb: forall b f x,
    b > x ->
    closed b f (tvar (varB x))
| cl_tvarf: forall b f x,
    f > x ->
    closed b f (tvar (varF x))
| cl_tabs:  forall b f ty tm,
    closed b f ty ->
    closed (S b) f tm ->
    closed b f (tabs ty tm)
| cl_tapp:  forall b f tm1 tm2,
    closed b f tm1 ->
    closed b f tm2 ->
    closed b f (tapp tm1 tm2)
| cl_tsig: forall b f tm1 tm2,
    closed b f tm1 ->
    closed b f tm2 ->
    closed b f (tsig tm1 tm2)
| cl_tfst: forall b f tm,
    closed b f tm ->
    closed b f (tfst tm)
| cl_tsnd: forall b f tm,
    closed b f tm ->
    closed b f (tsnd tm)
.

(* TODO complete the conversion relation *)
Inductive conv: tm -> tm -> Type :=
| conv_refl: forall t, conv t t
.

(* TODO complete the cumulativity/subtyping relation *)
Inductive sub: tm -> tm -> Type :=
| sub_conv: forall t1 t2,
    conv t1 t2 ->
    sub t1 t2
| sub_sort: forall i j,
    i <= j ->
    sub (Sort (Typ i)) (Sort (Typ j))
.

Inductive ctx_wf: tenv -> Type :=
| wf_empty:
    ctx_wf []
| wf_sort: forall Gamma T s,
    has_type Gamma T (Sort s) ->
    ctx_wf Gamma ->
    ctx_wf (T :: Gamma)
with has_type : tenv -> tm -> tm -> Type :=
| t_sort: forall Gamma s,
    has_type Gamma (Sort s) (Sort (sort_succ s))

| t_var: forall x Gamma T s,
    ctx_wf Gamma ->
    indexr x Gamma = Some T ->
    has_type Gamma T (Sort s) -> (* redundant, but makes kind_set definition easier *)
    has_type Gamma (tvar (varF x)) T

| t_allt: forall Gamma T1 T2 s,
    has_type Gamma T1 (Sort s) ->
    has_type (T1 :: Gamma) (open (varF (length Gamma)) T2) (Sort s) ->
    has_type Gamma (TAll T1 T2) (Sort s)

| t_sigt: forall Gamma T1 T2 s,
    has_type Gamma T1 (Sort s) ->
    has_type (T1 :: Gamma) (open (varF (length Gamma)) T2) (Sort s) ->
    has_type Gamma (TSig T1 T2) (Sort s)

| t_topt: forall Gamma,
    has_type Gamma TTop ⋆

| t_bott: forall Gamma,
    has_type Gamma TBot ⋆

| t_abs: forall Gamma t T1 T2 s,
    has_type Gamma (TAll T1 T2) (Sort s) ->
    has_type (T1 :: Gamma) t (open (varF (length Gamma)) T2) ->
    has_type Gamma (tabs T1 t) (TAll T1 T2)

| t_app: forall Gamma f e T1 T2 T,
    has_type Gamma f (TAll T1 T2) ->
    has_type Gamma e T1 ->
    T = (open' e T2) ->
    has_type Gamma (tapp f e) T

| t_sig: forall Gamma e1 e2 T1 T2,
    has_type Gamma e1 T1 ->
    has_type Gamma e2 (open' e1 T2) ->
    has_type Gamma (tsig e1 e2) (TSig T1 T2)

| t_fst: forall Gamma e T1 T2,
    has_type Gamma e (TSig T1 T2) ->
    has_type Gamma (tfst e) T1

| t_snd: forall Gamma e T1 T2,
    has_type Gamma e (TSig T1 T2) ->
    has_type Gamma (tsnd e) (open' (tfst e) T2)

| t_sub: forall Gamma t T T' s,
    has_type Gamma t T ->
    sub T T' ->
    has_type Gamma T' (Sort s) ->
    has_type Gamma t T'
.

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
  | 0 => None
  | S n =>
    match t with
    | tvar (varF x) => Some (indexr x env)
    | tvar (varB x) => Some None
    | tabs T y     =>  Some (Some (vabs env T y))
    | tapp ef ex   =>
      match teval n env ex with
      | None => None
      | Some None => Some None
      | Some (Some vx) =>
        match teval n env ef with
        | Some None => Some None
        | Some (Some (vabs env2 _ ey)) => teval n (vx::env2) ey
        | _ => None
        end
      end
    | tsig t1 t2 =>
      match teval n env t1 with
      | None => None
      | Some None => Some None
      | Some (Some v1) =>
        match teval n env t2 with
        | None => None
        | Some None => Some None
        | Some (Some v2) => Some (Some (vsig v1 v2))
        end
      end
    | _ => None
    end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

Fixpoint tsize_flat(T: tm) :=
  match T with
  | TAll T1 T2 => S (tsize_flat T1 + tsize_flat T2)
  | TSig T1 T2 => S (tsize_flat T1 + tsize_flat T2)
  | _ => 1
  end.
Lemma open_preserves_size: forall T x j,
    tsize_flat T = tsize_flat (open_rec j (tvar (varF x)) T).
Proof.
  intros T. induction T; intros; simpl; eauto. simpl.
  - destruct v; auto. simpl; destruct (beq_nat j i); eauto.
Qed.

Definition vset := vl -> Prop.

(* (* *)
(*   This computes the *types* of the sets that kinds represent (cf. V(_) interp in Geuvers '94), *)
(*   i.e., this is a dependent type indexed by the kinds in the system . Since we lump *)
(*   everything into one syntactic category, we define it inductively over typing derivations yielding ◻. *) *)
(* Fixpoint kind_set Gamma K (proof: has_type Gamma K ◻): Type := *)
(*   match proof with *)
(*   | t_box _ => (* ⋆ *) *)
(*     vset *)
(*   | t_var x Gamma T Box _ _ T_is_kind => *)
(*     (kind_set Gamma T T_is_kind) *)
(*   | t_allt Gamma T1 T2 Box Box T1_is_kind T2_is_kind =>  (* Πα:T1.T2, T1:◻ *) *)
(*     let V1 := (kind_set Gamma T1 T1_is_kind) in *)
(*     let V2 := (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) T2_is_kind) in *)
(*     V1 -> V2 *)
(*   | t_allt Gamma T1 T2 Star Box p1 p2 => (* Πα:T1.T2, T1:⋆ *) *)
(*     (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) p2) *)
(*   | t_sigt Gamma T1 T2 Box Box Box _ T1_is_kind T2_is_kind => (* Σα:T1.T2, T1:◻, T2:◻  *) *)
(*     let V1 := (kind_set Gamma T1 T1_is_kind) in *)
(*     let V2 := (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) T2_is_kind) in *)
(*     V1 -> V2 -> Prop (* V1 × V2 *) *)
(*   | t_sigt Gamma T1 T2 Star Box Box _ _ T2_is_kind => (* Σα:T1.T2, T1:⋆, T2:◻ *) *)
(*     (kind_set (T1 :: Gamma) (open (varF (length Gamma)) T2) T2_is_kind) *)
(*   | t_sigt Gamma T1 T2 Box Star Box _ T1_is_kind _ => (* Σα:T1.T2, T1:◻, T2:⋆ *) *)
(*     (kind_set Gamma T1 T1_is_kind) *)
(*   | _ => False *)
(*   end. *)

(* Design idea:
   terms and types are separate GADTs indexed by their sort, classifying their universe.
   Might yield more concise and readable definitions (such as kind_set).
Inductive ty: sort -> Type :=
| TAll : forall s s',
    ty s -> ty s' -> ty s'
| TSig : forall s s',
    ty s -> ty s' -> ty s'
| TTm: forall s,
    tm s -> ty s
with tm: sort -> Type :=
| tvar : forall s,
    var -> tm s (* TODO: might make sense to index variables with their sort *)
| tabs : forall s s',
    ty s -> tm s' -> tm s'
| tapp : forall s s',
    tm s -> tm s' -> tm s (* TODO: correct? *)
| tsig : forall s s',
    ty s -> tm s' -> tm s'
| tfst : forall s, tm s -> tm s
| tsnd : forall s, tm s -> tm s
| tty: forall s, ty s -> tm s
.

Potentially interesting, since we could define
a sort-indexed evaluator, that describes evaluation/normalization
at runtime and at type level.
*)

Definition renv := list vset.

(* TODO *)
Function val_type (rho: renv) (T: tm) (v: vl) {measure tsize_flat T} : Prop :=
  match T, v with
  | TTop, _ => True
  | _, _ => False
  end.
Qed.

(* TODO val_type_unfold *)

Definition R_env gamma rho Gamma :=
  length gamma = length Gamma /\
  length rho = length Gamma /\
  forall x TX, indexr x Gamma = Some TX ->
          (exists (vsx:vset) vx,
              indexr x gamma = Some vx /\
              indexr x rho = Some vsx /\
              val_type rho TX vx).

Definition strong_normalization := forall e Gamma T,
      has_type Gamma e T ->
      has_type Gamma T ⋆ ->
      forall gamma rho, R_env gamma rho Gamma ->
              exists v, tevaln gamma e v.

(* TODO: prove strong normalization *)

End CC.


Require Import List.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype bigop fingraph finfun finset.

(* Add LoadPath "~/Git/YC_in_Coq/". *)
Require Import fl.cfg.Definitions.

Module Base.

  Import Definitions.

  Section Definitions.

    Context {Tt Vt: Type}.

    Definition word := list (@ter Tt).

    Definition language := word -> Prop.

    Definition language_union (l1 l2 : language) := fun w => (l1 w) \/ (l2 w).

    Definition language_intersection (l1 l2 : language) := fun w => (l1 w) /\ (l2 w).

    Definition language_eq (l1  l2 : language) := forall w : word, l1 w <-> l2 w.

    Notation "l1 [\/] l2" := (language_union l1 l2) (at level 85).
    Notation "l1 [/\] l2" := (language_intersection l1 l2) (at level 80).
    Notation "l1 [==] l2" := (language_eq l1 l2) (at level 90).

  End Definitions.

  Section Kek.

    Fixpoint to_phrase {T V: Type} (w: word): @phrase T V :=
      match w with
        | s::sx => Ts s :: to_phrase sx
        | _ => [::]
      end.

  End Kek.

  Section Lemmas.

     Context {Tt Vt: Type}.
    (* TODO: del *)
    Notation "l1 [\/] l2" := (language_union l1 l2) (at level 85).
    Notation "l1 [/\] l2" := (language_intersection l1 l2) (at level 80).
    Notation "l1 [==] l2" := (language_eq l1 l2) (at level 90).

    Lemma mk_laguage_eq :
      forall (l1 l2 : @language Tt),
        (forall w, l1 w -> l2 w) ->
        (forall w, l2 w -> l1 w) -> l1 [==] l2.
    Proof.
      intros l1 l2 H1 H2.
      unfold language_eq.
      intro w.
      split.
      apply (H1 w).
      apply (H2 w).
    Qed.

    Theorem lang_distr : forall l1 l2 l3 : (@language Tt),
                           l1 [/\] (l2 [\/] l3) [==] (l1 [/\] l2) [\/] (l1 [/\] l3).
    Proof.
      intros.
      apply mk_laguage_eq.
      intros w H.
      unfold language_intersection in H.
      destruct H.
      unfold language_union in *.
      destruct H0.
      left.
      unfold language_intersection.
      intuition.
      right.
      unfold language_intersection.
      intuition.

      intros w H.
      unfold language_union in H.
      destruct H.
      unfold language_intersection in H.
      destruct H.
      unfold language_intersection.
      split.
      exact H.
      unfold language_union.
      left.
      exact H0.
      unfold language_intersection in H.
      unfold language_intersection.
      destruct H.
      split.

      exact H.
      unfold language_union.
      right.
      exact H0.
    Qed.

    Fixpoint language_list_union (l : list (@language Tt)) := fun w =>
                                                          match l with
                                                            | nil => False
                                                            | h :: t => (h w) \/ language_list_union t w
                                                          end.

    Theorem lang_distr_2 : forall (l2 : language) (ls : list language),
                             (l2 [/\] (language_list_union ls)) [==]
                                                               (language_list_union (map (fun l => l2 [/\] l) ls)).
    Proof.
      intros l2 ls.
      unfold language_eq.
      intros w.
      split.
      elim ls.
      intros H0.
      unfold language_intersection in H0.
      destruct H0.
      auto.
      intros a tail.
      intro HR.
      intro LI.
      simpl.
      unfold language_intersection in LI.
      simpl language_list_union in LI.
      destruct LI as [l2_w H1].
      elim H1.
      intro.
      left.
      unfold language_intersection.
      apply (conj l2_w H).
      intro.
      right.
      apply HR.
      unfold language_intersection.
      apply (conj l2_w H).
      elim ls.
      simpl.
      intros F; case F.
      clear ls.
      intros LA ls H0 LU.
      simpl language_list_union in LU.
      case LU.
      intro H1.
      unfold language_intersection.
      unfold language_intersection in H1.
      destruct H1.
      split.
      exact H.
      simpl language_list_union.
      left; exact H1.
      intro.
      apply H0 in H.
      unfold language_intersection.
      simpl language_list_union.
      assert(distr : forall (a b c : Prop), (a /\ c) -> a /\ (b \/ c)).
      intros.
      destruct H1.
      auto.
      apply distr.
      unfold language_intersection in H.
      exact H.
    Qed.

  End Lemmas.

End Base.


Variable A:Type.
Variable B:Type.

Definition C:Type := A->B.
Definition D:Type := forall (x:A), B.

Proposition same : C = D.
Proof.
  unfold C. unfold D. reflexivity.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e127m1_2limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e213m3_4limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.micromega.Lia.
Require Import Coq.Logic.Classical_Prop.

(** Test if a tactic succeeds, but always roll-back the results *)
Tactic Notation "test" tactic3(tac) :=
  try (first [ tac | fail 2 tac "does not succeed" ]; fail 0 tac "succeeds"; [](* test for [t] solved all goals *)).

Lemma EE: forall AA (P: AA -> Prop), (exists a: AA, ~ P a) <-> ~ forall (a: AA), P a.
Proof.
  intros. split.
  - intros. destruct H as [a H]. intro. apply H. auto.
  - intro. destruct (classic (exists a : AA, ~ P a)) as [C | C]; [assumption|].
    exfalso. apply H. intro. destruct (classic (P a)) as [D | D]; [assumption |].
    exfalso. apply C. exists a. assumption.
Qed.

Ltac negate :=
  (* revert all *)
  repeat match goal with
         | x: _ |- _ => revert x
         end;
  (* negate goal *)
  match goal with
  | |- ?P => assert (~P); [|admit]
  end;
  (* "not forall" to "exists such that not" *)
  repeat match goal with
         | |- context[~ (forall (x: ?T), _)] =>
           (assert (forall (P: T -> Prop), (exists x: T, ~ P x) <-> ~ (forall x: T, P x)) as EEE
               by apply EE);
           setoid_rewrite <- EEE;
           clear EEE
         end.

Ltac solver :=
  repeat match goal with
         | x: _ |- _ => subst x
         end;
  lia.

Ltac try_nats :=
  repeat multimatch goal with
  | |- exists (x: nat), _ => pose (x := 0); exists x
  | |- exists (x: nat), _ => pose (x := 1); exists x
  | |- exists (x: nat), _ => pose (x := 2); exists x
  end.

Ltac find_counterexample := negate; try_nats; test (solve [solver]).

Goal forall a b, min (a + 2) b < max (a + 2) b.
  intros.
  find_counterexample.

  solver.


Require Export
  Ty
  Exp
  Sub
  Sem
  Eval
  Norm.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

Section Example.

Import ListNotations.

Example exp_constant :
  run 10 (Constant (LInteger 123%Z)) = MkV (VConst (LInteger 123%Z)).
Proof. reflexivity. Qed.

Example exp_pair :
  run 20 (Pair (Constant (LInteger 123%Z))
               (Constant (LInteger 456%Z))) =
    MkV (VPair (VConst (LInteger 123%Z))
               (VConst (LInteger 456%Z))).
Proof. reflexivity. Qed.

Example exp_lam τ :
  run 10 (LAM (cod:=τ) (VAR ZV)) =
    MkV (VClosure (Lambda (VAR ZV) Empty)).
Proof. reflexivity. Qed.

Example exp_app :
  run 10 (APP (LAM (VAR ZV)) (Constant (LInteger 123%Z))) =
    MkV (VConst (LInteger 123%Z)).
Proof. reflexivity. Qed.

End Example.


From mathcomp Require Import ssreflect ssrnat eqtype.
From deriving Require Import deriving.

Require Import type.

(* cf. https://github.com/arthuraa/deriving/blob/master/tests/mutual.v *)

Scheme t_rect2  := Induction for t  Sort Type
  with t2_rect2 := Induction for t2 Sort Type.

Combined Scheme t_t2_rect from t_rect2, t2_rect2.

Time Definition t_indDef := [indDef for t_t2_rect].
Canonical t_indType := IndType t t_indDef.

Time Definition t_eqMixin := [derive eqMixin for t].
Canonical t_eqType := EqType t t_eqMixin.


Require Import SetoidList Wellfounded Omega.
Section GenGraphs.

  Variable T : Type.

  Record GenGraph : Type :=
    mkGGraph { gV : list T;
               gE : list (T*T);
               gE_irref : forall x, ~ In (x, x) gE;
               gE_symm : forall x y, In (x, y) gE -> In (y ,x) gE;
               gV_simplset : NoDup gV;
               gE_simplset : NoDup gE;
               gE_subset_l : forall x y, In (x, y) gE -> In x gV;
            }.

  Lemma gE_subset_r G : forall x y, In (x, y) (gE G) -> In y (gV G).
  Proof.
    intros. apply gE_symm in H. eapply gE_subset_l. eauto.
  Qed.

  Lemma GenGraph_StrongInd_aux :
      forall (P : (GenGraph -> Prop)),
        (forall G, (length (gV G) = 0) -> P G) ->
        (forall n, (forall G, length (gV G) <= n -> P G) ->
                   (forall G, length (gV G) = S n -> P G)) ->
        forall G, P G.
    Proof.
      intros.
      apply well_founded_induction
        with (R:= fun g1 g2 => length (gV g1) < length (gV g2)).
      apply wf_inverse_image.
      apply PeanoNat.Nat.lt_wf_0.
      intros.
      remember (gV x) as l.
      destruct l. apply H. rewrite <- Heql. auto.
      apply H0 with (n:= length l). intros. apply H1.
      simpl. omega. rewrite <- Heql. simpl. auto.
    Qed.
End GenGraphs.

  (* Given a list, this function maps the reversed indicies of the
      list to their corresponding elements.

    For example:
      Input: [34::36::nil]
      Output : f := if 0 then 36
                    elif 1 then 34
                    else _.
  *)
  Program Definition FromRevIndexToInT {T : Type} (l : list T)
    (pfX : {x : nat | x < length l}) : {t : T | In t l} :=
      match nth_error l (length l - (pfX + 1)) with
      | Some t => t
      | None => (False_rect _ _)
      end.
  Next Obligation.
    eapply nth_error_In. eauto.
  Qed.
  Next Obligation.
    symmetry in Heq_anonymous.
    apply nth_error_Some in Heq_anonymous; auto.
    omega.
  Qed.

  Fixpoint find_at {T : Type}
    (Tdec : forall t1 t2 : T, {t1 = t2} + {t1 <> t2})
    (l : list T) (t : T) : option nat :=
  match l with
  | nil => None
  | cons x l' =>  if Tdec x t
                    then Some O
                    else
                      match find_at Tdec l' t with
                      | None => None
                      | Some n => Some (S n)
                      end
  end.

  Lemma find_at_None :
    forall T pf (l : list T) t,
      find_at pf l t = None <-> ~ In t l.
  Proof.
    induction l.
    intros. simpl; split; intros.
    intros Hcontra. auto. auto.
    intros. simpl. split; intros.
    intros Hcontra. destruct Hcontra.
    subst. destruct (pf t t) in H. congruence.
    apply n. auto. apply IHl in H0. auto.
    destruct (pf a t); try congruence.
    destruct (find_at pf l t); try congruence.
    destruct (pf a t). apply False_rec. apply H.
    left. auto.
    assert (~ In t l). intros Hcontra.
    apply H. right. auto. apply IHl in H0.
    rewrite H0. auto.
  Qed.

  Lemma find_at_Some :
    forall T pf (l : list T) t,
      (exists x, find_at pf l t = Some x) <-> In t l.
  Proof.
    induction l.
    intros. split; intros.
    destruct H. simpl in H. congruence.
    inversion H.
    split; intros.
    destruct H. simpl in H.
    destruct (pf a t). left. auto.
    right. apply IHl.
    destruct (find_at pf l t). exists n0.
    auto. congruence.
    simpl. destruct (pf a t).
    subst. exists 0. auto. destruct H.
    congruence. apply IHl in H. destruct H.
    rewrite H. eauto.
  Qed.

  Lemma nth_error_nil : forall A n, @nth_error A nil n = None.
  Proof.
    intros. induction n. auto.
    simpl. auto.
  Qed.

  Lemma nth_error_Some_UB :
    forall A n l x, @nth_error A l n = Some x ->
      n < length l.
  Proof.
    induction n; intros.
    destruct l. inversion H. simpl. omega.
    destruct l. inversion H. simpl in H.
    apply IHn in H. simpl. omega.
  Qed.

  Lemma find_at_nth_error :
    forall x T pf (l : list T) t,
      find_at pf l t = Some x -> nth_error l x = Some t.
  Proof.
    induction x. intros. simpl.
    destruct l. simpl in H. congruence.
    simpl in H. destruct (pf t0 t). rewrite e. auto.
    destruct (find_at pf l t). inversion H. congruence.
    intros. simpl. destruct l.
    simpl in H. congruence. simpl in H.
    destruct (pf t0 t). inversion H.
    apply IHx with (pf := pf). destruct (find_at pf l t).
    inversion H. auto. congruence.
  Qed.

  Lemma nth_error_find_error :
    forall x T pf (l : list T) t,
      NoDup l -> nth_error l x = Some t -> find_at pf l t = Some x.
  Proof.
    induction x.
    intros. destruct l. simpl in H0.
    inversion H0. simpl in H0.
    inversion H0. subst. simpl. destruct (pf t t).
    auto. try congruence.
    intros. destruct l. simpl in H0.
    congruence.
    simpl in H0.
    assert (t <> t0).
    intros Hcontra.
    specialize (nth_error_In _ _ H0). intros.
    inversion H; subst. congruence.
    simpl. destruct (pf t0 t).
    congruence. erewrite IHx. congruence.
    inversion H. auto. auto.
  Qed.

  Definition FromInTToRevIndex {T : Type}
    (pf : forall t1 t2 : T, {t1 = t2} + {t1 <> t2})
    (l : list T) (pfT : {t : T | In t l}) : {x : nat | x < length l}.
  Proof.
    destruct pfT.
    remember (find_at pf l x).
    destruct o.
    exists n. symmetry in Heqo.
    apply find_at_nth_error in Heqo.
    eapply nth_error_Some_UB. eauto.
    apply False_rec. symmetry in Heqo.
    apply find_at_None in Heqo. congruence.
  Defined.

Definition listAsSet {T : Type} (l : list T) :=
  NoDup l.

Definition independent_E {T : Type} (G : GenGraph T) (l : list T) : Prop :=
  forall x y, In x l -> In y l -> ~ In (x, y) (gE _ G).

Definition valid_E {T : Type} (G : GenGraph T) (l : list T) : Prop :=
  forall x, In x l -> In x (gV _ G).

Inductive IndSet_E {T : Type} (G : GenGraph T) (l : list T) : Prop :=
  mkIndSet_E :
    valid_E G l ->
    independent_E G l ->
  IndSet_E G l.

Inductive MaximalIndSet_E {T : Type} (G : GenGraph T) (l : list T) : Prop :=
| mkMIS_E :
    IndSet_E G l ->
    (forall x, In x (gV _ G) -> ~ In x l ->
      (exists y, In y (gV _ G) /\
                 In y l /\
                 In (x, y) (gE _ G))) ->
    MaximalIndSet_E G l.

Lemma listeq_preserves_MIS_E :
  forall T (l1 l2 : list T) G,
    equivlistA eq l1 l2 ->
    (MaximalIndSet_E G l1) ->
    (MaximalIndSet_E G l2).
Proof.
  intros.
  constructor.
  constructor. intros x H1. apply H0.
  assert (InA eq x l2). apply InA_alt.
  exists x; split; auto. apply H in H2.
  apply InA_alt in H2. do 2 destruct H2; subst; auto.
  intros x y H1 H2.
  inversion H0. apply H3.
  specialize (H x). assert (InA eq x l2).
  apply InA_alt. exists x; split; auto.
  apply H in H5. apply InA_alt in H5. do 2 destruct H5; subst.
  auto.
  specialize (H y). assert (InA eq y l2).
  apply InA_alt. exists y; split; auto.
  apply H in H5. apply InA_alt in H5. do 2 destruct H5; subst.
  auto.
  intros. inversion H0.
  assert (~ In x l1).
  intros Hcontra. apply H2. assert (InA eq x l1).
  apply InA_alt. exists x. split; auto.
  apply H in H5. apply InA_alt in H5. do 2 destruct H5; subst.
  auto.
  specialize (H4 _ H1 H5).
  destruct H4. exists x0. repeat split.
  destruct H4. auto. destruct H4.
  destruct H6.
  assert (InA eq x0 l1). apply InA_alt.
  exists x0; split; auto. apply H in H8.
  apply InA_alt in H8. do 2 destruct H8; subst; auto.
  destruct H4. destruct H6. auto.
Qed.

Inductive ClosedNeighborhood
{T : Type} (G : GenGraph T) (v : T)  (l : list T) :=
| mkClosedNeighborhood :
  (forall x, In x l -> (In x (gV _ G))) ->
  (In v l) ->
  (forall x, In x l -> x <> v -> In (v, x) (gE _ G)) ->
ClosedNeighborhood G v l.

Inductive OpenNeighborhood
{T : Type} (G : GenGraph T) (v : T)  (l : list T) :=
| mkOpenNeighborhood :
  In v (gV _ G) ->
  (forall x, In x l -> (In x (gV _ G))) ->
  (forall x, In x l -> In (v, x) (gE _ G)) ->
OpenNeighborhood G v l.

Fixpoint OpenNeighborhood_witness_aux
  {T : Type} (E : list (T * T)) (v : T)
  (Tdec : (forall t1 t2 : T, {t1 = t2} + {t1 <> t2})) : list T :=
match E with
| nil => nil
| p::E' =>
    match p with pair x y =>
    if (Tdec x v)
      then y::(OpenNeighborhood_witness_aux E' v Tdec)
      else (OpenNeighborhood_witness_aux E' v Tdec)
    end
end.

Definition OpenNeighborhood_witness T Tdec (G : GenGraph T) v :=
  OpenNeighborhood_witness_aux (gE _ G) v Tdec.

Lemma OpenNeighborhood_witness_aux_spec
  {T : Type} (E : list (T * T)) (v : T)
  (Tdec : (forall t1 t2 : T, {t1 = t2} + {t1 <> t2})) :
    forall x, In x (OpenNeighborhood_witness_aux E v Tdec) ->
      In  (v, x) E.
Proof.
  induction E. intros.
  simpl in H. inversion H.
  simpl. intros. destruct a.
  destruct (Tdec t v); subst.
  destruct H; subst. left. auto.
  right. apply IHE. auto.
  right. apply IHE. auto.
Qed.

Lemma OpenNeighborhood_witness_spec :
  forall T Tdec G v,
    In v (gV _ G) ->
    OpenNeighborhood G v (OpenNeighborhood_witness T Tdec G v).
Proof.
  intros. constructor. auto.
  intros.
  apply OpenNeighborhood_witness_aux_spec in H0.
  apply gE_subset_r in H0. auto.
  intros.
  eapply OpenNeighborhood_witness_aux_spec.
  eauto.
Qed.

Section GraphSurgery.
  Variable T : Type.
  Variable Tdec : forall t1 t2 : T, {t1 = t2} + {t1 <> t2}.

  Fixpoint removeList (l r : list T) : list T :=
  match r with
  | nil => l
  | cons t r' => removeList (remove Tdec t l) r'
  end.

  Lemma remove_id : forall l r,
    ~ In r l ->
    remove Tdec r l = l.
  Proof.
    induction l; simpl; intros.
    auto.
    destruct Tdec. subst. apply False_rec.
    apply H. left. auto. f_equal.
    apply IHl. intros Hcontra. apply H.
    right. auto.
  Qed.

  Lemma remove_Subset : forall l r t,
    In t (remove Tdec r l) -> In t l.
  Proof.
    intros. induction l. simpl in H. auto.
    simpl in H. destruct Tdec; subst.
    right. apply IHl. auto.
    destruct H. left. auto.
    right. apply IHl. auto.
  Qed.

  Lemma remove_mem : forall l x t,
    In t (remove Tdec x l) <-> (In t l /\ ~ t = x).
  Proof.
    induction l.
    intros. split; intros. simpl in H. inversion H.
    destruct H. inversion H. intros; repeat split; intros.
    simpl in H. destruct Tdec in H. right. apply IHl in H.
    destruct H. auto. destruct H. left. auto. right.
    apply IHl in H. destruct H. auto.
    simpl in H. destruct Tdec in H. apply IHl in H.
    destruct H. auto. destruct H. subst. auto. apply IHl in H.
    destruct H. auto. simpl. destruct Tdec. apply IHl.
    destruct H. split. destruct H. congruence. auto.
    auto. destruct H. destruct H. left. auto. right.
    apply IHl. split. auto. auto.
  Qed.

  Lemma removeList_Subset : forall l r t,
    In t (removeList l r) -> In t l.
  Proof.
    intros l r t.
    generalize l t. clear l t.
    induction r. intros.
    simpl in H. auto.
    intros. simpl in H.
    apply IHr in H.
    eapply remove_Subset. eauto.
  Qed.

  Lemma removeList_mem : forall l r t,
    In t (removeList l r) <->
      (In t l /\ forall x, In x r -> x <> t).
  Proof.
    intros l r. generalize dependent l.
    induction r. intros. simpl; repeat split; intros.
    auto. inversion H0. destruct H. auto.
    intros; repeat split; intros. simpl in H.
    apply IHr in H. destruct H. apply remove_Subset in H.
    auto. simpl in H. apply IHr in H.
    destruct H. intros Hcontra. subst.
    destruct H0. subst.
    eapply remove_In. eauto. apply (H1 _ H0). auto.
    simpl. apply IHr. split. apply remove_mem. destruct H. split.
    auto. intros Hcontra. eapply H0. left; eauto. auto.
    destruct H. intros. apply H0. right. auto.
  Qed.

  Lemma remove_NoDup : forall l r, NoDup l -> NoDup (remove Tdec r l).
  Proof.
    intros. induction l. simpl. auto.
    simpl. destruct Tdec; subst. apply IHl.
    inversion H. auto.
    constructor. inversion H; subst.
    intros Hcontra. apply H2.
    apply remove_Subset in Hcontra. auto.
    apply IHl. inversion H; subst. auto.
  Qed.

  Lemma InA_remove_undo :
    forall l t,
      In t l ->
      (equivlistA eq l (t::(remove Tdec t l))).
  Proof.
    intros. constructor; intros.
    assert (In x (t::remove Tdec t l)).
    destruct (Tdec x t).
    left. auto. right.
    apply remove_mem. split. auto.
    apply InA_alt in H0. do 2 destruct H0. subst.
    auto. auto. apply InA_alt. exists x; split; auto.
    destruct (Tdec x t). subst. apply InA_alt.
    exists t; split; auto.
    apply InA_alt in H0.
    do 2 destruct H0; subst.
    inversion H1; subst; try congruence.
    apply remove_mem in H0. destruct H0.
    apply InA_alt. exists x0; split; auto.
  Qed.

  Lemma AllInA_remove_undo :
    forall L t,
      (forall l, In l L -> In t l) ->
      forall l', InA (equivlistA eq) l' (map (remove Tdec t) L) ->
        InA (equivlistA eq) (t::l') L.
  Proof.
    induction L. intros. inversion H0.
    intros. simpl in H0. inversion H0. subst.
    left. constructor. intros. inversion H1; subst.
    apply InA_alt. exists t; split; auto. apply H.
    left. auto. rewrite H2 in H4. apply InA_alt in H4.
    destruct H4. destruct H3. apply remove_Subset in H4.
    apply InA_alt. exists x0. split; auto.
    intros. rewrite H2. destruct (Tdec x t).
    left. auto. right. apply InA_alt in H1. do 2 destruct H1.
    subst. apply InA_alt. exists x0. split; auto. apply remove_mem.
    split; auto. subst. right. apply IHL.
    intros. apply H. right. auto.
    auto.
  Qed.

  Lemma remove_NoDupA :
    forall l x,
      NoDupA (equivlistA eq) l ->
      (forall l', In l' l -> In x l') ->
      NoDupA (equivlistA eq) (map (remove Tdec x) l).
  Proof.
    intros l x H. induction H; intros; subst. simpl. auto.
    simpl. constructor.
    intros Hcontra. apply H.
    assert (equivlistA eq x0 (x::remove Tdec x x0)).
    apply InA_remove_undo. apply H1. left. auto.
    rewrite H2. apply AllInA_remove_undo. intros. apply H1.
    right. auto. auto. apply IHNoDupA. intros. apply H1.
    right. auto.
  Qed.

  Lemma removeList_NoDup : forall l r, NoDup l -> NoDup (removeList l r).
  Proof.
    intros. generalize dependent l. induction r.
    intros. simpl. auto. simpl. intros.
    apply IHr. apply remove_NoDup. auto.
  Qed.

  Definition isElemOfPair_b (t : T) p :=
    if (Tdec t (fst p)) then true
    else if  (Tdec t (snd p)) then true
    else false.

  Lemma isElemOfPair_b_spec :
    forall t p, isElemOfPair_b t p = true <->
                (fst p = t \/ snd p = t).
  Proof.
    intros. destruct p.
    unfold isElemOfPair_b; simpl.
    destruct (Tdec t t0). split; auto.
    destruct (Tdec t t1); split; intros; auto;
    try congruence. inversion H; congruence.
  Qed.

  Fixpoint removePairs
    (l : list (T*T)) (r : list T) : list (T*T) :=
  match r with
  | nil => l
  | cons t r' => removePairs
                  ((filter (fun x => (negb (isElemOfPair_b t x))) l)) r'
  end.

  Lemma removePairs_subset :
   forall t l r, In t (removePairs l r) -> In t l.
  Proof.
    intros t l r. generalize t l. clear t l.
    induction r; simpl; intros. auto.
    apply IHr in H. apply filter_In in H.
    destruct H. auto.
  Qed.

  Lemma filter_NoDup :
    forall T (l : list T) f, NoDup l -> NoDup (filter f l).
  Proof.
    induction l. intros. simpl. auto.
    intros. simpl. destruct (f a).
    constructor. inversion H; subst. intros Hcontra.
    apply H2. apply filter_In in Hcontra. destruct Hcontra.
    auto. apply IHl. inversion H; subst; auto.
    apply IHl. inversion H; subst; auto.
  Qed.

  Lemma filter_NoDupA :
    forall T (R : T -> T -> Prop)
           (l : list T) f, NoDupA R l -> NoDupA R (filter f l).
  Proof.
    induction l. intros. simpl. auto.
    intros. simpl. destruct (f a).
    constructor. intros Hcontra.
    apply InA_alt in Hcontra.
    destruct Hcontra. destruct H0.
    apply filter_In in H1.
    inversion H; subst. apply H4.
    apply InA_alt. exists x. split; auto.
    destruct H1; auto.
    inversion H; subst. eapply IHl in H3.
    eauto. inversion H; subst.
    eapply IHl. eauto.
  Qed.

  Lemma removePairs_NoDup :
    forall l r, NoDup l -> NoDup (removePairs l r).
  Proof.
    intros. generalize dependent l.
    induction r. intros. simpl. auto.
    intros. simpl. apply IHr.
    apply filter_NoDup. auto.
  Qed.

  Lemma removePairs_mem :
    forall t l r, In t (removePairs l r) <->
                  (In t l /\
                  (forall x, In x r -> ~ (fst t = x)) /\
                  (forall x, In x r -> ~ (snd t = x))).
  Proof.
    intros t l r. generalize t l. clear t l.
    induction r. intros. split; simpl; intros.
    split; intros; auto. destruct H; auto.
    intros; split; intros; auto.
    repeat split. apply removePairs_subset in H. auto.
    intros. destruct H0.
    simpl in H.
    apply removePairs_subset in H. apply filter_In in H.
    destruct H. subst. unfold isElemOfPair_b in H1.
    destruct Tdec in H1. simpl in H1. congruence. auto.
    simpl in H. apply IHr in H.
    destruct H. destruct H1. apply H1. auto.
    intros. destruct H0.
    simpl in H.
    apply removePairs_subset in H. apply filter_In in H.
    destruct H. subst. unfold isElemOfPair_b in H1.
    destruct Tdec in H1. simpl in H1. congruence.
    destruct Tdec in H1. simpl in H1. congruence. auto.
    simpl in H. apply IHr in H.
    destruct H. destruct H1. apply H2. auto.
    simpl. apply IHr; split. apply filter_In.
    split. destruct H. auto.
    unfold isElemOfPair_b. destruct Tdec. destruct H. destruct H0.
    apply False_rec. apply (H0 a). left. auto. auto.
    destruct Tdec. destruct H. destruct H0. apply False_rec. apply (H1 a).
    left. auto. auto. auto.
    destruct H. destruct H0. split. intros. apply H0. right. auto.
    intros. apply H1. right. auto.
  Qed.

  Program Definition removeVerts (G : GenGraph T) (l : list T)
  : GenGraph T :=
  mkGGraph T (removeList (gV _ G) l)
           (removePairs (gE _ G) l) _ _ _ _ _.
  Next Obligation.
    intros Hcontra. apply removePairs_subset in Hcontra.
    apply (gE_irref _ G _ Hcontra).
  Qed.
  Next Obligation.
    apply removePairs_mem in H.
    destruct H.
    apply (gE_symm _ G) in H.
    apply removePairs_mem. split.
    auto. split; destruct H0;  simpl in *; auto.
  Qed.
  Next Obligation.
    apply removeList_NoDup. apply gV_simplset.
  Qed.
  Next Obligation.
    apply removePairs_NoDup. apply gE_simplset.
  Qed.
  Next Obligation.
    apply removePairs_mem in H.
    apply removeList_mem. split.
    destruct H. apply gE_subset_l in H. auto.
    destruct H. destruct H0. intros. simpl in *.
    intros Hcontra. eapply H0; eauto.
  Qed.

Inductive MIS_set_gGraph {T : Type} (G : GenGraph T) (l : list (list T)) :=
| mkMIS_set :
    (forall x, In x l -> MaximalIndSet_E G x) ->
    (NoDupA (equivlistA eq) l) ->
    (forall x, MaximalIndSet_E G x -> InA (equivlistA eq) x l) ->
      MIS_set_gGraph G l.

Lemma Prop4_aux1 :
  forall G x l,
    MaximalIndSet_E G l ->
    (In x (gV _ G)) ->
    ~ (In x l) ->
    MaximalIndSet_E (removeVerts G (x::nil)) l.
Proof.
  intros. constructor. constructor.
  inversion H. inversion H2. intros x0 H6.
  replace (gV T (removeVerts G (x :: nil))) with
    (removeList (gV _ G) (x::nil)) by auto.
  apply removeList_mem. split. apply H4. auto.
  intros. intros Hcontra. subst. inversion H7. subst. congruence.
  inversion H8.
  unfold independent_E.
  intros.
  replace (gE T (removeVerts G (x :: nil))) with
    (removePairs (gE _ G) (x::nil)) by auto.
  intros Hcontra. apply removePairs_subset in Hcontra.
  inversion H. inversion H4. apply (H7 x0 y); auto.
  replace (gV T (removeVerts G (x :: nil))) with
    (removeList (gV _ G) (x::nil)) by auto.
  replace (gE T (removeVerts G (x :: nil))) with
    (removePairs (gE _ G) (x::nil)) by auto.
  intros.
  assert (In x0 (gV T G)).
  apply removeList_Subset in H2. auto.
  inversion H. specialize (H6 _ H4 H3).
  destruct H6. exists x1. split.
  apply removeList_mem. split. destruct H6.
  auto. intros x' H7 H8. subst. apply H1.
  inversion H7. subst. destruct H6. destruct H8. auto.
  inversion H8. repeat split.
  destruct H6. destruct H7. auto.
  apply removePairs_mem. split. destruct H6.
  destruct H7. auto. split; simpl; intros.
  destruct H7; try congruence; subst.
  apply removeList_mem in H2.
  destruct H2. intros Hcontra; subst. eapply H7; eauto.
  left. auto. destruct H7; try congruence. subst.
  intros Hcontra. subst. apply H1. destruct H6.
  destruct H7. auto.
Qed.

Definition neighborhood_E (G : GenGraph T) (v : T) (l : list T) : Prop :=
  forall x, In x l <-> In (x, v) (gE _ G).

Lemma Prop4_aux2 :
  forall G l neigh x,
    In x l ->
    MaximalIndSet_E G l ->
    neighborhood_E G x neigh ->
    MaximalIndSet_E
      (removeVerts G (x::neigh))
      (remove Tdec x l).
  Proof.
    constructor. constructor.
    intros x0 H2.
    replace (gV T (removeVerts G (x :: neigh))) with
      (removeList (gV _ G) (x::neigh)) by auto.
    apply removeList_mem. split. inversion H0.
    inversion H3. apply H3. eapply remove_Subset. eauto.
    intros. intros Hcontra. subst. destruct H3. subst.
    apply remove_mem in H2. destruct H2. congruence.
    inversion H0. eapply H4. apply remove_mem in H2.
    destruct H2. apply H2.  apply H. apply H1. auto.
    inversion H0. inversion H2.
    replace (gE T (removeVerts G (x :: neigh))) with
      (removePairs (gE _ G) (x::neigh)) by auto.
    unfold independent_E; intros.
    intros Hcontra.
    apply remove_Subset in H6.
    apply remove_Subset in H7.
    apply removePairs_mem in Hcontra.
    eapply H2. apply H6. apply H7.
    destruct Hcontra. auto.
    replace (gE T (removeVerts G (x :: neigh))) with
      (removePairs (gE _ G) (x::neigh)) by auto.
    replace (gV T (removeVerts G (x :: neigh))) with
      (removeList (gV _ G) (x::neigh)) by auto.
    intros.
    inversion H0. assert (In x0 (gV T G)).
    apply removeList_mem in H2. destruct H2. auto.
    assert (~ In x0 l). auto.
    intros Hcontra. apply H3.
    apply remove_mem. split. auto. intros Hcontra'.
    apply removeList_mem in H2. subst.
    destruct H2. eapply H7. left. eauto. auto.
    specialize (H5 _ H6 H7).
    destruct H5. destruct H5. destruct H8.
    exists x1. assert (x1 <> x).
    assert (~ In (x0, x) (gE T G)).
    apply removeList_mem in H2.
    intros Hcontra. destruct H2.
    unfold neighborhood_E in H1. apply H1 in Hcontra.
    eapply H10. right. apply Hcontra. auto. intros Hcontra.
    subst. congruence. split.
    apply removeList_mem. split. auto. intros. inversion H11.
    subst. auto. intros Hcontra.
    inversion H0; subst. inversion H4.
    specialize (H16 x1 x H8 H).
    apply H1 in H12. congruence.
    split. apply remove_mem. split; auto.
    apply removePairs_mem. repeat split. auto.
    all: simpl; intros. intros Hcontra. subst.
    destruct H11. subst. apply removeList_mem in H2.
    destruct H2. eapply H11. left. auto. auto.
    apply removeList_mem in H2. destruct H2.
    eapply H12. right. apply H11. auto.
    destruct H11. subst. auto.
    intros Hcontra. subst. inversion H0.
    inversion H12.
    specialize (H15 x2 x H8 H). apply H15.
    apply H1 in H11. auto.
  Qed.

Lemma remove_length :
  forall l t,
    length (remove Tdec t l) <= length l.
Proof.
  induction l. intros. simpl. omega.
  intros. simpl. destruct Tdec. subst.
  etransitivity. apply IHl. omega.
  simpl. specialize (IHl t). omega.
Qed.

Lemma remove_length_in :
  forall l t,
    In t l ->
    length (remove Tdec t l) < length l.
Proof.
  induction l.
  intros. simpl. inversion H.
  intros.
  simpl. destruct Tdec; subst.
  specialize (remove_length l a). intros.
  omega. simpl.
  destruct H. congruence. apply IHl in H.
  omega.
Qed.

Lemma remove_length_le: forall l t,
  length (remove Tdec t l) <= length l.
Proof.
  induction l. simpl. auto.
  intros. simpl. destruct Tdec; specialize (IHl t);
  subst; simpl; omega.
Qed.

Lemma remove_length_lt : forall l t,
  In t l -> length (remove Tdec t l) < length l.
Proof.
  induction l. intros. inversion H.
  intros. destruct H. subst. simpl. destruct Tdec.
  subst. specialize (remove_length_le l t); intros.
  omega. congruence. simpl. destruct Tdec; simpl;
  specialize (IHl _ H); omega.
Qed.

Lemma removeList_length_le: forall l l',
  length (removeList l' l) <= length l'.
Proof.
  induction l; intros. simpl. omega.
  simpl. etransitivity. apply IHl.
  apply remove_length_le.
Qed.

Lemma remove_commute :
  forall l t1 t2,
    remove Tdec t1 (remove Tdec t2 l) =
    remove Tdec t2 (remove Tdec t1 l).
Proof.
  induction l. simpl. auto.
  intros. simpl. do 2 destruct Tdec; subst.
  auto. try rewrite IHl. simpl.
  destruct Tdec; try congruence.
  simpl. destruct Tdec; try congruence.
  simpl. do 2 destruct Tdec; try congruence.
Qed.

Lemma removeList_remove_commute :
  forall l' l t,
    remove Tdec t (removeList l l') = removeList (remove Tdec t l) l'.
Proof.
  induction l'.
  intros. simpl.
  auto. intros. simpl. rewrite IHl'. rewrite remove_commute.
  auto.
Qed.

Lemma removeList_length_lt: forall l l',
  (exists x, In x l /\ In x l') ->
  length (removeList l' l) < length l'.
Proof.
  induction l; intros.
  do 2 destruct H. inversion H.
  do 3 destruct H.
  subst. simpl.
  eapply Nat.le_lt_trans.
  apply removeList_length_le.
  apply remove_length_lt. auto.
  simpl.
  eapply Nat.le_lt_trans.
  2:{ apply IHl. exists x; split; auto. }
  rewrite <- removeList_remove_commute.
  apply remove_length_le.
Qed.

Lemma length_remove_in :
  forall l t,
    NoDup l ->
    In t l ->
      S (length (remove Tdec t l)) = length l.
Proof.
  induction l.
  intros. inversion H0.
  intros. destruct H0.
  simpl. subst. destruct Tdec.
  rewrite remove_id. auto.
  inversion H. subst. auto.
  congruence.
  simpl. destruct Tdec.
  inversion H. subst. congruence.
  simpl. erewrite <- IHl.
  eauto. inversion H. subst. auto.
  auto.
Qed.

Lemma length_removeList_all_in :
forall l' l,
  NoDup l ->
  NoDup l' ->
  (forall x, In x l' -> In x l) ->
length (removeList l l') + length l' = length l.
Proof.
  induction l'. intros.
  auto. intros. simpl.
  rewrite <- removeList_remove_commute.
  rewrite <- plus_Snm_nSm.
  erewrite -> length_remove_in.
  apply IHl'. inversion H0. auto.
  inversion H0. auto.
  intros. apply H1. right. auto.
  apply removeList_NoDup. auto.
  apply removeList_mem. split.
  apply H1. left. auto. inversion H0.
  subst. intros. intros Hcontra. apply H4.
  subst. auto.
Qed.

Lemma NoDup_subset_length :
  forall (l1 l2 : list T),
    NoDup l1 ->
    (forall x, In x l1 -> In x l2) ->
    length l1 <= length l2.
Proof.
  intros l1. induction l1. intros. simpl. omega.
  intros. simpl. apply le_lt_trans with (m := length (remove Tdec a l2)).
  apply IHl1. inversion H; subst. auto.
  intros. apply remove_mem. split. apply H0.
  right. auto. inversion H. subst. intros Hcontra.
  subst. auto. apply remove_length_in. apply H0.
  left. auto.
Qed.

Lemma NoDupA_subset_length :
  forall R (l1 l2 : list T),
    (Equivalence R) ->
    NoDupA R l1 ->
    (forall x, InA R x l1 -> InA R x l2) ->
    length l1 <= length l2.
Proof.
  intros R l1. induction l1. intros. simpl. omega.
  intros. simpl.
  assert (InA R a l2). apply H1.
  left. apply H.
  apply InA_alt in H2.
  destruct H2. destruct H2.
  specialize (IHl1 (remove Tdec x l2) H).
  inversion H0; subst. apply IHl1 in H7.
  apply le_trans with (m := (S (length (remove Tdec x l2)))).
  omega. specialize (remove_length_in _ _ H3). intros.
  omega. intros.
  specialize (H1 x0).
  assert (InA R x0 (a::l1)).
  right. auto. apply H1 in H5.
  apply InA_alt in H5.
  apply InA_alt. destruct H5. destruct H5.
  exists x1. split. auto. apply remove_mem.
  split. auto.  intros Hcontra. subst.
  apply H6. apply InA_alt in H4. destruct H4.
  destruct H4. apply InA_alt. exists x1.
  split. etransitivity. exact H2. symmetry in H5.
  transitivity x0. auto. auto. auto.
Qed.

Lemma splitList_length :
  forall f1 f2
    (H: forall (t : T), f1 t = negb (f2 t)) l,
  length l = length (filter f1 l) + length (filter f2 l).
Proof.
  intros. induction l.
  simpl. auto.
  simpl.
  replace (f1 a) with (negb (f2 a)).
  destruct (f2 a); simpl;
  rewrite IHl; omega.
  auto.
Qed.

Definition sumbool_left_bool
  P1 P2 (H : forall (t : T), {P1 t} + {P2 t}) t :=
    if H t then true else false.

Definition sumbool_right_bool
  P1 P2 (H : forall (t : T), {P1 t} + {P2 t}) t :=
    if H t then false else true.

Lemma splitList_summbool_spec P1 P2 H :
  forall t, (sumbool_left_bool P1 P2 H) t =
            negb ((sumbool_right_bool P1 P2 H) t).
Proof.
  intros. unfold sumbool_left_bool, sumbool_right_bool.
  destruct (H t); auto.
Qed.

End GraphSurgery.

Lemma In_InAeq_iff : forall A (x : A) (l : list A),
    InA eq x l <-> In x l.
Proof.
  clear.
  intros.
  split; intros H.
  all: revgoals.
  apply In_InA; auto.
  typeclasses eauto.
  {
    induction H.
    subst.
    left; auto.
    right; auto.
  }
Qed.


Load "eztactics.v".

Require Import Term.
Require Import Rewrites.

(** Strong normalization: a term is strongly normalizing if all its
    reducts are strongly normalizing.

    The well-foundedness of inductive objects in Coq means that the
    reduction trees are well-founded or strongly-normalizing.
*)
Inductive SN m :=
  reducts_SN : (forall m', (m ~> m') -> SN m') -> SN m.

Hint Constructors SN.
Hint Resolve reducts_SN.

Lemma SN_Const : SN TmConst.
 apply reducts_SN.
 intros.
 solve by inversion 1.
Qed.

Lemma SN_Var : forall x, SN (TmVar x).
 intros.
 apply reducts_SN.
 intros.
 solve by inversion.
Qed.

(*
Lemma SN_Abs : forall n, SN n -> SN (TmAbs n).
 intros; apply reducts_SN; intros.
 intros ; solve by inversion.
Qed.
*)

Hint Resolve SN_Const SN_Var (*SN_Abs*).

(** If a property is preserved by reduction, then it holds for all
    strongly normalizing terms. *)
Lemma SN_induction P:
  (forall M, (forall M', (M ~> M') -> P M') -> P M) ->
  forall M,
    SN M ->
    P M.
Proof.
 intros IH M H.
 induction H; eauto.
Qed.

Lemma SN_double_induction_weak P:
  (forall x y,
    (forall x', (x ~> x') -> P x' y) -> P x y) ->
  (forall x y,
    (forall y', (y ~> y') -> P x y') -> P x y) ->
  forall x y, SN x -> SN y -> P x y.
Proof.
 intros IH_x IH_y x y SN_x SN_y.
 induction SN_x; induction SN_y.
 eauto.
Qed.

(** [Double_SN] holds for a pair of terms iff all of the immediate
    reducts of each one is also [Double_SN]. TODO: I think this is the
    same as each one separately being strongly normalizing, so what do I
    need it for? *)
Inductive Double_SN M N :=
  | both_reducts_sn :
       (forall M', (M ~> M') -> Double_SN M' N)
    -> (forall N', (N ~> N') -> Double_SN M N')
    -> Double_SN M N.

Lemma double_sn_intro :
  forall M, SN M -> forall N, SN N -> Double_SN M N.
Proof.
 intros M SN_M.
 induction SN_M.
 intros N SN_N.
 induction SN_N.
 rename m into N.
 apply both_reducts_sn; solve [auto].
Qed.

Lemma double_sn_elim :
  forall M N, Double_SN M N -> SN M * SN N.
Proof.
 intros.
 induction H.
 split.
  apply reducts_SN.
  firstorder.
 apply reducts_SN.
 firstorder.
Qed.

Lemma Double_SN_induction P:
  (forall x y,
    (forall x', (x ~> x') -> P x' y) ->
    (forall y', (y ~> y') -> P x y') -> P x y) ->
  forall x y, Double_SN x y -> P x y.
Proof.
 intros IH x y SN_x_y.
 induction SN_x_y.
 auto.
Qed.

(** An induction principle on pairs of SN terms simultaneously. If a
    relation [P] between terms holds given its holding for every reduct of
    either term, then it holds for all strongly normalizing terms. *)
Lemma SN_double_induction P:
  (forall x y,
    (forall x', (x ~> x') -> P x' y) ->
    (forall y', (y ~> y') -> P x y') -> P x y) ->
  forall x y, SN x -> SN y -> P x y.
Proof.
 intros IH x y SN_x SN_y.
 apply Double_SN_induction; auto.
 apply double_sn_intro; auto.
Qed.

Ltac double_induction_SN M N :=
  cut (M ~>> M); [|auto]; cut (N ~>> N); [|sauto]; pattern N at 2 3, M at 2 3;
  refine (SN_double_induction _ _ N M _ _) ; [ | sauto | sauto].

Ltac double_induction_SN_intro M N :=
  cut (M ~>> M); [|auto]; cut (N ~>> N); [|sauto]; pattern N at 2 3, M at 2 3;
  refine (SN_double_induction _ _ N M _ _) ; [ | sauto | sauto];
  let N' := fresh N "'" in
  let M' := fresh M "'" in
  let IHN := fresh "IH" N in
  let IHM := fresh "IH" M in
  let N_rw_N' := fresh N "_rw_" N' in
  let M_rw_M' := fresh M "_rw_" M' in
  intros N' M' IHN IHM N_rw_N' M_rw_M'.

(** The tactic [redseq_induction M] allows us to prove the current
   goal [P M] by proving that [P] holds for an arbitrary transitive
   reduct of [M], provided that all of ITS immediate reducts have the
   property. *)
Ltac redseq_induction M :=
   cut (M ~>> M); [|auto];
   pattern M at 2 3; (* The reduct and the other position *)
   refine (SN_induction _ _ M _); [
   let M' := fresh M in
     let IH_M := fresh "IH" M in
         let M_to_M' := fresh M "to" M' in
           intros M' IH_M; intros
     | try trivial].

(** Reducing a term transitively preserves its SN status. *)
Lemma Rw_trans_preserves_SN :
  forall M M',
    SN M -> (M ~>> M') -> SN M'.
Proof.
 intros M M' H red.
 induction red.
   congruence.
  inversion_clear H; auto.
 auto.
Qed.

(* (        ~>          )      (               )
   (   M ---------> M'  )      (            N  )
   (   |            |   )      (            |  )
   ( f |          f |   )  ->  (          f |  ) -> SN Q -> SN N
   (   |            |   )      (            |  )
   (   V    ~>      V   )      (     ~>>    V  )
   (  f M · · · ·> f M' )      ( Q ------> f N ) *)

(** If we have a function [f] that is compatible with rewriting, then
    for any SN term [Q], if [Q] reduces (transitively) to some [f M],
    and [f M] is SN, then [M] is too. (Oy, that's awkward. Any simpler
    lemma we could use instead?) *)
Lemma SN_embedding f:
  (forall M M', (M ~> M') -> (f M ~> f M')) ->
  forall Q, SN Q ->
    forall M, (Q ~>> f M) -> SN M.
(* TODO: I can't believe how hard this was!
   TODO: Wrap this up in something that instantiates Q as f M, which is how we use it. *)
Proof.
 intros H Q H0.
 induction H0.
 rename m into q.
 intros.
 apply reducts_SN.
 assert (H2 : SN (f M)).
  apply Rw_trans_preserves_SN with (M := q); auto.
 inversion H2.
 intros.
 assert (H5 : {x:Term & ((q ~> x) * (x ~>> f m'))%type}).
  apply last_step_first_step_lemma with (f M); auto.
 destruct H5 as [x [q_x x_f_m']].
 apply H0 with x; auto.
Qed.

Lemma SN_context_Proj : forall b M,
                          SN (TmProj b M) -> SN M.
Proof.
 intros b M H.
 apply (SN_embedding (TmProj b)) with (TmProj b M); auto.
Qed.

Lemma SN_context_App_left:
  forall L M, SN (L@M) -> SN L.
Proof.
 intros L M H.
 apply (SN_embedding (fun x => (x @ M))) with (L @ M); auto.
Qed.


Section five_houses.

(* Definitions and axioms *)

Inductive owner : Type :=
| a : owner
| b : owner
| c : owner
| d : owner
| e : owner.

Inductive nationality : Type :=
| dane : nationality
| brit : nationality
| swede : nationality
| norwegian : nationality
| german : nationality.

Parameter citizen : owner -> nationality.

Inductive color : Type :=
| yellow : color
| red : color
| white : color
| green : color
| blue : color.

Parameter house : owner -> color.

Inductive animal : Type :=
| horse : animal
| cat : animal
| bird : animal
| fish : animal
| dog : animal.

Parameter pet : owner -> animal.

Inductive beverage : Type :=
| water : beverage
| tea : beverage
| milk : beverage
| coffee : beverage
| root_beer : beverage.

Parameter drink : owner -> beverage.

Inductive cigar : Type :=
| pall_mall : cigar
| prince : cigar
| blue_master : cigar
| dunhill : cigar
| blends : cigar.

Parameter smoke : owner -> cigar.

Definition left_of (X1 X2 : owner) : Prop :=
  match X1, X2 with
    | a, b => True
    | b, c => True
    | c, d => True
    | d, e => True
    | _, _ => False
  end.

Definition next_to (X1 X2 : owner) : Prop :=
  left_of X1 X2 \/ left_of X2 X1.

Definition surjective {A B:Type}(f: A->B) : Prop :=
  forall b:B, exists a : A, f a = b.

Definition injective {A B:Type}(f: A-> B) :Prop :=
  forall a1 a2:A, f a1 = f a2 -> a1 = a2.

Definition bijective {A B:Type}(f: A-> B) :Prop :=
  surjective f /\ injective f.

Axiom citizen_is_bijective : bijective citizen.
Axiom house_is_bijective : bijective house.
Axiom pet_is_bijective : bijective pet.
Axiom drink_is_bijective : bijective drink.
Axiom smoke_is_bijective : bijective smoke.

Axiom clue1: (* The Brit lives in the house with red walls. *)
  forall X : owner,  house X = red -> citizen X = brit.

Axiom clue2: (* The Swede has a dog. *)
  forall X : owner, citizen X = swede -> pet X = dog.

Axiom clue3: (* The Dane drinks tea. *)
  forall X : owner, citizen X = dane -> drink X = tea.

Axiom clue4: (* The house with green walls is directly to the left of the house with white walls. *)
  forall X1 X2 : owner,
    house X1 = green -> (left_of X1 X2 <-> house X2 = white).

Axiom clue5: (* The owner of the house with green walls drinks coffee. *)
  forall X : owner, house X = green -> drink X = coffee.

Axiom clue6: (* The person who smokes Pall Mall cigars owns a bird. *)
  forall X : owner, smoke X = pall_mall -> pet X = bird.

Axiom clue7: (* The owner of the house with yellow walls smokes Dunhill. *)
  forall X : owner, house X = yellow -> smoke X = dunhill.

Axiom clue8: (* The man living in the center house drinks milk. *)
  drink c = milk.

Axiom clue9: (* The Norwegian lives in the first house. *)
  citizen a = norwegian.

Axiom clue10: (* The man who smokes blends lives next to the cat owner. *)
  forall X1 X2 : owner,
    smoke X1 = blends -> pet X2 = cat -> next_to X1 X2.

Axiom clue11: (* The horse’s owner lives next to the man who smokes Dunhill. *)
  forall X1 X2: owner,
    pet X1 = horse -> smoke X2 = dunhill -> next_to X1 X2.

Axiom clue12: (* The man who smokes Blue Master drinks root beer. *)
  forall X : owner, drink X = root_beer -> smoke X = blue_master.

Axiom clue13: (* The German smokes Prince. *)
  forall X : owner, citizen X = german -> smoke X = prince.

Axiom clue14: (* The Norwegian lives next to the house with blue walls. *)
  forall X1 X2 : owner,
    citizen X1 = norwegian -> house X2 = blue -> next_to X1 X2.

Axiom clue15: (* The man who smokes Blends lives next to the man who drinks water. *)
  forall X1 X2 : owner,
    smoke X1 = blends -> drink X2 = water -> next_to X1 X2.

Lemma b_next_to_a : forall X:owner, next_to a X-> X = b.
Proof.
  intros.
  case H.
  case X; simpl; intros; try discriminate; contradiction || reflexivity.
  case X; simpl; contradiction || reflexivity.
Qed.

Lemma next_to_comm : forall a b:owner, next_to a b -> next_to b a.
Proof.
  intros.
  destruct H.
  right; assumption.
  left; assumption.
Qed.

Lemma b_next_to_a' : forall X:owner, next_to X a -> X = b.
Proof.
  intros.
  assert (next_to a X).
  apply (next_to_comm X a); assumption.
  apply b_next_to_a; assumption.
Qed.

Lemma clue14_0 :
  forall X1 X2 : owner,
    citizen X1 = norwegian -> house X2 = blue -> next_to a X2.
Proof.
  intros.
  apply clue14.
  exact clue9.
  assumption.
Qed.

Lemma clue14_1 :
  forall X1 X2 : owner,
    citizen X1 = norwegian -> house X2 = blue -> X2 = b.
Proof.
  intros.
  apply b_next_to_a.
  eapply clue14_0.
  exact clue9.
  assumption.
Qed.

Lemma clue14_2 :
  forall X1 X2 : owner,
    citizen X1 = norwegian -> house X2 = blue -> house b = blue.
Proof.
  intros.
  erewrite <- clue14_1.
  exact H0.
  exact clue9.
  assumption.
Qed.

Lemma b_color_blue : house b = blue.
Proof.
  assert (citizen a = norwegian).
  exact clue9.
  assert (exists X3:owner, house X3 = blue).
  generalize house_is_bijective.
  intros.
  destruct H0.
  apply H0.
  elim H0.
  intros.
  apply (clue14_2 a x).
  exact H.
  exact H1.
Qed.

Lemma green_is_d : house d = green.
Proof.
  assert ( house c <> green ).
  intros H.
  generalize clue8, clue5.
  intros.
  assert ( drink c = coffee ).
  apply H1.
  assumption.
  rewrite H0 in H2.
  discriminate.
  assert ( house b <> green).
  generalize b_color_blue;intros.
  intros H1.
  rewrite H0 in H1.
  discriminate.
  assert ( house a <> green ).
  intros H1.
  assert (house b = white ).
  apply (clue4 a b).
  assumption.
  simpl; exact I.
  generalize b_color_blue; intros.
  rewrite H2 in H3.
  discriminate.
  assert ( house e <> green ).
  intro H2.
  assert (exists x:owner, left_of e x).
  assert ( exists x:owner, house x = white).
  generalize house_is_bijective; intros.
  destruct H3.
  apply (H3 white).
  elim H3; intros.
  assert (left_of e x).
  apply (clue4 e x); assumption.
  exists x; assumption.
  elim H3; intros.
  simpl in H4; assumption.
  assert (exists x:owner, house x = green).
  generalize house_is_bijective; intros.
  destruct H3.
  apply H3.
  generalize H3.
  elim H3.
  intros.
  induction x; contradiction || assumption.
Qed.

Lemma white_is_e : house e = white.
Proof.
  apply (clue4 d e).
  apply green_is_d.
  simpl.
  exact I.
Qed.

Lemma red_is_c : house c = red.
Proof.
  assert (house a <> red).
  intros H.
  assert (citizen a = brit).
  apply clue1; assumption.
  generalize clue9; intros.
  rewrite H0 in H1; discriminate.
  assert (exists a : owner, house a = red).
  generalize house_is_bijective; intro Hhb; destruct Hhb.
  apply H0.
  elim H0; intros.
  induction x.
  contradiction.
  generalize b_color_blue;intros.
  rewrite H1 in H2; discriminate.
  assumption.
  generalize green_is_d; intros.
  rewrite H1 in H2; discriminate.
  generalize white_is_e; intros.
  rewrite H1 in H2; discriminate.
Qed.

Lemma yellow_is_a : house a = yellow.
Proof.
  generalize b_color_blue red_is_c green_is_d white_is_e; intros H0 H1 H2 H3.
  assert (exists a : owner, house a = yellow).
  generalize house_is_bijective; intro Hhb; destruct Hhb.
  apply H.
  elim H; intros.
  induction x; try assumption.
  rewrite H0 in H4; discriminate.
  rewrite H1 in H4; discriminate.
  rewrite H2 in H4; discriminate.
  rewrite H3 in H4; discriminate.
Qed.

Lemma c_is_brit : citizen c = brit.
Proof.
  apply (clue1 c).
  apply red_is_c.
Qed.

Lemma a_smoke_dunhill : smoke a = dunhill.
Proof.
  apply (clue7 a).
  apply yellow_is_a.
Qed.

Lemma d_drink_coffee : drink d = coffee.
Proof.
  apply (clue5 d).
  apply green_is_d.
Qed.

Lemma b_have_horse : pet b = horse.
Proof.
  assert (forall X:owner, next_to X a -> X = b).
  intros.
  case H; induction X; simpl; intros; contradiction || reflexivity.
  assert (forall X:owner, pet X = horse -> smoke a = dunhill -> pet b = horse ).
  intros.
  replace b with X.
  assumption.
  apply H.
  apply clue11; assumption.
  assert (exists x: owner, pet x = horse).
  generalize pet_is_bijective;intro Hpb; destruct Hpb.
  apply H1.
  elim H1; intros.
  apply (H0 x).
  assumption.
  apply a_smoke_dunhill.
Qed.

Lemma citizen_b_not_swede : citizen b <> swede.
Proof.
  intro H.
  assert (pet b = dog).
  apply (clue2 b); assumption.
  generalize b_have_horse; intros.
  rewrite H0 in H1.
  discriminate.
Qed.

Lemma dane_not_e : citizen e <> dane.
Proof.
  intro H.
  assert (citizen d = swede).
  generalize citizen_b_not_swede; intros.
  assert (citizen e <> swede).
  intros H1.
  rewrite H in H1; discriminate.
  assert (citizen a <> swede).
  generalize clue9; intros.
  intro H3.
  rewrite H2 in H3; discriminate.
  assert (citizen c <> swede).
  generalize c_is_brit; intros.
  intro H4.
  rewrite H3 in H4; discriminate.
  assert (exists x:owner, citizen x = swede).
  generalize citizen_is_bijective; intros Hcb; destruct Hcb.
  apply H4.
  elim H4; intros.
  induction x; try contradiction || assumption.
  assert (citizen b = german).
  generalize clue9 c_is_brit; intros.
  assert (exists x:owner, citizen x = german).
  generalize citizen_is_bijective; intros Hcb; destruct Hcb.
  apply H3.
  elim H3; intros.
  induction x.
  rewrite H1 in H4; discriminate.
  assumption.
  rewrite H2 in H4; discriminate.
  rewrite H0 in H4; discriminate.
  rewrite H in H4; discriminate.
  assert (smoke b = prince).
  apply (clue13 b); assumption.
  assert (drink e = tea).
  apply (clue3 e); assumption.
  generalize clue8 d_drink_coffee; intros.
  assert (drink a <> root_beer).
  intro H6.
  assert (smoke a = blue_master).
  apply (clue12 a); assumption.
  generalize a_smoke_dunhill; intros.
  rewrite H7 in H8; discriminate.
  assert (drink b = root_beer).
  assert (exists x:owner, drink x = root_beer).
  generalize drink_is_bijective; intro Hdb; destruct Hdb.
  apply H7.
  elim H7; intros.
  induction x.
  contradiction.
  assumption.
  rewrite H4 in H8; discriminate.
  rewrite H5 in H8; discriminate.
  rewrite H3 in H8; discriminate.
  assert (smoke b = blue_master).
  apply (clue12 b); assumption.
  rewrite H2 in H8; discriminate.
Qed.

Lemma b_is_dane : citizen b = dane.
Proof.
  generalize dane_not_e; intros.
  generalize c_is_brit clue9; intros.
  assert (citizen d <> dane).
  intro H2.
  assert (drink d = tea).
  apply (clue3 d); assumption.
  generalize d_drink_coffee; intros.
  rewrite H3 in H4; discriminate.
  assert (citizen a <> dane).
  intro Hf; rewrite H1 in Hf; discriminate.
  assert (citizen c <> dane).
  intro Hf; rewrite H0 in Hf; discriminate.
  assert (exists x:owner, citizen x = dane).
  generalize citizen_is_bijective; intro Hcb; destruct Hcb.
  apply H5.
  elim H5; intros.
  induction x; contradiction || assumption.
Qed.

Lemma b_drink_tea : drink b = tea.
Proof.
  apply (clue3 b).
  exact b_is_dane.
Qed.

Lemma e_drink_root_beer : drink e = root_beer.
Proof.
  generalize clue8 b_drink_tea d_drink_coffee; intros.
  assert (drink c <> root_beer).
  rewrite H; discriminate.
  assert (drink b <> root_beer).
  rewrite H0; discriminate.
  assert (drink d <> root_beer).
  rewrite H1; discriminate.
  assert (drink a <> root_beer).
  intros Hf.
  cut (smoke a = blue_master).
  intros.
  generalize a_smoke_dunhill; intros.
  rewrite H5 in H6; discriminate.
  apply (clue12 a); assumption.
  assert (exists x:owner, drink x = root_beer).
  generalize drink_is_bijective; intro Hdb; destruct Hdb.
  apply H6.
  elim H6; intros.
  induction x; contradiction || assumption.
Qed.

Lemma e_smoke_blue_master : smoke e = blue_master.
Proof.
  apply (clue12 e).
  exact e_drink_root_beer.
Qed.

Lemma a_drink_water : drink a = water.
Proof.
  assert (drink b <> water).
  generalize b_drink_tea; intro Hs; rewrite Hs; discriminate.
  assert (drink c <> water).
  generalize clue8; intro Hs; rewrite Hs; discriminate.
  assert (drink d <> water).
  generalize d_drink_coffee; intro Hs; rewrite Hs; discriminate.
  assert (drink e <> water).
  generalize e_drink_root_beer; intro Hs; rewrite Hs; discriminate.
  assert (exists x:owner, drink x = water).
  generalize drink_is_bijective; intro Hdb; destruct Hdb.
  apply H3.
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma b_smoke_blends : smoke b = blends.
Proof.
  assert (forall X: owner, smoke X = blends -> drink a = water -> smoke b = blends); intros.
  rewrite <- H.
  assert (X = b).
  apply (b_next_to_a' X).
  apply clue15.
  assumption.
  assumption.
  rewrite H1; reflexivity.
  assert (exists x:owner, smoke x = blends).
  generalize smoke_is_bijective; intro Hsb; destruct Hsb.
  apply H0.
  elim H0; intros.
  apply (H x).
  assumption.
  exact a_drink_water.
Qed.

Lemma d_smoke_prince : smoke d = prince.
Proof.
  assert (smoke a <> prince).
  generalize a_smoke_dunhill; intros Hs; rewrite Hs; discriminate.
  assert (smoke b <> prince).
  generalize b_smoke_blends; intros Hs; rewrite Hs; discriminate.
  assert (smoke e <> prince).
  generalize e_smoke_blue_master; intros Hs; rewrite Hs; discriminate.
  assert (smoke c <> prince).
  intro Hf.
  assert (forall X : owner, citizen X = german -> citizen c = german).
  intros.
  assert (X = c).
  generalize smoke_is_bijective; intros Hsb; destruct Hsb.
  apply H4.
  rewrite Hf.
  apply clue13; assumption.
  assert(exists x:owner, citizen x = german).
  generalize citizen_is_bijective; intros Hcb; destruct Hcb.
  apply H4.
  rewrite <- H2.
  rewrite H3; reflexivity.
  assert(exists x:owner, citizen x = german).
  generalize citizen_is_bijective; intros Hcb; destruct Hcb.
  apply H3.
  elim H3; intros.
  assert (citizen c = german).
  apply (H2 x); assumption.
  generalize c_is_brit; intros.
  rewrite H5 in H6; discriminate.
  assert (exists x:owner, smoke x = prince).
  generalize smoke_is_bijective; intros Hsb; destruct Hsb.
  apply H3.
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma c_smoke_pall_mall : smoke c = pall_mall.
  assert (smoke a <> pall_mall).
  generalize a_smoke_dunhill; intros Hs; rewrite Hs; discriminate.
  assert (smoke b <> pall_mall).
  generalize b_smoke_blends; intros Hs; rewrite Hs; discriminate.
  assert (smoke d <> pall_mall).
  generalize d_smoke_prince; intros Hs; rewrite Hs; discriminate.
  assert (smoke e <> pall_mall).
  generalize e_smoke_blue_master; intros Hs; rewrite Hs; discriminate.
  assert (exists x:owner, smoke x = pall_mall).
  generalize smoke_is_bijective; intro Hsb; destruct Hsb.
  apply H3.
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma c_have_bird : pet c = bird.
Proof.
  apply (clue6 c).
  apply c_smoke_pall_mall.
Qed.

Lemma d_is_german : citizen d = german.
Proof.
  assert (forall X : owner, citizen X = german -> citizen d = german).
  intros.
  cut (X = d); intros.
  rewrite <- H0; assumption.
  generalize (clue13 X); intros.
  assert (smoke X = prince).
  apply H0; assumption.
  generalize d_smoke_prince; intros.
  rewrite <- H1 in H2.
  generalize smoke_is_bijective; intro Hsb; destruct Hsb.
  apply H4; rewrite H2; reflexivity.
  assert (exists x:owner, citizen x = german).
  generalize citizen_is_bijective; intro Csb; destruct Csb.
  apply H0.
  elim H0; intros.
  apply (H x); assumption.
Qed.

Lemma e_is_swede : citizen e = swede.
Proof.
  assert (citizen a <> swede).
  generalize clue9; intros Hs; rewrite Hs; discriminate.
  assert (citizen b <> swede).
  generalize b_is_dane; intros Hs; rewrite Hs; discriminate.
  assert (citizen c <> swede).
  generalize c_is_brit; intros Hs; rewrite Hs; discriminate.
  assert (citizen d <> swede).
  generalize d_is_german; intros Hs; rewrite Hs; discriminate.
  assert (exists x:owner, citizen x = swede).
  generalize citizen_is_bijective; intro Hcb; destruct Hcb.
  apply H3.
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma e_have_dog : pet e = dog.
Proof.
  apply (clue2 e).
  apply e_is_swede.
Qed.

Lemma a_have_cat : pet a = cat.
Proof.
  assert (pet d <> cat).
  intro H.
  assert (next_to b d).
  apply (clue10 b d).
  apply b_smoke_blends.
  assumption.
  destruct H0.
  simpl in H0; assumption.
  simpl in H0; assumption.
  assert (pet b <> cat).
  generalize b_have_horse; intros Hs; rewrite Hs; discriminate.
  assert (pet c <> cat).
  generalize c_have_bird; intros Hs; rewrite Hs; discriminate.
  assert (pet e <> cat).
  generalize e_have_dog; intros Hs; rewrite Hs; discriminate.
  assert (exists x: owner, pet x = cat).
  generalize pet_is_bijective; intro Hcb; destruct Hcb.
  apply H3.
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Theorem d_have_fish : pet d = fish.
Proof.
  assert (pet a <> fish).
  generalize a_have_cat; intros Hs; rewrite Hs; discriminate.
  assert (pet b <> fish).
  generalize b_have_horse; intros Hs; rewrite Hs; discriminate.
  assert (pet c <> fish).
  generalize c_have_bird; intros Hs; rewrite Hs; discriminate.
  assert (pet e <> fish).
  generalize e_have_dog; intros Hs; rewrite Hs; discriminate.
  assert (exists x: owner, pet x = fish).
  generalize pet_is_bijective; intro Hcb; destruct Hcb.
  apply H3.
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Print d_have_fish.

End five_houses.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Cons : natural -> lst -> lst | Nil : lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite append_assoc.
      rewrite IHx. rewrite append_assoc. simpl. reflexivity.
   - intros. simpl. lfind. Admitted.


Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).
Proof.
  split.
  intros.
  destruct H as [x [H1 H2]].
  split.
  assumption.
  exists x.
  assumption.
  intros [H1 [x H2]].
  exists x.
  split.
  assumption.
  assumption.
Qed.

Theorem hilbert_axiom_S (P Q R : Prop) : (P -> Q -> R) -> (P -> Q) -> P -> R.
Proof.
  intros.
  pose (P_implies_Q := H0 H1).
  pose (P_and_Q_implies_R := H H1 P_implies_Q).
  exact P_and_Q_implies_R.
Qed.

Inductive or (A B : Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B
where "A \/ B" := (or A B) : type_scope.

(* Try to Prove Demorgan's Law -- Stuck trying to prove P *)
Theorem demorgans_law (P Q : Prop) :
 (~(P \/ Q) <-> (~P /\ ~Q)).
Proof.
  split.
  split.
  intros P'.
  apply H.
  left.
  assumption.
  intros Q'.
  apply H.
  right.
  assumption.
  intro H.
  destruct H as [P' Q'].
  absurd P.
  assumption.
  pose (disj_P := or_introl (P) (P)).
Qed.

(* Attempting to Prove this Tautology -- Stuck trying to prove R *)
Theorem tautology1 : (forall P Q R : Prop,
  (P /\ (Q \/ R)) -> ((P /\ Q) \/ (P /\ R))).
Proof.
  intros P Q R.
  intros left_side.
  right.
  elim left_side.
  split.
  apply left_side.
  destruct left_side.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Import proofmode.
From iris_examples.barrier Require Export barrier.
From iris_examples.barrier Require Import proof.
From iris.prelude Require Import options.
Import uPred.

Section spec.
Local Set Default Proof Using "Type*".
Context `{!heapGS Σ, !barrierG Σ}.

Lemma barrier_spec (N : namespace) :
  ∃ recv send : loc → iPropO Σ -n> iPropO Σ,
    (∀ P, ⊢ {{{ True }}} newbarrier #()
                     {{{ (l : loc), RET #l; recv l P ∗ send l P }}}) ∧
    (∀ l P, ⊢ {{{ send l P ∗ P }}} signal #l {{{ RET #(); True }}}) ∧
    (∀ l P, ⊢ {{{ recv l P }}} wait #l {{{ RET #(); P }}}) ∧
    (∀ l P Q, recv l (P ∗ Q) ={↑N}=∗ recv l P ∗ recv l Q) ∧
    (∀ l P Q, (P -∗ Q) -∗ recv l P -∗ recv l Q).
Proof.
  exists (λ l, OfeMor (recv N l)), (λ l, OfeMor (send N l)).
  split_and?; simpl.
  - iIntros (P) "!#". iIntros (Φ). iApply (newbarrier_spec _ P).
  - iIntros (l P) "!#". iIntros (Φ). iApply signal_spec.
  - iIntros (l P) "!#". iIntros (Φ). iApply wait_spec.
  - iIntros (l P Q). by iApply recv_split.
  - apply recv_weaken.
Qed.
End spec.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.
(* Requires No helper lemmas *)
Theorem theorem0 : forall (x : lst) (y : lst) (z : lst), eq (append (append x y) z) (append x (append y z)).
Proof.
   intros.
  induction x.
  - simpl. rewrite IHx. reflexivity.
  - reflexivity.

Qed.


(** * Defines effective abstractions *)
Require Import Compression.srp.
Require Import Coq.Arith.Peano_dec.

Section Abstraction.
  Context (concrete : SRP)
          (abstract : SRP).

  Class Abstraction :=
  { f : (Vertex) -> (Vertex);
    h : (option (@A concrete)) -> (option (@A abstract));
    f_onto: forall uhat, (@V abstract) uhat -> exists u, (@V concrete u) /\ f u = uhat
  }.
End Abstraction.

Section EffectiveAbstraction.

  Context {concrete : SRP}
          {abstract : SRP}
          {wfC : Wellformed concrete}
          {wfA : Wellformed abstract}
          {abs : Abstraction concrete abstract}.

  Notation dC := (@d concrete).
  Notation dA := (@d abstract).
  Notation adA := (@ad abstract).
  Notation routeType := (option (@A concrete)).
  Notation "A < B" := ((@prec concrete) A B).
  Notation "A <^ B" := ((@prec abstract) A B) (at level 40).
  Notation "A ==^ B" := (@rankEq abstract A B) (at level 40).
  Notation transA := (@trans abstract).
  Notation transC := (@trans concrete).
  Notation f := (@f concrete abstract abs).
  Notation h := (@h concrete abstract abs).

  Class Effective :=
  { dest_equiv: f dC = dA /\ (forall d', dC <> d' -> f(d') <> dA);
    drop_equiv: h(None) = None;
    orig_equiv: h((@ad concrete)) = adA;
    rank_equiv: forall (a b: routeType), a < b <-> h(a) <^ h(b);
    trans_equiv: forall (u v: Vertex) (a : routeType),
                   h(transC (u,v) a) = transA (f(u), f(v)) (h a);
    forAll_Exists: forall (uhat vhat: Vertex),
                   (@E abstract) uhat vhat <-> (forall v, f(v) = vhat -> exists u, f(u) = uhat /\
                                                                      (@E concrete) u v)
  }.

  Context {solC: @Solution concrete}
          {solA: @Solution abstract}.

  Notation labC := (@lab _ solC).
  Notation labA := (@lab _ solA).
  Notation fwdC := (fwd _ labC).
  Notation fwdA := (fwd _ labA).

  (** To be used for protocols that support ECMP *)
  Definition labEquiv := forall u, h (labC u) ==^ labA (f u).
  (** To be used otherwise, requires a total ordering of routes. *)
  Definition labEqual := forall u, h (labC u) = labA (f u).
  Definition fwdEquiv :=
  forall (uhat vhat : Vertex),
               @V abstract uhat /\ @V abstract vhat ->
               (fwdA (uhat, vhat) <->
                 (forall u, f u = uhat -> exists v, f v = vhat /\ fwdC (u,v))).
End EffectiveAbstraction.

Section LabelEquivalence.
  Context {concrete : SRP}
          {abstract : SRP}
          {wfC : Wellformed concrete}
          {wfA : Wellformed abstract}
          {abs : Abstraction concrete abstract}
          {eff : Effective}
          {solC: @Solution concrete}
          {solA: @Solution abstract}.

  Notation dC := (@d concrete).
  Notation dA := (@d abstract).
  Notation adA := (@ad abstract).
  Notation routeType := (option (@A concrete)).
  Notation routeTypeA := (option (@A abstract)).
  Notation "A < B" := ((@prec concrete) A B).
  Notation "A <^ B" := ((@prec abstract) A B) (at level 40).
  Notation "A ==^ B" := (@rankEq abstract A B) (at level 40).
  Notation "A == B" := (@rankEq concrete A B) (at level 40).
  Notation transA := (@trans abstract).
  Notation transC := (@trans concrete).
  Notation f := (@f concrete abstract abs).
  Notation h := (@h concrete abstract abs).
  Notation labC := (@lab _ solC).
  Notation labA := (@lab _ solA).
  Notation fwdC := (fwd labC).
  Notation fwdA := (fwd labA).
  Notation labSpecC := (@labSpec concrete _).
  Notation labSpecA := (@labSpec abstract _).

  Definition choiceEquiv :=
  forall (u: Vertex) (e: edge) (routeA: routeTypeA),
               (exists routeC, (h routeC) ==^ routeA /\ choices _ labC u e routeC)
               <->
               choices _ labA (f u) (f (fst e), f (snd e)) routeA.

  Require Import Coq.Classes.RelationClasses.
  Require Import Classes.Morphisms.
  (* Add == as an equivalence relation*)
  Add Parametric Relation Srp (Wf : Wellformed Srp) : (option (@A Srp)) (@rankEq Srp)
      reflexivity proved by (@Equivalence_Reflexive _ _ (@rankEq_eq Srp Wf))
      symmetry proved by (@Equivalence_Symmetric _ _ (@rankEq_eq Srp Wf))
      transitivity proved by (@Equivalence_Transitive _ _ (@rankEq_eq Srp Wf))
        as eq_rank_rel.

  (* Allow generic rewriting of == over <*)
  Instance prec_Proper Srp (Wf : Wellformed Srp) : Proper (eq ==> (fun x y => @rankEq Srp x y) ==> iff) (@prec Srp).
  Proof.
    intros x1 x2 Hxeq y1 y2 Hpreceq.
    subst.
    split; intros.
    - destruct (prec_eq_total x2 y2) as [Hlt | [Hgt | Heq]].
      + eauto.
      + exfalso.
        pose proof (prec_trans y2 x2 y1 Hgt H).
        apply prec_not_eq in Hpreceq.
        destruct Hpreceq;
          now eauto.
      + rewrite <- Hpreceq in Heq.
        apply prec_not_eq in Heq.
        destruct Heq.
        now exfalso.
    - destruct (prec_eq_total x2 y1) as [Hlt | [Hgt | Heq]].
      + eauto.
      + exfalso.
        pose proof (prec_trans y1 x2 y2 Hgt H).
        apply prec_not_eq in Hpreceq.
        destruct Hpreceq;
          now eauto.
      + rewrite Hpreceq in Heq.
        apply prec_not_eq in Heq.
        destruct Heq.
        now exfalso.
  Defined.

  Lemma rank_equiv_eq :
    forall a b
      (Hrank_eq: forall a b,  a < b <-> (h a) <^ (h b)),
                 a == b <-> h a ==^ h b.
  Proof.
    intros.
    split; intros Heq.
    - destruct (prec_eq_total (h a) (h b)) as [Hlt | [Hgt | Heq']];
      auto.
      + pose proof (proj2 (Hrank_eq a b) Hlt).
        eapply prec_not_eq in Heq.
        exfalso; now auto.
      + pose proof (proj2 (Hrank_eq b a) Hgt).
        eapply prec_not_eq in Heq.
        exfalso; now auto.
    - destruct (prec_eq_total a b) as [Hlt | [Hgt | Heq']];
      auto.
      + pose proof (proj1 (Hrank_eq a b) Hlt).
        eapply prec_not_eq in Heq.
        exfalso; now auto.
      + pose proof (proj1 (Hrank_eq b a) Hgt).
        eapply prec_not_eq in Heq.
        exfalso; now auto.
  Qed.

  (** Choice equivalence implies label equivalence *)
  Theorem choiceEquiv_implies_labEquiv :
    choiceEquiv -> labEquiv.
  Proof.
    intros HchoiceEq.
    unfold labEquiv.
    intros u.
    pose proof (labSpecC u) as HlabSpec.
    pose proof (labSpecA (f u)) as HlabSpecA.
    inversion HlabSpec; subst.
    - (* case u is the destination *)
      destruct (dest_equiv) as [Heq Hneq].
      rewrite Heq.
      rewrite HisDest.
      rewrite Heq in HlabSpecA.
      inversion HlabSpecA as [HdA| |]; subst; [|exfalso; now eauto | exfalso; now eauto].
      (* abstract solution must be initial abstract route *)
      rewrite HdA.
      erewrite orig_equiv.
      reflexivity.
    - (* case u is a node without choices *)
      inversion HlabSpecA as [HdA Hfd | ? HdA HlabA  HnochoiceA | ? vhat]; subst.
      + exfalso.
        apply Hd.
        destruct (dest_equiv) as [Hfd' Hfneq].
        rewrite Hfd in Hfd'.
        specialize (Hfneq u ltac:(eauto)).
        exfalso; now congruence.
      + rewrite Hempty, HlabA.
        erewrite drop_equiv.
        reflexivity.
      + exfalso.
        assert (HedgeA: E vhat (f u)) by (inversion Hchoice; eauto).
        destruct (proj1 (forAll_Exists vhat (f u)) HedgeA u ltac:(auto)) as [v [Hfv HE]].
        (* NOTE: interesting case here, because of the flipped order on how
        choices work we need to flip the order on forall-exists too?
        Intuitively it makes sense. We wish to guarantee that if an attribute
        is sent over (uhat, vhat) then every v |-> vhat gets the message from
        some u |-> uhat. *)
        specialize (HchoiceEq u (v, u) (labA (f u))).
        simpl in HchoiceEq.
        subst vhat.
        destruct (proj2 HchoiceEq Hchoice) as [routeC [Hh Hchoices]].
        eapply Hnochoice;
          now eauto.
    - (* case u is a node with a choice *)
      unfold choiceEquiv in *.
      (* By choice equivalence the abstract network has a similar choice *)
      pose proof (proj1 (HchoiceEq u (v,u) (h (labC u)))
                        ltac:(exists (labC u); split; (eauto || reflexivity))) as HchoiceA.
      simpl in HchoiceA.
      (* show it's minimal *)
      assert(HminA: forall (what : Vertex) (bhat : option A),
                            choices abstract labA (f u) (what, f u) bhat ->
                            h (labC u) <^ bhat \/ h (labC u) ==^ bhat).
      { intros what bhat HchoicewHat.
        (* Suppose there is some better choice for the abstract network *)
        (* Then by choice-eq the concrete network has this choice too *)

        (* Since there is a choice of what, there is an abstract edge *)
        assert (Hwhat_u: E what (f u)) by (inversion HchoicewHat; eauto).
        (* By forall-exists there is a concrete node that maps to w and
           (u, w) \in E*)
        destruct (proj1 (forAll_Exists what (f u)) Hwhat_u u ltac:(auto)) as [w [Hfw HEwu]].
        (* By choice-equivalence the concrete network must have a similar ranked
        choice over this edge. *)
        specialize (proj2 (HchoiceEq u (w, u) bhat)).
        simpl.
        intros HchoiceEqw.
        rewrite Hfw in HchoiceEqw.
        destruct (HchoiceEqw HchoicewHat) as [b [Hb Hchoicew]].
        clear HchoiceEqw.
        (* by rank equivalence *)
        rewrite <- Hb.
        specialize (Hmin w b Hchoicew).
        destruct Hmin as [HlabC_best | Heq].
        - pose proof (rank_equiv (labC u) b) as Hrankeq.
          pose proof (proj1 Hrankeq HlabC_best);
            now auto.
        - eapply rank_equiv_eq in Heq; eauto.
          now eapply eff.
      }
      inversion HlabSpecA; subst.
      + exfalso.
        destruct (dest_equiv) as [Heq Hneq].
        rewrite H0 in Heq.
        specialize (Hneq u ltac:(eauto)).
        eauto.
      + exfalso.
        eapply Hnochoice;
          now eauto.
      + (* The abstract node f u has some minimal choice over some edge v0, to show:
           that it coincides with the choice of u *)
        specialize (Hmin0 _ _ HchoiceA).
        specialize (HminA _ _ Hchoice0).
        destruct HminA as [Hlt | ?]; [| now eauto].
        destruct Hmin0 as [Hgt | ?]; [| now eauto].
        eapply prec_asym in Hlt.
        exfalso;
          now auto.
  Qed.

  Theorem labEquiv_implies_fwdEquiv :
    choiceEquiv -> fwdEquiv.
  Proof.
    intros HchoiceEq.
    unfold choiceEquiv, fwdEquiv in *.
    intros uhat vhat [Hvu Hvv].
    split.
    - (* If abstract forwards towards vhat then concrete forwards towards v, f v = vhat*)
      intros HfwdA u Hfu.
      inversion HfwdA.
      inversion He; subst u0 v.
      clear He.
      (* by the fact that (uhat, vhat) \in E and forall-exists *)
      assert (Hfv: exists v, f v = vhat).
      { inversion HbestChoice; subst.
        eapply forAll_Exists in Hedge;
          eauto.
        destruct Hedge as [? [? ?]];
          now eauto.
      }
      destruct Hfv as [v Hfv].
      exists v.
      split; [assumption|].
      (* By choice equivalence, concrete network has a similar choice *)
      pose proof (proj2 (HchoiceEq u (v,u) a)) as HchoiceEquiv.
      simpl in HchoiceEquiv.
      rewrite Hfu, Hfv in HchoiceEquiv.
      destruct (HchoiceEquiv HbestChoice) as [routeC [HrouteC HchoiceC]].
      rewrite Hbest in HrouteC.
      (* by label equivalence we get that lab(uhat) == h(lab(u))*)
      pose proof (choiceEquiv_implies_labEquiv HchoiceEq) as HlabEquiv.
      specialize (HlabEquiv u).
      rewrite Hfu in HlabEquiv.
      rewrite <- HlabEquiv in HrouteC.
      (* and hence routeC == labC u *)
      eapply rank_equiv_eq in HrouteC;
        eauto using rank_equiv.
      econstructor;
        now eauto.
    - (*If concrete forwards towards v then the abstract forwards towards f v *)
      intros HfwdC.
      (* NOTE: I think here we need the assumption that f is onto. Every uhat is
        mapped to some u. *)
      destruct (f_onto _ _ uhat Hvu) as [u [Hu Hfu]].
      destruct (HfwdC u Hfu) as [v [Hv Hfwd]].
      inversion Hfwd; subst.
      inversion He; subst u0 v0.
      (* By choice equivalence, the abstract network has a similar choice *)
      pose proof (proj1 (HchoiceEq u (v,u) (h (labC u)))) as HchoiceEquiv.
      assert (Hpre: (exists routeC : routeType,
                    h routeC ==^ h (labC u) /\ choices concrete labC u (v, u) routeC)).
      { exists a.
        split; eauto.
        eapply rank_equiv_eq;
          now eauto using rank_equiv.
      }
      specialize (HchoiceEquiv Hpre).
      clear Hpre.
      simpl in HchoiceEquiv.
      (* And by label equivalence, h (labC u) == labA (f u)) *)
      pose proof (choiceEquiv_implies_labEquiv HchoiceEq) as HlabEquiv.
      specialize (HlabEquiv u).
      econstructor;
        now eauto.
  Qed.

End LabelEquivalence.


Require Export Syntax.
Require Export Map.

Definition env := partial_map var ty.

Definition activeEnv (Gamma : env) : env :=
  fun x =>
    match Gamma x with
      | Some t => if is_active t then Some t else None
      | None => None
    end.

Reserved Notation " Gamma '|-' expr '\in' ty " (at level 40).

Inductive hasType (Gamma : env) : expr -> ty -> Prop :=
  | T_Var :
      forall x t
        (Hlookup : Gamma x = Some t),
        Gamma |- EVar x \in t
  | T_Unit :
        Gamma |- EUnit \in TUnit
  | T_Loc :
      forall l,
        Gamma |- ELoc l \in TPas
  | T_Id :
      forall id,
        Gamma |- EId id \in TAct
  | T_Bestowed :
      forall l id,
        Gamma |- EBId l id \in TBes
  | T_AtStart :
      forall e a,
        Gamma |- e \in a ->
        forall (Hactive : is_active a = true),
        Gamma |- EAtStart e \in TUnit
  | T_AtEnd :
      forall e a,
        Gamma |- e \in a ->
        forall (Hactive : is_active a = true),
        Gamma |- EAtEnd e \in TUnit
  | T_NewPassive :
        Gamma |- ENew TPas \in TPas
  | T_NewActive :
        Gamma |- ENew TAct \in TAct
  | T_Mutate :
      forall e,
        Gamma |- e \in TPas ->
        Gamma |- EMut e \in TUnit
  | T_Bestow :
      forall e,
        Gamma |- e \in TPas ->
        Gamma |- EBes e \in TBes
  | T_Lam :
      forall x t1 e t2
        (bodyHasType : extend Gamma x t1 |- e \in t2),
        Gamma |- ELam x t1 e \in TArr t1 t2
  | T_Apply :
      forall e1 e2 t1 t2,
        Gamma |- e1 \in TArr t1 t2 ->
        Gamma |- e2 \in t1 ->
        Gamma |- EApp e1 e2 \in t2
  | T_Send :
      forall x e e' a t,
        Gamma |- e \in a ->
        forall (Hactive : is_active a = true),
        extend (activeEnv Gamma) x TPas |- e' \in t ->
        freeLocs e' = nil ->
        Gamma |- ESend e x TPas e' \in TUnit
  where " Gamma '|-' expr '\in' ty " := (hasType Gamma expr ty).

Tactic Notation "hasType_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var"
  | Case_aux c "T_Unit"
  | Case_aux c "T_Loc"
  | Case_aux c "T_Id"
  | Case_aux c "T_Bestowed"
  | Case_aux c "T_AtStart"
  | Case_aux c "T_AtEnd"
  | Case_aux c "T_NewPassive"
  | Case_aux c "T_NewActive"
  | Case_aux c "T_Mutate"
  | Case_aux c "T_Bestow"
  | Case_aux c "T_Lam"
  | Case_aux c "T_Apply"
  | Case_aux c "T_Send"
  ]
.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (y : natural) : natural := lf1.