From SFL Require Import Imports Auxiliaries Terms.
Require Import Coq.Strings.String.

Definition ctx := list (string * type)%type.

Definition extend (c: ctx) (x: string) (t: type) :=
  (x, t) :: c.

Fixpoint lookup {A: Type} (c: list (string * A)) (s: string): option A :=
  match c with
    | nil => None
    | (x, t) :: r => if eqb x s then Some t else (lookup r s)
  end.

  Fixpoint typecheck (m: ctx) (e: term): option type :=
  match e with
    | Ident s       => lookup m s
    | Lambda x t e1 => let n := extend m x t in
                       let te1 := typecheck n e1 in
                       match te1 with
                         | Some te1 => Some (Arrow t te1)
                         | None => None
                       end
    | App e1 e2     => let te1 := typecheck m e1 in
                       let te2 := typecheck m e2 in
                       match te1, te2 with
                         | Some (Arrow te1s te1t), Some te2 =>
                             if type_eqb te1s te2 then Some te1t else None
                         | _, _  => None
                       end
    | NVal n         => Some Int
    | BVal b         => Some Bool
    | ITE e1 e2 e3   => let te1 := typecheck m e1 in
                        let te2 := typecheck m e2 in
                        let te3 := typecheck m e3 in
                        match te1, te2, te3 with
                          | Some nte1, Some nte2, Some nte3 =>
                            if type_eqb nte1 Bool && type_eqb nte2 nte3 then Some nte2 else None
                          | _, _, _    => None
                        end
     | Fix f         =>  let tf := typecheck m f in
                         match tf with
                           | Some (Arrow t1 t2) => if type_eqb t1 t2 then Some t2 else None
                           | _                  => None
                         end
     | Plus a b      => let t1 := typecheck m a in
                        let t2 := typecheck m b in
                        match t1, t2 with
                          | Some Int, Some Int => Some Int
                          | _, _               => None
                        end
     | Minus a b     => let t1 := typecheck m a in
                        let t2 := typecheck m b in
                        match t1, t2 with
                          | Some Int, Some Int => Some Int
                          | _, _               => None
                        end
     | Mult a b      => let t1 := typecheck m a in
                        let t2 := typecheck m b in
                        match t1, t2 with
                          | Some Int, Some Int => Some Int
                          | _, _               => None
                        end
     | Eq a b        => let t1 := typecheck m a in
                        let t2 := typecheck m b in
                        match t1, t2 with
                          | Some Int, Some Int => Some Bool
                          | _, _               => None
                        end
     | Gt a b        => let t1 := typecheck m a in
                        let t2 := typecheck m b in
                        match t1, t2 with
                          | Some Int, Some Int => Some Bool
                          | _, _               => None
                        end
  end.

  (** http://color.inria.fr/papers/koprowski06draft.pdf -- look into "Theorem autoType" *)

Lemma typecheck_decidable: forall t c, exists T, typecheck c t = Some T \/ typecheck c t = None.
Proof. intro t.
       induction t; intros.
       - cbn. induction c; intros.
         + cbn. exists Int. now right.
         + cbn. destruct a.
           case_eq (s0 =? s); intros; destruct IHc as (T, th).
           ++ exists t. now left.
           ++ exists T. easy.
       - cbn. specialize (IHt (extend c s t)).
         destruct IHt as (T, IHt).
         exists (Arrow t T). destruct IHt as [ IHt | IHt].
         ++ rewrite IHt. now left.
         ++ rewrite IHt. now right.
       - cbn. specialize (IHt1 c).
         destruct IHt1 as (T, IHt1).
         destruct IHt1 as [ IHt1 | IHt1 ].
         + rewrite IHt1.
           destruct T; intros.
           ++ exists Int. now right.
           ++ exists Bool. now right.
           ++ exists T2.
              specialize (IHt2 c).
              destruct IHt2 as (T, IHt2).
              destruct IHt2 as [IHt2 | IHt2 ].
              +++ rewrite IHt2.
                  case_eq (type_eqb T1 T); intros.
                  * now left.
                  * now right.
              +++ rewrite IHt2. now right.
         + rewrite IHt1. exists Int. now right.
       - cbn. exists Int. now left.
       - cbn. exists Bool. now left.
       - cbn. specialize (IHt1 c).
         destruct IHt1 as (T, IHt1).
         destruct IHt1 as [IHt1 | IHt1 ].
         + rewrite IHt1.
           specialize (IHt2 c).
           destruct IHt2 as (T2, IHt2).
           destruct IHt2 as [ IHt2 | IHt2 ].
           rewrite IHt2.
           specialize (IHt3 c).
           destruct IHt3 as (T3, IHt3).
           destruct IHt3 as [ IHt3 | IHt3 ].
           rewrite IHt3.
           exists T2.
           case_eq T; intros.
           ++ cbn. now right.
           ++ cbn. case_eq (type_eqb T2 T3); intros.
              +++ now left.
              +++ now right.
           ++ cbn. now right.
           ++ rewrite IHt3. exists T. now right.
           ++ rewrite IHt2. exists T. now right.
         + rewrite IHt1. exists T. now right.
       - cbn. specialize (IHt c).
         destruct IHt as (T, IHt).
         destruct IHt as [ IHt | IHt ].
         rewrite IHt.
         case_eq T; intros.
         + exists T. now right.
         + exists T. now right.
         + exists t1.
           case_eq (type_eqb t0 t1); intros. now left. now right.
         + exists T. rewrite IHt. now right.
       - cbn.
         specialize (IHt1 c).
         specialize (IHt2 c).
         destruct IHt1 as (ty1, IHt1).
         destruct IHt2 as (ty2, IHt2).
         destruct IHt1 as [ IHt1 | IHt1 ];
         destruct IHt2 as [ IHt2 | IHt2 ].
         + rewrite IHt1, IHt2.
           destruct ty1; destruct ty2; try (exists Int; now right).
           exists Int. now left.
         + rewrite IHt1, IHt2.
           destruct ty1; exists Int; now right.
         + rewrite IHt1. exists Int. now right.
         + rewrite IHt1. exists Int. now right.
       - cbn.
         specialize (IHt1 c).
         specialize (IHt2 c).
         destruct IHt1 as (ty1, IHt1).
         destruct IHt2 as (ty2, IHt2).
         destruct IHt1 as [ IHt1 | IHt1 ];
         destruct IHt2 as [ IHt2 | IHt2 ].
         + rewrite IHt1, IHt2.
           destruct ty1; destruct ty2; try (exists Int; now right).
           exists Int. now left.
         + rewrite IHt1, IHt2.
           destruct ty1; exists Int; now right.
         + rewrite IHt1. exists Int. now right.
         + rewrite IHt1. exists Int. now right.
       - cbn.
         specialize (IHt1 c).
         specialize (IHt2 c).
         destruct IHt1 as (ty1, IHt1).
         destruct IHt2 as (ty2, IHt2).
         destruct IHt1 as [ IHt1 | IHt1 ];
         destruct IHt2 as [ IHt2 | IHt2 ].
         + rewrite IHt1, IHt2.
           destruct ty1; destruct ty2; try (exists Int; now right).
           exists Int. now left.
         + rewrite IHt1, IHt2.
           destruct ty1; exists Int; now right.
         + rewrite IHt1. exists Int. now right.
         + rewrite IHt1. exists Int. now right.
       - cbn.
         specialize (IHt1 c).
         specialize (IHt2 c).
         destruct IHt1 as (ty1, IHt1).
         destruct IHt2 as (ty2, IHt2).
         destruct IHt1 as [ IHt1 | IHt1 ];
         destruct IHt2 as [ IHt2 | IHt2 ].
         + rewrite IHt1, IHt2.
           destruct ty1; destruct ty2; try (exists Bool; now right).
           exists Bool. now left.
         + rewrite IHt1, IHt2.
           destruct ty1; exists Bool; now right.
         + rewrite IHt1. exists Bool. now right.
         + rewrite IHt1. exists Bool. now right.
       - cbn.
         specialize (IHt1 c).
         specialize (IHt2 c).
         destruct IHt1 as (ty1, IHt1).
         destruct IHt2 as (ty2, IHt2).
         destruct IHt1 as [ IHt1 | IHt1 ];
         destruct IHt2 as [ IHt2 | IHt2 ].
         + rewrite IHt1, IHt2.
           destruct ty1; destruct ty2; try (exists Bool; now right).
           exists Bool. now left.
         + rewrite IHt1, IHt2.
           destruct ty1; exists Bool; now right.
         + rewrite IHt1. exists Bool. now right.
         + rewrite IHt1. exists Bool. now right.
Qed.

Definition istypechecked (c: ctx) (t: term): bool :=
  let ty := typecheck c t in
  match ty with
    | Some ty' => true
    | None     => false
  end.

Lemma istypechecked_t1: forall (t1 t2: term), istypechecked nil (App t1 t2) = true ->
  istypechecked nil t1 = true.
Proof. intro t1.
       case_eq t1; intros.
       - cbn in *. easy.
       - unfold istypechecked in *.
         case_eq (typecheck nil (Lambda s t t0)); intros.
         easy.
         cbn in *.
         case_eq (typecheck (extend nil s t) t0); intros.
         + rewrite H2 in H0, H1. easy.
         + rewrite H2 in H0. easy.
       - unfold istypechecked in *.
         case_eq (typecheck nil (App t t0)); intros.
         easy.
         case_eq (typecheck nil (App (App t t0) t2)); intros.
         rewrite H2 in H0. cbn in *.
         case_eq (typecheck nil t); intros.
         + rewrite H3 in H2, H1.
           case_eq t4; intros.
           * subst. easy.
           * subst. easy.
           * subst. case_eq (typecheck nil t0); intros.
             rewrite H in *. cbn in *.
             case_eq (type_eqb t5 t1); intros.
             rewrite H4 in *. easy.
             rewrite H4 in *. easy.
             rewrite H in *. easy.
         + rewrite H3 in *. easy.
         + rewrite H2 in *. easy.
       - cbn. easy.
       - cbn. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (typecheck nil t); intros.
         rewrite H1 in *.
         case_eq (typecheck nil t0 ); intros.
         rewrite H2 in *.
         case_eq (typecheck nil t2); intros.
         rewrite H3 in *.
         case_eq (type_eqb t4 Bool && type_eqb t5 t6); intros.
         rewrite H4 in *. easy.
         rewrite H4 in *.
         easy.
         rewrite H3 in *. easy.
         rewrite H2 in *. easy.
         rewrite H1 in *. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (typecheck nil t ); intros.
         rewrite H1 in H0.
         case_eq (match t0 with
                    | Arrow t1 t2 => if type_eqb t1 t2 then Some t2 else None
                    | _ => None
                  end); intros. easy.
         rewrite H2 in H0. easy.
         rewrite H1 in H0. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                   | Some Int => Some Int
                                   | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                   | Some Int => Some Int
                                   | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                   | Some Int => Some Int
                                   | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                   | Some Int => Some Bool
                                   | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                   | Some Int => Some Bool
                                   | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0. easy.
Qed.

Lemma istypechecked_t2: forall (t1 t2: term), istypechecked nil (App t1 t2) = true ->
  istypechecked nil t2 = true.
Proof. intros t1 t2.
       revert t1.
       case_eq t2; intros.
       - cbn in *.
         unfold istypechecked in *. cbn in *.
         case_eq (typecheck nil t1); intros.
         rewrite H1 in *.
         case_eq t; intros.
         rewrite H2 in *. easy.
         rewrite H2 in *. easy.
         rewrite H2 in *. easy.
         rewrite H1 in *. easy.
       - unfold istypechecked in *.
         case_eq (typecheck nil (Lambda s t t0)); intros.
         easy.
         cbn in *.
         case_eq (typecheck (extend nil s t) t0); intros.
         + rewrite H2 in H0, H1. easy.
         + rewrite H2 in H1.
           case_eq (typecheck nil t1 ); intros.
           rewrite H3 in *.
           case_eq t3; intros.
           rewrite H4 in *. easy.
           rewrite H4 in *. easy.
           rewrite H4, H2 in *. easy.
           rewrite H3 in *. easy.
       - unfold istypechecked in *.
         case_eq (typecheck nil (App t t0)); intros.
         easy. cbn in *.
         case_eq (typecheck nil t1); intros.
         rewrite H2 in *.
         case_eq t3; intros.
         rewrite H3 in *.
         easy.
         rewrite H3 in *.
         easy.
         rewrite H3 in *.
         case_eq (typecheck nil t); intros.
         rewrite H4 in *.
         case_eq t6; intros.
         rewrite H5 in *. easy.
         rewrite H5 in *. easy.
         rewrite H5 in *.
         case_eq (typecheck nil t0 ); intros.
         rewrite H6 in *.
         case_eq (type_eqb t7 t9); intros.
         rewrite H7 in *.
         easy.
         rewrite H7 in *. easy.
         rewrite H6 in *. easy.
         rewrite H4 in *. easy.
         rewrite H2 in *. easy.
       - easy.
       - easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (typecheck nil t3); intros.
         rewrite H1 in *.
         case_eq (t4 ); intros.
         rewrite H2 in *. easy.
         rewrite H2 in *. easy.
         rewrite H2 in *.
         case_eq (typecheck nil t); intros.
         rewrite H3 in *.
         case_eq (typecheck nil t0); intros.
         rewrite H4 in *.
         case_eq (typecheck nil t1); intros.
         rewrite H5 in *.
         case_eq (type_eqb t7 Bool && type_eqb t8 t9); intros.
         rewrite H6 in *. easy.
         rewrite H6 in *. easy.
         rewrite H5 in *. easy.
         rewrite H4 in *. easy.
         rewrite H3 in *. easy.
         rewrite H1 in *. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (typecheck nil t); intros.
         rewrite H1 in H0.
         case_eq t0; intros; subst.
         case_eq (typecheck nil t1); intros; rewrite H in H0.
         destruct t0; intros; easy.
         easy.
         case_eq (typecheck nil t1); intros; rewrite H in H0.
         destruct t0; intros; easy.
         easy.
         case_eq (type_eqb t3 t4); intros. easy.
         rewrite H in H0.
         destruct (typecheck nil t1).
         destruct t0; easy. easy.
         rewrite H1 in H0.
         case_eq (typecheck nil t1); intros; rewrite H2 in H0.
         destruct t0; intros; easy.
         easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                    | Some Int => Some Int
                                    | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0.
         case_eq (typecheck nil t1); intros; rewrite H2 in H0.
         destruct t3; intros; easy. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                    | Some Int => Some Int
                                    | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0.
         case_eq (typecheck nil t1); intros; rewrite H2 in H0.
         destruct t3; intros; easy. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                    | Some Int => Some Int
                                    | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0.
         case_eq (typecheck nil t1); intros; rewrite H2 in H0.
         destruct t3; intros; easy. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                    | Some Int => Some Bool
                                    | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0.
         case_eq (typecheck nil t1); intros; rewrite H2 in H0.
         destruct t3; intros; easy. easy.
       - unfold istypechecked in *.
         cbn in *.
         case_eq (match typecheck nil t with
                    | Some Int => match typecheck nil t0 with
                                    | Some Int => Some Bool
                                    | _ => None
                                  end
                    | _ => None
                  end); intros. easy. rewrite H1 in H0.
         case_eq (typecheck nil t1); intros; rewrite H2 in H0.
         destruct t3; intros; easy. easy.
Qed.

Lemma istypechecked_st: forall (t: term), istypechecked nil (Fix t) = true ->
  istypechecked nil t = true.
Proof. intro t.
       unfold istypechecked. cbn.
       case_eq (typecheck nil t); intros; easy.
Qed.

Lemma istypechecked_plus: forall (t1 t2: term), istypechecked nil (Plus t1 t2) = true ->
  istypechecked nil t1 = true /\ istypechecked nil t2 = true.
Proof. intro t.
       unfold istypechecked. cbn.
       case_eq (typecheck nil t); intros; try easy.
       split. easy.
       case_eq (typecheck nil t2); intros. easy.
       rewrite  H1 in H0.
       destruct t0; easy.
Qed.

Lemma istypechecked_minus: forall (t1 t2: term), istypechecked nil (Minus t1 t2) = true ->
  istypechecked nil t1 = true /\ istypechecked nil t2 = true.
Proof. intro t.
       unfold istypechecked. cbn.
       case_eq (typecheck nil t); intros; try easy.
       split. easy.
       case_eq (typecheck nil t2); intros. easy.
       rewrite  H1 in H0.
       destruct t0; easy.
Qed.

Lemma istypechecked_mult: forall (t1 t2: term), istypechecked nil (Mult t1 t2) = true ->
  istypechecked nil t1 = true /\ istypechecked nil t2 = true.
Proof. intro t.
       unfold istypechecked. cbn.
       case_eq (typecheck nil t); intros; try easy.
       split. easy.
       case_eq (typecheck nil t2); intros. easy.
       rewrite  H1 in H0.
       destruct t0; easy.
Qed.

Lemma istypechecked_eq: forall (t1 t2: term), istypechecked nil (Eq t1 t2) = true ->
  istypechecked nil t1 = true /\ istypechecked nil t2 = true.
Proof. intro t.
       unfold istypechecked. cbn.
       case_eq (typecheck nil t); intros; try easy.
       split. easy.
       case_eq (typecheck nil t2); intros. easy.
       rewrite  H1 in H0.
       destruct t0; easy.
Qed.

Lemma istypechecked_gt: forall (t1 t2: term), istypechecked nil (Gt t1 t2) = true ->
  istypechecked nil t1 = true /\ istypechecked nil t2 = true.
Proof. intro t.
       unfold istypechecked. cbn.
       case_eq (typecheck nil t); intros; try easy.
       split. easy.
       case_eq (typecheck nil t2); intros. easy.
       rewrite  H1 in H0.
       destruct t0; easy.
Qed.

Lemma context_invariance: forall G K t T,
  typecheck G t = Some T ->
  (forall x, find x (fv t) = true -> lookup G x = lookup K x) ->
  typecheck K t = Some T.
Proof. intros G K t.
       revert G K.
       induction t; intros.
       - simpl in *. rewrite <- H.
         specialize (H0 s).
         symmetry. apply H0.
         now rewrite String.eqb_refl.
       - cbn. cbn in H. unfold extend in *.
         case_eq (typecheck ((s, t) :: G) t0); intros.
         specialize (IHt ((s, t) :: G) ((s, t) :: K) t1).
         rewrite IHt.
         rewrite H1 in H. easy.
         easy.
         intros x Hx. cbn.
         case_eq ( s =? x ); intros.
         + easy.
         + apply H0. apply find0; easy.
         + rewrite H1 in H. easy.
       - cbn. cbn in H.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              specialize (IHt1 G K t).
              rewrite IHt1.
              specialize (IHt2 G K t0).
              rewrite IHt2. easy.
              easy.
              intros. apply H0.
              cbn. apply In1.
              apply In1 in H3.
              cbn.
              specialize (In5 (fv t1 ++ fv t2)); intros.
              apply H4. apply In7. easy.
              easy.
              intros. apply H0.
              cbn.
              apply In1.
              apply In1 in H3.
              specialize (In5 (fv t1 ++ fv t2)); intros.
              apply H4. apply In6. easy.
           ++ rewrite H2 in H.
              case_eq t; intros; subst; easy.
         + rewrite H1 in H. easy.
       - cbn in *. easy.
       - cbn in *. easy.
       - cbn in *.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              case_eq (typecheck G t3); intros.
              +++ rewrite H3 in H.
                  rewrite (IHt1 G K t).
                  rewrite (IHt2 G K t0).
                  rewrite (IHt3 G K t4).
                  easy.
                  easy.
                  intros. apply H0.
                  apply In1.
                  apply In1 in H4.
                  specialize (In5 (fv t1 ++ fv t2 ++ fv t3)); intros.
                  apply H5.
                  do 2 apply In7. easy.
                  easy.
                  intros. apply H0.
                  apply In1.
                  apply In1 in H4.
                  specialize (In5 (fv t1 ++ fv t2 ++ fv t3)); intros.
                  apply H5.
                  apply In7.
                  apply In6. easy.
                  easy.
                  intros. apply H0.
                  apply In1.
                  apply In1 in H4.
                  specialize (In5 (fv t1 ++ fv t2 ++ fv t3)); intros.
                  apply H5.
                  apply In6. easy.
              +++ rewrite H3 in H. easy.
           ++ rewrite H2 in H. easy.
         + rewrite H1 in H. easy.
       - cbn in *.
         case_eq (typecheck G t ); intros.
         + specialize (IHt G K t0 H1).
           rewrite IHt.
           case_eq t0; intros; subst; rewrite H1 in H; easy.
           intros y Hy.
           apply H0. easy.
         + rewrite H1 in H. easy.
       - cbn in *.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              specialize (IHt1 G K t H1).
              specialize (IHt2 G K t0 H2).
              rewrite IHt1, IHt2. easy.
              intros y Hy. apply H0.
              apply In1, In5, In7.
              apply In1 in Hy. easy.
              intros y Hy. apply H0.
              apply In1, In5, In6.
              apply In1 in Hy. easy.
           ++ rewrite H2 in H.
              destruct t; easy.
         + rewrite H1 in H. easy.
       - cbn in *.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              specialize (IHt1 G K t H1).
              specialize (IHt2 G K t0 H2).
              rewrite IHt1, IHt2. easy.
              intros y Hy. apply H0.
              apply In1, In5, In7.
              apply In1 in Hy. easy.
              intros y Hy. apply H0.
              apply In1, In5, In6.
              apply In1 in Hy. easy.
           ++ rewrite H2 in H.
              destruct t; easy.
         + rewrite H1 in H. easy.
       - cbn in *.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              specialize (IHt1 G K t H1).
              specialize (IHt2 G K t0 H2).
              rewrite IHt1, IHt2. easy.
              intros y Hy. apply H0.
              apply In1, In5, In7.
              apply In1 in Hy. easy.
              intros y Hy. apply H0.
              apply In1, In5, In6.
              apply In1 in Hy. easy.
           ++ rewrite H2 in H.
              destruct t; easy.
         + rewrite H1 in H. easy.
       - cbn in *.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              specialize (IHt1 G K t H1).
              specialize (IHt2 G K t0 H2).
              rewrite IHt1, IHt2. easy.
              intros y Hy. apply H0.
              apply In1, In5, In7.
              apply In1 in Hy. easy.
              intros y Hy. apply H0.
              apply In1, In5, In6.
              apply In1 in Hy. easy.
           ++ rewrite H2 in H.
              destruct t; easy.
         + rewrite H1 in H. easy.
       - cbn in *.
         case_eq (typecheck G t1); intros.
         + rewrite H1 in H.
           case_eq (typecheck G t2); intros.
           ++ rewrite H2 in H.
              specialize (IHt1 G K t H1).
              specialize (IHt2 G K t0 H2).
              rewrite IHt1, IHt2. easy.
              intros y Hy. apply H0.
              apply In1, In5, In7.
              apply In1 in Hy. easy.
              intros y Hy. apply H0.
              apply In1, In5, In6.
              apply In1 in Hy. easy.
           ++ rewrite H2 in H.
              destruct t; easy.
         + rewrite H1 in H. easy.
Qed.

Lemma subst0: forall t v x T,
(subst (Lambda x T t) x v) = (Lambda x T t).
Proof. intros.
       induction t; intros; simpl; rewrite String.eqb_refl; simpl; easy.
Qed.

(* Lemma subst00: forall t v x T f T2,
(subst (Fix f x T t T2) x v) = (Fix f x T t T2).
Proof. intros.
       induction t; intros; simpl; rewrite String.eqb_refl; simpl; easy.
Qed. *)

Lemma fv_neq: forall t x y T,
  find y (fv (Lambda x T t)) = true -> String.eqb x y = false.
Proof. intros.
       apply In1 in H. cbn in H.
       apply List.filter_In in H.
       destruct H.
       case_eq ((y =? x)); intros.
       + rewrite H1 in H0. cbn in H0. easy.
       + now rewrite String.eqb_sym in H1.
Qed.

(* Lemma fv_neq0: forall t x y T f T2,
  find y (fv (Fix f x T t T2)) = true -> String.eqb x y = false /\ String.eqb f y = false.
Proof. intros.
       apply In1 in H. cbn in H.
       apply List.filter_In in H.
       destruct H.
       apply Bool.andb_true_iff in H0.
       destruct H0.
       case_eq ((y =? x)); intros.
       + rewrite H2 in H0. cbn in H0. easy.
       + rewrite String.eqb_sym in H2. rewrite H2.
         case_eq (f =? y); intros.
         ++ rewrite String.eqb_sym in H1.
            rewrite H3 in H1. easy.
         ++ easy.
Qed. *)

Lemma cinv0: forall t x s T T2 U G,
  String.eqb x s = false ->
  typecheck ((s, T) :: (x, U) :: G) t = Some T2 ->
  typecheck ((x, U) :: (s, T) :: G) t = Some T2.
Proof. intros.
       specialize (context_invariance ((s, T) :: (x, U) :: G)  ((x, U) :: (s, T) :: G) t T2); intros.
       apply H1.
       easy.
       intros y Hy. cbn.
       case_eq (s =? y); intros.
       + rewrite String.eqb_eq in H2.
         rewrite H2 in H. rewrite H. easy.
       + easy.
Qed.

Lemma cinv1: forall a b A B C t T G,
  String.eqb a b = false ->
  typecheck ((a, A) :: (b, B) :: (b, C) :: G) t = Some T ->
  typecheck ((a, A) :: (b, B) :: G) t = Some T.
Proof. intros.
       specialize (context_invariance ((a, A) :: (b, B) :: (b, C) :: G) ((a, A) :: (b, B) :: G) t T H0); intros.
       rewrite H1. easy.
       intros y Hy. cbn.
       case_eq (a =? y); intros. easy.
       case_eq (b =? y); intros. easy. easy.
Qed.

Lemma cinv2: forall a b c A B C t T G,
  String.eqb a b = false ->
  String.eqb b c = false ->
  String.eqb a c = false ->
  typecheck ((a, A) :: (b, B) :: (c, C) :: G) t = Some T ->
  typecheck ((c, C) :: (a, A) :: (b, B) :: G) t = Some T.
Proof. intros.
       specialize (context_invariance ((a, A) :: (b, B) :: (c, C) :: G)
                                      ((c, C) :: (a, A) :: (b, B) :: G) t T H2); intros.
       rewrite H3. easy.
       intros y Hy. cbn.
       case_eq (a =? y); intros.
       apply String.eqb_eq in H4.
       subst. rewrite String.eqb_sym in H1.
       rewrite H1. easy.
       case_eq (b =? y); intros.
       apply String.eqb_eq in H5.
       subst. rewrite String.eqb_sym in H0.
       rewrite H0. easy.
       case_eq (c =? y); intros.
       easy. easy.
Qed.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose     : Extension for string
  author      : ZhengPu Shi
  date        : 2022.08
*)

