Require Import SepLogic.Pred.Def.

Theorem lift1_left : forall (P: Prop) `(q: pred A V),
    (P -> [| True |] ===> q) ->
    [| P |] ===> q.
Proof.
  unfold pimpl; simpl; intuition.
Qed.


Require Import
  Coq.Lists.List Coq.Program.Wf
  Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.ssrnat
  Ssreflect.seq FormalPS.stdlib_ext FormalPS.Core.

Set Implicit Arguments.

Section ListIndex.

Variable A : Type.

Fixpoint listindex (xs : seq A) n x :=
  if xs is x' :: xs
    then (if n is n.+1 then listindex xs n x else x = x')
    else False.

Theorem lift_listindex :
  forall xs ys n a, listindex ys n a -> listindex (xs ++ ys) (size xs + n) a.
Proof.
  by elim.
Qed.

Theorem dec_listindex :
  forall xs n, { a | listindex xs n a } + ({ a | listindex xs n a } -> False).
Proof.
  elim => [| x xs IH] /=.
  - by right; case.
  - by case => //; left; exists x.
Defined.

Theorem unique_listindex :
  forall xs n x y, listindex xs n x -> listindex xs n y -> x = y.
Proof.
  elim => // x xs IHxs; case => //= x' y H H0; congruence.
Qed.

End ListIndex.

Inductive instt : Set :=
  | insttpop | insttcopy | insttswap | insttcons | insttquote | insttexec
  | insttpush of instt
  | insttpair of instt & instt
  | instthole of nat.

Fixpoint holes_of_template (t : instt) : seq nat :=
  match t with
    | insttpush i => holes_of_template i
    | insttpair i1 i2 => holes_of_template i1 ++ holes_of_template i2
    | instthole n => [:: n]
    | _ => [::]
  end.

Fixpoint instt_size (t : instt) : nat :=
  match t with
    | insttpush t => (instt_size t)
    | insttpair t1 t2 => (instt_size t1 + instt_size t2)
    | _ => 0
  end.+1.

Fixpoint lift_instt (n : nat) (t : instt) : instt :=
  match t with
    | insttpush t => insttpush (lift_instt n t)
    | insttpair t1 t2 => insttpair (lift_instt n t1) (lift_instt n t2)
    | instthole m => instthole (n + m)
    | _ => t
  end.

Fixpoint instt_of_inst (i : inst) : instt :=
  match i with
    | instpop => insttpop
    | instcopy => insttcopy
    | instswap => insttswap
    | instcons => insttcons
    | instquote => insttquote
    | instexec => insttexec
    | instpush i => insttpush (instt_of_inst i)
    | instpair i1 i2 => insttpair (instt_of_inst i1) (instt_of_inst i2)
  end.

Theorem instt_size_lifted :
  forall n t, instt_size t = instt_size (lift_instt n t).
Proof.
  move => n; elim => //=; f_equal; auto.
Qed.

Inductive fill_template : seq inst -> instt -> inst -> Prop :=
  | fillpop   : forall l, fill_template l insttpop instpop
  | fillcopy  : forall l, fill_template l insttcopy instcopy
  | fillswap  : forall l, fill_template l insttswap instswap
  | fillcons  : forall l, fill_template l insttcons instcons
  | fillquote : forall l, fill_template l insttquote instquote
  | fillexec  : forall l, fill_template l insttexec instexec
  | fillpush  :
    forall l t i, fill_template l t i ->
    fill_template l (insttpush t) (instpush i)
  | fillpair  :
    forall l t1 t2 i1 i2, fill_template l t1 i1 -> fill_template l t2 i2 ->
    fill_template l (insttpair t1 t2) (instpair i1 i2)
  | fillhole  :
    forall l n i, listindex l n i -> fill_template l (instthole n) i.

Theorem fill_instt_of_inst : forall xs i, fill_template xs (instt_of_inst i) i.
Proof.
  by move => xs; elim; constructor.
Qed.

Theorem lift_fill_template :
  forall xs ys t i, fill_template ys t i ->
  fill_template (xs ++ ys) (lift_instt (size xs) t) i.
Proof.
  move => xs.
  apply fill_template_ind; constructor => //.
  by apply lift_listindex.
Qed.

Theorem dec_fill_template :
  forall l t, {i | fill_template l t i} + ({i | fill_template l t i} -> False).
Proof.
  move => l; elim; try by (left; eexists; econstructor).
  - move => t; elim => H.
    - by left; elim: H => i H; exists (instpush i); constructor.
    - right => H0; apply: H; case: H0;
        case => [||||||i|il ir] H; try by apply False_rec; inversion H.
      by exists i; inversion H.
  - move => t1; elim => H1.
    - move => t2; elim => H2.
      - left; elim: H1 => i1 H1; elim: H2 => i2 H2.
        by exists (instpair i1 i2); constructor.
      - right => H3; apply: H2; case: H3;
          case => [||||||i|il ir] H; try by apply False_rec; inversion H.
        by exists ir; inversion H.
    - move => t H2.
      right => H3; apply: H1; case: H3;
        case => [||||||i|il ir] H; try by apply False_rec; inversion H.
      by exists il; inversion H.
  - move => n; case (dec_listindex l n).
    - by case => i; left; eexists i; constructor.
    - by move => H; right; case => i H0; apply: H; exists i; inversion H0.
Defined.

Theorem dec_fill_template' :
  forall l tl,
    {il | Forall2 (fill_template l) tl il} +
    ({il | Forall2 (fill_template l) tl il} -> False).
Proof.
  move => l; elim.
  - by left; exists [::].
  - move => t tl; case => [[il H] | H].
    - case (dec_fill_template l t) => [[i H0] | H0].
      - by left; exists (i :: il); constructor.
      - right; case; case.
        - move => H1; inversion H1.
        - move => i il' H1; apply H0.
          by exists i; inversion H1.
    - right; case => l' H1; inversion_clear H1; apply H.
      by exists l'0.
Defined.

Theorem unique_fill_template :
  forall l t i1 i2, fill_template l t i1 -> fill_template l t i2 -> i1 = i2.
Proof.
  move => l; elim; try by move => i1 i2 H H0; inversion H; inversion H0.
  - move => t IH i1 i2 H H0.
    inversion H; inversion H0; subst.
    f_equal; auto.
  - move => t1 IH1 t2 IH2 i1 i2 H H0.
    inversion H; inversion H0; subst.
    f_equal; auto.
  - move => n i1 i2 H H0.
    inversion H; inversion H0; subst.
    by apply (unique_listindex l n).
Qed.

Lemma exists_inst_listindex_iter :
  forall n, { inst_listindex |
  forall xs x ys, listindex xs n x -> forall vs cs,
  (instseqv ys :: xs ++ vs, inst_listindex :: cs) |=>*
  (x :: ys ++ xs ++ vs, cs) }.
Proof.
  elim => [| n [i IH]]; eexists; case => //= x xs x' ys H vs cs.
  - subst.
    evalpartial' evalquote.
    evalpartial' evalswap.
    evalpartial' evalquote.
    evalpartial' evalcopy.
    evalpartial' evalcons.
    evalpartial' evalsnoc.
    evalpartial' evalexec.
    evalauto.
    evalpartial' evalswap.
    evalpartial' evalquote.
    evalpartial' evalcons.
    evalpartial evalexec.
    evalauto.
    evalpartial evalseqv.
    evalauto.
  - evalpartial' evalswap.
    evalpartial' evalquote.
    evalpartial' evalsnoc.
    rewrite -/(instseqv' (instseqv ys) [:: x])
      -(app_instseqv ys [:: x]) -/([:: x] ++ xs ++ vs) catA.
    by apply IH.
Defined.

Theorem exists_inst_listindex :
  forall n, { inst_listindex |
  forall xs x, listindex xs n x -> forall vs cs,
  (xs ++ vs, inst_listindex :: cs) |=>* (x :: xs ++ vs, cs) }.
Proof.
  move => n; eexists => xs x H vs cs.
  evalpartial' evalpush.
  apply (proj2_sig (exists_inst_listindex_iter n) xs x [::] H).
Defined.

Lemma exists_inst_fill_template_iter :
  forall len t, { inst_fill_template |
  forall l i, size l = len -> fill_template l t i -> forall vs cs,
  (l ++ vs, inst_fill_template :: cs) |=>* (i :: l ++ vs, cs) }.
Proof.
  have Heq1: forall n m, n < (n + m).+1 by move => n m; rewrite ltnS leq_addr.
  have Heq2: forall n t1 t2,
    instt_size (lift_instt n t1) < (instt_size t2 + instt_size t1).+1
    by move => n t1 t2; rewrite ltnS -instt_size_lifted leq_addl.
  move => len t; move: t len.
  refine (well_founded_induction (measure_wf well_founded_lt instt_size) _ _).
  rewrite /MR; case; try by move => H len;
    eexists => l i H0 H1 vs cs; inversion H1; evalpartial evalpush; evalauto.
  - move => /= t IH len; eexists => l i H H0 vs cs.
    inversion H0 => {i l0 t0 H0 H1 H2 H4}.
    evalpartial' (proj2_sig (IH t (ltnSn (instt_size t)) len) l i0 H H3).
    apply evalrtc_step, evalquote.
  - move => /= t1 t2 IH len; eexists => l i H H0 vs cs.
    inversion H0 => {i l0 t0 t3 H0 H1 H2 H3 H5}.
    evalpartial' (proj2_sig (IH t1 (Heq1 _ _) len) l i1 H H4).
    evalpartial' (proj2_sig (IH (lift_instt 1 t2) (Heq2 1 t2 t1) len.+1)
      (i1 :: l) i2 (eq_S _ _ H) (@lift_fill_template [:: i1] l t2 i2 H6)) => /=.
    apply evalrtc_step, evalcons.
  - move => /= n _ len; eexists => l i H H0 vs cs.
    inversion H0.
    apply (proj2_sig (exists_inst_listindex n) l i H3).
Defined.

Theorem exists_clear_used :
  forall len, { inst_clear_used |
  forall i vs1, size vs1 = len -> forall vs2 cs,
  (i :: vs1 ++ vs2, inst_clear_used :: cs) |=>* (i :: vs2, cs) }.
Proof.
  elim => [| n [i1 IH]]; eexists => i2.
  - case => [| v vs1] H vs2 cs.
    - apply evalnop.
    - inversion H.
  - case => [| v vs1] H vs2 cs; inversion H => /=.
    evalpartial' evalswap.
    evalpartial' evalpop.
    apply (IH i2 vs1 H1).
Defined.

Theorem exists_inst_fill_template :
  forall len tvs tcs, { inst_fill_template |
    forall l vs' cs', size l = len ->
    Forall2 (fill_template l) tvs vs' ->
    Forall2 (fill_template l) tcs cs' -> forall vs cs,
    (l ++ vs, inst_fill_template :: cs) |=>* (vs' ++ vs, cs' ++ cs) }.
Proof.
  move => len tvs tcs; eexists => l vs' cs' H H0 H1.
  have: fill_template l
    (foldl (fun a b => insttpair (insttpush b) a)
      (foldl insttpair (instt_of_inst instnop) tcs) tvs)
    (instseqv' (instseqc cs') vs').
    move: tcs cs' H1 instnop
      (instt_of_inst instnop) (fill_instt_of_inst l instnop) {len H}.
    refine (Forall2_ind _ _ _) => //.
    - move: tvs vs' H0;
        refine (Forall2_ind _ _ _) => //= t i tl il H H0 H1 i' t' H2.
      by apply H1; do! constructor.
    - move => t i tl il H H1 H2 t' i' H3.
      by apply H2; constructor.
  move => H2 vs cs.
  evalpartial' (proj2_sig (exists_inst_fill_template_iter len _) l _ H H2).
  evalpartial' (proj2_sig (exists_clear_used len)).
  evalpartial evalexec.
  evalpartial evalseqv'.
  apply evalseqc.
Defined.

Tactic Notation "evaltemplate_evalpartial"
    constr(vs) constr(n) constr(tvs) constr(tcs) :=
  match eval compute in (Peano_dec.eq_nat_dec (size (firstn n vs)) n) with
    | left ?H1 =>
      match eval compute in (dec_fill_template' (firstn n vs) tvs) with
        | inl (exist _ ?vs' ?H2) =>
          match eval compute in (dec_fill_template' (firstn n vs) tcs) with
            | inl (exist _ ?cs' ?H3) =>
              evalpartial (proj2_sig (exists_inst_fill_template n tvs tcs)
                           (firstn n vs) vs' cs' H1 H2 H3)
          end
      end
  end.

Tactic Notation "evaltemplate_evalpartial'"
    constr(vs) constr(n) constr(tvs) constr(tcs) :=
  match eval compute in (Peano_dec.eq_nat_dec (size (firstn n vs)) n) with
    | left ?H1 =>
      match eval compute in (dec_fill_template' (firstn n vs) tvs) with
        | inl (exist _ ?vs' ?H2) =>
          match eval compute in (dec_fill_template' (firstn n vs) tcs) with
            | inl (exist _ ?cs' ?H3) =>
              evalpartial' (proj2_sig (exists_inst_fill_template n tvs tcs)
                            (firstn n vs) vs' cs' H1 H2 H3)
          end
      end
  end.

Tactic Notation "evaltemplate" constr(n) constr(tvs) constr(tcs) :=
  match goal with
    | |- (?vs, _) |=>* _ =>
      evaltemplate_evalpartial vs n tvs tcs
    | |- exists _, _ /\ (?vs, _) |=>* _ =>
      evaltemplate_evalpartial vs n tvs tcs
    | |- exists _, _ /\ exists _, _ /\ (?vs, _) |=>* _ =>
      evaltemplate_evalpartial vs n tvs tcs
  end; simpl.

Tactic Notation "evaltemplate'" constr(n) constr(tvs) constr(tcs) :=
  match goal with
    | |- (?vs, _) |=>* _ =>
      evaltemplate_evalpartial' vs n tvs tcs
    | |- exists _, _ /\ (?vs, _) |=>* _ =>
      evaltemplate_evalpartial' vs n tvs tcs
    | |- exists _, _ /\ exists _, _ /\ (?vs, _) |=>* _ =>
      evaltemplate_evalpartial' vs n tvs tcs
  end; simpl.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Extraction to Ocaml: conversion from/to [int]

    Nota: no check that [int] values aren't generating overflows *)

Require Import Arith ZArith.

Parameter int : Type.
Parameter int_zero : int.
Parameter int_succ : int -> int.
Parameter int_opp : int -> int.
Parameter int_twice : int -> int.

Extract Inlined Constant int => int.
Extract Inlined Constant int_zero => "0".
Extract Inlined Constant int_succ => "succ".
Extract Inlined Constant int_opp => "-".
Extract Inlined Constant int_twice => "2 *".

Definition int_of_nat : nat -> int :=
 (fix loop acc n :=
  match n with
   | O => acc
   | S n => loop (int_succ acc) n
  end) int_zero.

Fixpoint int_of_pos p :=
 match p with
  | xH => int_succ int_zero
  | xO p => int_twice (int_of_pos p)
  | xI p => int_succ (int_twice (int_of_pos p))
 end.

Fixpoint int_of_z z :=
 match z with
  | Z0 => int_zero
  | Zpos p => int_of_pos p
  | Zneg p => int_opp (int_of_pos p)
 end.

Fixpoint int_of_n n :=
 match n with
  | N0 => int_zero
  | Npos p => int_of_pos p
 end.

(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and
    [pos_of_int] are total and return zero (resp. one) for
    non-positive inputs. *)

Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A.
Extract Constant int_natlike_rec =>
"fun fO fS ->
 let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1)
 in loop fO".

Definition nat_of_int : int -> nat := int_natlike_rec _ O S.

Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A.
Extract Constant int_poslike_rec =>
"fun f1 f2x f2x1 ->
 let rec loop i = if i <= 1 then f1 else
  if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1))
 in loop".

Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI.

Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A.
Extract Constant int_zlike_case =>
"fun f0 fpos fneg i ->
 if i = 0 then f0 else if i>0 then fpos i else fneg (-i)".

Definition z_of_int : int -> Z :=
 int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i))
                     (fun i => Zneg (pos_of_int i)).

Definition n_of_int : int -> N :=
 int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0).

(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int],
    since [min_int] has no positive opposite ([-min_int = min_int]).
*)

(*
Extraction "/tmp/test.ml"
  nat_of_int int_of_nat
  pos_of_int int_of_pos
  z_of_int int_of_z
  n_of_int int_of_n.
*)


(* ############################################################ *)
(*                                                              *)
(*                 Type soundness for STLC 1/2                  *)
(*                                                              *)
(* ############################################################ *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Require Export stlc1.

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

(* ### Value typing and well-typed runtime environments ### *)

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : forall n, wf_env (Def vl nil nil n) (Def ty nil nil n)
| wfe_cons : forall v t vs ts n,
    val_type (expand_env vs v n) v t ->
    wf_env vs ts ->
    get_inv_idx vs = get_inv_idx ts ->
    wf_env (expand_env vs v n) (expand_env ts t n)

with val_type : venv -> vl -> ty -> Prop :=
| v_bool: forall venv b,
    val_type venv (vbool b) TBool
| v_abs: forall env venv tenv y T1 T2 m,
    wf_env venv tenv ->
    has_type (expand_env (expand_env tenv (TFun T1 m T2) Second) T1 m) y First T2 ->
    val_type env (vabs venv m y) (TFun T1 m T2)
.

(* type equivalence: only via reflexivity *)
Inductive stp: venv -> ty -> venv -> ty -> Prop :=
| stp_refl: forall G1 G2 T,
   stp G1 T G2 T.

Hint Constructors val_type.
Hint Constructors wf_env.

Hint Unfold expand_env.

Lemma length_env_incr : forall (X : Type) n m env (x : X),
   n = m ->
   length_env n (expand_env env x m) = 1 + length_env n env.
Proof.
  intros. destruct env; destruct n; inversion H; auto.
Qed.

Lemma length_env_same : forall (X : Type) n m env (x : X),
   n <> m ->
   length_env n (expand_env env x m) = length_env n env.
Proof.
  intros. destruct env; destruct n; destruct m.
      apply ex_falso_quodlibet; auto.
      auto.
      auto.
      apply ex_falso_quodlibet; auto.
Qed.

Hint Rewrite length_env_incr.
Hint Rewrite length_env_same.
Hint Unfold not.

Lemma wf_length : forall vs ts,
      wf_env vs ts ->
      length_env First vs = length_env First ts /\ length_env Second vs = length_env Second ts.
Proof.
  intros. induction H; auto.
  destruct IHwf_env as [L R].
  destruct n.
  Case "First"; split.
  repeat rewrite length_env_incr; auto.
  repeat rewrite length_env_same; auto.
  unfold not; intros. inversion H2. unfold not; intros. inversion H2.
  Case "Second"; split.
  repeat rewrite length_env_same; auto.
  unfold not; intros. inversion H2. unfold not; intros. inversion H2.
  repeat rewrite length_env_incr; auto.
Qed.

Hint Immediate wf_length.

Lemma wf_idx : forall vs ts,
      wf_env vs ts ->
      get_inv_idx vs = get_inv_idx ts.
Proof.
  intros. induction H; auto.
  destruct vs; destruct ts; destruct n; auto.
Qed.

Hint Immediate wf_idx.

Lemma valtp_extend : forall vs v v1 T n,
                       val_type vs v T ->
                       val_type (expand_env vs v1 n) v T.
Proof. intros. induction H; eauto. Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Hint Immediate index_extend.

Lemma lookup_extend : forall X vs x a (T: X) n,
                       lookup x vs = Some T ->
                       lookup x (expand_env vs a n) = Some T.

Proof.
  intros.
  assert (get_idx x < length_env (get_class x) vs). eapply lookup_max. eauto.
  assert (get_idx x <> length_env (get_class x) vs). omega.
  assert (beq_nat (get_idx x) (length_env (get_class x) vs) = false) as E. eapply beq_nat_false_iff; eauto.
  destruct vs.
  destruct n; destruct x; destruct c; simpl in E;
    inversion H; simpl; try rewrite E; auto.
Qed.

(*
Lemma index_safe_ex: forall Hl1 Hl2 Gl1 Gl2 Hidx Gidx TF i,
   wf_env (Def vl Hl1 Hl2 Hidx) (Def ty Gl1 Gl2 Gidx) ->
   index i Gl1 = Some TF ->
   exists v, index i Hl1 = Some v.
Proof. intros.
  apply wf_length in H. destruct H as [L _]. simpl in L.

Qed.
*)

Lemma lookup_safe_ex: forall H1 G1 TF x,
             wf_env H1 G1 ->
             lookup x G1 = Some TF ->
             exists v, lookup x H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
  Case "nil". inversion H0. destruct x; destruct c; destruct (ble_nat n i); inversion H1.
  Case "cons". destruct vs as [vl1 vl2 vidx]. destruct ts as [tl1 tl2 tidx].
    apply wf_length in H1. destruct H1 as [H1l H1r].
    destruct x; destruct c; inversion H0.
    SCase "VFst". destruct n; simpl in H0 ; simpl in H2.
      SSCase "First".
        case_eq (beq_nat i (length tl1)).
        SSSCase "hit".
          intros E.
          rewrite E in H0. inversion H0. subst t. simpl.
          assert (beq_nat i (length vl1) = true). eauto.
          rewrite H1. eauto.
        SSSCase "miss".
          intros E.
          assert (beq_nat i (length vl1) = false). eauto.
          assert (exists v0, lookup (V First i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
          eapply IHwf_env. simpl. rewrite E in H0. eauto.
          inversion HI as [v0 HI1]. inversion HI1.
          eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto.
     SSCase "Second".
       assert (exists v0, lookup (V First i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
       eapply IHwf_env. simpl. eauto.
       inversion HI as [v0 HI1]. inversion HI1.
       eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto.
   SCase "VSnd". destruct n; simpl in H0; simpl in H2.
     SSCase "First".
       assert (exists v0, lookup (V Second i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
       eapply IHwf_env. simpl. eauto.
       inversion HI as [v0 HI1]. inversion HI1.
       eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto.
     SSCase "Second".
       case_eq (beq_nat i (length tl2)).
        SSSCase "hit".
          intro E.
          rewrite E in H0. simpl. destruct (ble_nat tidx i); inversion H0.
          subst t.
          assert (beq_nat i (length vl2) = true). eauto.
          rewrite H1. inversion H3. subst vidx. destruct (ble_nat tidx i); eauto. inversion H5.
        SSSCase "miss".
          intro E.
          assert (beq_nat i (length vl2) = false). eauto.
          assert (exists v0, lookup (V Second i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
          eapply IHwf_env. simpl. destruct (ble_nat tidx i). inversion H0. rewrite E in H0. rewrite H0. rewrite E. auto. auto.
          inversion HI as [v0 HI1]. inversion HI1.
          eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto.
Qed.

Inductive res_type: venv -> option vl -> ty -> Prop :=
| not_stuck: forall venv v T,
      val_type venv v T ->
      res_type venv (Some v) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stp H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros. inversion H; inversion H0; subst T2; subst; eauto.
Qed.

Lemma invert_abs: forall venv vf vx T1 n T2,
  val_type venv vf (TFun T1 n T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env n y) /\
    wf_env env tenv /\
    has_type (expand_env (expand_env tenv (TFun T3 n T4) Second) T3 n) y First T4 /\
    stp venv T1 (expand_env (expand_env env vf Second) vx n) T3 /\
    stp (expand_env (expand_env env vf Second) vx n) T4 venv T2.
Proof.
  intros. inversion H. repeat eexists; repeat eauto.
Qed.

Lemma ext_sanitize_commute : forall {T} n venv (v:T) c,
   expand_env (sanitize_any venv n) v c = sanitize_any (expand_env venv v c) n.
Proof.
  intros. destruct venv. destruct c; simpl; eauto.
Qed.

Lemma val_type_sanitize_any : forall n venv res T,
  val_type venv res T ->
  val_type (sanitize_any venv n) res T.
Proof.
  intros. inversion H; eauto.
Qed.

Lemma val_type_sanitize : forall env res T n,
  val_type (sanitize_env n env) res T ->
  val_type env res T.
Proof.
  intros. inversion H; eauto.
Qed.

Lemma wf_sanitize_any : forall n venv tenv,
   wf_env venv tenv ->
   wf_env (sanitize_any venv n) (sanitize_any tenv n).
Proof.
  intros. induction H.
  - simpl. eapply wfe_nil.
  - eapply wfe_cons in IHwf_env.
    rewrite <-ext_sanitize_commute. rewrite <-ext_sanitize_commute.
    eauto. eauto. rewrite ext_sanitize_commute.
    eapply val_type_sanitize_any in H. eauto. eauto.
Qed.

Lemma wf_sanitize : forall n venv tenv,
   wf_env venv tenv ->
   wf_env (sanitize_env n venv) (sanitize_env n tenv).
Proof.
  intros. destruct n; unfold sanitize_env. destruct venv. destruct tenv.
  assert (length l0 = length l2). apply wf_length in H; destruct H as [L R]; eauto.
  rewrite H0. eapply wf_sanitize_any. eauto.
  eauto.
Qed.

Hint Immediate wf_sanitize.

(* ### Theorem 3.5 ### *)
(* if result of STLC 1/2 evaluation is not a timeout, then *)
(* it is not stuck, and well-typed *)

Theorem full_safety : forall k e n tenv venv res T,
  teval k venv e n = Some res -> has_type tenv e n T -> wf_env venv tenv ->
  res_type venv res T.

Proof.
  intros k. induction k.
  (* 0 *)   intros. inversion H.
  (* S n *) intros. destruct e; inversion H; inversion H0.

  - Case "True".  eapply not_stuck. eapply v_bool.
  - Case "False". eapply not_stuck. eapply v_bool.

  - Case "Var".
    subst.
    destruct (lookup_safe_ex (sanitize_env n venv) (sanitize_env n tenv) T v) as [va [I V]]; eauto.

    rewrite I. eapply not_stuck. eapply val_type_sanitize. eapply V.

  - Case "App".
    remember (teval k venv e1 Second) as tf.
    subst T. subst n0.

    destruct tf as [rf|]; try solve by inversion.
    assert (res_type venv rf (TFun T1 m T2)) as HRF. SCase "HRF". subst. eapply IHk; eauto.
    inversion HRF as [? vf].

    subst rf. remember vf as rvf. destruct vf; try (subst rvf; solve by inversion).
    assert (c = m). destruct m; destruct c; try (subst rvf ; solve by inversion); eauto. subst c. subst rvf.
    remember (teval k venv e2 m) as tx.

    destruct tx as [rx|]; try solve by inversion.
    assert (res_type venv rx T1) as HRX. SCase "HRX". subst. eapply IHk; eauto.
    inversion HRX as [? vx].

    destruct (invert_abs venv (vabs e m t) vx T1 m T2) as
        [env1 [tenv1 [y0 [T3 [T4 [EF [WF [HTY [STX STY]]]]]]]]]. eauto.
    (* now we know it's a closure, and we have has_type evidence *)

    inversion EF. subst e. subst y0. clear EF.
    subst rx.

    assert (res_type (expand_env (expand_env env1 (vabs env1 m t) Second) vx m) res T4) as HRY.
        SSSCase "HRY".
          subst. eapply IHk; eauto.
        (* wf_env f x *) econstructor. eapply valtp_widen; eauto.
        (* wf_env f   *) econstructor. eapply v_abs; eauto.
          eauto.
          apply wf_idx. assumption.
          apply wf_idx. econstructor. eauto. assumption. apply wf_idx. assumption.

    inversion HRY as [? vy].

    eapply not_stuck. eapply valtp_widen; eauto.

  - Case "Abs". intros. inversion H. inversion H0.
    eapply not_stuck. eapply v_abs; eauto.
    eauto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Arith.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Wf_nat.
Require Export MiscRsa.
(******************************************************************************)

Inductive divides : nat -> nat -> Prop :=
    dividesDef : forall a b q : nat, b = q * a -> divides a b.

Lemma div_ref : forall a : nat, divides a a.
intros a; apply dividesDef with (q := 1); auto with arith.
Qed.

Lemma div_divides :
 forall x y : nat, (exists q : _, is_div x y q 0) -> divides y x.
Proof.
intros x y H'; elim H'; intros q E; inversion_clear E; clear H'.
apply dividesDef with (q := q); auto.
rewrite H0; auto with arith.
Qed.

Lemma divides_div :
 forall x y : nat, 0 < y -> divides y x -> exists q : _, is_div x y q 0.
Proof.
intros x y H'1 H'2; inversion H'2.
exists q; auto.
apply is_div_def; auto with arith.
rewrite H; auto.
Qed.

Lemma divides_dec' :
 forall x y : nat,
 {(exists q : _, is_div x y q 0)} + {~ (exists q : _, is_div x y q 0)}.
Proof.
intros x y; case y; auto.
right; red in |- *; intros H'; elim H'; intros q E; inversion E; clear H';
 auto.
inversion H.
intros y'; case (eucl_dev (S y') (gt_Sn_O y') x).
intros q r; case r; auto.
intros H' H'0; left; exists q; auto.
apply is_div_def; auto; rewrite H'0; auto with arith.
intros n H' H'0; right; red in |- *; intros H'1; elim H'1; intros q0 E;
 clear H'1.
absurd (0 = S n); auto with arith.
apply div_unic_r with (a := x) (b := S y') (q1 := q0) (q2 := q); auto.
apply is_div_def; auto with arith.
Qed.

Lemma divides_dec : forall x y : nat, {divides x y} + {~ divides x y}.
intros x y; case x; case y; auto.
left; apply dividesDef with (q := 0); auto.
intros n; right; red in |- *; intros H'; inversion_clear H'.
rewrite (mult_comm q 0) in H; discriminate.
intros n; left; apply dividesDef with (q := 0); auto.
intros x' y'; case (divides_dec' (S x') (S y')); auto.
intros H'; left; apply div_divides; auto.
intros H'; right; red in |- *; intros H'0; case H'; auto.
inversion H'0.
exists q; auto.
apply is_div_def; auto with arith.
rewrite H; auto with arith.
Qed.

Lemma all_divides_O : forall n : nat, divides n 0.
Proof.
intros n; apply dividesDef with (q := 0); auto.
Qed.

Lemma SO_divides_all : forall n : nat, divides 1 n.
Proof.
intros n; apply dividesDef with (q := n); auto with arith.
Qed.

Lemma divides_plus1 :
 forall a b c : nat, divides a b -> divides a c -> divides a (b + c).
Proof.
intros a b c H' H'0; inversion_clear H'; inversion_clear H'0.
apply dividesDef with (q := q + q0); auto.
rewrite H; rewrite H0; auto with arith.
Qed.

Lemma divides_plus2 :
 forall a b c : nat, divides a b -> divides a (b + c) -> divides a c.
Proof.
intros a b c H' H'0; inversion_clear H'; inversion_clear H'0.
apply dividesDef with (q := q0 - q).
rewrite mult_minus_distr_r.
rewrite <- H; rewrite <- H0.
rewrite minus_plus; auto.
Qed.

Theorem divides_le : forall a b : nat, b <> 0 -> divides a b -> a <= b.
intros a b; case b.
intros H'; case H'; auto.
intros n H' H'0; inversion_clear H'0.
rewrite H; generalize H; case q; simpl in |- *; auto with arith; intros;
 discriminate.
Qed.

Lemma divides_antisym : forall a b : nat, divides a b -> divides b a -> a = b.
Proof.
intros a b; case a; case b; auto.
intros b' H' H'1; inversion_clear H'.
rewrite H; auto with arith.
intros a' H' H'1; inversion_clear H'1.
rewrite H; auto with arith.
intros n n0 H' H'0; apply le_antisym; apply divides_le; auto.
Qed.

Lemma not_lt_div : forall a b : nat, 0 < b -> b < a -> ~ divides a b.
intros a b H'1 H'2; red in |- *; intros H'3; absurd (a <= b); auto with arith.
apply divides_le; auto.
apply sym_not_eq; auto with arith.
Qed.
(********************************************************************)

Inductive prime : nat -> Prop :=
    primeDef :
      forall a : nat,
      a <> 1 -> (forall b : nat, divides b a -> b <> 1 -> a = b) -> prime a.

Lemma not_prime_O : ~ prime 0.
Proof.
red in |- *; intros H'; inversion_clear H'; auto.
absurd (0 = 2); auto with arith.
apply H0; auto.
apply all_divides_O.
Qed.

Lemma not_prime_1 : ~ prime 1.
Proof.
red in |- *; intros H'; inversion_clear H'; auto.
Qed.
Hint Resolve div_ref all_divides_O SO_divides_all not_prime_O not_prime_1.

Lemma lt_prime : forall p : nat, prime p -> 1 < p.
Proof.
intros p; case p.
intro; absurd (prime 0); auto.
intros n; case n.
intro; absurd (prime 1); auto.
intros; auto with arith.
Qed.
(**********************************************************************)

Inductive is_gcd (a b c : nat) : Prop :=
    is_gcd_intro :
      divides c a ->
      divides c b ->
      (forall d : nat, divides d a -> divides d b -> divides d c) ->
      is_gcd a b c.

Lemma is_gcd_unic :
 forall a b c d : nat, is_gcd a b c -> is_gcd a b d -> c = d.
Proof.
intros a b c d H' H'0; inversion_clear H'; inversion_clear H'0.
apply divides_antisym; auto.
Qed.

Lemma is_gcd_ref : forall x : nat, is_gcd x x x.
Proof.
intros x; apply is_gcd_intro; auto.
Qed.

Lemma is_gcd_sym : forall a b c : nat, is_gcd a b c -> is_gcd b a c.
intros a b c H; inversion_clear H; intros.
apply is_gcd_intro; auto.
Qed.

Lemma is_gcd_O' : forall a r : nat, is_gcd a 0 r -> a = r.
Proof.
intros a r H'; inversion_clear H'.
apply divides_antisym; auto.
Qed.

Lemma is_gcd_Ol : forall a : nat, is_gcd a 0 a.
intros a.
apply is_gcd_intro; auto.
Qed.

Lemma is_gcd_Or : forall a : nat, is_gcd 0 a a.
intros a.
apply is_gcd_intro; auto.
Qed.

Lemma prime_gcd : forall p n : nat, prime p -> ~ divides p n -> is_gcd n p 1.
intros p n H' H'0.
apply is_gcd_intro; auto.
intros d H'1 H'2.
inversion_clear H'.
elim (eq_nat_dec d 1); intros H'4; auto.
rewrite H'4; auto.
elim (eq_nat_dec p d); intros H'5; auto.
case H'0; try rewrite H'5; auto.
case H'5; apply H0; auto.
Qed.

Lemma gcd_rec :
 forall P : nat -> nat -> Set,
 (forall x : nat, P 0 x) ->
 (forall x : nat, P x 0) ->
 (forall a b : nat, P a b -> P a (b + a)) ->
 (forall a b : nat, P a b -> P (a + b) b) -> forall a b : nat, P a b.
Proof.
intros P H H0 H1 H2 a; pattern a in |- *; apply lt_wf_rec.
intros a' H' b; pattern b in |- *; apply lt_wf_rec.
intros b' H'0.
case (lt_eq_lt_dec a' b'); intros Ca'b';
 [ case Ca'b'; clear Ca'b'; intros Ca'b' | idtac ].
2: rewrite Ca'b'; auto.
2: pattern b' at 1 in |- *; replace b' with (0 + b'); auto.
replace b' with (b' - a' + a'); auto with arith.
case (zerop a'); intros lta'.
rewrite lta'; auto.
apply H1; apply H'0; auto with arith.
rewrite plus_comm; auto with arith.
replace a' with (a' - b' + b'); auto with arith.
case (zerop b'); intros ltb'.
rewrite ltb'; auto.
apply H2; apply H'; auto with arith.
rewrite plus_comm; auto with arith.
Qed.

Lemma gcd_ind :
 forall P : nat -> nat -> Prop,
 (forall x : nat, P 0 x) ->
 (forall x : nat, P x 0) ->
 (forall a b : nat, P a b -> P a (b + a)) ->
 (forall a b : nat, P a b -> P (a + b) b) -> forall a b : nat, P a b.
Proof.
intros P H H0 H1 H2 a; pattern a in |- *; apply lt_wf_ind.
intros a' H' b; pattern b in |- *; apply lt_wf_ind.
intros b' H'0.
case (lt_eq_lt_dec a' b'); intros Ca'b';
 [ case Ca'b'; clear Ca'b'; intros Ca'b' | idtac ].
2: rewrite Ca'b'; auto.
2: pattern b' at 1 in |- *; replace b' with (0 + b'); auto.
replace b' with (b' - a' + a'); auto with arith.
case (zerop a'); intros lta'.
rewrite lta'; auto.
apply H1; apply H'0; auto with arith.
rewrite plus_comm; auto with arith.
replace a' with (a' - b' + b'); auto with arith.
case (zerop b'); intros ltb'.
rewrite ltb'; auto.
apply H2; apply H'; auto with arith.
rewrite plus_comm; auto with arith.
Qed.

Inductive gcd_spec : nat -> nat -> nat -> Prop :=
  | gcd_spec_ex0 : forall a : nat, gcd_spec a 0 a
  | gcd_spec_ex1 : forall b : nat, gcd_spec 0 b b
  | gcd_spec_ex2 :
      forall a b c : nat, a < b -> gcd_spec a (b - a) c -> gcd_spec a b c
  | gcd_spec_ex3 :
      forall a b c : nat, b <= a -> gcd_spec (a - b) b c -> gcd_spec a b c.
Hint Resolve gcd_spec_ex0 gcd_spec_ex1.

Theorem gcd_inv_Or_aux : forall a b c : nat, gcd_spec a b c -> b = 0 -> a = c.
intros a b c H'; elim H'; auto.
intros a0 b0 c0 H'0 H'1 H'2 H'3.
apply H'2; auto.
rewrite H'3; auto.
intros a0 b0 c0 H'0 H'1 H'2 H'3.
replace a0 with (a0 - b0); auto.
rewrite H'3; auto with arith.
Qed.

Theorem gcd_inv_Or : forall a b : nat, gcd_spec a 0 b -> a = b.
intros a b H'.
apply gcd_inv_Or_aux with (b := 0); auto.
Qed.

Theorem gcd_inv_Ol_aux : forall a b c : nat, gcd_spec a b c -> a = 0 -> b = c.
intros a b c H'; elim H'; auto.
intros a0 b0 c0 H'0 H'1 H'2 H'3.
replace b0 with (b0 - a0); auto.
rewrite H'3; auto with arith.
intros a0 b0 c0 H'0 H'1 H'2 H'3.
apply H'2; auto.
rewrite H'3; auto.
Qed.

Theorem gcd_inv_Ol : forall a b : nat, gcd_spec 0 a b -> a = b.
intros a b H'.
apply gcd_inv_Ol_aux with (a := 0); auto.
Qed.

Definition gcd' :=
  gcd_rec (fun _ _ : nat => nat) (fun x : nat => x)
    (fun x : nat => x) (fun x y r : nat => r) (fun x y r : nat => r).

Lemma gcd_ex : forall a b : nat, {r : nat | gcd_spec a b r}.
intros a b; pattern b, a in |- *; apply gcd_rec; clear a b.
intros a; exists a; auto.
intros b; exists b; auto.
intros a b Rr; case Rr; intros r Hr; exists r.
apply gcd_spec_ex3; auto with arith.
rewrite plus_comm; rewrite minus_plus; auto; rewrite <- minus_n_n; auto.
intros a b Rr; case Rr; intros r Hr; exists r.
case (zerop a); intros lta.
rewrite lta; simpl in |- *.
rewrite <- (gcd_inv_Or b r); auto.
apply gcd_spec_ex3; auto with arith.
rewrite <- minus_n_n; auto.
rewrite <- lta; auto.
apply gcd_spec_ex2; auto with arith.
pattern b at 1 in |- *; replace b with (0 + b); auto with arith.
rewrite plus_comm; rewrite minus_plus; auto; rewrite <- minus_n_n; auto.
Qed.

Definition gcd (a b : nat) := proj1_sig (gcd_ex a b).

Lemma gcd_correct : forall a b : nat, gcd_spec a b (gcd a b).
Proof.
intros a b; unfold gcd in |- *; case (gcd_ex a b); simpl in |- *; auto.
Qed.
Hint Resolve gcd_correct.

Lemma gcd_spec_uniq :
 forall a b r1 r2 : nat, gcd_spec a b r1 -> gcd_spec a b r2 -> r1 = r2.
intros a b r1 r2 H'; generalize r2; elim H'; clear H' a b r1 r2.
exact gcd_inv_Or.
exact gcd_inv_Ol.
intros a b c H' H'0 H'1 r2 H'2; inversion H'2; auto.
apply H'1; auto.
rewrite <- H0; simpl in |- *; rewrite H1; auto.
apply H'1; auto.
rewrite <- H; simpl in |- *; rewrite <- minus_n_O; rewrite H1; auto.
absurd (a < b); auto with arith.
intros a b c H' H'0 H'1 r2 H'2; inversion H'2; auto.
apply H'1; auto.
rewrite <- H0; simpl in |- *; rewrite H1; rewrite <- minus_n_O; auto.
apply H'1; auto.
rewrite <- H; simpl in |- *; rewrite H1; auto.
absurd (a < b); auto with arith.
Qed.

Lemma gcd_correct2 : forall a b r : nat, gcd_spec a b r -> gcd a b = r.
Proof.
intros a b r H'.
apply gcd_spec_uniq with (a := a) (b := b); auto.
Qed.

Lemma gcd_def0l : forall x : nat, gcd 0 x = x.
Proof.
intros x; apply gcd_spec_uniq with (a := 0) (b := x); auto.
Qed.

Lemma gcd_def0r : forall x : nat, gcd x 0 = x.
Proof.
intros x; apply gcd_spec_uniq with (a := x) (b := 0); auto.
Qed.

Lemma gcd_def1 : forall x : nat, gcd x x = x.
Proof.
intros x; apply gcd_spec_uniq with (a := x) (b := x); auto.
apply gcd_spec_ex3; auto.
rewrite <- minus_n_n; auto.
Qed.

Lemma gcd_def2 : forall a b : nat, gcd a b = gcd a (b + a).
Proof.
intros a b; apply gcd_spec_uniq with (a := a) (b := b + a); auto.
case (zerop b); intros ltb.
rewrite ltb; simpl in |- *; rewrite gcd_def0r; auto.
apply gcd_spec_ex3; auto.
rewrite <- minus_n_n; auto.
apply gcd_spec_ex2; auto with arith.
replace a with (0 + a); auto with arith.
rewrite plus_comm; rewrite minus_plus.
apply gcd_correct; auto.
Qed.

Lemma gcd_def3 : forall a b : nat, gcd a b = gcd (a + b) b.
Proof.
intros a b; apply gcd_spec_uniq with (a := a + b) (b := b); auto.
case (zerop a); intros lta.
rewrite lta; simpl in |- *; rewrite gcd_def0l; auto.
apply gcd_spec_ex3; auto with arith.
rewrite <- minus_n_n; auto.
apply gcd_spec_ex3; auto with arith.
rewrite plus_comm; rewrite minus_plus.
apply gcd_correct; auto.
Qed.

Lemma gcd_is_gcd : forall a b : nat, is_gcd a b (gcd a b).
Proof.
intros; pattern a, b in |- *; apply gcd_ind; clear a b.
intros x; rewrite gcd_def0l; auto.
apply is_gcd_Or; auto.
intros x; rewrite gcd_def0r; auto.
apply is_gcd_Ol; auto.
intros a b H'; rewrite <- gcd_def2.
inversion_clear H'.
apply is_gcd_intro; auto.
apply divides_plus1; auto.
intros d H' H'0.
apply H1; auto.
apply divides_plus2 with (b := a); auto.
rewrite plus_comm; auto.
intros a b H'; rewrite <- gcd_def3.
inversion_clear H'.
apply is_gcd_intro; auto.
apply divides_plus1; auto.
intros d H' H'0.
apply H1; auto.
apply divides_plus2 with (b := b); auto.
rewrite plus_comm; auto.
Qed.

Lemma preEuclid :
 forall a b c m : nat,
 divides c (m * a) -> divides c (m * b) -> divides c (m * gcd a b).
Proof.
intros a b; pattern a, b in |- *; apply gcd_ind; clear a b.
intros x c m H' H'0; rewrite gcd_def0l; auto.
intros x c m H' H'0; rewrite gcd_def0r; auto.
intros a b H' c m H'0 H'1; rewrite <- gcd_def2.
apply H'; auto.
apply divides_plus2 with (m * a); auto.
rewrite mult_comm; pattern mult at 1 in |- *; rewrite mult_comm;
 rewrite <- mult_plus_distr_r; rewrite mult_comm.
rewrite plus_comm; simpl in |- *; assumption.
intros a b H' c m H'0 H'1; rewrite <- gcd_def3.
apply H'; auto.
apply divides_plus2 with (m * b); auto.
rewrite mult_comm; pattern mult at 1 in |- *; rewrite mult_comm;
 rewrite <- mult_plus_distr_r; rewrite mult_comm.
rewrite plus_comm; simpl in |- *; assumption.
Qed.

Theorem L_Euclides :
 forall x a b : nat, is_gcd x a 1 -> divides x (a * b) -> divides x b.
Proof.
intros x a b H' H'0; replace b with (b * gcd x a).
apply preEuclid; auto with arith.
apply dividesDef with (q := b); auto with arith.
rewrite mult_comm; auto.
rewrite (is_gcd_unic x a (gcd x a) 1); auto with arith.
apply gcd_is_gcd; auto.
Qed.

Lemma L_Euclides1 :
 forall p a b : nat,
 prime p -> divides p (a * b) -> ~ divides p a -> divides p b.
intros; apply L_Euclides with a; auto.
apply is_gcd_sym.
apply prime_gcd; auto.
Qed.

Lemma L_Euclides2 :
 forall p a b : nat,
 prime p -> divides p (a * b) -> divides p a \/ divides p b.
intros.
elim (divides_dec p a); [ left | right ]; auto.
apply L_Euclides1 with a; auto.
Qed.

Theorem div_power_prime :
 forall p w n : nat, prime p -> divides p (power w n) -> divides p w.
intros p w n; elim n; simpl in |- *; auto.
intros H' H'0; inversion_clear H'0.
generalize H' H; case q; case p; simpl in |- *; intros; try discriminate.
absurd (prime 0); auto.
generalize H0; case n0; simpl in |- *; auto.
intros n2 H'1; absurd (1 = S (S (n2 + n1 * S (S n2)))); auto.
intros n0 H' H'0 H'1.
case (divides_dec p (power w n0)); intros H; auto.
apply L_Euclides1 with (a := power w n0); auto.
rewrite mult_comm; auto.
Qed.
Section CD.
Variable n : nat.
(**********************************************************************)

Inductive congruent : nat -> nat -> Prop :=
    congruentDef :
      forall a b u v : nat, a + u * n = b + v * n -> congruent a b.

Lemma cong_ref : forall a : nat, congruent a a.
Proof.
intros a.
apply congruentDef with (u := 1) (v := 1); auto.
Qed.

Lemma cong_sym : forall a b : nat, congruent a b -> congruent b a.
Proof.
intros a b H; elim H.
intros a0 b0 c d H'.
apply congruentDef with (u := d) (v := c); auto.
Qed.

Lemma cong_trans :
 forall a b c : nat, congruent a b -> congruent b c -> congruent a c.
Proof.
intros a b c H' H'0; inversion_clear H'; inversion_clear H'0.
apply congruentDef with (u := u + u0) (v := v + v0); auto.
repeat rewrite mult_plus_distr_r; repeat rewrite plus_assoc; rewrite H.
repeat rewrite plus_comm with (m := v * n); repeat rewrite plus_assoc_reverse;
 rewrite H0; auto.
Qed.

Lemma cong_mult_O : forall a b : nat, congruent a 0 -> congruent (a * b) 0.
Proof.
intros a b H'; inversion_clear H'.
apply congruentDef with (u := u * b) (v := v * b).
repeat rewrite mult_comm with (m := b); repeat rewrite mult_assoc_reverse;
 repeat rewrite (mult_comm b).
rewrite <- mult_plus_distr_r; rewrite H; rewrite mult_plus_distr_r;
 simpl in |- *; auto.
Qed.

Lemma cong_plus :
 forall a b c d : nat,
 congruent a b -> congruent c d -> congruent (a + c) (b + d).
Proof.
intros a b c d H' H'0; inversion_clear H'; inversion_clear H'0.
apply congruentDef with (u := u0 + u) (v := v0 + v).
repeat rewrite mult_plus_distr_r; repeat rewrite plus_assoc_reverse.
rewrite (plus_assoc c); rewrite (plus_assoc d); rewrite H0.
rewrite (plus_comm a); rewrite (plus_comm b);
 repeat rewrite plus_assoc_reverse; rewrite plus_comm with (m := a);
 rewrite plus_comm with (m := b); rewrite H; auto.
Qed.

Lemma cong_add :
 forall a b c : nat, congruent a b -> congruent (a + c) (b + c).
Proof.
intros a b c H; inversion_clear H.
apply congruentDef with (u := u) (v := v); auto.
repeat rewrite plus_comm with (m := c); repeat rewrite plus_assoc_reverse;
 rewrite H0; auto.
Qed.

Lemma cong_times :
 forall a b c : nat, congruent a b -> congruent (a * c) (b * c).
intros a b c H; inversion_clear H.
apply congruentDef with (u := u * c) (v := v * c); auto.
repeat rewrite mult_comm with (m := c); repeat rewrite mult_assoc_reverse;
 repeat rewrite (mult_comm c).
repeat rewrite <- mult_plus_distr_r.
rewrite H0; auto.
Qed.

Lemma cong_mult :
 forall a b c d : nat,
 congruent a b -> congruent c d -> congruent (a * c) (b * d).
intros a b c d H' H'0; inversion_clear H'; inversion_clear H'0.
apply
 congruentDef
  with (u := u0 * a + u * u0 * n + u * c) (v := v0 * b + v * v0 * n + v * d).
repeat rewrite mult_plus_distr_r.
repeat rewrite plus_assoc.
rewrite (mult_comm u0); rewrite (mult_comm v0).
repeat rewrite mult_assoc_reverse.
repeat rewrite (mult_comm a); repeat rewrite (mult_comm b).
repeat rewrite <- mult_plus_distr_r.
repeat rewrite mult_assoc.
repeat rewrite mult_comm with (m := n).
rewrite (mult_assoc n u); rewrite (mult_assoc n v).
repeat rewrite mult_assoc.
repeat rewrite (mult_assoc_reverse n n).
rewrite mult_comm with (m := n * u); rewrite mult_comm with (m := n * v).
repeat rewrite mult_assoc_reverse with (m := n).
repeat rewrite (mult_comm (n * u)); repeat rewrite (mult_comm (n * v)).
repeat rewrite plus_assoc_reverse; repeat rewrite <- mult_plus_distr_r.
rewrite plus_comm with (m := c); rewrite plus_comm with (m := d).
repeat rewrite (mult_comm (c + n * u0));
 repeat rewrite (mult_comm (d + n * v0)).
repeat rewrite (mult_comm (c + n * u0));
 repeat rewrite (mult_comm (d + n * v0)).
repeat rewrite <- mult_plus_distr_r.
repeat rewrite (mult_comm n); rewrite H; auto.
Qed.

Lemma cong_pow :
 forall a b c : nat, congruent a b -> congruent (power a c) (power b c).
intros a b c; elim c; simpl in |- *; auto.
intros H'; apply cong_ref.
intros n0 H' H'0.
apply cong_mult; auto.
Qed.

Theorem congruent' :
 forall a b : nat, b <= a -> congruent a b -> exists k : nat, a = k * n + b.
intros a b H' H'0; inversion_clear H'0.
exists (v - u).
rewrite mult_minus_distr_r; auto.
rewrite plus_minus_assoc.
rewrite plus_comm; rewrite <- H; rewrite plus_comm; auto with arith.
apply le_plus_le with (a := b) (b := a); auto.
Qed.

Lemma cong1_le : forall x : nat, 1 < n -> congruent x 1 -> 1 <= x.
Proof.
intros x; case x; auto with arith.
intros H' H'0; inversion_clear H'0.
absurd (n = 1).
red in |- *; intros H'0; absurd (1 < n); auto; rewrite H'0; auto with arith.
apply mult_SO with (y := u - v); auto.
rewrite mult_comm.
rewrite mult_minus_distr_r; auto.
simpl in H; rewrite H.
rewrite <- minus_Sn_m; auto with arith.
Qed.

Lemma divides_cong : forall x : nat, divides n x -> congruent 0 x.
Proof.
intros x H; inversion_clear H.
apply congruentDef with (u := q) (v := 0); simpl in |- *; rewrite H0;
 auto with arith.
Qed.

Theorem cong_divides :
 forall a b : nat, b <= a -> congruent a b -> divides n (a - b).
Proof.
intros a b H H0; elim (congruent' _ _ H H0).
intros x H1; exists x.
apply plus_reg_l with b.
rewrite le_plus_minus_r; auto.
rewrite plus_comm; rewrite <- H1; auto.
Qed.
End CD.


Require Export hott_lemmas.

(* Part I : definition of the type slist. *)

Section slist_private.

Private Inductive slist (X : Type) : Type :=
  | nil : slist X
  | cons : X -> slist X -> slist X.
Global Arguments nil {X}.
Global Arguments cons {X} _ _.

End slist_private.

Declare Scope slist_scope.
Infix "::" := cons (at level 60, right associativity) : slist_scope.
Open Scope slist_scope.

Section slist.

Context {X : Type}.

Axiom swap
  : forall (x y : X) (l : slist X),
    x :: y :: l = y :: x :: l.

Axiom double
  : forall (x y : X) (l : slist X),
    swap x y l @ swap y x l = idpath.

Axiom triple
  : forall (x y z : X) (l : slist X),
  swap x y (cons z l) @ ap (cons y) (swap x z l) @ swap y z (cons x l)
  = ap (cons x) (swap y z l) @ swap x z (cons y l) @ ap (cons z) (swap x y l).

Axiom T_slist
  : IsTrunc 1 (slist X).

Lemma swap_natural {x y : X} {l l' : slist X} (p : l = l')
  : swap x y l @ ap (cons y) (ap (cons x) p) = ap (cons x) (ap (cons y) p) @ swap x y l'.
Proof.
  induction p; simpl. exact (concat_p1 _ @ (concat_1p _)^).
Defined.

Lemma swap_inv {x y : X} {l : slist X}
  : swap x y l = (swap y x l)^.
Proof.
  apply moveL_1V. apply double.
Defined.

Section slist_ind.

Definition swap'_ind_type
  (P : slist X -> Type)
  (cons' : forall (x : X) (l : slist X) (IHl : P l), P (x :: l))
  : Type
  := forall (x y : X) (l : slist X) (IHl : P l),
    transport P (swap x y l) (cons' x _ (cons' y _ IHl)) = cons' y _ (cons' x _ IHl).

Definition double'_ind_type
  (P : slist X -> Type)
  (cons' : forall (x : X) (l : slist X) (IHl : P l), P (x :: l))
  (swap' : swap'_ind_type P cons')
  : Type
  := forall (x y : X) (l : slist X) (IHl : P l),
    concat_D (swap' x y l IHl) (swap' y x l IHl)
    = ap (fun z => transport P z (cons' x _ (cons' y _ IHl))) (double x y l).

Definition triple'_ind_type
  (P : slist X -> Type)
  (cons' : forall (x : X) (l : slist X) (IHl : P l), P (x :: l))
  (swap' : swap'_ind_type P cons')
  : Type
  := forall (x y z : X) (l : slist X) (IHl : P l),
    concat_D
      (concat_D
        (swap' x y _ (cons' z _ IHl))
        (transport_ap P (cons y) (cons' y) _ (swap' x z _ IHl)))
      (swap' y z _ (cons' x _ IHl))
    = ap (fun w => transport P w (cons' x _ (cons' y _ (cons' z _ IHl)))) (triple x y z l)
    @ concat_D
        (concat_D
          (transport_ap P (cons x) (cons' x) _ (swap' y z _ IHl))
          (swap' x z _ (cons' y _ IHl)))
        (transport_ap P (cons z) (cons' z) _ (swap' x y _ IHl)).

Fixpoint slist_ind
  (P : slist X -> Type)
  (nil' : P nil)
  (cons' : forall (x : X) (l : slist X) (IHl : P l), P (x :: l))
  (swap' : swap'_ind_type P cons')
  (double' : double'_ind_type P cons' swap')
  (triple' : triple'_ind_type P cons' swap')
  (T_slist' : forall (l : slist X), IsTrunc 1 (P l))
  (l : slist X)
  : P l
  := match l with
    | nil => nil'
    | x :: k => cons' x k (slist_ind P nil' cons' swap' double' triple' T_slist' k)
    end.

Axiom slist_ind_beta_swap
  : forall (P : slist X -> Type)
  (nil' : P nil)
  (cons' : forall (x : X) (l : slist X) (IHl : P l), P (x :: l))
  (swap' : swap'_ind_type P cons')
  (double' : double'_ind_type P cons' swap')
  (triple' : triple'_ind_type P cons' swap')
  (T_slist' : forall (l : slist X), IsTrunc 1 (P l))
  (x y : X) (l : slist X),
  apD (slist_ind P nil' cons' swap' double' triple' T_slist') (swap x y l) = swap' x y _ (slist_ind P nil' cons' swap' double' triple' T_slist' l).

End slist_ind.

Section slist_ind_trunc.

Context (P : slist X-> Type)
  (nil' : P nil)
  (cons' : forall (x : X) (l : slist X) (IHl : P l), P (x :: l)).

Definition slist_ind_to_set
  (swap' : swap'_ind_type P cons')
  (T_slist' : forall (l : slist X), IsTrunc 0 (P l))
  : forall l : slist X, P l.
Proof.
  srefine (@slist_ind P nil' cons' swap' _ _ _);
  [ unfold double'_ind_type | unfold triple'_ind_type];
  intros; apply T_slist'.
Defined.

Definition slist_ind_to_prop
  (T_slist' : forall (l : slist X), IsTrunc (-1) (P l))
  : forall l : slist X, P l.
Proof.
  srapply @slist_ind_to_set;
  unfold swap'_ind_type;
  intros; apply T_slist'.
Defined.

End slist_ind_trunc.

Section slist_ind_paths.

Definition slist_ind_to_paths_in_gpd
  (P : Type)
  (f f' : slist X -> P)
  (nil' : f nil = f' nil)
  (cons' : forall (x : X) (l : slist X) (IHl : f l = f' l), f (x :: l) = f' (x :: l))
  (swap' : forall (x y : X) (l : slist X) (IHl : f l = f' l),
    cons' x (y :: l) (cons' y l IHl) @ ap f' (swap x y l)
    = ap f (swap x y l) @ cons' y (x :: l) (cons' x l IHl))
  (T' : IsTrunc 1 P)
  : forall w : slist X, f w = f' w.
Proof.
  srefine (@slist_ind_to_set (fun w => f w = f' w) nil' cons' _ _); simpl.
  unfold swap'_ind_type; intros.
  refine (transport_paths_FlFr _ _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp.
  apply swap'.
Defined.

Definition slist_ind_to_paths_in_set
  (P : Type)
  (T' : IsTrunc 0 P)
  (f f' : slist X -> P)
  (nil' : f nil = f' nil)
  (cons' : forall (x : X) (l : slist X) (IHl : f l = f' l), f (x :: l) = f' (x :: l))
  : forall w : slist X, f w = f' w.
Proof.
  exact (@slist_ind_to_prop (fun w => f w = f' w) nil' cons' _).
Defined.

Definition slist_ind_to_2paths_in_gpd
  (P : Type)
  (T' : IsTrunc 1 P)
  (f f' : slist X -> P)
  (p p' : forall l : slist X, f l = f' l)
  (nil' : p nil = p' nil)
  (cons' : forall (x : X) (l : slist X) (IHl : p l = p' l), p (x :: l) = p' (x :: l))
  : forall w : slist X, p w = p' w.
Proof.
  exact (@slist_ind_to_prop (fun w => p w = p' w) nil' cons' _).
Defined.

Definition slist_ind_to_fam_paths_in_gpd
  `{Funext}
  (P : Type)
  (T' : IsTrunc 1 P)
  (f f' : slist X -> slist X -> P)
  (nil' : forall l' : slist X, f nil l' = f' nil l')
  (cons' : forall (x : X) (l : slist X) (IHl : forall l' : slist X, f l l' = f' l l') (l' : slist X),
    f (x :: l) l' = f' (x :: l) l')
  (swap' : forall (x y : X) (l : slist X) (IHl : forall w' : slist X, f l w' = f' l w') (l' : slist X),
    cons' x (y :: l) (cons' y l IHl) l' @ ap (fun a : slist X => f' a l') (swap x y l)
    = ap (fun a : slist X => f a l') (swap x y l) @ cons' y (x :: l) (cons' x l IHl) l')
  : forall w w' : slist X, f w w' = f' w w'.
Proof.
  srefine (@slist_ind_to_set (fun w => forall w' : slist X, f w w' = f' w w') nil' cons' _ _).
  unfold swap'_ind_type; intros.
  by_extensionality l'.
  refine (transport_forall' f f' (swap x y l) _ l' @ _); apply moveR_Vp.
  apply swap'.
Defined.

Definition slist_ind_to_fam_2paths_in_gpd
  `{Funext}
  (P : Type)
  (T' : IsTrunc 1 P)
  (f f' : slist X -> slist X -> P)
  (p p' : forall (l l' : slist X), f l l' = f' l l')
  (nil' : forall w' : slist X, p nil w' = p' nil w')
  (cons' : forall (x : X) (l : slist X) (IHl : forall w' : slist X, p l w' = p' l w') (w' : slist X),
    p (x :: l) w' = p' (x :: l) w')
  : forall w w' : slist X, p w w' = p' w w'.
Proof.
  exact (slist_ind_to_prop (fun l : slist X => forall w' : slist X, p l w' = p' l w') nil' cons' _).
Defined.

End slist_ind_paths.

Section slist_rec.

Definition swap'_rec_type
  (P : Type)
  (cons' : X -> P -> P)
  : Type
  := forall (x y : X) (l' : P),
      cons' x (cons' y l') = cons' y (cons' x l').

Definition double'_rec_type
  (P : Type)
  (cons' : X -> P -> P)
  (swap' : swap'_rec_type P cons')
  : Type
  := forall (x y : X) (l' : P),
      swap' x y l' @ swap' y x l' = idpath.

Definition triple'_rec_type
  (P : Type)
  (cons' : X -> P -> P)
  (swap' : swap'_rec_type P cons')
  : Type
  := forall (x y z : X) (l' : P),
      swap' x y (cons' z l') @ ap (cons' y) (swap' x z l') @ swap' y z (cons' x l')
      = ap (cons' x) (swap' y z l') @ swap' x z (cons' y l') @ ap (cons' z) (swap' x y l').

  Definition slist_rec_swap
    {P : Type}
    {cons' : X -> P -> P}
    (swap' : swap'_rec_type P cons')
    : swap'_ind_type (fun _ : slist X => P) (fun (x : X) (_ : slist X) => cons' x).
  Proof.
    unfold swap'_ind_type; unfold swap'_rec_type in swap'.
    exact (fun x y _ l' => transport_const _ _ @ swap' x y l').
  Defined.

  Definition slist_rec_double
    {P : Type}
    {cons' : X -> P -> P}
    (swap' : swap'_rec_type P cons')
    (double' : double'_rec_type P cons' swap')
    : double'_ind_type (fun _ : slist X => P) (fun (x : X) (_ : slist X) => cons' x) (slist_rec_swap swap').
  Proof.
    unfold double'_ind_type; unfold double'_rec_type in double'.
    intros. refine (concat_D_const_p (swap' x y IHl) (swap' y x IHl) @ _).
    refine (whiskerL _ (double' x y IHl) @ concat_p1 _ @ _).
    exact ((transport_const_pq (double x y l) _)^ @ concat_p1 _).
  Qed.

  Definition slist_rec_triple
    {P : Type}
    {cons' : X -> P -> P}
    (swap' : swap'_rec_type P cons')
    (triple' : triple'_rec_type P cons' swap')
    : triple'_ind_type (fun _ : slist X => P) (fun (x : X) (_ : slist X) => cons' x) (slist_rec_swap swap').
  Proof.
    unfold triple'_ind_type; unfold triple'_rec_type in triple'.
    intros. simpl.
    rewrite transport_ap_transport_const_p, transport_ap_transport_const_p, transport_ap_transport_const_p.
    rewrite concat_D_const_p, concat_D_const_p, concat_D_const_p, concat_D_const_p.
    apply moveR_pM.
    refine ((transport_const_pq (triple x y z l) (cons' x (cons' y (cons' z IHl))))^ @ _).
    refine (_ @ concat_p_pp _ _ _). apply whiskerL.
    refine ((concat_p1 _)^ @ _ @ concat_p_pp _ _ _). apply whiskerL.
    apply moveL_pV. refine (concat_1p _ @ _). apply triple'.
  Qed.

Definition slist_rec
  (P : Type)
  (nil' : P)
  (cons' : X -> P -> P)
  (swap' : swap'_rec_type P cons')
  (double' : double'_rec_type P cons' swap')
  (triple' : triple'_rec_type P cons' swap')
  (T_slist' : IsTrunc 1 P)
  : slist X -> P.
Proof.
  exact (slist_ind (fun _ => P) nil' (fun x _ => cons' x) (slist_rec_swap swap') (slist_rec_double swap' double') (slist_rec_triple swap' triple') _).
Defined.

Definition slist_rec_beta_swap
  (P : Type)
  (T_slist' : IsTrunc 1 P)
  (nil' : P)
  (cons' : X -> P -> P)
  (swap' : swap'_rec_type P cons')
  (double' : double'_rec_type P cons' swap')
  (triple' : triple'_rec_type P cons' swap')
  (x y : X) (l : slist X)
  : ap (slist_rec P nil' cons' swap' double' triple' T_slist') (swap x y l) = swap' x y (slist_rec P nil' cons' swap' double' triple' T_slist' l).
Proof.
  eapply (cancelL (transport_const (swap x y l) _)).
  refine ((apD_const _ (swap x y l))^ @ _).
  exact (slist_ind_beta_swap (fun _ => P) nil' (fun x _ => cons' x) (slist_rec_swap swap') (slist_rec_double swap' double') (slist_rec_triple swap' triple') _ x y l).
Defined.

End slist_rec.

Section slist_rec_trunc.

Definition slist_rec_to_set
  (P : Type)
  (nil' : P)
  (cons' : X -> P -> P)
  (swap' : swap'_rec_type P cons')
  (T_slist' : IsTrunc 0 P)
  : slist X -> P.
Proof.
  srefine (@slist_rec P nil' cons' swap' _ _ _);
  [ unfold double'_rec_type | unfold triple'_rec_type ];
  intros; apply T_slist'.
Defined.

Definition slist_rec_to_prop
  (P : Type)
  (nil' : P)
  (cons' : X -> P -> P)
  (T_slist' : IsTrunc (-1) P)
  : slist X -> P.
Proof.
  srefine (@slist_rec_to_set P nil' cons' _ _);
  unfold swap'_rec_type; intros; apply T_slist'.
Defined.

End slist_rec_trunc.

End slist.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments swap {X} _ _ _.
Arguments double {X} _ _ _.
Arguments triple {X} _ _ _ _.
Arguments swap_natural {X} _ _ {l} {l'} _.
Arguments swap_inv {X} _ _ _.

Ltac unfold_slist_types
  := try unfold triple'_ind_type in *;
      try unfold triple'_rec_type in *;
      try unfold double'_ind_type in *;
      try unfold double'_rec_type in *;
      try unfold swap'_ind_type in *;
      try unfold swap'_rec_type in *.

(* Part II : definition of the symmetric monoidal product (slist append). *)
Require Export smonoidalgroupoid.

Section sapp.

Open Scope path_scope.
Open Scope slist_scope.

Context `{Funext}.
Context {X : Type}.

  Lemma sapp_cons
    : X -> (slist X -> slist X) -> slist X -> slist X.
  Proof.
    intros x f. exact (cons x o f).
  Defined.

  Lemma sapp_swap
    : swap'_rec_type (slist X -> slist X) sapp_cons.
  Proof.
    unfold_slist_types.
    intros x y f. unfold sapp_cons.
    exact (path_forall (fun l : slist X => x :: y :: f l) (fun l : slist X => y :: x :: f l) (fun l => swap x y (f l))).
  Defined.

  Lemma sapp_double
    : double'_rec_type (slist X -> slist X) sapp_cons sapp_swap.
  Proof.
    unfold_slist_types.
    intros x y f.
    unfold sapp_swap.
    refine ((path_forall_pp _ _ _ (fun l => swap x y (f l)) (fun l => swap y x (f l)))^ @ _).
    refine (_ @ path_forall_1 (fun l : slist X => x :: y :: f l)).
    apply ap. srapply @path_forall; intro l.
    apply double.
  Qed.

  Lemma sapp_triple
    : triple'_rec_type (slist X -> slist X) sapp_cons sapp_swap.
  Proof.
    unfold_slist_types.
    intros x y z f.
    rewrite (ap_pf_2 (swap x z)), (ap_pf_2 (swap y z)), (ap_pf_2 (swap x y)).
    unfold sapp_swap, sapp_cons.
    rewrite <- path_forall_pp, <- path_forall_pp, <- path_forall_pp, <- path_forall_pp.
    apply ap. apply path_forall; intro l.
    apply triple.
  Qed.

  Definition sapp_trunc
    : IsTrunc 1 (slist X -> slist X).
  Proof.
    exact (@trunc_forall H (slist X) (fun _ => slist X) 1 (fun _ => T_slist)).
  Defined.

Definition sapp
  : slist X -> slist X -> slist X
  := slist_rec _ idmap sapp_cons sapp_swap sapp_double sapp_triple sapp_trunc.

End sapp.

Infix "++" := sapp (right associativity, at level 60) : slist_scope.

Section sapp_monoidal_structure.

Open Scope path_scope.
Open Scope slist_scope.

Context `{Funext}.
Context {X : Type}.

Lemma sapp_beta_swap (x y : X) (l' : slist X)
  : ap sapp (swap x y l') = path_forall _ _ (fun z => swap x y (l' ++ z)).
Proof.
  srapply @slist_rec_beta_swap.
Defined.

Lemma sapp_blank_beta_swap (x y : X) (l l' : slist X)
  : ap (fun w : slist X => w ++ l') (swap x y l) = swap x y (l ++ l').
Proof.
  refine (ap_compose sapp (fun q => q l') (swap x y l) @ _).
  refine (ap (ap (fun q => q l')) (sapp_beta_swap x y l) @ _).
  exact (ap_pf (fun z : slist X => swap x y (l ++ z)) l').
Defined.

Lemma ap011_sapp_ap_cons (x : X) {l l' k k' : slist X} (p : l = l') (q : k = k')
  : ap011 sapp (ap (cons x) p) q = ap (cons x) (ap011 sapp p q).
Proof.
  induction p, q; constructor.
Defined.

(* alpha *)
  Lemma alpha_slist_swap (l2 l3 : slist X)
    : forall (x y : X) (l1 : slist X) (h : (l1 ++ l2) ++ l3 = l1 ++ l2 ++ l3),
      ap (cons x) (ap (cons y) h) @ ap (fun w : slist X => w ++ l2 ++ l3) (swap x y l1)
      = ap (fun w : slist X => (w ++ l2) ++ l3) (swap x y l1) @ ap (cons y) (ap (cons x) h).
  Proof.
    intros x y l1 h; simpl.
    refine (whiskerL _ (sapp_blank_beta_swap x y l1 (l2 ++ l3)) @ _).
    refine (_ @ whiskerR (ap_compose ((fun h => h l2) o sapp) ((fun h => h l3) o sapp) (swap x y l1))^ _).
    refine (_ @ whiskerR (ap (ap (fun h => sapp h l3)) (sapp_blank_beta_swap x y l1 l2))^ _).
    refine (_ @ whiskerR (sapp_blank_beta_swap x y (l1 ++ l2) l3)^ _).
    exact (swap_natural x y h)^.
  Qed.

Lemma alpha_slist
  : forall l1 l2 l3 : slist X, (l1 ++ l2) ++ l3 = l1 ++ l2 ++ l3.
Proof.
  intros; revert l1; srapply @slist_ind_to_paths_in_gpd; simpl.
  + constructor.
  + intros x l1 h.
    change (x :: (l1 ++ l2) ++ l3 = x :: l1 ++ l2 ++ l3).
    apply ap; exact h.
  + hnf. apply alpha_slist_swap.
  + exact T_slist.
Defined.

(* lambda *)
Lemma lambda_slist
  : forall l : slist X, nil ++ l = l.
Proof.
  intros. constructor.
Defined.

(* rho *)
  Lemma rho_slist_swap
    : forall (x y : X) (l : slist X) (h : l ++ nil = l),
      ap (cons x) (ap (cons y) h) @ ap idmap (swap x y l)
      = ap (fun w : slist X => w ++ nil) (swap x y l) @ ap (cons y) (ap (cons x) h).
  Proof.
    intros; simpl.
    refine (whiskerL _ (ap_idmap _) @ _).
    refine ((swap_natural x y h)^ @ _); apply whiskerR.
    exact (sapp_blank_beta_swap x y l nil)^.
  Qed.

Lemma rho_slist
  : forall l : slist X, l ++ nil = l.
Proof.
  srapply @slist_ind_to_paths_in_gpd; simpl.
  + constructor.
  + intros x l h.
    change (x :: l ++ nil = x :: l).
    apply ap; exact h.
  + hnf. apply rho_slist_swap.
  + exact T_slist.
Defined.

(* tau *)
  Lemma sapp_Q_swap (x : X) (l2 : slist X)
    : forall (y z : X) (l1 : slist X) (h : x :: l1 ++ l2 = l1 ++ x :: l2),
      (swap x y ((z :: l1) ++ l2) @ ap (cons y) (swap x z (l1 ++ l2) @ ap (cons z) h))
      @ ap (fun w : slist X => w ++ x :: l2) (swap y z l1)
      = ap (fun w : slist X => x :: w ++ l2) (swap y z l1)
      @ (swap x z ((y :: l1) ++ l2) @ ap (cons z) (swap x y (l1 ++ l2) @ ap (cons y) h)).
  Proof.
    intros.
    refine (whiskerL _ (sapp_blank_beta_swap y z l1 (x :: l2)) @ _).
    refine (whiskerR (whiskerL _ (ap_pp _ _ _) @ concat_p_pp _ _ _) _ @ _);
    refine (concat_pp_p _ _ _ @ whiskerL _ (swap_natural y z h)^ @ concat_p_pp _ _ _ @ _);
    refine (_ @ concat_pp_p _ _ _ @ whiskerL _ (concat_pp_p _ _ _ @ whiskerL _ (ap_pp _ _ _)^));
    apply whiskerR.
    refine (triple x y z (l1 ++ l2) @ concat_pp_p _ _ _ @ _); apply whiskerR.
    refine (_ @ (ap_compose (fun w => w ++ l2) (cons x) (swap y z l1))^); apply ap.
    exact (sapp_blank_beta_swap y z l1 l2)^.
  Qed.

Lemma sapp_Q (x : X) (l2 : slist X)
  : forall l1 : slist X,
    x :: l1 ++ l2 = l1 ++ x :: l2.
Proof.
  srapply @slist_ind_to_paths_in_gpd; simpl.
  + constructor.
  + intros y l1 h.
    change (x :: y :: l1 ++ l2 = y :: l1 ++ x :: l2).
    refine (swap x y (l1 ++ l2) @ _).
    apply ap. exact h.
  + hnf. apply sapp_Q_swap.
  + exact T_slist.
Defined.

Lemma sapp_R (x y : X) (l1 : slist X)
  : forall l2 : slist X,
    swap x y (l2 ++ l1) @ (ap (cons y) (sapp_Q x l1 l2) @ sapp_Q y (x :: l1) l2) =
    (ap (cons x) (sapp_Q y l1 l2) @ sapp_Q x (y :: l1) l2) @ ap (fun z => l2 ++ z) (swap x y l1).
Proof.
  srapply @slist_ind_to_2paths_in_gpd; hnf.
  + srapply T_slist.
  + simpl. refine (concat_p1 _ @ _ @ (concat_1p _)^).
    change (swap x y l1 = ap idmap (swap x y l1)).
    exact (ap_idmap _)^.
  + intros z l2 h.
    change (swap x y ((z :: l2) ++ l1) @ (ap (cons y) (swap x z (l2 ++ l1) @ ap (cons z) (sapp_Q x l1 l2)) @ (swap y z (l2 ++ x :: l1) @ ap (cons z) (sapp_Q y (x :: l1) l2))) = (ap (cons x) (swap y z (l2 ++ l1) @ ap (cons z) (sapp_Q y l1 l2)) @  (swap x z (l2 ++ y :: l1) @ ap (cons z) (sapp_Q x (y :: l1) l2))) @ ap (fun z0 : slist X => (z :: l2) ++ z0) (swap x y l1));
    repeat rewrite ap_pp.
    refine (whiskerL _ (concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ whiskerR (swap_natural y z (sapp_Q x l1 l2))^ _)) @ _).
    refine (concat_p_pp _ _ _ @ whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ whiskerR (triple x y z (sapp l2 l1)) _ @ _);
    refine (concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ _ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _); apply whiskerL.
    refine (whiskerL _ (whiskerL _ (ap_pp (cons z) _ _)^ @ (ap_pp (cons z) _ _)^ @ ap (ap (cons z)) h) @ _); repeat rewrite ap_pp.
    refine (whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ whiskerR (swap_natural x z (sapp_Q y l1 l2)) _ @ concat_pp_p _ _ _ @ _);
    apply whiskerL;
    refine (_ @ concat_p_pp _ _ _);
    apply whiskerL; apply whiskerL.
    exact (ap_compose (fun w => l2 ++ w) (cons z) (swap x y l1))^.
Qed.

  Lemma tau_slist_swap
    : forall (x y : X) (l1 : slist X) (h : forall w' : slist X, l1 ++ w' = w' ++ l1) (l2 : slist X),
    (ap (cons x) (ap (cons y) (h l2) @ sapp_Q y l1 l2) @ sapp_Q x (y :: l1) l2)
    @ ap (fun a : slist X => l2 ++ a) (swap x y l1)
    = ap (fun a : slist X => a ++ l2) (swap x y l1)
    @ (ap (cons y) (ap (cons x) (h l2) @ sapp_Q x l1 l2) @ sapp_Q y (x :: l1) l2).
  Proof.
    intros.
    repeat rewrite ap_pp.
    refine (whiskerR (concat_pp_p _ _ _) _ @ concat_pp_p _ _ _ @ whiskerL _ (sapp_R x y l1 l2)^ @ concat_p_pp _ _ _ @ _ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _)); apply whiskerR.
    refine ((swap_natural x y (h l2))^ @ _); apply whiskerR.
    exact (sapp_blank_beta_swap x y l1 l2)^.
  Qed.

  Lemma tau_slist_nil_swap
    : forall (x y : X) (l : slist X) (h : l = l ++ nil),
      ap (cons x) (ap (cons y) h) @ ap (fun w : slist X => w ++ nil) (swap x y l)
      = ap idmap (swap x y l) @ ap (cons y) (ap (cons x) h).
  Proof.
    intros; simpl.
    refine (_ @ whiskerR (ap_idmap _)^ _).
    refine (_ @ (swap_natural x y h)^); apply whiskerL.
    exact (sapp_blank_beta_swap x y l nil).
  Defined.

Lemma tau_slist
  : forall l1 l2 : slist X,
    l1 ++ l2 = l2 ++ l1.
Proof.
  srapply @slist_ind_to_fam_paths_in_gpd; hnf.
  + srapply T_slist.
  + change (forall l' : slist X, l' = l' ++ nil).
    srapply @slist_ind_to_paths_in_gpd; hnf.
    - constructor.
    - intros x l h.
      change (x :: l = x :: l ++ nil).
      exact (ap (cons x) h).
    - hnf. apply tau_slist_nil_swap.
    - srapply T_slist.
  + intros x l1 h l2.
    change (x :: l1 ++ l2 = l2 ++ x :: l1).
    exact (ap (cons x) (h l2) @ sapp_Q x l1 l2).
  + hnf. apply tau_slist_swap.
Defined.

(* pentagon *)
Lemma pentagon_slist
  : IsPentagonCoherent sapp alpha_slist.
Proof.
  unfold IsPentagonCoherent.
  change (forall l1 l2 l3 l4 : slist X, alpha_slist (l1 ++ l2) l3 l4 @ alpha_slist l1 l2 (l3 ++ l4) = (ap011 sapp (alpha_slist l1 l2 l3) 1 @ alpha_slist l1 (l2 ++ l3) l4) @ ap011 sapp 1 (alpha_slist l2 l3 l4)).
  intros; revert l1; srapply @slist_ind_to_2paths_in_gpd; hnf.
  + srapply T_slist.
  + simpl. refine (concat_p1 _ @ _ @ (concat_1p _)^).
    change (alpha_slist l2 l3 l4 = ap idmap (alpha_slist l2 l3 l4)).
    exact (ap_idmap _)^.
  + intros x l1 h.
    change (ap (cons x) (alpha_slist (l1 ++ l2) l3 l4) @ ap (cons x) (alpha_slist l1 l2 (l3 ++ l4)) =
(ap011 sapp (ap (cons x) (alpha_slist l1 l2 l3)) 1 @ ap (cons x) (alpha_slist l1 (l2 ++ l3) l4)) @
ap011 sapp (ap (cons x) 1) (alpha_slist l2 l3 l4)).
    rewrite (ap011_sapp_ap_cons x (alpha_slist l1 l2 l3) (idpath l4)).
    rewrite (ap011_sapp_ap_cons x (idpath l1) (alpha_slist l2 l3 l4)).
    repeat rewrite <- (ap_pp (cons x)); apply ap; exact h.
Qed.

(* triangle *)
Lemma triangle_slist
  : IsTriangleCoherent nil sapp alpha_slist lambda_slist rho_slist.
Proof.
  unfold IsTriangleCoherent.
  change (forall l1 l2 : slist X, alpha_slist l1 nil l2 @ ap011 sapp 1 (lambda_slist l2) = ap011 sapp (rho_slist l1) 1).
  intros; revert l1; srapply @slist_ind_to_2paths_in_gpd; hnf.
  + srapply T_slist.
  + constructor.
  + intros x l1 h; unfold lambda_slist.
    change (ap (cons x) (alpha_slist l1 nil l2) @ ap (cons x) 1 = ap011 sapp (ap (cons x) (rho_slist l1)) 1).
    rewrite (ap011_sapp_ap_cons x (rho_slist l1) 1).
    rewrite <- (ap_pp (cons x)); apply ap; exact h.
Defined.

(* hexagon *)
Lemma sapp_H (x : X) (l1 l3 : slist X)
  : forall l2 : slist X,
    ((ap (cons x) (alpha_slist l2 l1 l3) @ ap (cons x) (ap011 sapp 1 (tau_slist l1 l3)))
      @ (ap (cons x) (alpha_slist l2 l3 l1))^)
    @ (sapp_Q x l1 (l2 ++ l3) @ alpha_slist l2 l3 (x :: l1))
    = (ap011 sapp (sapp_Q x l1 l2) 1 @ alpha_slist l2 (x :: l1) l3)
    @ (ap011 sapp 1 (ap (cons x) (tau_slist l1 l3)) @ ap011 sapp 1 (sapp_Q x l1 l3)).
Proof.
  intro l2; repeat rewrite (ap011_1p sapp); revert l2.
  srapply @slist_ind_to_2paths_in_gpd; hnf.
  + srapply T_slist.
  + simpl. refine (concat2 (concat_p1 _ @ concat_1p _) (concat_p1 _) @ _ @ (concat_1p _)^).
    refine (whiskerL _ (ap_idmap _)^ @ _); apply whiskerR.
    refine ((ap_compose idmap (cons x) _)^ @ ap_compose (cons x) idmap _).
  + intros y l2 h.
    change (((ap (cons x) (ap (cons y) (alpha_slist l2 l1 l3)) @ ap (cons x) (ap (cons y o sapp l2) (tau_slist l1 l3))) @ (ap (cons x) (ap (cons y) (alpha_slist l2 l3 l1)))^) @ ((swap x y ((l2 ++ l3) ++ l1) @ ap (cons y) (sapp_Q x l1 (l2 ++ l3))) @ ap (cons y) (alpha_slist l2 l3 (x :: l1))) = (ap011 sapp (swap x y (l2 ++ l1) @ ap (cons y) (sapp_Q x l1 l2)) (1 @ 1) @ ap (cons y) (alpha_slist l2 (x :: l1) l3)) @ (ap (cons y o sapp l2) (ap (cons x) (tau_slist l1 l3)) @ ap (cons y o sapp l2) (sapp_Q x l1 l3)));
    rewrite <- (ap011_pqpq sapp (swap x y (l2 ++ l1)) _ 1 1);
    repeat rewrite (ap_compose (sapp l2) (cons y)).
    repeat rewrite <- ap_V.
    repeat rewrite <- (ap_pp (cons x)).
    repeat rewrite <- (ap_pp (cons y)).
    refine (whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ whiskerR (swap_natural x y _)^ _ @ _).
    rewrite (ap011_p1 sapp (swap x y (sapp l2 l1)));
    refine (concat_pp_p _ _ _ @ _ @ whiskerR (sapp_blank_beta_swap x y (l2 ++ l1) l3)^ _ @ concat_p_pp _ _ _ @ concat_p_pp _ _ _); apply whiskerL.
    repeat rewrite <- (ap_pp (cons y));
    repeat rewrite (ap_pp (cons x));
    repeat rewrite ap_V.
    refine (ap (ap (cons y)) h @ _).
    rewrite ap011_sapp_ap_cons.
    repeat rewrite <- (ap_pp (cons y)).
    apply ap.
    refine (concat_pp_p _ _ _).
Qed.

Lemma hexagon_slist
  : IsHexagonCoherent sapp alpha_slist tau_slist.
Proof.
  unfold IsHexagonCoherent.
  change (forall l1 l2 l3 : slist X, (alpha_slist l1 l2 l3 @ tau_slist l1 (l2 ++ l3)) @ alpha_slist l2 l3 l1 = (ap011 sapp (tau_slist l1 l2) 1 @ alpha_slist l2 l1 l3) @ ap011 sapp 1 (tau_slist l1 l3)).
  intros; revert l2; revert l1; srapply @slist_ind_to_fam_2paths_in_gpd; hnf.
  + srapply T_slist.
  + srapply @slist_ind_to_2paths_in_gpd; hnf.
    - srapply T_slist.
    - change (1 @ tau_slist nil l3 @ 1 = 1 @ 1 @ ap idmap (tau_slist nil l3)).
      refine (concat_p1 _ @ concat_1p _ @ (ap_idmap _)^ @ (concat_1p _)^).
    - intros y l2 h.
      change ((ap (cons y) (alpha_slist nil l2 l3) @ ap (cons y) (tau_slist nil (l2 ++ l3))) @ ap (cons y) (alpha_slist l2 l3 nil) = (ap011 sapp (tau_slist nil (y :: l2)) 1 @ alpha_slist (y :: l2) nil l3) @ ap011 sapp 1 (tau_slist nil l3)).
      repeat rewrite <- (ap_pp (cons y)).
      refine (ap (ap (cons y)) h @ _).
      repeat rewrite (ap_pp (cons y)).
      refine (concat2 (concat2 _ 1) _).
      { change (ap (cons y) (ap011 sapp (tau_slist nil l2) (idpath l3)) = ap011 sapp (ap (cons y) (tau_slist nil l2)) 1).
      exact (ap011_sapp_ap_cons y _ _)^. }
      exact (ap011_sapp_ap_cons y (idpath l2) _)^.
  + intros x l1 hl1 l2.
    change ((ap (cons x) (alpha_slist l1 l2 l3) @ (ap (cons x) (tau_slist l1 (l2 ++ l3)) @ sapp_Q x l1 (l2 ++ l3))) @ alpha_slist l2 l3 (x :: l1) = (ap011 sapp (tau_slist (x :: l1) l2) 1 @ alpha_slist l2 (x :: l1) l3) @ ap011 sapp 1 (tau_slist (x :: l1) l3)).
    refine (whiskerR (concat_p_pp _ _ _ @ whiskerR ((concat_p1 _)^ @ whiskerL _ (concat_pV (ap (cons x) (alpha_slist _ _ _)))^ @ concat_p_pp _ _ _ @ whiskerR (whiskerR (ap_pp _ _ _)^ _ @ (ap_pp _ _ _)^ @ ap (ap (cons x)) (hl1 l2) @ ap_pp _ _ _ @ whiskerR (ap_pp _ _ _) _) _) _) _ @ _).
    refine (concat_pp_p _ _ _ @ whiskerR (concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _)) _ @ concat_pp_p _ _ _ @ whiskerL _ (sapp_H x l1 l3 l2) @ _).
    refine (_ @ concat_p_pp _ _ _).
    refine (whiskerR (ap011_sapp_ap_cons x (tau_slist l1 l2) idpath)^ _ @ _).
    change (ap011 sapp (ap (cons x) (tau_slist l1 l2)) 1 @ ((ap011 sapp (sapp_Q x l1 l2) 1 @ alpha_slist l2 (cons x l1) l3) @  (ap011 sapp 1 (ap (cons x) (tau_slist l1 l3)) @ ap011 sapp 1 (sapp_Q x l1 l3))) = ap011 sapp (tau_slist (cons x l1) l2) 1 @ (alpha_slist l2 (cons x l1) l3 @ ap011 sapp (1 @ 1) (ap (cons x) (tau_slist _ _) @ sapp_Q x l1 l3))).
    rewrite <- (ap011_pqpq sapp 1 1 _ (sapp_Q x l1 l3)).
    refine (whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ _); apply whiskerR.
    exact (ap011_pqpq sapp _ (sapp_Q x l1 l2) 1 1).
Qed.

(* bigon *)
Lemma bigon_slist
  : IsBigonCoherent sapp tau_slist.
Proof.
  unfold IsBigonCoherent.
  change (forall l1 l2 : slist X, tau_slist l1 l2 @ tau_slist _ _ = idpath).
  srapply @slist_ind_to_fam_2paths_in_gpd; hnf.
  + srapply T_slist.
  + srapply @slist_ind_to_2paths_in_gpd; hnf.
    - srapply T_slist.
    - constructor.
    - intros y l2 h.
      refine (whiskerL _ (concat_p1 _) @ _).
      change (ap (cons y) (tau_slist nil l2) @ ap (cons y) (tau_slist l2 nil) = ap (cons y) idpath).
      refine ((ap_pp (cons y) _ _)^ @ _).
      exact (ap (ap (cons y)) h).
  + intros x l1 hl1.
    srapply @slist_ind_to_2paths_in_gpd; hnf.
    - srapply T_slist.
    - refine (whiskerR (concat_p1 _) _ @ _).
      change (ap (cons x) (tau_slist l1 nil) @ ap (cons x) (tau_slist nil l1) = ap (cons x) idpath).
      refine ((ap_pp (cons x) _ _)^ @ _).
      exact (ap (ap (cons x)) (hl1 nil)).
    - intros y l2 hl2.
      change ((ap (cons x) (tau_slist l1 (y :: l2)) @ (swap x y (l2 ++ l1) @ ap (cons y) (sapp_Q x l1 l2))) @ (ap (cons y) (tau_slist l2 (x :: l1)) @ (swap y x (l1 ++ l2) @ ap (cons x) (sapp_Q y l2 l1))) = 1);
      apply concat_1_pq;
      repeat rewrite inv_pp;
      repeat rewrite <- ap_V.
      refine (_ @ concat_p_pp _ _ _).
      refine (whiskerR (ap (ap (cons x)) (concat_pq_1 (hl1 (y :: l2)))) _ @ _).
      change (ap (cons x) (ap (cons y) (tau_slist l2 l1) @ sapp_Q y l2 l1)^ @ (swap x y (l2 ++ l1) @ ap (cons y) (sapp_Q x l1 l2)) = ap (cons x) (sapp_Q y l2 l1)^ @ ((swap y x (l1 ++ l2))^ @ ap (cons y) (tau_slist l2 (x :: l1))^));
      rewrite inv_pp;
      rewrite ap_pp.
      refine (concat_pp_p _ _ _ @ _); apply whiskerL.
      refine (_ @ whiskerR (concat_pq_1 (double x y (l1 ++ l2))) _).
      rewrite <- ap_V.
      refine (whiskerR (ap (ap (cons x)) (ap (ap (cons y)) (concat_pq_1 (hl1 l2))^)) _ @ concat_p_pp _ _ _ @ _).
      refine (whiskerR (swap_natural x y (tau_slist l1 l2))^ _ @ concat_pp_p _ _ _ @ _); apply whiskerL.
      refine ((ap_pp (cons y) _ _ )^ @ ap (ap (cons y)) (concat_pq_1 hl2)).
Qed.

End sapp_monoidal_structure.

Definition slistSMG `{Funext} (X : Type)
  : SymMonoidalGroupoid
  := @Build_SymMonoidalGroupoid (slist X) (T_slist) nil sapp alpha_slist lambda_slist rho_slist tau_slist pentagon_slist triangle_slist hexagon_slist bigon_slist.


(** * Exponential laws about the initial category *)
Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Identity Functor.Composition.Core.
Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors InitialTerminalCategory.NaturalTransformations.
Require Import HoTT.Basics HoTT.Types.

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

Local Open Scope functor_scope.

(** In this file, we prove that

      - [x⁰ ≅ 1]
      - [0ˣ ≅ 0] if [x ≠ 0]
      - [0⁰ ≅ 1]
 *)

(** ** x⁰ ≅ 1 *)
Section law0.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.

  Global Instance IsTerminalCategory_functors_from_initial
  : IsTerminalCategory (0 -> C) := {}.

  (** There is only one functor to the terminal category [1]. *)
  Definition functor : Functor (0 -> C) 1
    := center _.

  (** We have already proven in [InitialTerminalCategory.v] that [0 -> C] is a terminal category, so there is only one functor to it. *)
  Definition inverse : Functor 1 (0 -> C)
    := center _.

  (** Since the objects and morphisms in terminal categories are contractible, functors to a terminal category are also contractible, by [trunc_functor]. *)
  Definition law
  : functor o inverse = 1
    /\ inverse o functor = 1
    := center _.
End law0.

(** ** [0ˣ ≅ 0] if [x ≠ 0] *)
Section law0'.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.
  Variable c : C.

  Local Instance IsInitialCategory_functors_to_initial_from_inhabited
  : IsInitialCategory (C -> 0)
    := fun P F => @Functors.to_initial_category_empty C _ _ F P c.

  (** There is exactly one functor from an initial category, and we proved above that if [C] is inhabited, then [C -> 0] is initial. *)
  Definition functor' : Functor (C -> 0) 0
    := center _.

  (** There is exactly one functor from the initial category [0]. *)
  Definition inverse' : Functor 0 (C -> 0)
    := center _.

  (** Since objects and morphisms in an initial category are -1-truncated, so are functors to an initial category. *)
  Definition law'
  : functor' o inverse' = 1
    /\ inverse' o functor' = 1
    := center _.
End law0'.

(** ** [0⁰ ≅ 1] *)
Section law00.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsInitialCategory zero'}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "00" := zero' : category_scope.
  Local Notation "1" := one : category_scope.

  (** This is just a special case of the first law above. *)

  Definition functor00 : Functor (0 -> 0) 1
    := functor _.

  Definition inverse00 : Functor 1 (0 -> 0)
    := inverse _.

  Definition law00
  : functor00 o inverse00 = 1
    /\ inverse00 o functor00 = 1
    := law _.
End law00.


From hahn Require Import Hahn.
From Coq Require Import Lia.
Require Import Events.

Set Implicit Arguments.

(******************************************************************************)
(** ** Inserting into relation  *)
(******************************************************************************)

(** Update a partial order [r] by insert [b] right after [a]. *)
Definition into_rel A (r : relation A) (a b : A) :=
  fun e e' =>
      r e e'          \/
      r e a /\ e' = b \/
      e = a /\ e' = b \/
      e = b /\ r a e'.

Lemma into_rel_trans A (r : relation A) a b
  (TR_r : transitive r) (IRR_r : irreflexive r)
  (Nrxb : forall x, ~ r x b) (Nrbx : forall x, ~ r b x) :
  transitive (into_rel r a b).
Proof.
  unfold transitive, not, into_rel in *; ins; desf; eauto 8.
  all: solve [exfalso; eauto].
Qed.

Lemma into_rel_irr A (r : relation A) a b
  (IRR_r : irreflexive r)
  (Nrxb : forall x, ~ r x b) (Nrbx : forall x, ~ r b x)
  (Nab : a <> b) :
  irreflexive (into_rel r a b).
Proof.
  intros x; unfold not, into_rel in *; ins; desf; eauto.
Qed.

Add Parametric Morphism A : (@into_rel A) with signature
  inclusion ==> eq ==> eq ==> inclusion as into_rel_mori.
Proof. unfold into_rel; unfolder; ins; desf; eauto 8. Qed.

Add Parametric Morphism A : (@into_rel A) with signature
  same_relation ==> eq ==> eq ==> same_relation as into_rel_more.
Proof. unfold same_relation; intuition; auto using into_rel_mori. Qed.

(******************************************************************************)
(** ** Other lemmas  *)
(******************************************************************************)

Lemma total_order_from_list_filterP A l (P : A -> Prop):
  total_order_from_list (filterP P l) ≡
  ⦗P⦘ ⨾ total_order_from_list l ⨾ ⦗P⦘.
Proof.
  induction l as [ | a l]; unfolder in *; split; ins; desf.
  all: try solve [forward eapply total_order_from_list_in1; eauto; ins].
  all: rewrite total_order_from_list_cons in *; desf.
  all: try rewrite in_filterP_iff in *; desf; eauto.
  all: apply IHl in H; desf; eauto.
Qed.

Lemma total_order_from_list_total A (l : list A) :
  is_total (fun x => In x l) (total_order_from_list l).
Proof.
  elim l; [basic_solver|intros ?? IHl ? IN1 ? IN2 NE; ins; desf].
  3: apply (IHl _ IN1 _ IN2) in NE; desf.
  all: by left+right; apply total_order_from_list_cons; eauto.
Qed.

Lemma total_order_from_list_cons_max A (l : list A) x y
  (ND : NoDup (y :: l)) :
  ~ total_order_from_list (y :: l) x y.
Proof.
  intro T; apply total_order_from_list_cons in T; apply nodup_cons in ND; desf.
  by apply total_order_from_list_in2 in T.
Qed.

Lemma length_filterP A l (P : A -> Prop) :
  length (filterP P l) <= length l.
Proof.
  induction l; ins; destruct (excluded_middle_informative _); ins; lia.
Qed.

Lemma total_sub A (ord1 ord2 : relation A) D
  (T2 : is_total D ord2)
  (IRR1 : irreflexive ord1)
  (ordD : <|D|> ;; ord1 ∩ (ord2⁻¹) ;; <|D|> ≡ ∅₂):
  restr_rel D ord1 ⊆ restr_rel D ord2.
Proof.
  intros x y [ORD [Dx Dy]].
  destruct (T2 _ Dx _ Dy); [|basic_solver|].
  { by intro; desf; apply IRR1 in ORD. }
  exfalso; eapply ordD with (x := x) (y := y); basic_solver.
Qed.

Lemma total_eqv A (ord1 ord2 : relation A) D
  (T1   : is_total D ord1)
  (T2   : is_total D ord2)
  (IRR1 : irreflexive ord1)
  (IRR2 : irreflexive ord2)
  (ordD : <|D|> ;; ord1 ∩ (ord2⁻¹) ;; <|D|> ≡ ∅₂):
  restr_rel D ord1 ≡ restr_rel D ord2.
Proof.
  split; apply total_sub; auto.
  generalize ordD. unfolder. firstorder.
Qed.

Lemma total_transp A (ord : relation A) D:
  is_total D ord <-> is_total D ord⁻¹.
Proof. firstorder. Qed.

Lemma n_is_w : is_r ≡₁ set_compl is_w.
Proof using.
  unfolder; split; intro e; ins; by destruct e as [[]|??[]].
Qed.

Lemma n_is_r : is_w ≡₁ set_compl is_r.
Proof using.
  unfolder; split; intro e; ins; by destruct e as [[]|??[]].
Qed.

Lemma wf_ext_sb : well_founded ext_sb.
Proof.
  apply Wf_nat.well_founded_lt_compat with
    (f := fun e =>
        match e with
        | InitEvent _ => 0
        | _           => S (index e)
        end).
  intros x y SB; destruct x, y; ins; lia.
Qed.

Inductive Revisit :=
  | RV : Event -> Revisit
  | NR : Revisit.

Lemma ct_step_ct A (r : relation A) : r⁺ ≡ r ;; r⁺ ∪ r.
Proof using.
  split; intros ?? R.
  { apply clos_trans_t1n in R; destruct R; vauto.
    apply clos_t1n_trans in R; vauto. }
  apply clos_t1n_trans; destruct R as [R|R]; vauto.
  destruct R as [? R]; desf; apply clos_trans_t1n in R0; vauto.
Qed.

Lemma codom_seq A (r1 r2 : relation A) :
  codom_rel (r1 ;; r2) ≡₁
  codom_rel (<|codom_rel r1|> ;; r2).
Proof using. basic_solver. Qed.

Lemma not_finite A (P : A -> Prop)
  (NFIN : ~ exists s, P ⊆₁ (fun x => In x s)):
  forall k : nat, exists s,
    << NDs  : NoDup s                >> /\
    << LENs : length s = k           >> /\
    << SUBs : (fun x => In x s) ⊆₁ P >>.
Proof.
  ins; induction k.
  { exists nil; basic_solver. }
  desf.
  tertium_non_datur (P \₁ (fun x => In x s) ≡₁ ∅) as [F|F].
  { destruct NFIN; exists s. by apply set_subsetE. }
  exists (n :: s); splits; eauto.
  { apply nodup_cons; generalize F; basic_solver. }
  generalize SUBs F. basic_solver.
Qed.

Lemma transp_imm A (r : relation A) :
  immediate r⁻¹ ≡ (immediate r)⁻¹.
Proof.
  rewrite ?immediateE, <-transp_seq.
  basic_solver.
Qed.

Lemma acyclic_transp A (r : relation A) :
  acyclic r -> acyclic r⁻¹.
Proof.
  intros AC; intros ? R.
  by apply transp_ct, AC in R.
Qed.

Lemma pow_transp A (r : relation A) k : r⁻¹^^k ≡ r^^k⁻¹.
Proof.
  induction k; [firstorder|].
  rewrite pow_S_begin; ins.
  by rewrite transp_seq, IHk.
Qed.


From algebra Require Export agree.
From program_logic Require Export ghost_ownership.
Import uPred.

Class savedPropG (Λ : language) (Σ : gFunctors) (F : cFunctor) :=
  saved_prop_inG :> inG Λ Σ (agreeR (laterC (F (iPreProp Λ (globalF Σ))))).
Definition savedPropGF (F : cFunctor) : gFunctor :=
  GFunctor (agreeRF (▶ F)).
Instance inGF_savedPropG  `{inGF Λ Σ (savedPropGF F)} : savedPropG Λ Σ F.
Proof. apply: inGF_inG. Qed.

Definition saved_prop_own `{savedPropG Λ Σ F}
    (γ : gname) (x : F (iPropG Λ Σ)) : iPropG Λ Σ :=
  own γ (to_agree $ Next (cFunctor_map F (iProp_fold, iProp_unfold) x)).
Typeclasses Opaque saved_prop_own.
Instance: Params (@saved_prop_own) 4.

Section saved_prop.
  Context `{savedPropG Λ Σ F}.
  Implicit Types x y : F (iPropG Λ Σ).
  Implicit Types γ : gname.

  Global Instance saved_prop_always_stable γ x :
    AlwaysStable (saved_prop_own γ x).
  Proof. by rewrite /AlwaysStable always_own. Qed.

  Lemma saved_prop_alloc_strong N x (G : gset gname) :
    True ⊑ pvs N N (∃ γ, ■ (γ ∉ G) ∧ saved_prop_own γ x).
  Proof. by apply own_alloc_strong. Qed.

  Lemma saved_prop_alloc N x : True ⊑ pvs N N (∃ γ, saved_prop_own γ x).
  Proof. by apply own_alloc. Qed.

  Lemma saved_prop_agree γ x y :
    (saved_prop_own γ x ★ saved_prop_own γ y) ⊑ ▷(x ≡ y).
  Proof.
    rewrite -own_op own_valid agree_validI agree_equivI later_equivI.
    set (G1 := cFunctor_map F (iProp_fold, iProp_unfold)).
    set (G2 := cFunctor_map F (@iProp_unfold Λ (globalF Σ),
                               @iProp_fold Λ (globalF Σ))).
    assert (∀ z, G2 (G1 z) ≡ z) as help.
    { intros z. rewrite /G1 /G2 -cFunctor_compose -{2}[z]cFunctor_id.
      apply (ne_proper (cFunctor_map F)); split=>?; apply iProp_fold_unfold. }
    rewrite -{2}[x]help -{2}[y]help. apply later_mono.
    apply (eq_rewrite (G1 x) (G1 y) (λ z, G2 (G1 x) ≡ G2 z))%I;
      first solve_proper; auto with I.
  Qed.
End saved_prop.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_con_other_reduce :
  forall T1 T1' Ts1, T1 = t_con T1' Ts1 ->
                forall T2, (T2 <> t_nil)  ->
                      (forall T2' Ts2, T2 <> t_con T2' Ts2) ->
                      subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto.
  contradiction H0; auto.
  contradiction (H1 T2_1 T2_2); auto.
Qed.


(*****************************************************************

 Colimits in the enriched opposite category

 If an enriched category has limits, then its opposite inherits
 these as colimits.

 Contents
 1. Initial object
 2. Binary coproducts
 3. Coequalizers
 4. Type indexed coproducts
 5. Copowers

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.OppositeCategory.Core.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.equalizers.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Section OppositeColimits.
  Context {V : sym_monoidal_cat}
          {C : category}
          (E : enrichment C V).

  Let E' : enrichment (C^opp) V := op_enrichment V E.

  (**
   1. Initial object
   *)
  Definition opposite_initial_enriched
             (T : terminal_enriched E)
    : initial_enriched E'.
  Proof.
    exact T.
  Defined.

  (**
   2. Binary coproducts
   *)
  Section OppositeBinaryCoproducts.
    Context {x y : C}
            (s : binary_prod_enriched E x y).

    Definition opposite_binary_coprod_enriched_is_coprod
      : is_binary_coprod_enriched E' x y (pr1 s).
    Proof.
      intro w.
      use (isBinProduct_eq_arrow _ _ (pr2 s w)).
      - abstract
          (unfold E' ;
           rewrite op_enrichment_precomp ;
           apply maponpaths ; cbn ;
           apply idpath).
      - abstract
          (unfold E' ;
           rewrite op_enrichment_precomp ;
           apply maponpaths ; cbn ;
           apply idpath).
    Defined.

    Definition opposite_binary_coprod_enriched
      : binary_coprod_enriched E' x y.
    Proof.
      simple refine (_ ,, _).
      - exact (pr1 s).
      - exact opposite_binary_coprod_enriched_is_coprod.
    Defined.
  End OppositeBinaryCoproducts.

  (**
   3. Coequalizers
   *)
  Section OppositeCoequalizers.
    Context {x y : C}
            {f g : x --> y}
            (e : equalizer_enriched E f g).

    Definition opposite_is_coequalizer_enriched
      : is_coequalizer_enriched E' f g (pr1 e).
    Proof.
      intro w.
      use (isEqualizer_eq _ _ _ _ _ (pr2 e w)).
      - abstract
          (refine (!_) ;
           apply op_enrichment_precomp).
      - abstract
          (refine (!_) ;
           apply op_enrichment_precomp).
      - abstract
          (refine (!_) ;
           apply op_enrichment_precomp).
    Defined.

    Definition opposite_coequalizer_enriched : coequalizer_enriched E' f g
      := pr1 e ,, opposite_is_coequalizer_enriched.
  End OppositeCoequalizers.

  (**
   4. Type indexed coproducts
   *)
  Section OppositeCoproducts.
    Context {J : UU}
            (ys : J → C)
            (s : prod_enriched E ys).

    Definition opposite_coprod_enriched_is_coprod
      : is_coprod_enriched E' ys (pr1 s).
    Proof.
      intro w.
      use (isProduct_eq_arrow _ (pr2 s w)).
      abstract
        (intro j ;
         unfold E' ;
         rewrite op_enrichment_precomp ;
         apply maponpaths ; cbn ;
         apply idpath).
    Defined.

    Definition opposite_coprod_enriched
      : coprod_enriched E' ys.
    Proof.
      simple refine (_ ,, _).
      - exact (pr1 s).
      - exact opposite_coprod_enriched_is_coprod.
    Defined.
  End OppositeCoproducts.
End OppositeColimits.

(**
 5. Copowers
 *)
Definition opposite_copower_enriched
           {V : sym_mon_closed_cat}
           {C : category}
           (E : enrichment C V)
           {v : V} {x : C}
           (e : power_cone E v x)
           (He : is_power_enriched E v x e)
  : is_copower_enriched (op_enrichment V E) v x e.
Proof.
  intros w.
  use (is_z_isomorphism_path _ (He w)).
  abstract
    (unfold is_copower_enriched_map, is_power_enriched_map ;
     use internal_funext ;
     intros a h ;
     rewrite tensor_split ;
     rewrite !assoc' ;
     rewrite internal_beta ;
     refine (!_) ;
     rewrite tensor_split ;
     rewrite !assoc' ;
     rewrite internal_beta ;
     apply idpath).
Defined.