Require Export Nat List.
Export ListNotations.

Require Export Ascii String.

Open Scope string.
Open Scope nat.

(** nat to ascii：只有0~9能正确转换，其余的都会转换为'A' *)
Definition nat2ascii (n:nat) : ascii :=
  match n with
  | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4"
  | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | 9 => "9"
  | _ => "A"
  end.

(** nat to string 的辅助函数。
  cnt     用于循环计数，初始值至少是位数那么大，比如125的位数是3
  n       输入的自然数
  suffix  后缀字符串，初始值为 ""，随着循环会逐步构成 "5", "25", "125"
*)
Fixpoint nat2str_aux (cnt:nat) (n:nat) (suffix:string) : string :=
  let suffix' := String (nat2ascii (n mod 10)) suffix in
  match cnt with
  | O => suffix'
  | S cnt' => match (n/10) with
    | O => suffix'
    | n' => nat2str_aux cnt' n' suffix'
    end
  end.

(** nat to string *)
Definition nat2str (n : nat) : string := nat2str_aux n n "".

(* Compute map (fun n => nat2str n) (seq 0 103). *)

(** 生成 n 个字符串：a1,a2,...,an *)
Definition create_nstrs (n:nat) (prefix:string) : list string :=
  map (fun i => prefix ++ nat2str i) (seq 1 n).


Add LoadPath "..".
Add LoadPath "../LabelFree".
Require Import Shared.
Require Import LabelFree.

Open Scope is5_scope.
Open Scope permut_scope.

(* Find a variable in a list of potential substitutions *)
Fixpoint find_var (L: list (var * ty * te_LF)) (x:var) :
                     option (var * ty * te_LF) :=
match L with
| nil => None
| (v, A, M) :: L' =>
  if (eq_var_dec x v) then Some (v, A, M) else find_var L' x
end.

Lemma Mem_find_var:
  forall L v,
    Mem v (map fst_ (map fst_ L)) ->
    exists A M, find_var L v = Some (v, A, M).
induction L; intros; [ rewrite Mem_nil_eq in *; contradiction | ];
destruct a; destruct p; rew_map in *; simpl in *.
subst; rewrite Mem_cons_eq in H.
destruct (eq_var_dec v v0).
subst; simpl; exists t0 t; auto.
destruct H; try contradiction; apply IHL; auto.
Qed.

Lemma NotMem_find_var:
  forall L v,
    ~Mem v (map fst_ (map fst_ L)) ->
    find_var L v = None.
induction L; intros; simpl in *; auto;
destruct a; destruct p; rew_map in *; simpl in *;
case_if.
elim H; apply Mem_here.
apply IHL; intro; elim H;
rewrite Mem_cons_eq; right; auto.
Qed.

Lemma find_var_Mem:
forall L v A M,
  find_var L v = Some (v, A, M) -> Mem (v, A, M) L.
induction L; intros; [inversion H; subst | ].
destruct a; destruct p; simpl in *; case_if.
inversion H; subst; apply Mem_here.
rewrite Mem_cons_eq; right; apply IHL; auto.
Qed.

(* A list of potential substitutions contains no repetitions *)

Fixpoint OkL (L: list (var * ty * te_LF)) U :=
match L with
| nil => True
| (v, A, M) :: L' => ~ Mem v U /\ OkL L' (v::U)
end.

Lemma OkL_permut:
forall L U1 U2,
  U1 *=* U2 ->
  OkL L U1 -> OkL L U2.
induction L; intros; [constructor | destruct a; destruct p];
inversion H0; subst; constructor.
intro; elim H1; apply Mem_permut with (l:=U2); [symmetry | ]; auto.
apply IHL with (U1:=v::U1); auto.
Qed.

Lemma OkL_weaken:
forall L U w,
  OkL L (w::U) -> OkL L U.
induction L; intros; simpl in *; auto; destruct a; destruct p; destruct H;
split.
intro; elim H; rewrite Mem_cons_eq; right; auto.
apply IHL with w. apply OkL_permut with (U1:=v::w::U); auto; permut_simpl.
Qed.

Lemma OkL_used_notin:
forall L U x A M,
  OkL L U ->
  Mem x U ->
  ~ Mem (x, A, M) L.
induction L; intros.
rewrite Mem_nil_eq; tauto.
intro; destruct a; destruct p; rewrite Mem_cons_eq in *; inversion H; subst;
destruct H1.
inversion H1; subst; contradiction.
specialize IHL with U x A M.
apply OkL_weaken in H3; apply IHL in H3; auto.
Qed.

Lemma OkL_fresh:
forall L x U,
  OkL L U->
  x \notin from_list (map fst_ (map fst_ L)) \u from_list U ->
  OkL L (x::U).
induction L; intros; [constructor | destruct a; destruct p];
simpl in *; destruct H; split.
intro; elim H; rewrite Mem_cons_eq in *; destruct H2; subst; auto;
repeat rewrite notin_union in *; destruct H0; destruct H0;
rew_map; simpl; rewrite from_list_cons; rewrite in_union; left;
rewrite in_singleton; auto.
apply OkL_permut with (U1:=x::v::U); [permut_simpl | apply IHL]; auto.
rew_map in *; simpl in *;
repeat rewrite from_list_cons in *; repeat rewrite notin_union in *;
simpl in *; destruct H0; destruct H0; split; auto.
Qed.

Lemma Mem_find_var_type:
  forall L v A,
    OkL L nil ->
    Mem (v, A) (map fst_ L) ->
    {M | find_var L v = Some (v, A, M)}.
induction L; intros; [ rewrite Mem_nil_eq in *; contradiction | ];
destruct a; destruct p; rew_map in *; simpl in *; destruct H.
subst; apply Mem_cons_spec in H0.
case_if.
destruct H0.
inversion e; subst; exists t; auto.
destruct IHL with v0 A; auto.
apply OkL_weaken in H1; auto.
apply find_var_Mem in e.
apply OkL_used_notin with (x:=v0) (A:=A) (M:=x) in H1; [ | apply Mem_here];
contradiction.
destruct H0; [inversion e; subst; elim H2; auto | ].
apply IHL; auto; apply OkL_weaken in H1; auto.
intros; decide equality. apply eq_ty_dec. apply eq_var_dec.
Qed.

(* Simultaneous substitution *)

Fixpoint SL (L: list (var * ty * te_LF)) M :=
match M with
| hyp_LF (bte v) => M
| hyp_LF (fte v) =>
  let x := find_var L v in
  match x with
    | Some (v, A, M) => M
    | None => hyp_LF (fte v)
  end
| lam_LF A M => lam_LF A (SL L M)
| appl_LF M N => appl_LF (SL L M) (SL L N)
| box_LF M => box_LF (SL L M)
| unbox_LF M => unbox_LF (SL L M)
| here_LF M => here_LF (SL L M)
| letdia_LF M N => letdia_LF (SL L M) (SL L N)
end.

Lemma lc_SL:
forall M L n,
  lc_t_n_LF n M ->
  (forall a b c, Mem (a,b,c) L -> lc_t_LF c) ->
  lc_t_n_LF n (SL L M).
induction M; intros; simpl in *;
try (inversion H; subst; constructor; eapply IHM; eauto).
destruct v; inversion H; subst;
[constructor; auto | ];
destruct (Mem_dec var (map fst_ (map fst_ L)) v);
[apply eq_var_dec | apply Mem_find_var in m; destruct m; destruct H1 | ].
rewrite H1; replace n with (0+n) by omega;
apply closed_t_addition_LF; apply H0 with v x; apply find_var_Mem; auto.
rewrite NotMem_find_var; auto.
inversion H; subst; constructor; [apply IHM1 | apply IHM2]; auto.
inversion H; subst; constructor; [eapply IHM2 | apply IHM1]; auto.
Qed.

Lemma SL_bte_subst:
forall L0 M x k,
  ~ Mem x (map fst_ (map fst_ L0)) ->
  (forall v a m, Mem (v, a, m) L0 -> lc_t_LF m) ->
  [hyp_LF (fte x) // bte k](SL L0 M) =
  SL L0 [hyp_LF (fte x) // bte k]M.
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto.
case_if; simpl.
case_if. rewrite NotMem_find_var; auto.
destruct v; simpl; repeat case_if; auto.
destruct (Mem_dec var (map fst_ (map fst_ L0)) v);
try apply eq_var_dec; [ | rewrite NotMem_find_var]; auto;
simpl; repeat case_if; auto.
apply Mem_find_var in m; destruct m as (a, (b, m)); rewrite m; simpl.
rewrite closed_subst_t_bound_LF with (n:=0); auto; try omega;
apply H0 with v a; apply find_var_Mem; auto.
Qed.

Fixpoint FV_L (L: list (var * ty * te_LF)) :=
match L with
| nil => \{}
| (v, A, M) :: L' => used_vars_te_LF M \u FV_L L'
end.

Lemma notin_FV_notin_elem:
forall x L,
  x \notin FV_L L ->
  forall a b c, Mem (a,b,c) L -> x \notin used_vars_te_LF c.
induction L; intros; simpl in *.
rewrite Mem_nil_eq in *; contradiction.
rewrite Mem_cons_eq in H0; destruct H0; [inversion H0; subst | ].
rewrite notin_union in H; destruct H; auto.
destruct a; destruct p; rewrite notin_union in H; destruct H;
apply IHL with (a:=a0) (b:=b); auto.
Qed.

Lemma SL_extend:
forall M L0 x A N,
  x \notin FV_L L0 ->
  ~Mem x (map fst_ (map fst_ L0)) ->
  SL ((x, A, N) :: L0) M =
  [N // fte x](SL L0 M).
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto.
destruct v; simpl; repeat case_if; auto.
rewrite NotMem_find_var; auto; simpl; case_if; auto.
destruct (Mem_dec var (map fst_ (map fst_ L0)) v);
try apply eq_var_dec; [ | rewrite NotMem_find_var]; auto;
simpl; repeat case_if; auto.
apply Mem_find_var in m; destruct m as (a, (b, m)); rewrite m; simpl.
rewrite closed_subst_t_free_LF; auto.
apply notin_FV_notin_elem with L0 v a; eauto.
apply find_var_Mem; eauto.
Qed.

(* Termination *)

Inductive WT: te_LF -> Prop :=
| val_WT: forall V, value_LF V -> WT V
| step_WT: forall M, (exists V, value_LF V /\ steps_LF M V) -> WT M
.

Hint Resolve lc_t_step_LF lc_t_steps_LF.

Lemma step_LF_unique:
forall M N N',
  M |-> N ->
  M |-> N' ->
  N = N'.
intros; generalize dependent N'; induction H; intros.
inversion H1; subst; auto; inversion H7.
inversion H0; subst; auto; inversion H3.
inversion H2; subst; auto; inversion H8; subst;
apply value_no_step_LF in H7; auto; contradiction.
inversion H2; subst; [inversion H1 | ]; rewrite IHstep_LF with M'0; auto.
inversion H1; subst; [inversion H0 | ]; rewrite IHstep_LF with M'0; auto.
inversion H1; subst; rewrite IHstep_LF with M'0; auto.
inversion H2; subst.
  inversion H1; subst; apply value_no_step_LF in H7; auto; contradiction.
  rewrite IHstep_LF with M'0; auto.
Qed.

Theorem WT_step:
forall M M',
  WT M ->
  M |-> M' ->
  WT M'.
intros; inversion H; subst.
apply value_no_step_LF with (N:=M') in H1; contradiction.
destruct H1 as (V, (H1, H2)).
inversion H2; subst.
apply step_LF_unique with (N':=V) in H0; subst; auto; constructor; auto.
apply step_WT; exists V; split; auto.
apply step_LF_unique with (N':=M'0) in H0; subst; auto.
Qed.

Lemma WT_step_back:
forall M N,
  WT N ->
  M |-> N ->
  WT M.
intros; inversion H; subst.
apply step_WT; exists N; split; auto; constructor; auto.
destruct H1 as (V, (H1, H2)); apply step_WT; exists V; split; auto.
apply multi_step_LF with (M':=N); auto.
Qed.

Lemma WT_steps:
forall M N,
  steps_LF M N ->
  WT M -> WT N.
intros; induction H; apply WT_step in H; auto.
Qed.

Lemma WT_steps_back:
forall M N,
  steps_LF M N ->
  WT N -> WT M.
intros; induction H; apply WT_step_back in H; auto.
Qed.

Lemma here_val:
forall M V,
  value_LF V -> steps_LF (here_LF M) V ->
  exists M', V = here_LF M'.
intros; remember (here_LF M) as M0; generalize dependent M.
induction H0; intros; subst.
inversion H0; subst. eexists; eauto.
inversion H0; subst.
apply IHsteps_LF with (M:=M'0); auto.
Qed.

Lemma WT_here:
forall M,
  lc_t_LF M ->
  (WT M <-> WT (here_LF M)).
split.
intros; inversion H0; subst.
constructor; constructor; auto.
destruct H1 as (V, (H1, H2)).
apply step_WT; exists (here_LF V); split.
constructor; auto.
induction H2; intros; subst.
  constructor; constructor; auto.
  apply multi_step_LF with (here_LF M').
    constructor; auto.
    apply IHsteps_LF; auto.
    apply lc_t_step_LF in H2; auto.
    apply WT_step in H2; auto.
intros. remember (here_LF M) as T; generalize dependent M.
induction H0; intros; subst.
inversion H; constructor; subst; auto.
destruct H as (V, (H, H1)).
assert ( steps_LF (here_LF M0) V) by auto.
apply here_val in H1; auto; destruct H1; subst.
apply step_WT; exists x; split; inversion H; subst; auto.
remember (here_LF M0) as hm; remember (here_LF x) as hx; generalize dependent x;
generalize dependent M0; induction H2; intros; subst.
inversion H0; subst; constructor; auto.
inversion H0; subst.
apply multi_step_LF with M'0; auto. apply IHsteps_LF; auto.
apply lc_t_step_LF in H6; auto.
Qed.

Hint Resolve WT_step.

Inductive Cont :=
| IdK: ty -> Cont
| ConsU: Cont -> ty -> Cont
| ConsD: Cont -> te_LF -> ty -> ty -> Cont
| ConsA: Cont -> te_LF -> ty -> ty -> Cont
.

Fixpoint ContAppl (K: Cont) (M: te_LF) : te_LF :=
match K with
| IdK A => M
| ConsU K' A => ContAppl K' (unbox_LF M)
| ConsD K' N A B => ContAppl K' (letdia_LF M N)
| ConsA K' N A B => ContAppl K' (appl_LF M N)
end.

Notation " K '@' M " := (ContAppl K M) (at level 65).

Inductive ContLC: Cont -> Prop :=
| ContId_lc: forall A, ContLC (IdK A)
| ContU_lc: forall K A, ContLC K -> ContLC (ConsU K A)
| ContD_lc: forall K N A B,
                 ContLC K -> lc_t_n_LF 1 N -> ContLC (ConsD K N A B)
| ContA_lc: forall K N A B,
                 ContLC K -> lc_t_LF N -> ContLC (ConsA K N A B)
.

Definition WTC K := forall M, WT (K@M).

Lemma Step_KApplStep:
forall K M M',
  ContLC K ->
  lc_t_LF M ->
  M |-> M' ->
  K @ M |-> K @ M'.
induction K; intros; simpl in *; auto.
inversion H; subst;
assert (unbox_LF M |-> unbox_LF M')
   by (repeat constructor; auto);
apply IHK in H2; auto; constructor; auto.
inversion H; subst;
assert (letdia_LF M t |-> letdia_LF M' t)
   by (repeat constructor; auto);
apply IHK in H2; auto; constructor; auto.
inversion H; subst;
assert (appl_LF M t |-> appl_LF M' t)
   by (repeat constructor; auto);
apply IHK in H2; auto; constructor; auto.
Qed.

Lemma steps_KApplSteps:
forall K M M',
  ContLC K ->
  lc_t_LF M ->
  steps_LF M M' ->
  steps_LF (K @ M) (K @ M').
intros; generalize dependent K; induction H1; intros.
constructor; apply Step_KApplStep; auto.
apply multi_step_LF with (M':=(ContAppl K M')).
apply Step_KApplStep; auto.
apply IHsteps_LF; auto. apply lc_t_step_LF in H; auto.
Qed.

Fixpoint R M A {struct A} : Prop :=
let Q M A := forall K,
               lc_t_LF M -> ContLC K -> RC K A ->
               WT (K @ M) in
match A with
| tvar => WT M
| A1 ---> A2 => WT M /\
                (forall N,
                   lc_t_LF N ->
                   Q N A1 ->
                   Q (appl_LF M N) A2)
| [*]A1 => WT M /\ forall K, RC K A1 -> WT (K @ (unbox_LF M))
| <*>A1 => forall K, ContLC K ->
                     (forall V,
                        lc_t_LF V ->
                        R V A1 ->
                        WT (K @ (here_LF V))) ->
                     WT (K @ M)
end
with RC K A {struct A} : Prop :=
let Q M A := forall K,
               lc_t_LF M -> ContLC K -> RC K A ->
               WT (K @ M) in
match A with
| tvar => forall V, lc_t_LF V -> WT V -> WT (K @ V)
| tbox A1 => forall V, lc_t_LF V ->
                       (WT V /\
                        forall K0, ContLC K0 ->
                                   RC K0 A1 ->
                                   WT (K0 @ (unbox_LF V))) ->
                       WT (K @ V)
| A1 ---> A2 => forall V, lc_t_LF V ->
                  (WT V /\
                   (forall N,
                      lc_t_LF N ->
                      Q N A1 ->
                      Q (appl_LF V N) A2)) ->
                  WT (K @ V)
| <*> A1 => forall V, lc_t_LF V ->
                       Q V A1 -> WT (K @ (here_LF V))
end.

Definition Q N A :=
    forall K, lc_t_LF N -> ContLC K -> RC K A -> WT (K @ N).

Hint Unfold Q.

(* This is required for the main theorem *)
Lemma RCIdK:
forall t, RC (IdK t) t.
induction t; simpl in *; intros; auto.
destruct H0; auto.
destruct H0; auto.
assert (WT ((IdK t) @ V));
[apply H0; auto; constructor | rewrite <- WT_here; auto].
Qed.

Lemma steps_letdia:
forall M M', steps_LF M M' ->
forall N, lc_t_LF M -> lc_t_n_LF 1 N ->
            steps_LF (letdia_LF M N) (letdia_LF M' N).
intros M M' H; induction H; intros; simpl in *.
constructor; constructor; auto.
apply multi_step_LF with (M':=letdia_LF M' N); auto.
constructor; auto. apply IHsteps_LF; auto. apply lc_t_step_LF in H; auto.
Qed.

Lemma steps_here:
forall M M', steps_LF M M' -> lc_t_LF M -> steps_LF (here_LF M) (here_LF M').
intros; induction H; simpl in *.
repeat constructor; auto.
apply multi_step_LF with (M':=here_LF M').
repeat constructor; auto.
apply IHsteps_LF; apply lc_t_step_LF in H; auto.
Qed.

Lemma Q_SL_hyp:
forall L G Gamma v A,
  OkL L nil ->
  concat (Gamma::G) *=* map fst_ L ->
  (forall a b c, Mem (a, b, c) L -> Q c b) ->
  G |= Gamma |- hyp_LF (fte v) ::: A ->
  Q (SL L (hyp_LF (fte v))) A.
intros.
inversion H2; subst.
assert (Mem (v, A) (map fst_ L)).
  apply Mem_permut with (l:=concat (Gamma::G)); auto.
  rew_concat; rewrite Mem_app_or_eq; left; auto.
apply Mem_find_var_type in H3; auto. destruct H3.
simpl; rewrite e.
apply H1 with v.
apply find_var_Mem; auto.
Qed.

Theorem main_theorem:
forall G Gamma M A,
  lc_t_LF M ->
  G |= Gamma |- M ::: A ->
 forall L,
    OkL L nil ->
    concat(Gamma::G) *=* map fst_ L ->
    (forall a b c, Mem (a,b,c) L -> lc_t_LF c) ->
    (forall a b c, Mem (a,b,c) L -> Q c b) ->
    forall K,
      ContLC K ->
      RC K A ->
      WT (K @ (SL L M)).
intros G Gamma M A LC HT;
induction HT;
intros; simpl in *.
(* hyp *)
assert (lc_t_LF (SL L (hyp_LF (fte v)))) by
  (apply lc_SL; auto; constructor);
simpl in *;
assert (Q (SL L (hyp_LF (fte v))) A);
[apply Q_SL_hyp with G Gamma; auto; constructor | apply H7]; auto.
(* lam *)
autounfold in *; inversion LC; subst; apply H6; simpl;
[ constructor; apply lc_SL; auto |];
split; intros; [repeat constructor | ];
apply WT_step_back with (N:=ContAppl K0 (((SL L0 M) ^t^ N)));
[ unfold open_LF in *;
  assert (exists x, x \notin L \u used_vars_te_LF (SL L0 M) \u FV_L L0
       \u  from_list (map fst_ (map fst_ L0))  \u from_list nil)
  as HF by apply Fresh; destruct HF | ];
[ | apply Step_KApplStep; auto; repeat constructor; auto; apply lc_SL; auto];
rewrite subst_t_neutral_free_LF with (v:=x); auto;
rewrite SL_bte_subst; auto;
[rewrite <- SL_extend with (A:=A) | apply notin_Mem]; auto;
[|apply notin_Mem]; auto;
apply H0; auto.
  apply lc_t_subst_t_LF_bound; [constructor | inversion LC; auto].
  constructor; [ rewrite Mem_nil_eq | apply OkL_fresh]; auto.
  rew_map in *; simpl; rewrite <-  H2; rew_concat; auto.
  intros; rewrite Mem_cons_eq in *; destruct H14; eauto;
  inversion H14; subst; auto.
  intros; rewrite Mem_cons_eq in *; destruct H14; eauto;
  inversion H14; subst; auto.
(* appl *)
inversion LC; subst;
assert (WT ((ConsA K (SL L N) A B) @ (SL L M))); [ | simpl; auto];
apply IHHT1; auto; [constructor; auto; apply lc_SL; auto | ];
autounfold in *; simpl; intros; destruct H6; apply H7; auto;
repeat constructor; auto; apply lc_SL; auto.
(* box *)
inversion LC; subst;
apply H4; [constructor; apply lc_SL; auto | ];
split; [repeat constructor | intros].
apply WT_step_back with (K0 @ (SL L M)).
  apply IHHT; auto; rewrite <- H0; rew_concat; permut_simpl.
  apply Step_KApplStep; auto; repeat constructor; apply lc_SL; auto.
(* unbox *)
inversion LC; subst;
assert (WT ((ConsU K A) @ (SL L M))); [ | simpl; auto];
apply IHHT; auto; [ constructor; auto | intros ];
destruct H6; simpl; apply H8; auto.
(* unbox-fetch *)
inversion LC; subst;
assert (WT ((ConsU K A) @ (SL L M))); [ | simpl; auto];
apply IHHT; auto; [ | constructor; auto | intros ];
[ | destruct H7; simpl; apply H9; auto];
rewrite <- H1; rew_concat; permut_simpl;
replace (Gamma ++ concat G) with (concat (Gamma::G)) by (rew_concat; auto);
apply PPermut_concat_permut; rewrite <- H; PPermut_LF_simpl.
(* here *)
inversion LC; subst; apply H4; [apply lc_SL; auto | intros]; apply IHHT; auto.
(* get-here *)
inversion LC; subst.
apply H5; [apply lc_SL; auto | ]; simpl; intros;
apply IHHT; auto.
rew_map in *; simpl; rewrite <-  H1; rew_concat; auto; permut_simpl;
replace (Gamma ++ concat G) with (concat (Gamma::G)) by (rew_concat; auto);
apply PPermut_concat_permut; rewrite <- H; PPermut_LF_simpl.
(* letdia *)
inversion LC; subst;
assert (WT ((ConsD K (SL L0 N) A B) @ (SL L0 M))); [ | simpl; auto];
apply IHHT; auto; [constructor; auto; apply lc_SL; auto | ]; intros; simpl in *.
assert (WT ((IdK A) @ V)).
  apply H7; auto. constructor. apply RCIdK.
simpl in H8; inversion H8; subst.
  (* value *)
  apply WT_step_back with (K @ ((SL L0 N) ^t^ V));
  [ | apply Step_KApplStep; auto; repeat constructor; auto; apply lc_SL; auto].
  unfold open_LF in *;
  assert (exists x, x \notin L \u used_vars_te_LF (SL L0 M) \u FV_L L0
       \u  used_vars_te_LF (SL L0 N)
       \u  from_list (map fst_ (map fst_ L0))  \u from_list nil)
  as HF by apply Fresh; destruct HF.
  rewrite subst_t_neutral_free_LF with (v:=x); auto;
  rewrite SL_bte_subst; auto;
  [rewrite <- SL_extend with (A:=A) | apply notin_Mem]; auto;
  [|apply notin_Mem]; auto.
  apply H with (G':=((x,A)::nil) :: G); auto.
    apply lc_t_subst_t_LF_bound; [constructor | inversion LC; auto].
    constructor; [ rewrite Mem_nil_eq | apply OkL_fresh]; auto.
    rew_map in *; simpl; rewrite <-  H1; rew_concat; auto;
    replace (Gamma ++ concat G) with (concat (Gamma::G)) by (rew_concat; auto);
    permut_simpl.
    intros; rewrite Mem_cons_eq in *; destruct H13; auto;
    inversion H13; subst; eauto.
    intros; rewrite Mem_cons_eq in *; destruct H13; auto;
    inversion H13; subst; eauto.
  (* step *)
  destruct H11 as (V', (H11, H12)).
  apply WT_steps_back with (K @ letdia_LF (here_LF V') (SL L0 N)).
    apply steps_KApplSteps; auto.
      repeat constructor; auto; apply lc_SL; auto.
      apply steps_letdia; [apply steps_here | |]; auto; repeat constructor;
      auto; apply lc_SL; auto.
  assert (lc_t_LF V') by (apply lc_t_steps_LF in H12; auto);
  apply WT_step_back with (K @ ((SL L0 N) ^t^ V'));
  [ | apply Step_KApplStep; auto; repeat constructor; auto; apply lc_SL; auto];
  unfold open_LF in *;
  assert (exists x, x \notin L \u used_vars_te_LF (SL L0 M) \u FV_L L0
       \u  used_vars_te_LF (SL L0 N)
       \u  from_list (map fst_ (map fst_ L0))  \u from_list nil)
  as HF by apply Fresh; destruct HF;
  rewrite subst_t_neutral_free_LF with (v:=x); auto;
  rewrite SL_bte_subst; auto;
  [rewrite <- SL_extend with (A:=A) | apply notin_Mem]; auto;
  [|apply notin_Mem]; auto.
  apply H with (G':=((x,A)::nil) :: G); auto.
    apply lc_t_subst_t_LF_bound; [constructor | inversion LC; auto].
    constructor; [ rewrite Mem_nil_eq | apply OkL_fresh]; auto.
    rew_map in *; simpl; rewrite <-  H1; rew_concat; auto;
    replace (Gamma ++ concat G) with (concat (Gamma::G)) by (rew_concat; auto);
    permut_simpl.
    intros; rewrite Mem_cons_eq in *; destruct H15; auto;
    inversion H15; subst; eauto.
    intros; rewrite Mem_cons_eq in *; destruct H15; auto;
    inversion H15; subst; eauto. autounfold. intros.
    apply WT_steps with (M:=K0 @ V).
      apply steps_KApplSteps; auto. apply H7; auto.
(* letdia-get *)
inversion LC; subst;
assert (WT ((ConsD K (SL L0 N) A B) @ (SL L0 M))); [ | simpl; auto];
apply IHHT; auto; [ |constructor; auto; apply lc_SL; auto | ];
[rewrite <-  H2; apply PPermut_concat_permut; rewrite <- H0; PPermut_LF_simpl|
 intros; simpl in *];
assert (WT ((IdK A) @ V)).
  apply H8; auto; [constructor | apply RCIdK].
simpl in H9; inversion H9; subst.
  (* value *)
  apply WT_step_back with (K @ ((SL L0 N) ^t^ V));
  [ | apply Step_KApplStep; auto; repeat constructor; auto; apply lc_SL; auto].
  unfold open_LF in *;
  assert (exists x, x \notin L \u used_vars_te_LF (SL L0 M) \u FV_L L0
       \u  used_vars_te_LF (SL L0 N)
       \u  from_list (map fst_ (map fst_ L0))  \u from_list nil)
  as HF by apply Fresh; destruct HF.
  rewrite subst_t_neutral_free_LF with (v:=x); auto;
  rewrite SL_bte_subst; auto;
  [rewrite <- SL_extend with (A:=A) | apply notin_Mem]; auto;
  [|apply notin_Mem]; auto.
  apply H; auto.
    apply lc_t_subst_t_LF_bound; [constructor | inversion LC; auto].
    constructor; [ rewrite Mem_nil_eq | apply OkL_fresh]; auto.
    rew_map in *; simpl; rewrite <-  H2; rew_concat; auto; permut_simpl;
    replace (concat G ++ Gamma) with (concat (G & Gamma)) by (rew_concat; auto);
    apply PPermut_concat_permut; auto.
    intros; rewrite Mem_cons_eq in *; destruct H14; auto;
    inversion H14; subst; eauto.
    intros; rewrite Mem_cons_eq in *; destruct H14; auto;
    inversion H14; subst; eauto.
  (* step *)
  destruct H12 as (V', (H12, H13)).
  apply WT_steps_back with (K @ letdia_LF (here_LF V') (SL L0 N)).
    apply steps_KApplSteps; auto.
      repeat constructor; auto; apply lc_SL; auto.
      apply steps_letdia; [apply steps_here | |]; auto; repeat constructor;
      auto; apply lc_SL; auto.
  assert (lc_t_LF V') by (apply lc_t_steps_LF in H13; auto);
  apply WT_step_back with (K @ ((SL L0 N) ^t^ V'));
  [ | apply Step_KApplStep; auto; repeat constructor; auto; apply lc_SL; auto];
  unfold open_LF in *;
  assert (exists x, x \notin L \u used_vars_te_LF (SL L0 M) \u FV_L L0
       \u  used_vars_te_LF (SL L0 N)
       \u  from_list (map fst_ (map fst_ L0))  \u from_list nil)
  as HF by apply Fresh; destruct HF;
  rewrite subst_t_neutral_free_LF with (v:=x); auto;
  rewrite SL_bte_subst; auto;
  [rewrite <- SL_extend with (A:=A) | apply notin_Mem]; auto;
  [|apply notin_Mem]; auto.
  apply H; auto.
    apply lc_t_subst_t_LF_bound; [constructor | inversion LC; auto].
    constructor; [ rewrite Mem_nil_eq | apply OkL_fresh]; auto.
    rew_map in *; simpl; rewrite <-  H2; rew_concat; auto; permut_simpl;
    replace (concat G ++ Gamma) with (concat (G & Gamma)) by (rew_concat; auto);
    apply PPermut_concat_permut; auto.
    intros; rewrite Mem_cons_eq in *; destruct H16; auto;
    inversion H16; subst; eauto.
    intros; rewrite Mem_cons_eq in *; destruct H16; auto;
    inversion H16; subst; eauto. autounfold. intros.
    apply WT_steps with (M:=K0 @ V).
      apply steps_KApplSteps; auto. apply H8; auto.
Qed.

Lemma lc_t_n_LF_subst_t:
forall N M n,
lc_t_n_LF n M ->
lc_t_n_LF n (subst_t_LF M (bte n) N) ->
lc_t_n_LF (S n) N.
induction N; intros; simpl in *; try destruct v; constructor;
repeat case_if; try inversion H1; subst; try omega;
inversion H0; subst; eauto.
apply IHN with (M:=M); eauto; apply closed_t_succ_LF; auto.
apply IHN2 with (M:=M); eauto; apply closed_t_succ_LF; auto.
Qed.

Lemma types_LF_lc_t_LF:
forall G Gamma M A,
  G |= Gamma |- M ::: A -> lc_t_LF M.
intros; induction H; constructor; try apply IHHT;
unfold open_LF in *; auto.
assert (exists x, x \notin L) by apply Fresh; destruct H1;
assert (x \notin L) by auto;
specialize H0 with x; apply H0 in H1;
apply lc_t_n_LF_subst_t in H0; auto; constructor.
assert (exists x, x \notin L) by apply Fresh; destruct H1;
assert (x \notin L) by auto;
specialize H0 with (((x, A) :: nil) :: G) x; apply H0 in H1;
apply lc_t_n_LF_subst_t in H0; auto; constructor.
assert (exists x, x \notin L) by apply Fresh; destruct H2;
assert (x \notin L) by auto;
specialize H0 with x; apply H0 in H2;
apply lc_t_n_LF_subst_t in H2; auto; constructor.
Qed.

Lemma SL_nil:
forall M,
  SL nil M = M.
induction M; intros; simpl; try destruct v;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); eauto.
Qed.

Theorem WT_Lang:
forall G M A,
  emptyEquiv_LF G |= nil |- M ::: A ->
  WT M.
intros.
assert (lc_t_LF M).
  apply types_LF_lc_t_LF in H; auto.
assert (WT (ContAppl (IdK A) M)); [ | simpl in *; auto];
apply main_theorem with (L:=nil) (K:=IdK A) in H; auto.
rewrite SL_nil in H; auto.
constructor.
rew_concat; rew_map; clear M A H H0;
induction G; simpl; rew_concat; auto.
intros; rewrite Mem_nil_eq in *; contradiction.
intros; rewrite Mem_nil_eq in *; contradiction.
constructor.
apply RCIdK.
Qed.


Require Import IFOL.Semantics.Signature.

Require Import IFOL.Examples.HA.Syntax.Sort.

Definition eval_HA_sort : sort_dom HA_sort :=
  fun s =>
    match s with
    | Nat => nat
    end.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export logic.
Definition lemma__together : forall A B C D F G P Q a b c, (euclidean__defs.TG A a B b C c) -> ((euclidean__axioms.Cong D F A a) -> ((euclidean__axioms.Cong F G B b) -> ((euclidean__axioms.BetS D F G) -> ((euclidean__axioms.Cong P Q C c) -> ((euclidean__defs.Lt P Q D G) /\ ((euclidean__axioms.neq A a) /\ ((euclidean__axioms.neq B b) /\ (euclidean__axioms.neq C c)))))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro F.
intro G.
intro P.
intro Q.
intro a.
intro b.
intro c.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
assert (exists R, (euclidean__axioms.BetS A a R) /\ ((euclidean__axioms.Cong a R B b) /\ (euclidean__defs.Lt C c A R))) as H4 by exact H.
destruct H4 as [R H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
assert (* Cut *) (euclidean__axioms.Cong A a A a) as H10.
- apply (@euclidean__axioms.cn__congruencereflexive A a).
- assert (* Cut *) (euclidean__axioms.Cong B b a R) as H11.
-- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B a R b H8).
-- assert (* Cut *) (euclidean__axioms.Cong F G a R) as H12.
--- apply (@lemma__congruencetransitive.lemma__congruencetransitive F G B b a R H1 H11).
--- assert (* Cut *) (euclidean__axioms.Cong D G A R) as H13.
---- apply (@euclidean__axioms.cn__sumofparts D F G A a R H0 H12 H2 H6).
---- assert (* Cut *) (euclidean__axioms.Cong A R D G) as H14.
----- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A D G R H13).
----- assert (* Cut *) (euclidean__axioms.Cong C c P Q) as H15.
------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C P Q c H3).
------ assert (* Cut *) (euclidean__defs.Lt P Q A R) as H16.
------- apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 C c A R P Q H9 H15).
------- assert (* Cut *) (euclidean__defs.Lt P Q D G) as H17.
-------- apply (@lemma__lessthancongruence.lemma__lessthancongruence P Q A R D G H16 H14).
-------- assert (* Cut *) (euclidean__axioms.neq A a) as H18.
--------- assert (* Cut *) ((euclidean__axioms.neq a R) /\ ((euclidean__axioms.neq A a) /\ (euclidean__axioms.neq A R))) as H18.
---------- apply (@lemma__betweennotequal.lemma__betweennotequal A a R H6).
---------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H21.
--------- assert (* Cut *) (euclidean__axioms.neq a R) as H19.
---------- assert (* Cut *) ((euclidean__axioms.neq a R) /\ ((euclidean__axioms.neq A a) /\ (euclidean__axioms.neq A R))) as H19.
----------- apply (@lemma__betweennotequal.lemma__betweennotequal A a R H6).
----------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H20.
---------- assert (* Cut *) (euclidean__axioms.neq B b) as H20.
----------- apply (@euclidean__axioms.axiom__nocollapse a R B b H19 H8).
----------- assert (exists S, (euclidean__axioms.BetS A S R) /\ (euclidean__axioms.Cong A S C c)) as H21 by exact H9.
destruct H21 as [S H22].
destruct H22 as [H23 H24].
assert (* Cut *) (euclidean__axioms.neq A S) as H25.
------------ assert (* Cut *) ((euclidean__axioms.neq S R) /\ ((euclidean__axioms.neq A S) /\ (euclidean__axioms.neq A R))) as H25.
------------- apply (@lemma__betweennotequal.lemma__betweennotequal A S R H23).
------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H28.
------------ assert (* Cut *) (euclidean__axioms.neq C c) as H26.
------------- apply (@euclidean__axioms.axiom__nocollapse A S C c H25 H24).
------------- split.
-------------- exact H17.
-------------- split.
--------------- exact H18.
--------------- split.
---------------- exact H20.
---------------- exact H26.
Qed.


(** * Opposite natural transformations *)
Require Category.Dual Functor.Dual.
Import Category.Dual.CategoryDualNotations Functor.Dual.FunctorDualNotations.
Require Import Category.Core Functor.Core NaturalTransformation.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.

(** ** Definition of [Tᵒᵖ] *)
Definition opposite
           C D
           (F G : Functor C D)
           (T : NaturalTransformation F G)
: NaturalTransformation G^op F^op
  := Build_NaturalTransformation' (G^op) (F^op)
                                  (components_of T)
                                  (fun s d => commutes_sym T d s)
                                  (fun s d => commutes T d s).

Local Notation "T ^op" := (opposite T) : natural_transformation_scope.

(** ** [ᵒᵖ] is judgmentally involutive *)
Local Open Scope natural_transformation_scope.

Definition opposite_involutive C D (F G : Functor C D) (T : NaturalTransformation F G)
: (T^op)^op = T
  := idpath.

Module Export NaturalTransformationDualNotations.
  Notation "T ^op" := (opposite T) : natural_transformation_scope.
End NaturalTransformationDualNotations.


Require Export UniMath.Foundations.All.

(** *** Propositions equivalent to negations of propositions *)

Definition negProp P := ∑ Q, isaprop Q × (¬P <-> Q).

Definition negProp_to_isaprop {P} (nP : negProp P) : isaprop (pr1 nP)
  := pr1 (pr2 nP).

Definition negProp_to_hProp {P : UU} (Q : negProp P) : hProp.
Proof.
  intros. exists (pr1 Q). apply negProp_to_isaprop.
Defined.
Coercion negProp_to_hProp : negProp >-> hProp.

Definition negProp_to_iff {P} (nP : negProp P) : ¬P <-> nP
  := pr2 (pr2 nP).

Definition negProp_to_neg {P} {nP : negProp P} : nP -> ¬P.
Proof.
  intros np. exact (pr2 (negProp_to_iff nP) np).
Defined.

Coercion negProp_to_neg : negProp >-> Funclass.

Definition neg_to_negProp {P} {nP : negProp P} : ¬P -> nP.
Proof.
  intros np. exact (pr1 (negProp_to_iff nP) np).
Defined.

Definition negPred {X:UU} (x  :X) (P:∏ y:X, UU)      := ∏ y  , negProp (P y).

Definition negReln {X:UU}         (P:∏ (x y:X), UU)  := ∏ x y, negProp (P x y).

Definition neqProp {X:UU} (x y:X) :=            negProp (x=y).

Definition neqPred {X:UU} (x  :X) := ∏ y,       negProp (x=y).

Definition neqReln (X:UU)         := ∏ (x y:X), negProp (x=y).

Lemma negProp_to_complementary P : ∏ (Q : negProp P), P ⨿ Q <-> complementary P Q.
Proof.
  intros [Q [i [r s]]]; simpl in *.
  split.
  * intros pq. split.
    - intros p q. apply s.
      + assumption.
      + assumption.
    - assumption.
      * intros [j c].
        assumption.
Defined.

Lemma negProp_to_uniqueChoice P : ∏ (Q:negProp P), (isaprop P × (P ⨿ Q)) <-> iscontr (P ⨿ Q).
Proof.
  intros [Q [j [r s]]]; simpl in *. split.
  * intros [i v]. exists v. intro w.
    induction v as [v|v].
    - induction w as [w|w].
      + apply maponpaths, i.
      + contradicts (s w) v.
    - induction w as [w|w].
      + contradicts (s v) w.
      + apply maponpaths, j.
  * intros [c e]. split.
    - induction c as [c|c].
      + apply invproofirrelevance; intros p p'.
        exact (equality_by_case (e (ii1 p) @ !e (ii1 p'))).
      + apply invproofirrelevance; intros p p'.
        contradicts (s c) p.
    - exact c.
Defined.

(** Rework some foundational material using negative propositions. *)

Definition isisolated_ne (X:UU) (x:X) (neq_x:neqPred x) := ∏ y:X, (x=y) ⨿ neq_x y.

Definition isisolated_to_isisolated_ne {X x neq_x} :
  isisolated X x -> isisolated_ne X x neq_x.
Proof.
  intros i y. induction (i y) as [eq|ne].
  - exact (ii1 eq).
  - apply ii2. apply neg_to_negProp. assumption.
Defined.

Definition isisolated_ne_to_isisolated {X x neq_x} :
  isisolated_ne X x neq_x -> isisolated X x.
Proof.
  intros i y. induction (i y) as [eq|ne].
  - exact (ii1 eq).
  - apply ii2. use negProp_to_neg.
    + exact (neq_x y).
    + exact ne.
Defined.

Definition isolated_ne ( T : UU ) (neq:neqReln T) := ∑ t:T, isisolated_ne _ t (neq t).

Definition make_isolated_ne (T : UU) (t:T) (neq:neqReln T) (i:isisolated_ne _ t (neq t)) :
  isolated_ne T neq
  := (t,,i).

Definition pr1isolated_ne ( T : UU ) (neq:neqReln T) (x:isolated_ne T neq) : T := pr1 x.

Theorem isaproppathsfromisolated_ne (X : UU) (x : X) (neq_x : neqPred x)
        (is : isisolated_ne X x neq_x) (y : X)
  : isaprop (x = y).
Proof.
  (* we could follow the proof of isaproppathsfromisolated here, but we try a
     different way *)
  intros. unfold isisolated_ne in is. apply invproofirrelevance; intros m n.
  set (Q y := (x = y) ⨿ (neq_x y)).
  assert (a := (transport_section is m) @ !(transport_section is n)).
  induction (is x) as [j|k].
  - assert (b := transport_map (λ y p, ii1 p : Q y) m j); simpl in b;
      assert (c := transport_map (λ y p, ii1 p : Q y) n j); simpl in c.
    assert (d := equality_by_case (!b @ a @ c)); simpl in d.
    rewrite 2? transportf_id1 in d. apply (pathscomp_cancel_left j). assumption.
  - contradicts (neq_x x k) (idpath x).
Defined.

Definition compl_ne (X:UU) (x:X) (neq_x : neqPred x) := ∑ y, neq_x y.

Definition make_compl_ne (X : UU) (x : X) (neq_x : neqPred x) (y : X)
           (ne :neq_x y) :
  compl_ne X x neq_x := (y,,ne).

Definition pr1compl_ne (X : UU) (x : X) (neq_x : neqPred x)
           (c : compl_ne X x neq_x) :
  X := pr1 c.

Definition make_negProp {P : UU} : negProp P.
Proof.
  intros. exists (¬ P). split.
       - apply isapropneg.  (* uses [funextemptyAxiom] *)
       - apply isrefl_logeq.
Defined.

Definition make_neqProp {X : UU} (x y : X) : neqProp x y.
Proof.
  intros. apply make_negProp.
Defined.

Lemma isinclpr1compl_ne (X : UU) (x : X) (neq_x : neqPred x) :
  isincl (pr1compl_ne X x neq_x).
Proof.
  intros. apply isinclpr1. intro y. apply negProp_to_isaprop.
Defined.

Lemma compl_ne_weq_compl (X : UU) (x : X) (neq_x : neqPred x) :
  compl X x ≃ compl_ne X x neq_x.
Proof.
  (* uses [funextemptyAxiom] *)
  intros. apply weqfibtototal; intro y. apply weqiff.
  - apply negProp_to_iff.
  - apply isapropneg.
  - apply negProp_to_isaprop.
Defined.

Lemma compl_weq_compl_ne (X : UU) (x : X) (neq_x : neqPred x) :
  compl_ne X x neq_x ≃ compl X x.
Proof.
  (* uses [funextemptyAxiom] *)
  intros. apply weqfibtototal; intro y. apply weqiff.
  - apply issymm_logeq. apply negProp_to_iff.
  - apply negProp_to_isaprop.
  - apply isapropneg.
Defined.

Definition recompl_ne (X : UU) (x : X) (neq_x:neqPred x) :
  compl_ne X x neq_x ⨿ unit -> X.
Proof.
  intros w.
  induction w as [c|t].
  - exact (pr1compl_ne _ _ _ c).
  - exact x.
Defined.

Definition maponcomplincl_ne {X Y : UU} (f : X -> Y) (is : isincl f) (x : X)
           (neq_x : neqPred x) (neq_fx : neqPred (f x))
  : compl_ne X x neq_x -> compl_ne Y (f x) neq_fx.
Proof.
  intros c.
  set (x' := pr1 c).
  set (neqx := pr2 c).
  exact (f x',,neg_to_negProp (nP := neq_fx (f x'))
           (negf (invmaponpathsincl _ is x x') (negProp_to_neg neqx))).
Defined.

Definition weqoncompl_ne {X Y : UU} (w : X ≃ Y) (x : X) (neq_x : neqPred x)
           (neq_wx : neqPred (w x))
  : compl_ne X x neq_x ≃ compl_ne Y (w x) neq_wx.
Proof.
  intros. intermediate_weq (∑ x', neq_wx (w x')).
  - apply weqfibtototal; intro x'.
    apply weqiff.
    {apply (logeq_trans (Y := x != x')).
     {apply issymm_logeq, negProp_to_iff. }
     apply (logeq_trans (Y := w x != w x')).
     {apply logeqnegs. apply weq_to_iff. apply weqonpaths. }
     apply negProp_to_iff. }
    {apply negProp_to_isaprop. }
    {apply negProp_to_isaprop. }
  - refine (weqfp _ _).
Defined.

Definition weqoncompl_ne_compute {X Y : UU}
           (w : X ≃ Y) (x : X) (neq_x : neqPred x) (neq_wx : neqPred (w x)) x' :
  pr1 (weqoncompl_ne w x neq_x neq_wx x') = w (pr1 x').
Proof.
  intros. apply idpath.
Defined.

Definition invrecompl_ne (X : UU) (x : X) (neq_x : neqPred x)
           (is : isisolated X x) : X -> compl_ne X x neq_x ⨿ unit.
Proof.
  intros y. induction (is y) as [k|k].
  - exact (ii2 tt).
  - exact (ii1 (make_compl_ne X x neq_x y (neg_to_negProp k))).
Defined.

Theorem isweqrecompl_ne (X : UU) (x : X) (is : isisolated X x)
        (neq_x : neqPred x) : isweq (recompl_ne _ x neq_x).
Proof.
  (* does not use [funextemptyAxiom] *)
  intros.
  set (f := recompl_ne X x neq_x). set (g := invrecompl_ne X x neq_x is).
  refine (isweq_iso f g _ _).
  {intro u. induction (is (f u)) as [ eq | ne ].
   - induction u as [ c | u].
     + simpl. induction c as [ t neq ]; simpl; simpl in eq.
       contradicts (negProp_to_neg neq) eq.
     + induction u.
       intermediate_path (g x).
       {apply maponpaths. exact (pathsinv0 eq). }
       {unfold g, invrecompl_ne. induction (is x) as [ i | e ].
        {apply idpath. }
        {simpl. contradicts e (idpath x). }}
   - induction u as [ c | u ]. simpl.
     + induction c as [ y neq ]; simpl. unfold g, invrecompl_ne.
       induction (is y) as [ eq' | ne' ].
       {contradicts (negProp_to_neg neq) eq'. }
       {induction (ii2 ne') as [eq|neq'].
        {simpl. contradicts eq ne'. }
        {simpl. apply maponpaths. unfold make_compl_ne. apply maponpaths.
         apply proofirrelevance. exact (pr1 (pr2 (neq_x y))). }}
     + induction u. unfold f,g,invrecompl_ne;simpl.
       induction (is x) as [eq|neq].
       {simpl. apply idpath. }
       {apply fromempty. apply neq. apply idpath. }}
  {intro y. unfold f,g,invrecompl_ne;simpl.
   induction (is y) as [eq|neq].
   - induction eq. apply idpath.
   - simpl. apply idpath. }
Defined.

Theorem isweqrecompl_ne' (X : UU) (x : X) (is : isisolated X x)
        (neq_x : neqPred x) : isweq (recompl_ne _ x neq_x).
Proof.
  (* an alternative proof *)
  intros. set (f := recompl_ne X x neq_x). intro y.
  unfold neqPred,negProp in neq_x; unfold isisolated in is.
  apply (iscontrweqb (weqtotal2overcoprod _)). induction (is y) as [eq|ne].
  {induction eq. refine (iscontrweqf (weqii2withneg _ _) _).
   {intros z; induction z as [z e]; induction z as [z neq]; simpl in *.
    contradicts (!e) (negProp_to_neg neq). }
   {change x with (f (ii2 tt)). simple refine ((_,,_),,_).
    {exact tt. }
    {apply idpath. }
    {intro w. induction w as [t e]. unfold f in *; simpl in *. induction t.
     apply maponpaths. apply isaproppathsfromisolated. exact is. }}}
  {refine (iscontrweqf (weqii1withneg _ _) _).
   {intros z; induction z as [z e]; simpl in *. contradicts ne e. }
   {simple refine ((_,,_),,_).
    {exists y. apply neg_to_negProp. assumption. }
    {simpl. apply idpath. }
    intros z; induction z as [z e]; induction z as [z neq];
      induction e; simpl in *.
    induction (proofirrelevance _ (pr1 (pr2 (neq_x z))) neq
                                (neg_to_negProp ne)).
    apply idpath.
  }}
Defined.

Definition weqrecompl_ne (X : UU) (x : X) (is : isisolated X x)
           (neq_x : neqPred x) : compl_ne X x neq_x ⨿ unit ≃ X
  := make_weq _ (isweqrecompl_ne X x is neq_x).

Theorem isweqrecompl' (X : UU) (x : X) (is : isisolated X x) :
  isweq (recompl _ x).
Proof.
  (* alternative proof, spoils a computation if used in [weqrecompl], so unused *)
  intros. set (neq_x := λ y, make_neqProp x y).
  apply (isweqhomot (weqrecompl_ne X x is neq_x
                                   ∘ weqcoprodf (compl_ne_weq_compl X x neq_x)
                                   (idweq unit))%weq).
  {intro y. induction y as [y|t]; apply idpath. }
  apply weqproperty.
Defined.

Lemma iscotrans_to_istrans_negReln {X : UU} {R : hrel X} (NR : negReln R) :
  isdeccotrans R -> istrans NR.
(* uses no axioms; compare to istransnegrel *)
Proof.
  intros i ? ? ? nxy nyz. apply neg_to_negProp.
  apply (negf (i x1 x2 x3)). intro c. induction c as [c|c].
  - exact (negProp_to_neg nxy c).
  - exact (negProp_to_neg nyz c).
Defined.

Definition natneq (m n : nat) : negProp (m = n).
Proof.
  intros. exists (m ≠ n). split.
  - apply propproperty.
  - apply natneq_iff_neq.
Defined.

(* this replaces an earlier notation: *)
Notation " x ≠ y " := (natneq x y) (at level 70, no associativity) : nat_scope.

Definition nat_compl (i : nat) := compl_ne _ i (λ j, i ≠ j).

Theorem weqdicompl (i : nat) : nat ≃ nat_compl i.
Proof.
  use weq_iso.
  - intro j. exists (di i j). apply di_neq_i.
  - intro j. exact (si i (pr1 j)).
  - simpl. intro j. unfold di. induction (natlthorgeh j i) as [lt|ge].
    + unfold si. induction (natlthorgeh i j) as [lt'|ge'].
      * contradicts (isasymmnatlth _ _ lt') lt.
      * apply idpath.
    + unfold si. induction (natlthorgeh i (S j)) as [lt'|ge'].
      * change (S j) with (1 + j). rewrite natpluscomm. apply plusminusnmm.
      * unfold natgeh,natleh in ge. contradicts (natlehneggth ge') ge.
  - simpl. intro j. induction j as [j ne]; simpl.
    apply subtypePath.
    + intro k. apply negProp_to_isaprop.
    + simpl. unfold si. induction (natlthorgeh j i) as [lt|ge].
      * clear ne.
        induction (natlthorgeh i j) as [lt'|_].
        { contradicts (isasymmnatlth _ _ lt') lt. }
        { unfold di. induction (natlthorgeh j i) as [lt'|ge'].
          - apply idpath.
          - contradicts (natgehtonegnatlth _ _ ge') lt. }
      * assert (lt := natleh_neq ge ne); clear ne ge.
        induction (natlthorgeh i j) as [_|ge'].
        { unfold di. induction (natlthorgeh (j - 1) i) as [lt'|ge'].
          - apply fromempty. induction j as [|j _].
            + exact (negnatlthn0 _ lt).
            + change (S j) with (1 + j) in lt'.
                 rewrite natpluscomm in lt'.
                 rewrite plusminusnmm in lt'.
                 change (i < S j) with (i ≤ j) in lt.
                 exact (natlehneggth lt lt').
          - induction j as [|j _].
            + contradicts (negnatlthn0 i) lt.
            + simpl. apply maponpaths. apply natminuseqn. }
        contradicts (natgehtonegnatlth _ _ ge') lt.
Defined.


Require Import Axiom_Extensionality.
Require Import Axiom_ProofIrrelevance.
Require Import Cast.
Require Import Category5.
Require Import Setoid.

Lemma eq_Category5 : forall (C C':Category5) (p:Obj C = Obj C'),
    forall (q:forall a b: Obj C, Hom a b = Hom (cast p a) (cast p b)),
    (forall (a b c:Obj C) (f:Hom a b) (g:Hom b c),
        cast (q a c) (f ; g) = cast (q a b) f ; cast (q b c) g) ->
    (forall (a:Obj C), cast (q a a) (id a) = id (cast p a)) -> C = C'.
Proof.
    intros C1 C2 p q Hc Hi.
    destruct C1 as [Obj1 Hom1 cmp1 i1 pl1 pr1 pa1].
    destruct C2 as [Obj2 Hom2 cmp2 i2 pl2 pr2 pa2].
    simpl in p. simpl in q. simpl in Hc. simpl in Hi.
    revert pl1 pr1 pa1.
    revert Hc Hi. revert cmp1 i1. revert q. revert Hom1.
    rewrite p.
    intros Hom1 q. simpl in q.
    assert (Hom1 = Hom2) as H. { apply extensionality2. exact q. }
    revert q. rewrite H. clear H. simpl. intros q.
    assert (forall a b, q a b = eq_refl) as Hq.
        { intros a b. apply proof_irrelevance. }
    intros cmp1 i1 Hc Hi.
    assert (i1 = i2) as Hi'.
        { apply extensionality. intros a. rewrite <- (Hi a).
            rewrite (proof_irrelevance _ (q a a) eq_refl).
            reflexivity.
        }
    rewrite Hi'.
    assert (cmp1 = cmp2) as Hc'.
    { apply extensionality3. intros a b c.
      apply extensionality2. intros f g.
      assert (cast (q a b) f = f) as Hf.
        { rewrite (proof_irrelevance _ (q a b) eq_refl). reflexivity. }
      assert (cast (q b c) g = g) as Hg.
        { rewrite (proof_irrelevance _ (q b c) eq_refl). reflexivity. }
        rewrite <- Hf at 2. (* need 'Setoid' for some reason *)
        rewrite <- Hg at 2.
        rewrite <- (Hc a b c).
        rewrite (proof_irrelevance _ (q a c) eq_refl). reflexivity.
    }
    rewrite Hc'.
    intros pl1 pr1 pa1.
    rewrite (proof_irrelevance _ pl1 pl2).
    rewrite (proof_irrelevance _ pr1 pr2).
    rewrite (proof_irrelevance _ pa1 pa2).
    reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Import NAxioms NSub GenericMinMax.

Module Type NMaxMinProp (Import N : NAxiomsMiniSig').
Include NSubProp N.

Lemma max_0_l : forall n, max 0 n == n.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.max_0_l".
intros. apply max_r. apply le_0_l.
Qed.

Lemma max_0_r : forall n, max n 0 == n.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.max_0_r".
intros. apply max_l. apply le_0_l.
Qed.

Lemma min_0_l : forall n, min 0 n == 0.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.min_0_l".
intros. apply min_l. apply le_0_l.
Qed.

Lemma min_0_r : forall n, min n 0 == 0.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.min_0_r".
intros. apply min_r. apply le_0_l.
Qed.

Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m).
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.succ_max_distr".
intros. destruct (le_ge_cases n m);
[rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono.
Qed.

Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m).
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.succ_min_distr".
intros. destruct (le_ge_cases n m);
[rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono.
Qed.

Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.add_max_distr_l".
intros. destruct (le_ge_cases n m);
[rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l.
Qed.

Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.add_max_distr_r".
intros. destruct (le_ge_cases n m);
[rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r.
Qed.

Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.add_min_distr_l".
intros. destruct (le_ge_cases n m);
[rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l.
Qed.

Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.add_min_distr_r".
intros. destruct (le_ge_cases n m);
[rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r.
Qed.

Lemma mul_max_distr_l : forall n m p, max (p * n) (p * m) == p * max n m.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.mul_max_distr_l".
intros. destruct (le_ge_cases n m);
[rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l.
Qed.

Lemma mul_max_distr_r : forall n m p, max (n * p) (m * p) == max n m * p.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.mul_max_distr_r".
intros. destruct (le_ge_cases n m);
[rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r.
Qed.

Lemma mul_min_distr_l : forall n m p, min (p * n) (p * m) == p * min n m.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.mul_min_distr_l".
intros. destruct (le_ge_cases n m);
[rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l.
Qed.

Lemma mul_min_distr_r : forall n m p, min (n * p) (m * p) == min n m * p.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.mul_min_distr_r".
intros. destruct (le_ge_cases n m);
[rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r.
Qed.

Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.sub_max_distr_l".
intros. destruct (le_ge_cases n m).
rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l.
rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l.
Qed.

Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.sub_max_distr_r".
intros. destruct (le_ge_cases n m);
[rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r.
Qed.

Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.sub_min_distr_l".
intros. destruct (le_ge_cases n m).
rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l.
rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l.
Qed.

Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p.
Proof. hammer_hook "NMaxMin" "NMaxMin.NMaxMinProp.sub_min_distr_r".
intros. destruct (le_ge_cases n m);
[rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r.
Qed.

End NMaxMinProp.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Category.Composable_Chain.
From Categories Require Import Functor.Functor.

(** The image of a functor is not simply the image of its object and arrow maps
    as those may not form a category. Consider the following example.

  category C:
#

             f
       x1 ——————–> y1

       x2 ——————–> y2
             g

#
   category D:
#

             h1        h2
       x ——————–> y ————————> z

       u ——————–> v
            m

#
    functor F where:
#

       F _o x1 = x
       F _o y1 = y
       F _o x2 = y
       F _o y2 = z

       F _a f = h1
       F _a g = h2

#

Here we have not drawn identity arrows and compositions of arrows in categories
and their mappings by the functor as these are trivial details.

In this case, the simple image of arrow map of F has only h1 and h2 but not
their composition and is hence not a category.

We define the image of a functor to be a sum category of the codomain category
with objects the image of object map of the functor and as morphisms image of
the arrow map of the functor closed under composition. That is, each morphism
in the image category is a morphism that corresponds to a composable chain of
morohisms in the image of the arrow map of the functor.

*)
Section Functor_Image.
  Context {C D : Category}
          (F : (C --> D)%functor).

  Local Open Scope morphism_scope.

  Ltac destr_exists :=
    progress
    (repeat
       match goal with
         [H : ∃ x, _ |- _] =>
         let x := fresh "x" in
         let Hx := fresh "H" x in
         destruct H as [x Hx]
       end).

  Program Definition Functor_Image :=
    SubCategory
      D
      (fun a => ∃ x, (F _o x)%object = a)
      (
        fun a b f =>
          ∃ (ch : Composable_Chain D a b),
            (Compose_of ch) = f
            ∧
            Forall_Links
              ch (fun x y g =>
                    ∃ (c d : Obj) (h : c --> d)
                      (Fca : (F _o c)%object = x)
                      (Fdb : (F _o d)%object = y),
                      match Fca in (_ = Z) return Z --> _ with
                        eq_refl =>
                        match Fdb in (_ = Y) return _ --> Y with
                          eq_refl => (F _a h)%morphism
                        end
                      end = g)
      )
      _ _.
  Next Obligation. (* Hom_Cri_id *)
  Proof.
    destr_exists.
    ElimEq.
    exists (Single (F _a id)); simpl; split; auto.
    do 3 eexists; do 2 exists eq_refl; reflexivity.
  Qed.
  Next Obligation. (* Hom_Cri_compose *)
  Proof.
    destr_exists.
    intuition.
    ElimEq.
    match goal with
        [ch1 : Composable_Chain _ ?a ?b, ch2 : Composable_Chain _ ?b ?c|- _] =>
        exists (Chain_Compose ch1 ch2); split
    end.
    rewrite <- Compose_of_Chain_Compose; trivial.
    apply Forall_Links_Chain_Compose; auto.
  Qed.

End Functor_Image.


Set Warnings "-notation-overridden".

Require Import Category.Lib.

Require Import VectorFacts.

Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Arith.Arith.
Require Import Coq.Vectors.Vector.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section ilist.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Vectors.VectorDef.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)

  Record prim_prod A B : Type :=
    { prim_fst : A;
      prim_snd : B }.

  Fixpoint ilist {n} (l : Vector.t A n) : Type :=
    match l with
      | [] => unit
      | a :: l => @prim_prod (B a) (ilist l)
    end.

  Definition icons
             (a : A)
             {n}
             {l : Vector.t A n}
             (b : B a)
             (il : ilist l)
  : ilist (a :: l)
    := {| prim_fst := b; prim_snd := il |}.

  Definition inil : ilist [] := tt.

  (* Get the car of an ilist. *)
  Definition ilist_hd {n} {As : Vector.t A n} (il : ilist As) :
    match As return ilist As -> Type with
      | a :: As' => fun il => B a
      | [] => fun _ => unit
    end il :=
    match As return
          forall (il : ilist As),
            match As return ilist As -> Type with
              | a :: As' => fun il => B a
              | [] => fun _ => unit
            end il with
      | a :: As => fun il => prim_fst _ _ il
      | [] => fun il => tt
    end il.

  Definition ilist_hd' {n} {As : Vector.t A (S n)} (il : ilist As) :
    B (Vector.hd As)
    := Vector.caseS (fun n As => ilist As -> B (Vector.hd As))
                           (fun a As m => ilist_hd) As il.

  (* Get the cdr of an ilist. *)
  Definition ilist_tl {n} {As : Vector.t A n} (il : ilist As) :
    match As return ilist As -> Type with
      | a :: As' => fun il => ilist As'
      | [] => fun _ => unit
    end il :=
    match As return
          forall (il : ilist As),
            match As return ilist As -> Type with
              | a :: As' => fun il => ilist As'
              | [] => fun _ => unit
            end il with
      | a :: As => fun il => prim_snd _ _ il
      | [] => fun il => tt
    end il.

  Definition ilist_tl'
             {n} {As : Vector.t A (S n)} (il : ilist As)
    : ilist (Vector.tl As) :=
    Vector.caseS (fun n As => ilist As -> ilist (Vector.tl As))
                 (fun a As m => ilist_tl) As il.

  Infix "++" := Vector.append : vector_scope.

  (* Appending ilists *)
  Fixpoint ilist_app {n} {As : Vector.t A n}
    : forall {n'} {As' : Vector.t A n'},  ilist As -> ilist As' -> ilist (As ++ As') :=
      match As return
            forall {n'} (As' : Vector.t A n'),
              ilist As -> ilist As' -> ilist (As ++ As') with
        | [] =>
          fun n' As' il il' => il'
        | a :: As'' =>
          fun n' As' il il' =>
            {| prim_fst := ilist_hd il;
               prim_snd := ilist_app (ilist_tl il) il' |}
      end.

  (* Membership in an indexed list. *)

  Inductive ilist_In {a : A} (b : B a)
  : forall {n} {As : Vector.t A n} (il : ilist As), Prop :=
  | In_hd : forall n' As' (il : ilist (n := n') As'),
              ilist_In b (icons _ b il)
  | In_tl : forall {n'} a' (b' : B a') As' (il : ilist (n := n') As'),
              ilist_In b il ->
              ilist_In b (icons _ b' il).

  (* Looking up the ith value, returning None for indices not in the Vector.t *)

  Fixpoint ith
             {m : nat}
             {As : Vector.t A m}
             (il : ilist As)
             (n : Fin.t m)
  : B (Vector.nth As n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            ilist As
            -> B (Vector.nth As n) with
      | @Fin.F1 k =>
        fun As =>
          Vector.caseS (fun n As => ilist As
                                    -> B (Vector.nth As (@Fin.F1 n)))
                       (fun h n t => ilist_hd) As
      | @Fin.FS k n' =>
        fun As =>
          Vector_caseS' Fin.t
                        (fun n As n' => ilist As
                                        -> B (Vector.nth As (@Fin.FS n n')))
                        (fun h n t m il => ith (ilist_tl il) m)
                        As n'
    end As il.

  Lemma ilist_invert {n} (As : Vector.t A n) (il : ilist As) :
    match As as As' return ilist As' -> Prop with
      | a :: As' => fun il => (exists b il', il = icons _ b il')%type
      | [] => fun il => il = inil
    end il.
  Proof.
    destruct As; destruct il; simpl; unfold icons; eauto.
  Qed.

  Lemma ilist_invert' {n} (As : Vector.t A n) (il : ilist As) :
    match As as As' return ilist As' -> Type with
      | a :: As' => fun il => sigT (fun b => sigT (fun il' => il = icons _ b il'))
      | [] => fun il => il = inil
    end il.
  Proof.
    destruct As; destruct il; unfold icons; eauto.
  Qed.

  (* The [ith_induction] tactic is for working with lookups of bounded indices.
     It first inducts on n, then destructs the index Vector.t [As] and eliminates
     the contradictory cases, then finally destructs any indexed Vector.t in the
     context with Bounds of [As]. *)

End ilist.

(** ** Mapping a function over a(n i)[list], in two non-dependent ways *)
Section ilist_map.
  Context {A} (B : A -> Type).

  Import Vectors.VectorDef.VectorNotations.

  Fixpoint imap_list (f : forall a : A, B a) {n} (As : Vector.t A n) : ilist As
    := match As with
         | [] => inil
         | x :: xs => @icons _ B x _ _ (f x) (imap_list f xs)
       end.

End ilist_map.

Ltac icons_invert :=
  repeat match goal with
           | [il : ilist _ (_ :: _) |- _]
             => let il' := fresh "il" in
                let b' := fresh "b" in
                let il'_eq := fresh "il_eq" in
                generalize (ilist_invert il);
                  intros il'; destruct il' as [b' [il' il'_eq]]; subst
         end.

Section ilist_imap.

  (* Mapping a function over an indexed Vector.t. *)

  Import Vectors.VectorDef.VectorNotations.

  Variable A : Type. (* The indexing type. *)
  Variable B B' : A -> Type. (* The two types of indexed elements. *)
  Variable f : forall a, B a -> B' a. (* The function to map over the Vector.t. *)

  Fixpoint imap {n} (As : Vector.t A n)
    : ilist As -> ilist As :=
    match As return ilist As -> ilist As with
    | [] => fun il => inil
    | a :: As' => fun il => icons _ (@f a (ilist_hd il)) (imap As' (ilist_tl il))
    end.

(*
  (* [imap] behaves as expected with the [ith_default] lookup
     function. *)
  Lemma ith_imap :
    forall {n}
           (m : Fin.t n)
           (As : Vector.t A n)
           (il : ilist As),
      f (ith il m) = ith (imap As il) m.
  Proof.
    induction m; intro.
    - eapply Vector.caseS with (v := As); intros; simpl in *; destruct il; reflexivity.
    - revert m IHm.
      pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; eapply (@Vector.rectS _ P); intros
      end.
      inversion m.
      eapply IHm.
  Qed.
*)

End ilist_imap.

Section ilist_replace.

  Import Vectors.VectorDef.VectorNotations.

  (* Replacing an element of an indexed Vector.t. *)
  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The two types of indexed elements. *)

  Fixpoint replace_Index
             {m}
             (As : Vector.t A m)
             (il : ilist As)
             (n : Fin.t m)
             (new_b : B (Vector.nth As n))
             {struct n}
    : ilist As :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            @ilist _ B _ As
            -> B (Vector.nth As n)
            -> ilist As with
    | @Fin.F1 k =>
      fun As =>
        Vector.caseS (fun n As => ilist As
                                  -> B (Vector.nth As (@Fin.F1 n))
                                  -> ilist As)
                     (fun h n t il new_b => icons _ new_b (ilist_tl il) ) As
    | @Fin.FS k n' =>
      fun As =>
        Vector_caseS' Fin.t
                     (fun n As n' =>
                          ilist As
                          -> B (Vector.nth As (@Fin.FS n n'))
                          -> ilist As)
                     (fun h n t m il new_b => icons _ (ilist_hd il)
                                                    (@replace_Index _ _ (ilist_tl il) _ new_b))
                     As n'
    end As il new_b.

  Lemma ith_replace_Index_neq {m}
    : forall
      (n n' : Fin.t m)
      (As : Vector.t A m)
      (il : ilist As)
      (new_b : B (Vector.nth As n')),
      n <> n'
      -> ith (replace_Index As il n' new_b) n = ith il n.
  Proof.
    intros n n'; pattern m, n, n'.
    match goal with
      |- ?P m n n' => simpl; eapply (Fin.rect2 P); intros
    end.
    - congruence.
    - generalize il f new_b; clear f new_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - generalize il f new_b; clear f new_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - assert (f <> g) by congruence.
      generalize il f g new_b H H1; clear f g new_b il H H1 H0.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.caseS _ P); intros;
        eapply (H _ (prim_snd _ _ il) new_b); eauto
      end.
  Qed.

  Lemma ith_replace_Index_eq {m}
    : forall
      (n : Fin.t m)
      (As : Vector.t A m)
      (il : ilist As)
      (new_b : B (Vector.nth As n)),
      ith (replace_Index As il n new_b) n = new_b.
  Proof.
    induction n; simpl.
    - intro As; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); intros; reflexivity
      end.
    - intro As; revert n0 IHn; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); simpl; eauto
      end.
  Qed.

End ilist_replace.


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

(** * Decidable equivalences.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

(** Export notations. *)

Require Export Coq.Classes.Equivalence.

(** The [DecidableSetoid] class asserts decidability of a [Setoid].
   It can be useful in proofs to reason more classically. *)

Require Import Coq.Logic.Decidable.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Program.Program.

Generalizable Variables A B R.

Open Scope equiv_scope.

Class DecidableEquivalence `(equiv : Equivalence A) :=
  setoid_decidable : forall x y : A, decidable (x === y).

(** The [EqDec] class gives a decision procedure for a particular
   setoid equality. *)

Class EqDec A R {equiv : Equivalence R} :=
  equiv_dec : forall x y : A, { x === y } + { x =/= y }.

(** We define the [==] overloaded notation for deciding equality. It does not
   take precedence of [==] defined in the type scope, hence we can have both
   at the same time. *)

Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) : equiv_scope.

Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
  match x with
    | left H => @right _ _ H
    | right H => @left _ _ H
  end.

Local Open Scope program_scope.

(** Invert the branches. *)

Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } :=
          swap_sumbool (x == y).

(** Overloaded notation for inequality. *)

Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope.

(** Define boolean versions, losing the logical information. *)

Definition equiv_decb `{EqDec A} (x y : A) : bool :=
  if x == y then true else false.

Definition nequiv_decb `{EqDec A} (x y : A) : bool :=
  negb (equiv_decb x y).

Infix "==b" := equiv_decb (no associativity, at level 70).
Infix "<>b" := nequiv_decb (no associativity, at level 70).

(** Decidable leibniz equality instances. *)

(** The equiv is burried inside the setoid, but we can recover it by specifying
   which setoid we're talking about. *)

Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec.

Program Instance bool_eqdec : EqDec bool eq := bool_dec.

Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left.

  Next Obligation.
  Proof.
    destruct x ; destruct y.
    reflexivity.
  Qed.

Obligation Tactic := unfold complement, equiv ; program_simpl.

Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) :
  ! EqDec (prod A B) eq :=
  { equiv_dec x y :=
    let '(x1, x2) := x in
    let '(y1, y2) := y in
    if x1 == y1 then
      if x2 == y2 then in_left
      else in_right
    else in_right }.

Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) :
  EqDec (sum A B) eq := {
  equiv_dec x y :=
    match x, y with
      | inl a, inl b => if a == b then in_left else in_right
      | inr a, inr b => if a == b then in_left else in_right
      | inl _, inr _ | inr _, inl _ => in_right
    end }.

(** Objects of function spaces with countable domains like bool have decidable
  equality. Proving the reflection requires functional extensionality though. *)

Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq :=
  { equiv_dec f g :=
    if f true == g true then
      if f false == g false then in_left
      else in_right
    else in_right }.

  Next Obligation.
  Proof.
    extensionality x.
    destruct x ; auto.
  Qed.

Require Import List.

Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq :=
  { equiv_dec :=
    fix aux (x y : list A) :=
    match x, y with
      | nil, nil => in_left
      | cons hd tl, cons hd' tl' =>
        if hd == hd' then
          if aux tl tl' then in_left else in_right
          else in_right
      | _, _ => in_right
    end }.

  Next Obligation. destruct y ; unfold not in *; eauto. Defined.

  Solve Obligations with unfold equiv, complement in * ;
    program_simpl ; intuition (discriminate || eauto).