(* Reference: https://www.cs.umd.edu/~rrand/vqc/Matrix.html#Matrix *)

Require Import Psatz.
Require Import Setoid.
Require Import Arith.
Require Import Bool.
Require Import Program.
Require Import ZSum.
Require Export Coq.ZArith.ZArith.

Delimit Scope matrix_scope with M.
Open Scope matrix_scope.
Open Scope nat_scope.

(* We define a _matrix_ as a simple function from two nats
(corresponding to a row and a column) to a integer. *)
Definition Matrix (m n : nat) := nat -> nat -> Z.

Bind Scope matrix_scope with Matrix.
Notation Vector n := (Matrix n 1).
Notation Square n := (Matrix n n).

Definition mat_equiv {m n : nat} (A B : Matrix m n) : Prop :=
  forall i j, i < m -> j < n -> A i j = B i j.

Infix "==" := mat_equiv (at level 80).

(* Some important notions about matrix equality. *)
Lemma mat_equiv_refl : forall {m n} (A : Matrix m n), A == A.
Proof.
  intros.
  unfold mat_equiv.
  intros.
  reflexivity.
Qed.

Lemma mat_equiv_sym : forall {m n} (A B : Matrix m n), A == B -> B == A.
Proof.
  unfold mat_equiv.
  intros.
  specialize (H i j H0 H1).
  rewrite H.
  reflexivity.
Qed.

Lemma mat_equiv_trans : forall {m n} (A B C : Matrix m n),
    A == B -> B == C -> A == C.
Proof.
  unfold mat_equiv.
  intros.
  specialize (H i j H1 H2).
  specialize (H0 i j H1 H2).
  rewrite H, H0.
  reflexivity.
Qed.

Add Parametric Relation m n : (Matrix m n) (@mat_equiv m n)
  reflexivity proved by mat_equiv_refl
  symmetry proved by mat_equiv_sym
  transitivity proved by mat_equiv_trans
    as mat_equiv_rel.

(* ################################################################# *)
(** * Basic Matrices and Operations *)

Close Scope nat_scope.
Open Scope Z_scope.

(** Because we will use these so often, it is good to have them in matrix scope. *)
Notation "m =? n" := (Nat.eqb m n) (at level 70) : matrix_scope.
Notation "m <? n" := (Nat.ltb m n) (at level 70) : matrix_scope.
Notation "m <=? n" := (Nat.leb m n) (at level 70) : matrix_scope.

Open Scope matrix_scope.

Definition I (n : nat) : Matrix n n := fun i j => if (i =? j)%nat then 1 else 0.

Definition Zero (m n : nat) : Matrix m n := fun _ _ => 0.

Definition Mplus {m n : nat} (A B : Matrix m n) : Matrix m n :=
  fun i j => A i j + B i j.

Definition Mminus {m n : nat} (A B : Matrix m n) : Matrix m n :=
  fun i j => A i j - B i j.

Infix "+" := Mplus (at level 50, left associativity) : matrix_scope.
Infix "-" := Mminus (at level 50, left associativity) : matrix_scope.

Lemma Mplus_assoc : forall {m n} (A B C : Matrix m n), (A + B) + C == A + (B + C).
Proof.
  intros m n A B C i j Hi Hj.
  unfold Mplus.
  lia.
Qed.

Lemma Mplus_comm : forall {m n} (A B : Matrix m n), A + B == B + A.
Proof.
  intros m n A B i j Hi Hj.
  unfold Mplus.
  lia.
Qed.

Lemma Mplus_0_l : forall {m n} (A : Matrix m n), Zero m n + A == A.
Proof.
  intros m n A i j Hi Hj.
  unfold Zero, Mplus.
  lia.
Qed.

Lemma Mplus_0_r : forall {m n} (A : Matrix m n), A + Zero m n == A.
Proof.
  intros m n A.
  rewrite Mplus_comm.
  apply Mplus_0_l.
Qed.

Lemma Mplus_compat : forall {m n} (A B A' B' : Matrix m n),
  A == A' -> B == B' -> A + B == A' + B'.
Proof.
  intros m n A B A' B' HA HB.
  intros i j Hi Hj.
  unfold Mplus.
  rewrite HA, HB; tauto.
Qed.

Add Parametric Morphism m n : (@Mplus m n)
  with signature mat_equiv ==> mat_equiv ==> mat_equiv as Mplus_mor.
Proof.
  intros A A' HA B B' HB.
  apply Mplus_compat; tauto.
Qed.

Lemma Mminus_compat : forall {m n} (A B A' B' : Matrix m n),
  A == A' -> B == B' -> A - B == A' - B'.
Proof.
  intros m n A B A' B' HA HB.
  intros i j Hi Hj.
  unfold Mminus.
  rewrite HA, HB; tauto.
Qed.

Add Parametric Morphism m n : (@Mminus m n)
  with signature mat_equiv ==> mat_equiv ==> mat_equiv as Mminus_mor.
Proof.
  intros A A' HA B B' HB.
  apply Mminus_compat; tauto.
Qed.

Definition Mmult {m n o : nat} (A : Matrix m n) (B : Matrix n o) : Matrix m o :=
  fun x z => Zsum (fun y => A x y * B y z)%Z n.

Infix "×" := Mmult (at level 40, left associativity) : matrix_scope.

Lemma Mmult_compat : forall {m n o} (A A' : Matrix m n) (B B' : Matrix n o),
    A == A' -> B == B' -> A × B == A' × B'.
Proof.
  intros m n o A A' B B' HA HB i j Hi Hj.
  unfold Mmult.
  apply Zsum_eq; intros x Hx.
  rewrite HA, HB; tauto.
Qed.

Add Parametric Morphism m n o : (@Mmult m n o)
  with signature mat_equiv ==> mat_equiv ==> mat_equiv as Mmult_mor.
Proof. intros. apply Mmult_compat; easy. Qed.

Definition SubMat {m n} (A : Matrix m n) (rowl rowh coll colh : nat) : Matrix (rowh - rowl)%nat (colh - coll)%nat :=
  fun i j => A (i + rowl)%nat (j + coll)%nat.

Definition Split(n : nat) (A : Square (2 * n)) (A11 A12 A21 A22 : Square n): Prop :=
  A11 = SubMat A 0 n 0 n  /\
  A12 = SubMat A 0 n n (2 * n) /\
  A21 = SubMat A n (2 * n) 0 n /\
  A22 = SubMat A n (2 * n) n (2 * n)
.

Lemma Splitable(n : nat) (A : Square (2 * n)):
  n <> Z.to_nat 0 ->
  exists (A11 A12 A21 A22 : Square n), Split n A A11 A12 A21 A22.
Proof.
  intros.
  exists
    (SubMat A 0 n 0 n),
    (SubMat A 0 n n (2 * n)),
    (SubMat A n (2 * n) 0 n),
    (SubMat A n (2 * n) n (2 * n))
  .
  unfold Split.
  tauto.
Qed.

(* ################################################################# *)
(** * Matrix Properties *)

Theorem Mmult_assoc : forall {m n o p : nat} (A : Matrix m n) (B : Matrix n o)
  (C: Matrix o p), A × B × C == A × (B × C).
Proof.
  intros m n o p A B C i j Hi Hj.
  unfold Mmult.
  induction n.
  + simpl.
    clear B.
    induction o. reflexivity.
    simpl. rewrite IHo.
    - lia.
    - tauto.
  + simpl.
    rewrite <- IHn.
    simpl.
    rewrite Zsum_mult_l.
    rewrite <- Zsum_plus.
    apply Zsum_eq; intros.
    rewrite Zmult_plus_dist_r.
    rewrite Zmult_assoc.
    reflexivity.
Qed.

(* ################################################################# *)
(** * Matrix Library *)

Lemma Mmult_plus_dist_l : forall {m n o : nat} (A : Matrix m n) (B C : Matrix n o),
                           A × (B + C) == A × B + A × C.
Proof.
  intros. intros i j _ _.
  unfold Mplus, Mmult.
  rewrite <- Zsum_plus.
  apply Zsum_eq_bounded; intros.
  rewrite Zmult_plus_dist_l.
  reflexivity.
Qed.

Lemma Mmult_plus_dist_r : forall {m n o : nat} (A B : Matrix m n) (C : Matrix n o),
                           (A + B) × C == A × C + B × C.
Proof.
  intros. intros i j _ _.
  unfold Mplus, Mmult.
  rewrite <- Zsum_plus.
  apply Zsum_eq_bounded; intros.
  rewrite Zmult_plus_dist_r.
  reflexivity.
Qed.

Lemma Mmult_plus_dist : forall {m n o : nat} (A B : Matrix m n) (C D : Matrix n o),
                           (A + B) × (C + D) == A × C + A × D + B × C + B × D.
Proof.
  intros.
  pose proof (Mmult_plus_dist_l (A + B) C D).
  rewrite H.
  pose proof (Mmult_plus_dist_r A B C).
  pose proof (Mmult_plus_dist_r A B D).
  rewrite H0, H1.
  intros i j _ _.
  unfold Mplus.
  lia.
Qed.

Lemma Mmult_minus_dist_l : forall {m n o : nat} (A : Matrix m n) (B C : Matrix n o),
                           A × (B - C) == A × B - A × C.
Proof.
  intros. intros i j _ _.
  unfold Mminus, Mmult.
  rewrite <- Zsum_minus.
  apply Zsum_eq_bounded; intros.
  rewrite Zmult_minus_dist_l.
  reflexivity.
Qed.

Lemma Mmult_minus_dist_r : forall {m n o : nat} (A B : Matrix m n) (C : Matrix n o),
                           (A - B) × C == A × C - B × C.
Proof.
  intros. intros i j _ _.
  unfold Mminus, Mmult.
  rewrite <- Zsum_minus.
  apply Zsum_eq_bounded; intros.
  rewrite Zmult_minus_dist_r.
  reflexivity.
Qed.

Lemma Mmult_minus_dist : forall {m n o : nat} (A B : Matrix m n) (C D : Matrix n o),
                           (A - B) × (C - D) == A × C - A × D - B × C + B × D.
Proof.
  intros.
  pose proof (Mmult_minus_dist_l (A - B) C D).
  rewrite H.
  pose proof (Mmult_minus_dist_r A B C).
  pose proof (Mmult_minus_dist_r A B D).
  rewrite H0, H1.
  intros i j _ _.
  unfold Mplus, Mminus.
  lia.
Qed.

Lemma Mmult_minus_plus_dist : forall {m n o : nat} (A B : Matrix m n) (C D : Matrix n o),
                           (A - B) × (C + D) == A × C + A × D - B × C - B × D.
Proof.
  intros.
  pose proof (Mmult_plus_dist_l (A - B) C D).
  rewrite H.
  pose proof (Mmult_minus_dist_r A B C).
  pose proof (Mmult_minus_dist_r A B D).
  rewrite H0, H1.
  intros i j _ _.
  unfold Mplus, Mminus.
  lia.
Qed.

Lemma Mmult_plus_minus_dist : forall {m n o : nat} (A B : Matrix m n) (C D : Matrix n o),
                           (A + B) × (C - D) == A × C - A × D + B × C - B × D.
Proof.
  intros.
  pose proof (Mmult_minus_dist_l (A + B) C D).
  rewrite H.
  pose proof (Mmult_plus_dist_r A B C).
  pose proof (Mmult_plus_dist_r A B D).
  rewrite H0, H1.
  intros i j _ _.
  unfold Mplus, Mminus.
  lia.
Qed.

(* Haoxuan Xu, Yichen Tao *)
(* 2021-05-26 14:34 *)


Require Export SfLib.

Module AExp.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (e : aexp) : nat :=
  match e with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2 => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof.
  reflexivity.
Qed.

Fixpoint beval (e : bexp) : bool :=
  match e with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2 => ble_nat (aeval a1) (aeval a2)
  | BNot b1 => negb (beval b1)
  | BAnd b1 b2 => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (e : aexp) : aexp :=
  match e with
  | ANum n => ANum n
  | APlus (ANum 0) n => n
  | APlus e1 e2 => APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 => AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 => AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Theorem optimize_0plus_sound : forall e,
  aeval (optimize_0plus e) = aeval e.
Proof.
  intros e. induction e; try (simpl; auto; fail).

  destruct e1.
  + destruct n; simpl; auto.
  + destruct e1_1; simpl; auto.
  + destruct e1_1; simpl; auto.
  + destruct e1_1; simpl; auto.
Qed.

Fixpoint bexp_map_aexp (f : aexp -> aexp) (b : bexp) :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (f a1) (f a2)
  | BLe a1 a2 => BLe (f a1) (f a2)
  | BNot b => BNot (bexp_map_aexp f b)
  | BAnd b1 b2 => BAnd (bexp_map_aexp f b1) (bexp_map_aexp f b2)
  end.

Theorem beval_map_aexp_sound
  (f : aexp -> aexp)
  (H : forall a:aexp, aeval (f a) = aeval a) :
  forall b: bexp, beval (bexp_map_aexp f b) = beval b.
Proof.
  intro b.
  induction b; simpl; auto.
  + rewrite IHb; trivial.
  + rewrite IHb1, IHb2; trivial.
Qed.

Reserved Notation "e '==>' n" (at level 40).
Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat), (ANum n) ==> n
  | E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 ==> n1) -> (e2 ==> n2) -> (APlus e1 e2) ==> (n1 + n2)
  | E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 ==> n1) -> (e2 ==> n2) -> (AMinus e1 e2) ==> (n1 - n2)
  | E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 ==> n1) -> (e2 ==> n2) -> (AMult e1 e2) ==> (n1 * n2)
  where "e '==>' n" := (aevalR e n).

Theorem aeval_iff_aevalR : forall a n,
  aeval a = n <-> (a ==> n).
Proof.
  split.
  + generalize dependent n.
    induction a; intros; subst; constructor;
      try apply IHa1; try apply IHa2; reflexivity.
  + intros. induction H; simpl; auto.
Qed.

End AExp.

(* States *)
Definition state := id -> nat.
Definition empty_state : state := fun _ => 0.
Definition update (st : state) (V : id) (n : nat) : state :=
  fun V' => if beq_id V V' then n else st V'.

Theorem update_eq : forall n V st,
  (update st V n) V = n.
Proof.
  intros.
  unfold update.
  assert (beq_id V V = true).
    destruct V. induction n0; auto.
  rewrite H; auto.
Qed.

Theorem update_neq : forall V2 V1 n st,
  beq_id V2 V1 = false ->
  (update st V2 n) V1 = (st V1).
Proof.
  intros.
  unfold update. rewrite H.
  reflexivity.
Qed.

Theorem update_example : forall (n:nat),
  (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intro.
  compute.
  reflexivity.
Qed.

Theorem update_shadow : forall x1 x2 k1 k2 (f : state),
   (update (update f k2 x1) k2 x2) k1 = (update f k2 x2) k1.
Proof.
  intros.
  unfold update.
  destruct (beq_id k2 k1); auto.
Qed.

Theorem beq_id_eq k1 k2 : beq_id k1 k2 = true <-> k1 = k2.
Proof.
  split.

  - destruct k1.
    destruct k2.
    revert n0.

    induction n; induction n0.

    + auto.
    + intros; inversion H.
    + intros; inversion H.
    + intros. repeat f_equal.
      assert (beq_id (Id n) (Id n0) = true).
      rewrite <- H.
      compute. auto.
      assert (Id n = Id n0) by apply (IHn n0 H0).
      injection H1; intro; auto.
  - intro.
    rewrite H.
    destruct k2.
    unfold beq_id; simpl.
    clear H; clear k1.
    induction n; auto.
Qed.

Theorem update_same : forall x1 k1 k2 (f : state),
  f k1 = x1 ->
  (update f k1 x1) k2 = f k2.
Proof.
  intros.
  unfold update.
  remember (beq_id k1 k2) as H'.
  destruct H'; auto.
  symmetry in HeqH'.
  rewrite <- H.
  assert (k1 = k2) by
    (apply (beq_id_eq _ _); auto).
  subst. auto.
Qed.

Theorem update_permute : forall x1 x2 k1 k2 k3 f,
  beq_id k2 k1 = false ->
  (update (update f k2 x1) k1 x2) k3 = (update (update f k1 x2) k2 x1) k3.
Proof.
  intros.
  unfold update.
  remember (beq_id k1 k3) as b.
  destruct b.
  remember (beq_id k2 k3) as b'.
  destruct b'.
  + symmetry in Heqb; symmetry in Heqb'.
    assert (k1 = k3) by (apply (beq_id_eq _ _); auto).
    assert (k2 = k3) by (apply (beq_id_eq _ _); auto).
    rewrite H0 in H.
    rewrite H1 in H.
    assert (beq_id k3 k3 = true)
      by (apply (beq_id_eq k3 k3); auto).
      rewrite H2 in H; inversion H.
  + auto.
  + auto.
Qed.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Fixpoint aeval (st : state) (e : aexp) : nat :=
  match e with
  | AId id => st id
  | ANum n => n
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (e : bexp) : bool :=
  match e with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2 => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "l '::=' a" :=
  (CAss l a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
  | SKIP => st
  | l ::= a1 =>
      update st l (aeval st a1)
  | c1 ; c2 =>
      let st' := ceval_step1 st c1 in
      ceval_step1 st' c2
  | IFB b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step1 st c1
      else ceval_step1 st c2
  | WHILE b1 DO c1 END => st
  end.

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          update st l (aeval st a1)
      | c1 ; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b) then ceval_step2 st c1 i' else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b) then ceval_step3 st c1 i' else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

Definition bind_option {X Y : Type} (xo : option X) (f : X -> option Y)
                      : option Y :=
  match xo with
    | None => None
    | Some x => f x
  end.

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ; c2 =>
          bind_option
            (ceval_step st c1 i')
            (fun st' => ceval_step st' c2 i')
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b) then ceval_step st c1 i' else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then bind_option
                 (ceval_step st c1 i')
                 (fun st' => ceval_step st' c i')
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.

Definition pup_to_n : com :=
  Z ::= ANum 1;
  Y ::= ANum 0;
  WHILE BLe (AId Z) (AId X) DO
    Y ::= APlus (AId Y) (AId Z);
    Z ::= APlus (AId Z) (ANum 1)
  END;
  X ::= ANum 0;
  Z ::= ANum 0.

Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

Definition even_X : com :=
  Z ::= ANum 1;
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    X ::= AMinus (AId X) (ANum 1);
    Z ::= AMinus (ANum 1) (AId Z)
  END.

Reserved Notation "c1 '/' st '==>' st'" (at level 40, st at level 39).
Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st ==> st
  | E_Ass : forall st a1 n l,
      aeval st a1 = n ->
      (l ::= a1) / st ==> (update st l n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st ==> st' ->
      c2 / st' ==> st'' ->
      (c1 ; c2) / st ==> st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      c1 / st ==> st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st ==> st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      c2 / st ==> st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st ==> st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      (WHILE b1 DO c1 END) / st ==> st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      c1 / st ==> st' ->
      (WHILE b1 DO c1 END) / st' ==> st'' ->
      (WHILE b1 DO c1 END) / st ==> st''

  where "c1 '/' st '==>' st'" := (ceval c1 st st').

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st ==> st'.
Proof.
  intros.
  destruct H; rename H into E.
  generalize dependent st.
  generalize dependent st'.
  generalize dependent c.
  induction x.
  + (* x = 0 *)
    intros; inversion E.
  + induction c; intros; inversion E; try (constructor; auto; fail).
    - unfold bind_option in H0.
      remember (ceval_step st c1 x).
      induction o.
      * apply E_Seq with (st' := a);
        apply IHx; auto.
      * inversion H0.
    - remember (beval st b) as bval.
      induction bval.
      * apply E_IfTrue; auto.
      * apply E_IfFalse; auto.
    - remember (beval st b) as bval.
      induction bval.
      * unfold bind_option in H0.
        remember (ceval_step st c x).
        destruct o.
        apply E_WhileLoop with (st':=s); auto.
        try inversion H0.
      * inversion H0.
        apply E_WhileEnd.
        subst; auto.
Qed.

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 -> ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
  induction i1.
  * intros; inversion H0.
  * intros.
    induction i2; [inversion H | .. ].
    apply le_S_n in H.
    destruct c.
    - (* SKIP *) simpl; inversion H0; auto.
    - (* ::= *) simpl; inversion H0; auto.
    - (* ; *)
      inversion H0.
      remember (ceval_step st c1 i1) as st'c1.
      destruct st'c1; symmetry in Heqst'c1.
      + simpl.
        pose Heqst'c1.
        apply IHi1 with (i2:=i2) in e; auto.
        rewrite e; simpl.
        simpl in H2.
        rewrite (IHi1 i2 _ _ _ H H2).
        auto.
      + inversion H2.
   - (* IF *)
     inversion H0; simpl.
     destruct (beval st b).
     + rewrite (IHi1 i2 _ _ _ H H2).
       auto.
     + rewrite (IHi1 i2 _ _ _ H H2).
       auto.
   - (* WHILE *)
     inversion H0; simpl.
     destruct (beval st b); try reflexivity.
     remember (ceval_step st c i1) as st'c1.
     destruct st'c1.
     + simpl. simpl in H2.
       symmetry in Heqst'c1.
       assert (ceval_step st c i2 = Some s) as Heqst'c1'
         by (apply IHi1; auto).
       rewrite Heqst'c1'.
       simpl.
       rewrite H2.
       apply IHi1 with (i2:=i2) in H2; auto.
     + inversion H2.
Qed.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st ==> st1 ->
     c / st ==> st2 ->
     st1 = st2.
Proof.
  intros.
  generalize dependent st2.
  (*induction c.
  - inversion H; intros; inversion H0; auto.
  - inversion H; intros. inversion H5.
    rewrite <- H10, <- H4; reflexivity.
  - inversion H; subst.
    intros.
    inversion H0; subst.

  inversion H6; subst.*)

  induction H.
  - intros. inversion H0. auto.
  - intros. inversion H0; subst. auto.
  - intros. inversion H1; subst.
    apply IHceval2.
    rewrite (IHceval1 st'0 H4).
    auto.
  - intros.
    inversion H1; subst.
    + apply IHceval; auto.
    + rewrite H7 in H.
      inversion H.
  - intros.
    inversion H1; subst.
    + congruence.
    + apply IHceval; auto.
  - intros.
    inversion H0; subst; auto.
    congruence.
  - intros.
    inversion H2; subst.
    + congruence.
    + apply IHceval2.
      rewrite IHceval1 with (st2:=st'0); auto.
Qed.

Inductive sinstr : Type :=
  | SPush : nat -> sinstr
  | SLoad : id -> sinstr
  | SPlus : sinstr
  | SMinus : sinstr
  | SMult : sinstr.

Fixpoint s_execute (st : state) (stack : list nat)
  (prog : list sinstr) : list nat :=
  match prog with
  | instr :: prog' =>
      match instr with
      | SPush n => s_execute st (n :: stack) prog'
      | SLoad V => s_execute st (st V :: stack) prog'
      | SPlus =>
          match stack with
          | a :: b :: stack' =>
              s_execute st ((b + a) :: stack') prog'
          | _ => s_execute st stack prog'
          end
      | SMult =>
          match stack with
          | a :: b :: stack' =>
              s_execute  st ((b * a) :: stack') prog'
          | _ => s_execute st stack prog'
          end
      | SMinus =>
          match stack with
          | a :: b :: stack' =>
              s_execute  st ((b - a) :: stack') prog'
          | _ => s_execute st stack prog'
          end
      end
  | nil => stack
  end.

Fixpoint s_compile (e : aexp) : list sinstr :=
  match e with
  | ANum n => [SPush n]
  | AId V => [SLoad V]
  | APlus e1 e2 => s_compile e1 ++ s_compile e2 ++ [SPlus]
  | AMult e1 e2 => s_compile e1 ++ s_compile e2 ++ [SMult]
  | AMinus e1 e2 => s_compile e1 ++ s_compile e2 ++ [SMinus]
  end.

Theorem s_execute_compose : forall st stk x xs,
 s_execute st stk (x :: xs) = s_execute st (s_execute st stk [x]) xs.
Proof.
  induction stk.
  - intros.
    destruct x; auto.
  - intros.
    simpl.
    destruct x; destruct stk; auto.
Qed.

Theorem s_execute_compose' st stk l1 l2:
 s_execute st stk (l1 ++ l2) = s_execute st (s_execute st stk l1) l2.
Proof.
  generalize dependent stk.
  induction l1.
  - auto.
  - rewrite <- app_comm_cons.
    intro.
    rewrite s_execute_compose.
    rewrite IHl1.
    rewrite <- s_execute_compose.
    auto.
Qed.

Theorem s_compile_correct : forall (st : state) (e : aexp) stk,
  s_execute st stk (s_compile e) = (aeval st e) :: stk.
Proof.
  induction e; simpl; auto;
   (intros;
    rewrite s_execute_compose';
    rewrite s_execute_compose';
    rewrite IHe1;
    rewrite IHe2;
    reflexivity).
Qed.


(*partie 2.2*)
(* ATTENTION !!!!!
Il faut lancer coqide avec la cmd = coqide -impredicative-set*)
(*L'identité polymorphe*)

(*2.2.1*)
Definition tid : Set := forall T : Set, T -> T.
Definition id : tid := fun T:Set => fun x : T => x.

(*TESTS OF IDENTITY*)
(* 5 est nat? *)
Compute id nat 5.
(* true est boolean? *)
Compute id bool true.
(* BAD TEST | UNCOMMENT *)
(*Compute id bool 0.*)

Definition nbtrue1 :=
fun b => match b with true => 1 |
false => 0 end.

(*Verif : la fonction rend bien un nat*)
Compute id nat (nbtrue1 false).
Compute id tid id.

(*2.2.2*)
(*booleans*)
Definition pbool : Set := forall T : Set, T -> T -> T.
(*vrai*)
Definition ptr : pbool := fun T:Set => fun x:T => fun y:T => x .
(*faux*)
Definition pfa : pbool := fun T:Set => fun (x:T) (y:T) => y.
Print ptr.
Print pfa.

(*first negation*)
Definition cneg1 : pbool -> pbool := fun b => fun T:Set => fun x => fun y => b T y x.

Compute cneg1 ptr.
Compute cneg1 pfa.
(*second negation*)
Definition cneg2 : pbool -> pbool:= fun b => b pbool pfa ptr.

Compute cneg2 ptr.
Compute cneg2 pfa.
(*conj*)
Definition conjonc : pbool -> pbool -> pbool := fun a b => a pbool b a.
Compute conjonc ptr pfa.
Compute conjonc pfa ptr.
Compute conjonc ptr ptr.

(*disonj*)
Definition disjonc : pbool -> pbool -> pbool := fun a b => a pbool a b.

Compute disjonc ptr pfa.
Compute disjonc pfa ptr.
Compute disjonc pfa pfa.

(*3 si vrai. 5, sinon.*)
Definition foo35 : pbool -> nat := fun b => b nat 3 5.
Compute foo35 ptr.
Compute foo35 pfa.

(*BONUS : lui-meme*)
Definition bluimeme := fun (b:pbool) => b pbool b.
Compute bluimeme ptr pfa.
Compute bluimeme pfa ptr.
Compute bluimeme pfa pfa.
Compute bluimeme ptr ptr.
(*C'est la fonction OR .*)

(*2.2.3.1*)

(*A -> B -> T) ->T*)
Definition pprod_nb : Set := forall T: Set, (nat -> bool -> T) -> T.
Definition pcpl_nb : nat -> bool -> pprod_nb := fun a b => fun T => fun k => k a b.

(* (5,true) *)
Compute pcpl_nb 5 true.
(*2.2.3.2*)
Definition pprod_bn : Set := forall T: Set, (bool -> nat -> T) -> T.
Definition pcpl_bn : bool -> nat -> pprod_bn := fun a b => fun T => fun k => k a b.
(* (true,5) *)
Compute pcpl_bn true 5.

(*2.2.3.3*)
Definition convertProd : pprod_nb -> pprod_bn := fun c => c pprod_bn (fun n b => pcpl_bn b n).
(*TEST : (5,true) => (true, 5)*)
Definition c1 := pcpl_nb 5 true.
Definition res := convertProd c1.
Compute c1.
Compute res.
(*produit universel*)
Definition pprod : Set -> Set -> Set := fun A B => forall T:Set, (A -> B -> T) -> T.
Definition pcpl : forall A B:Set, A -> B -> pprod A B := fun A B:Set => fun (a:A) (b:B) => fun T:Set => fun k:(A -> B -> T) => k a b.
(* couple = (99,true) *)
Compute pcpl nat bool 99 true.
(* couple = (1,0) *)
Compute pcpl nat nat 1 0.
(* couple = (1,(3, si vrai, 5 sinon) *)
Compute pcpl pbool nat ptr (foo35 ptr).

(*Choix (Sommes de Types) *)
(*On a juste implementé ça : A+B = ∀T, (A→T)→(B→T)→T.)*)
Definition psom (A B : Set) : Set := forall T:Set, (A -> T) -> (B -> T) -> T.
Definition inj1 (A B : Set) : A -> psom A B := fun a => fun T:Set => fun k1 : (A ->  T) => fun k2 : (B ->  T) => k1 a.
(*Inspirée par inj1*)
Definition inj2 (A B : Set) : B -> psom A B := fun b => fun T:Set => fun k1 : (A ->  T) => fun k2 : (B ->  T) => k2 b.

(*2.2.4  Entiers de Church avec typage polymorphe *)

(*Base form*)
(*On a re-utilisé les definitions de la partie1.v*)
Definition pnat := forall (T:Set), (T->T) -> (T->T).
Definition p0 : pnat := fun (T:Set) => fun (f:T->T) => fun (x:T) => x.
Definition pS : pnat -> pnat :=  fun (n: pnat) => fun (T : Set) f  x => f (n  T f x).
(*Definition de 1 2 et 3 on utilisant pS*)
Definition p1 := pS p0.
Definition p2 := pS p1.
Definition p3 := pS p2.
(*Definition cadd := \n m·\f x·n f(m f x).*)
Definition padd : pnat -> pnat -> pnat := fun n m => fun f x => n f (m f x ).
(* 2 + 2 = 4 *)
Compute padd p2 p2.
(*Definition cmult := \n m · \f· n(m f).*)
Definition pmult : pnat -> pnat -> pnat := fun m n =>  fun T:Set => (fun f => n T (m T f)).
(* 2 X 3 = 6 *)
Compute pmult p2 p3.
(*Definition ceq0 := \n·\x y· n(\z·x) y.*)
Definition peq0 : pnat -> pbool := fun n => fun T:Set => fun (x:T) (y:T) => (n T (fun z => y) x).
(* 3 X 0 == 0 ? *)
Compute peq0 (pmult p3 p0).
(* 3 == 0 ? *)
Compute peq0  p3.

(* special pplus *)
Definition pplus : pnat -> pnat -> pnat := fun n : pnat => fun m : pnat =>  n pnat pS m.
(* Test : 1 + 3 *)
Compute pplus p1 p3.

(*prédécesseur : We did not implement it... No time :-( *)

(* 2.2.5  Listes (bonus) *)
(*On a fait que la premiere question.*)
(*listen = ∀T, T→(pnat→T→T)→T.*)
Definition listen : Set := forall T: Set, T -> (pnat -> T -> T) -> T.
(*liste A = ∀T, T→(A→T→T)→T.*)
(*L'espace entre liste et A EST MANDATORY.*)
Definition liste A : Set := forall T: Set, T -> (A -> T -> T) -> T.
(*pnil A :liste A = ΛT.λxTcA→T→T.x*)
Definition pnil A : liste A := fun T:Set => fun x : T => fun c : (A -> T -> T) =>x.
(*pcons A :  A→ liste A →liste A = λaAq liste A.ΛT.λxTcA→T→T.c a(qTx c).*)
Definition pcons A : A -> liste A -> liste A :=  fun (a : A) (q : liste A) => fun T: Set => fun (x:T) (c : A -> T -> T)=> c a (q T x c).

(*2.2.6  Super bonus : arbres binaires et tri par arbre binaire de recherche*)
(*Reference*)
Definition arbin (A : Set) := forall T: Set, T -> (T -> A -> T -> T) -> T.
(*arbre Vide.*)
Definition pV (A:Set) := fun T:Set=> fun x : T => fun c : T -> A -> T -> T=> x.
(*le nœud comprenant un sous-arbre gauche, un habitant de A et un sous-arbre droit*)
Definition pN (A : Set):= fun (g : arbin A) (a : A) (d : arbin A) => fun T : Set  => fun(x : T) (c : T -> A -> T -> T) => c (g T x c) a (d T x c ).


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

(** Properties of subtraction between natural numbers.

 This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead.

 [minus] is now an alias for [Nat.sub], which is defined in [Init/Nat.v] as:
<<
Fixpoint sub (n m:nat) : nat :=
  match n, m with
  | S k, S l => k - l
  | _, _ => n
  end
where "n - m" := (sub n m) : nat_scope.
>>
*)

Require Import PeanoNat Lt Le.

Local Open Scope nat_scope.

(** * 0 is right neutral *)

Lemma minus_n_O n : n = n - 0.
Proof.
 symmetry. apply Nat.sub_0_r.
Qed.

(** * Permutation with successor *)

Lemma minus_Sn_m n m : m <= n -> S (n - m) = S n - m.
Proof.
 intros. symmetry. now apply Nat.sub_succ_l.
Qed.

Theorem pred_of_minus n : pred n = n - 1.
Proof.
 symmetry. apply Nat.sub_1_r.
Qed.

(** * Diagonal *)

Notation minus_diag := Nat.sub_diag (only parsing). (* n - n = 0 *)

Lemma minus_diag_reverse n : 0 = n - n.
Proof.
 symmetry. apply Nat.sub_diag.
Qed.

Notation minus_n_n := minus_diag_reverse.

(** * Simplification *)

Lemma minus_plus_simpl_l_reverse n m p : n - m = p + n - (p + m).
Proof.
 now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub.
Qed.

(** * Relation with plus *)

Lemma plus_minus n m p : n = m + p -> p = n - m.
Proof.
 symmetry. now apply Nat.add_sub_eq_l.
Qed.

Lemma minus_plus n m : n + m - n = m.
Proof.
 rewrite Nat.add_comm. apply Nat.add_sub.
Qed.

Lemma le_plus_minus_r n m : n <= m -> n + (m - n) = m.
Proof.
 rewrite Nat.add_comm. apply Nat.sub_add.
Qed.

Lemma le_plus_minus n m : n <= m -> m = n + (m - n).
Proof.
 intros. symmetry. rewrite Nat.add_comm. now apply Nat.sub_add.
Qed.

(** * Relation with order *)

Notation minus_le_compat_r :=
  Nat.sub_le_mono_r (only parsing). (* n <= m -> n - p <= m - p. *)

Notation minus_le_compat_l :=
  Nat.sub_le_mono_l (only parsing). (* n <= m -> p - m <= p - n. *)

Notation le_minus := Nat.le_sub_l (only parsing). (* n - m <= n *)
Notation lt_minus := Nat.sub_lt (only parsing). (* m <= n -> 0 < m -> n-m < n *)

Lemma lt_O_minus_lt n m : 0 < n - m -> m < n.
Proof.
 apply Nat.lt_add_lt_sub_r.
Qed.

Theorem not_le_minus_0 n m : ~ m <= n -> n - m = 0.
Proof.
 intros. now apply Nat.sub_0_le, Nat.lt_le_incl, Nat.lt_nge.
Qed.

(** * Hints *)

Hint Resolve minus_n_O: arith.
Hint Resolve minus_Sn_m: arith.
Hint Resolve minus_diag_reverse: arith.
Hint Resolve minus_plus_simpl_l_reverse: arith.
Hint Immediate plus_minus: arith.
Hint Resolve minus_plus: arith.
Hint Resolve le_plus_minus: arith.
Hint Resolve le_plus_minus_r: arith.
Hint Resolve lt_minus: arith.
Hint Immediate lt_O_minus_lt: arith.


Require Import Setoid.
Require Import SetoidClass.
Open Scope type_scope.

Inductive andT (A B:Type) : Prop :=
  conjT : A -> B -> andT A B.

Definition equivT (A B:Type) : Prop := andT (A ->B) (B-> A).

Lemma equivT_refl : forall A, equivT A A.
Proof.
  intros A.
  split;tauto.
Qed.

Lemma equivT_sym : forall A B, equivT A B -> equivT B A.
Proof.
  intros A B X.
  destruct X;split;tauto.
Qed.

Lemma equivT_trans : forall A B C, equivT A B -> equivT B C -> equivT A C.
Proof.
  intros A B C [H1 H2] [H3 H4].
  split;eauto.
Qed.

Add  Relation Type equivT
  reflexivity proved by equivT_refl
  symmetry proved by equivT_sym
  transitivity proved by equivT_trans
as toto.


Require Export Category.
Require Export Functor.

Generalizable All Variables.
Open Scope signature.

Section natrual_transformation.
Check @Functor.
Context (C D : Type)
        {aC:Arrows C} {aD:Arrows D}
        {catC:Category C} {catD:Category D}
       `{@Functor C aC catC D aD catD F Fmor}
       `{@Functor C aC catC D aD catD G Gmor}.

Notation " a ~{ X }{ Y }~> b " := (@Hom X Y a b) (at level 40).

Class NatTrans
  (trans : forall x : C, (F x) ~> (G x))
  :=
  { nt_trans := trans
  ; nt_natural : forall (x y : C) (f : x ~> y),
    (nt_trans y) ∘ (Fmor x y f) == (Gmor x y f) ∘ (nt_trans x)
  }.

Notation "η_{ x }" := (nt_trans x) (at level 40).
End natrual_transformation.

Section id_nat_trans.
Context `{aC:Arrows C} `{aD:Arrows D}
        {catC:Category C} {catD:Category D}
        `(F : C->D) `(F_f : @Functor C aC catC D aD catD F Fmor).

Definition idN (x:C) := @cat_id D aD catD (F x).
Global Program Instance :
  @NatTrans C D aC aD catD F Fmor F Fmor idN.
Next Obligation.
  unfold idN.
  rewrite id_r. symmetry. apply id_l.
  Qed.

End id_nat_trans.


(******************************************************************************)
(* Chapter 1.6.1: Product Categories                                          *)
(******************************************************************************)

(*
(0)
同じディレクトリにある Categories.v と Functor.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Notations.                   (* coq standard libs. *)
Require Import Categories.                  (* same dir. *)
Require Import Functors.                    (* same dir. *)
Require Import Isomorphisms.                (* same dir. *)

(* 積圏 *)
Section ProductCategories.

  Locate "_ ~~{ _ }~~> _".                  (* Categories.v *)

(*
  Context `(C1 : Category Obj1 Hom1).
  Context `(C2 : Category Obj2 Hom2).
*)
  Context `(C1 : Category).                 (* Obj Hom *)
  Context `(C2 : Category).                 (* Obj0 Hom0 *)

  (* trying to use the standard "prod" here causes a universe
  inconsistency once we get to coqBinoidal; moreover, using a
  general fully-polymorphic pair type seems to trigger some serious
  memory leaks in Coq *)

  Inductive  prod_obj : Type :=
  | pair_obj : C1 -> C2 -> prod_obj.

  Definition fst_obj (x : prod_obj) : C1 :=
    match x with
      | pair_obj a _ => a
    end.

  Definition snd_obj (x : prod_obj) : C2 :=
    match x with
      | pair_obj _ b => b
    end.

  Inductive prod_mor (a b : prod_obj) : Type :=
    pair_mor :
      ((fst_obj a) ~~{C1}~~> (fst_obj b)) -> (* f1 *)
      ((snd_obj a) ~~{C2}~~> (snd_obj b)) -> (* f2 *)
      prod_mor a b.                          (* f *)
  Check prod_mor : prod_obj → prod_obj → Type.

  Definition prod_eqv (a b : prod_obj)
             (f : prod_mor a b) (g : prod_mor a b) : Prop :=
    match f with
      | pair_mor f1 f2 =>
        match g with
          | pair_mor g1 g2 =>
            f1 === g1 /\ f2 === g2
        end
    end.

  Program Instance prod_Equiv (a b : prod_obj) : Equivalence (@prod_eqv a b).
  Obligation 1.                             (* Reflexive *)
  Proof.
    rewrite /prod_eqv /Reflexive /=.
    case=> f1 f2.
    split.
    - reflexivity.
    - reflexivity.
  Qed.
  Obligation 2.                             (* Symmetric *)
  Proof.
    rewrite /prod_eqv /Symmetric /=.
    case=> f1 f2.
    case=> g1 g2.
    case=> H1 H2.
    split.
    - rewrite H1.
      reflexivity.
    - rewrite H2.
      reflexivity.
  Qed.
  Obligation 3.                             (* Transitive *)
  Proof.
    rewrite /prod_eqv /Transitive /=.
    case=> f1 f2.
    case=> g1 g2.
    case=> h1 h2.
    case=> Hfg1 Hfg2.
    case=> Hgh1 Hgh2.
    split.
    - rewrite Hfg1 Hgh1.
      reflexivity.
    - rewrite Hfg2 Hgh2.
      reflexivity.
  Qed.

  (* 射はSetoidでないといけない。 *)
  Instance PC_mor (a b : prod_obj) : Setoid :=
    {
      carrier := prod_mor a b;
      eqv := @prod_eqv a b
    }.
  Check PC_mor : prod_obj → prod_obj → Setoid.
  Print PC_mor.

  Definition fst_mor {a b : prod_obj} (f : prod_mor a b) :=
    match f with
      | pair_mor a _ => a
    end.

  Definition snd_mor {a b : prod_obj} (f : prod_mor a b) :=
    match f with
      | pair_mor _ b => b
    end.

  Check @Category.
  Check prod_obj : Type.
  Check prod_mor : prod_obj → prod_obj → Type.
  Check PC_mor   : prod_obj → prod_obj → Setoid.
  Check @Category prod_obj PC_mor.

  Program Instance ProductCategory : @Category prod_obj PC_mor.
  Obligation 1.                             (* id *)
  Proof.
    apply pair_mor.
    - apply id.
    - apply id.
  Defined.
  Obligation 2.                             (* comp *)
  Proof.
    apply pair_mor.
    Check (fun (f1 : fst_obj a ~~{ C1 }~~> fst_obj b)
               (g1 : fst_obj b ~~{ C1 }~~> fst_obj c) => (g1 \\o f1)).
    - apply (fun (f1 : fst_obj a ~~{ C1 }~~> fst_obj b)
                 (g1 : fst_obj b ~~{ C1 }~~> fst_obj c) => (g1 \\o f1));
        by [apply X | apply X0].
    - apply (fun (f2 : snd_obj a ~~{ C2 }~~> snd_obj b)
                 (g2 : snd_obj b ~~{ C2 }~~> snd_obj c) => (g2 \\o f2));
        by [apply X | apply X0].
  Defined.
  Obligation 3.                             (* comp_respects *)
  Proof.
    rewrite /ProductCategory_obligation_2.
    move=> g1 g2 Hg.
    move=> f1 f2 Hf.
    move: Hg Hf.
    rewrite /prod_eqv.
    case g1 => gf1 gs1.
    case f1 => ff1 fs1.
    case g2 => gf2 gs2.
    case f2 => ff2 fs2.
    case=> Hgf Hgs.
    case=> Hff Hfs.
    split.
    - rewrite Hgf Hff.
      reflexivity.
    - rewrite Hgs Hfs.
      reflexivity.
  Defined.
  Obligation 4.                             (* id \\o f === f  *)
  Proof.
    case: f => ff fs.
    split.
    - rewrite left_identity.
      reflexivity.
    - rewrite left_identity.
      reflexivity.
  Defined.
  Obligation 5.                             (* f \\o id === f  *)
  Proof.
    case: f => ff fs.
    split.
    - rewrite right_identity.
      reflexivity.
    - rewrite right_identity.
      reflexivity.
  Defined.
  Obligation 6.                             (* f \\o g \\o h === f \\o (g \\o h) *)
  Proof.
    case: f => ff fs.
    split.
    - case: g => gf gs.
      case: h => hf hs.
      rewrite associativity.
      reflexivity.
    - case: g => gf gs.
      case: h => hf hs.
      rewrite associativity.
      reflexivity.
  Defined.
End ProductCategories.

Notation "C ×× D" := (ProductCategory C D).

(*
Implicit Arguments pair_obj [ Ob1 Hom1 Ob2 Hom2 C1 C2 ].
Implicit Arguments pair_mor [ Ob1 Hom1 Ob2 Hom2 C1 C2 ].
 *)

Check @pair_obj : ∀Obj Hom C1 Obj Hom C2 a b, prod_obj C1 C2.
Check @pair_mor : ∀Obj Hom C1 Obj Hom C2 a b f g, prod_mor a b.
Check @fst_obj.
Check @fst_mor.
Arguments pair_obj {Obj1 Hom1 C1 Obj2 Hom2 C2} a b : rename.
Arguments pair_mor {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} f g : rename.
Arguments fst_obj  {Obj1 Hom1 C1 Obj2 Hom2 C2} D : rename.
Arguments snd_obj  {Obj1 Hom1 C1 Obj2 Hom2 C2} D : rename.
Arguments fst_mor  {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} i : rename.
Arguments snd_mor  {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} i : rename.
Check pair_obj : _ -> _ -> prod_obj _ _.    (* 圏の指定は要らない。 *)
Check pair_mor : _ ~> _ ->  _ ~> _ -> prod_mor _ _.
Check fst_obj  : prod_obj _ _ -> _.
Check snd_obj  : prod_obj _ _ -> _.
Check fst_mor  : prod_mor _ _ -> _ ~> _.

Check @PC_mor : ∀Obj Hom C1 Obj0 Hom0 C2 _ _, Setoid.
Arguments PC_mor {Obj1 Hom1 C1 Obj2 Hom2 C2} f g : rename.
Check PC_mor : prod_obj _ _ → prod_obj _ _ → Setoid.

Check @Functor : ∀Obj Hom C1 Obj0 Hom0 C2 _, Type.
Arguments Functor {Obj Hom} C1 {Obj0 Hom0} C2 i : rename.

Section ProductCategoryFunctors.

  Context `{C : Category}.                  (* Obj Hom C *)
  Context `{D:Category}.                    (* Obj0 Hom0 D *)

  Check @Functor.
  Check @Functor _ _ (C ×× D) Obj Hom C (fun c => fst_obj c).
  Check Functor (C ×× D) C (fun c => fst_obj c).

  Check @prod_obj Obj Hom C Obj0 Hom0 D.
  Check prod_obj C D.

  Check @PC_mor Obj Hom C Obj0 Hom0 D.
  Check PC_mor.

  Check @fst_obj Obj Hom C Obj0 Hom0 D : prod_obj C D → C.
  Check fst_obj : prod_obj C D → C.

  Check fun (c : prod_obj C D) => @fst_obj Obj Hom C Obj0 Hom0 D c.
  Check fun (c : prod_obj C D) => fst_obj c.

  Check @Functor (prod_obj C D) (@PC_mor Obj Hom C Obj0 Hom0 D) (C ×× D)
        Obj Hom C (fun c => fst_obj _ c).
  Check Functor (C ×× D) C (fun (c : prod_obj C D) => @fst_obj Obj Hom C Obj0 Hom0 D c).

  (* 積圏からもとの圏をとりだす関手 *)
  Program Instance func_pi1 : Functor (C ×× D) C
                                      (fun (c : prod_obj C D) => fst_obj c).
  Obligation 1.
  (* fst_obj a ~~{ C }~~> fst_obj b *)
  Proof.
    by apply fst_mor.
  Defined.
  Obligation 2.
  (* fst_mor f === fst_mor f' *)
  Proof.
    rewrite /func_pi1_obligation_1.
    case: f H => ff fs.
    case: f' => f'f f's H /=.
    by case: H.
  Defined.
  Obligation 3.
  (* id === id *)
  Proof.
    reflexivity.
  Defined.
  Obligation 4.
  Proof.
    rewrite /func_pi1_obligation_1.
    case: f => ff fs.
    case: g => gf gs.
    reflexivity.
  Defined.

  Program Instance func_pi2 : Functor (C ×× D) D
                                      (fun (c : prod_obj C D) => snd_obj c).
  Obligation 1.
  (* snd_obj a ~~{ D }~~> snd_obj b *)
  Proof.
    by apply snd_mor.
  Defined.
  Obligation 2.
  (* snd_mor f === snd_mor f' *)
  Proof.
    rewrite /func_pi2_obligation_1.
    case: f H => ff fs.
    case: f' => f'f f's H /=.
    by case: H.
  Defined.
  Obligation 3.
  (* id === id *)
  Proof.
    reflexivity.
  Defined.
  Obligation 4.
  Proof.
    rewrite /func_pi2_obligation_1.
    case: f => ff fs.
    case: g => gf gs.
    reflexivity.
  Defined.

  (* 積圏の左が恒等射である場合 *)
  Definition llecnac_fmor (I : C) (a b : D) (g : a ~~{D}~~> b) :
    (pair_obj I a) ~~{C××D}~~> (pair_obj I b).
  Proof.
    apply: pair_mor => /=.
    - by apply: id.
    - by apply: g.
  Defined.

  (* 圏から左が恒等射である積圏への関手 *)
  Program Instance func_llecnac (I : C) : Functor D (C ×× D) (pair_obj I).
  Obligation 1.
  (* prod_mor (pair_obj I a) (pair_obj I b) *)
   Proof.
    apply: pair_mor;
      by apply llecnac_fmor.
  Defined.
  Obligation 2.
  Proof.
    split; [reflexivity | done].
  Defined.
  Obligation 3.
    split; [reflexivity | reflexivity].
  Defined.
  Obligation 4.
  Proof.
    split.
    - rewrite left_identity.
      reflexivity.
    - reflexivity.
  Defined.

  (* 積圏の右が恒等射である場合 *)
  Definition rlecnac_fmor (I : D) (a b : C) (f : a ~~{C}~~> b) :
    (pair_obj a I) ~~{C××D}~~> (pair_obj b I).
  Proof.
    apply: pair_mor => /=.
    - by apply: f.
    - by apply: id.
  Defined.

  (* 圏から右が恒等射である積圏への関手 *)
  Program Instance func_rlecnac (I : D) : Functor C (C ×× D) (fun c => (pair_obj c I)).
  Obligation 1.
  (* prod_mor (pair_obj a I) (pair_obj b I) *)
  Proof.
    apply: pair_mor;
      by apply rlecnac_fmor.
  Defined.
  Obligation 2.
  Proof.
    split; [done | reflexivity].
  Defined.
  Obligation 3.
    split; [reflexivity | reflexivity].
  Defined.
  Obligation 4.
  Proof.
    split.
    - reflexivity.
    - rewrite right_identity.
      reflexivity.
  Defined.

  Context `{E : Category}.

  (* 積圏の結合律 *)
  Definition cossa : ((C ×× D) ×× E) -> (C ×× (D ×× E)).
  Proof.
    move=> [[HC HD] HE].
    by [].
  Defined.

  (* 次の定理のための補題 *)
  Definition cossa_fmor (a : ((C ×× D) ×× E)) (b : ((C ×× D) ×× E))
             (f : a ~~{(C ×× D) ×× E}~~> b) :
    (cossa a) ~~{C ×× (D ×× E)}~~> (cossa b).
  Proof.
    case: a f => HCxD HE.
    case: b => GCxD GE.
    case: HCxD.
    case: GCxD.
    move=> HC HD GC GD.
    case=> fCD fE.
    case: fCD => fC fD.
    done.
  Defined.

  (* cossa は、関手である。 *)
  Program Instance func_cossa : Functor ((C ×× D) ×× E) (C ×× (D ×× E)) cossa :=
    {|
      fmor := fun a b f => cossa_fmor f
    |}.
  Obligation 1.
  Proof.
    move: a b f f' H.
    (* ∀a b f f' _, cossa_fmor f === cossa_fmor f' *)
    move=> [[a11 a12] a2].                  (* case a *)
    move=> [[b11 b12] b2].                  (* case b *)
    move=> [[f11 f12] f2].                  (* case f *)
    move=> [[g11 g12] g2].                  (* case f' *)
    case; case.
    split; [exact | split; exact].
  Defined.
  Obligation 2.
  Proof.
    (* ∀ a : (C ×× D) ×× E, cossa_fmor id === id *)
    case: a => HCxD HE.
    case: HCxD => HC HD.
    split; [reflexivity | split; reflexivity].
  Defined.
  Obligation 3.
  Proof.
    move: a b c f g.
    (* ∀a b c f g, cossa_fmor g \\o cossa_fmor f === cossa_fmor (g \\o f) *)
    move=> [[a11 a12] a2].                  (* case a *)
    move=> [[b11 b12] b2].                  (* case b *)
    move=> [[c11 c12] c2].                  (* case c *)
    move=> [[f11 f12] f2].                  (* case f *)
    move=> [[g11 g12] g2].                  (* case g *)
    rewrite /=; split; [reflexivity | split; reflexivity].
  Defined.

  (* 同じ圏の積 C^2 *)
  Program Instance func_diagonal : Functor C (C ×× C) (fun c => (pair_obj c c)).
  Obligation 1.
  (* prod_mor (pair_obj a a) (pair_obj b b) *)
  Proof.
    by apply: pair_mor.
  Defined.
  Obligation 3.
  (* id === id ∧ id === id *)
  Proof.
    split; reflexivity.
  Defined.
  Obligation 4.
  (* g \\o f === g \\o f ∧ g \\o f === g \\o f *)
  Proof.
    split; reflexivity.
  Defined.
End ProductCategoryFunctors.

Section func_prod.

  Context `{C1 : Category} `{C2 : Category} `{C3 : Category} `{C4 : Category}.
  Variables (Fobj1 : C1 -> C2) (Fobj2 : C3 -> C4).
  Variables (F1 : Functor C1 C2 Fobj1) (F2 : Functor C3 C4 Fobj2).

  Definition functor_product_fobj (a : prod_obj C1 C3) :=
    pair_obj (Fobj1 (fst_obj a)) (Fobj2 (snd_obj a)).
  Check functor_product_fobj.
  Check functor_product_fobj : prod_obj C1 C3 → prod_obj C2 C4.

  Definition functor_product_fmor (a b : (C1 ×× C3)) (f : a ~~{C1 ×× C3}~~> b) :
    (functor_product_fobj a) ~~{C2 ×× C4}~~> (functor_product_fobj b).
  Proof.
    case: a f => HC1 HC3 H.
    apply: pair_mor => /=.
    - apply (fmor F1); by case H.
    - apply (fmor F2); by case H.
  Defined.

  Hint Unfold fst_obj.

  Program Instance func_prod : Functor (C1 ×× C3) (C2 ×× C4) functor_product_fobj :=
    {|
      fmor := fun a b (f:a~~{C1 ×× C3}~~>b) => functor_product_fmor f
    |}.
  Obligation 1.
  Proof.
    move: a b f f' H.
    (* ∀a b f f' _, functor_product_fmor f === functor_product_fmor f' *)
    move=> [a1 a2].                         (* case a *)
    move=> [b1 b2].                         (* case b *)
    move=> [f1 f2].                         (* case f *)
    move=> [g1 g2].                         (* case g *)
    case=> H1 H2.                           (* case H *)
    split; [rewrite H1 | rewrite H2]; reflexivity.
  Defined.
  Obligation 2.
  Proof.
  (* ∀ a : C1 ×× C3, functor_product_fmor id === id *)
    case: a => [a1 a2] /=.
      by split; apply fmor_preserves_id.
  Defined.
  Obligation 3.
  Proof.
    move: a b c f g.
  (* ∀a b c f g,
   functor_product_fmor g \\o functor_product_fmor f ===
   functor_product_fmor (g \\o *)
    move=> [a1 a2].                         (* case a *)
    move=> [b1 b2].                         (* case b *)
    move=> [c1 c2].                         (* case c *)
    case=> f1 f3.                           (* case f *)
    case=> g1 g3.                           (* csae g *)
    by move=> /=; split; apply fmor_preserves_comp.
  Defined.
End func_prod.

Notation "f **** g" := (func_prod f g).

Program Instance iso_prod `{C : Category} `{D : Category} {a b : C} {c d : D}
         (ic : a ≅ b) (id : @Isomorphic _ _ D c d) :
  @Isomorphic _ _ (C ×× D) (pair_obj a c) (pair_obj b d).
Obligation 1.                               (* prod_mor (pair_obj a c) (pair_obj b d) *)
Proof.
  apply: pair_mor => /=.
  - by case: ic.
  - by case: id.
Defined.
Obligation 2.                               (* prod_mor (pair_obj b d) (pair_obj a c) *)
Proof.
  apply: pair_mor => /=.
  - by case: ic.
  - by case: id.
Defined.
Obligation 3.
Proof.
   by split; apply iso_comp1.
Defined.
Obligation 4.
Proof.
   by split; apply iso_comp2.
Defined.

(* END *)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (x : natural) : natural :=
  plus (Succ lf2) (mult x y).


Require Import List.

Require Import Bool.

Require Import Lia.

Variable T : Type.

Hypothesis T_eq_dec : forall (x y :T), {x=y} + {~x=y}.

(** Definition **)

Definition multiset := list (T*nat).

Definition empty:multiset := nil.

Fixpoint member (x : T) (ms : multiset) : bool :=
  match ms with
  |nil => false
  |(a,b)::r => match T_eq_dec a x with
                    |left _ => true
                    |right _ => (member x r)
               end
  end.

Definition singleton (x : T) := (x,1)::empty .

Fixpoint add (x : T) (n : nat) (ms : multiset) : multiset :=
 match ms with
  |nil => match n with
                  |0 => nil
                  |_ => (x,n)::nil
          end
  |(a,b)::r =>  match T_eq_dec a x with
                    |left _ => (a,n+b)::r
                    |right _ => (a,b)::(add x n r)
               end
end.

Fixpoint union (ms1 : multiset) (ms2 : multiset) : multiset :=
match ms1 with
  |nil => ms2
  |(a,b)::r => union r (add a b ms2)
end.

Fixpoint multiplicity (x : T) (ms : multiset) : nat :=
match ms with
  |nil =>0
  |(a,b)::r => match T_eq_dec a x with
                    |left _ => b
                    |right _ => multiplicity x r
              end
end.

Fixpoint removeOne (x : T) (ms : multiset) : multiset :=
match ms with
  |nil => nil
  |(a,b)::r => match T_eq_dec a x with
                     |right _ => (a,b)::(removeOne x r)
                     |left _ => match b with
                                              |0 | S(0) => r
                                              | S(m) => (a,m)::r
                                end
              end
end.

Fixpoint removeAll (x : T) (ms : multiset) : multiset :=
match ms with
  |nil => nil
  |(a,b)::r => match T_eq_dec a x with
                     |right _ => (a,b)::(removeAll x r)
                     |left _ => removeAll x r
              end
end.

(** Rq : Cette definition est redondante car elle laisse croire que l'on peut trouver plusieurs couples pour un même élément x, cependant cela facilite les preuves de correction **)

Inductive InMultiset : T -> multiset -> Prop :=
  | TL : forall h x ms, InMultiset x ms -> InMultiset x (cons h ms)
  | HD : forall x n ms, InMultiset x (cons (x,S(n)) ms).

Inductive wf : multiset -> Prop :=
 | Empt : wf empty
 | Cons : forall x n t,(wf t)/\~(InMultiset x t) -> wf (cons (x,S(n)) t).

Goal wf empty.
Proof.
apply Empt.
Qed.

Goal forall x, wf (singleton x).
Proof.
intro x. apply (Cons x 0 empty).
split. apply Empt. intro H. inversion H.
Qed.

Lemma Add0 : forall x ms, (add x 0 ms)=ms.
Proof.
induction ms as [|hd tl].
  + simpl. reflexivity.
  + simpl. destruct hd as [a n]. destruct (T_eq_dec a x).
    ++ reflexivity.
    ++ rewrite IHtl. reflexivity.
Qed.

Lemma AddDistinct : forall (a x : T) (n : nat) (ms : multiset), ~(InMultiset a ms) -> ~(a=x) -> ~(InMultiset a (add x (S n) ms)).
Proof.
intros a x n ms. intros Happ Hdist. induction ms.
  + simpl. intro Hneg. inversion Hneg. inversion H1. contradiction.
  + intro Hneg. Admitted.

Goal forall x n ms, wf ms -> wf (add x n ms).
destruct n.
  +intros ms H. rewrite (Add0 x ms). exact H.
  + induction ms as [ |hd tl].
    ++ intro H. apply (Cons x n nil). split. exact H. intro Hneg. inversion Hneg.
    ++ intro H. simpl. destruct hd as [a m]. destruct (T_eq_dec a x).
        +++ apply (Cons a (n+m) tl). inversion H. destruct H1. split. exact H1. exact H4.
        +++ destruct m. inversion H. apply (Cons a m (add x (S n) tl)). inversion H. destruct H1. split.
            ++++ apply IHtl in H1. exact H1.
            ++++ intro Hneg. destruct Hneg. Admitted.

(** Question 3 **)

Goal forall x, ~InMultiset x empty.
Proof.
intro x. intro Hneg. inversion Hneg.
Qed.

Goal forall x y, InMultiset y (singleton x) -> x=y.
Proof.
intros x y. intro Hyp. inversion Hyp. inversion H1. reflexivity.
Qed.

Goal forall x y, x=y -> InMultiset y (singleton x).
Proof.
intros x y. intro Hyp. rewrite Hyp. apply (HD y 0 empty).
Qed.

Goal forall x, multiplicity x (singleton x) = 1.
Proof.
intro x. simpl. destruct (T_eq_dec x x). reflexivity. contradiction.
Qed.

Lemma WfSub : forall a ms, wf(a::ms)-> wf ms.
Proof.
intros a ms. intro Hform. inversion Hform. destruct H0. exact H0.
Qed.

Goal forall x s, wf s -> (member x s = true <-> InMultiset x s).
intros x s. intro Hform. split.
  + intro Hmem. induction s.
    ++ inversion Hmem.
    ++ pose proof (WfSub a s Hform) as Hform2. destruct a as [a1 n]. destruct (T_eq_dec a1 x).
      +++ destruct n. inversion Hform. rewrite e. apply (HD x n s).
      +++ apply IHs in Hform2. apply (TL (a1,n) x s Hform2). inversion Hmem. destruct (T_eq_dec a1 x). contradiction. reflexivity.
  + intro Hyp. induction Hyp.
    ++ pose proof (WfSub h ms Hform) as Hform2. apply IHHyp in Hform2. destruct h as [a n]. simpl. destruct (T_eq_dec a x). reflexivity. exact Hform2.
    ++ simpl. destruct (T_eq_dec x x). reflexivity. contradiction.
Qed.

Goal forall x n s, n>0 -> InMultiset x (add x n s).
intros x n s Hstr. destruct n. lia. induction s.
  + simpl. apply (HD x n empty).
  + destruct a as [a1 m]. simpl. destruct (T_eq_dec a1 x).
    ++ rewrite e. apply (HD x (n+m) s).
    ++ apply (TL (a1,m) x (add x (S n) s)). exact IHs.
Qed.

Lemma CoqEstPerdu : forall (a : T) (k : nat) (h : T*nat) (ms tl : multiset), h::ms = (a,k)::tl -> tl=ms.
Proof.
intros a k h ms tl. Admitted.

Goal forall x y n s, x<>y ->(InMultiset y (add x n s) <-> InMultiset y s).
Proof.
intros x y n s. intro Hdiff. split.
  + intro Happ. induction s as [|hd tl].
    ++ destruct n.
      +++ inversion Happ.
      +++ inversion Happ. inversion H1. admit. (** on a x<>y et x=y mais Coq ne voit pas la contradiction ... **)
   ++ destruct hd as [a m]. destruct (T_eq_dec a x).
      +++ rewrite e. apply (TL (x,m) y tl). rewrite -> e in Happ. inversion Happ. destruct (T_eq_dec x x). pose proof (CoqEstPerdu x (n+m) h ms tl H). rewrite <- H2 in H1. exact H1. contradiction.

inversion Happ. destruct (T_eq_dec a x). apply (TL (a,m) y tl). pose proof (CoqEstPerdu a (n+m) h ms tl H). rewrite H2. exact H1.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules.

Set Implicit Arguments.

Section Relational_phase_semantics.

  (** We define a sound relational phase sematics for ILL
      based on stable closures

      The algebraic developments below follow the sketch
      in the book "Lectures on Linear Logic"

      http://phil.gu.se/logic/books/Troelstra:Lectures_on_Linear_Logic.pdf

    *)

  Variable M : Type.

  Implicit Types A B C : M -> Prop.

  Variable cl : (M -> Prop) -> (M -> Prop).

  Hypothesis cl_increase   : forall A, A ⊆ cl A.
  Hypothesis cl_monotone   : forall A B, A ⊆ B -> cl A ⊆ cl B.
  Hypothesis cl_idempotent : forall A, cl (cl A) ⊆ cl A.

  Proposition cl_prop A B : A ⊆ cl B <-> cl A ⊆ cl B.
  Proof.
    split; intros H x Hx.
    apply cl_idempotent; revert Hx; apply cl_monotone; auto.
    apply H, cl_increase; auto.
  Qed.

  Definition cl_inc A B := proj1 (cl_prop A B).
  Definition inc_cl A B := proj2 (cl_prop A B).

  Fact cl_eq1 A B : A ≃ B -> cl A ≃ cl B.
  Proof. intros []; split; apply cl_monotone; auto. Qed.

  Hint Resolve cl_inc cl_eq1.

  Notation closed := (fun x : M -> Prop => cl x ⊆ x).

  Fact cl_closed A B : closed B -> A ⊆ B -> cl A ⊆ B.
  Proof.
    intros H1 H2.
    apply inc1_trans with (2 := H1), cl_inc,
          inc1_trans with (1 := H2), cl_increase.
  Qed.

  Fact cap_closed A B : closed A -> closed B -> closed (A ∩ B).
  Proof.
    intros HA HB x Hx; split; [ apply HA | apply HB ]; revert Hx; apply cl_monotone; tauto.
  Qed.

  Hint Resolve cap_closed.

  (* this is a relational/non-deterministic monoid *)

  Variable Compose : M -> M -> M -> Prop.

  (* Composition lifted to predicates *)

  Inductive Composes (A B : M -> Prop) : M -> Prop :=
    In_composes : forall a b c, A a -> B b -> Compose a b c -> Composes A B c.

  (* ⊆ ≃ ∩ ∪ ∘ *)

  Infix "∘" := Composes (at level 50, no associativity).

  Proposition composes_monotone A A' B B' : A ⊆ A' -> B ⊆ B' ->  A ∘ B ⊆ A' ∘ B'.
  Proof. intros ? ? _ [ ? ? ? ? ? H ]; apply In_composes with (3 := H); auto. Qed.

  Hint Resolve composes_monotone.

  Variable e : M.

  (* Stability is the important axiom in phase semantics *)

  Definition cl_stability   := forall A B, cl A ∘ cl B ⊆ cl (A ∘ B).
  Notation cl_stability_l  := (forall A B, cl A ∘    B ⊆ cl (A ∘ B)).
  Definition cl_stability_r := forall A B,    A ∘ cl B ⊆ cl (A ∘ B).

  Proposition cl_stable_imp_stable_l : cl_stability -> cl_stability_l.
  Proof.
    intros H ? ? x Hx.
    apply H; revert x Hx.
    apply composes_monotone; auto.
  Qed.

  Proposition cl_stable_imp_stable_r : cl_stability -> cl_stability_r.
  Proof.
    intros H ? ? x Hx.
    apply H; revert x Hx.
    apply composes_monotone; auto.
  Qed.

  Proposition cl_stable_lr_imp_stable : cl_stability_l -> cl_stability_r -> cl_stability.
  Proof.
    intros H1 H2 A B x Hx.
    apply cl_idempotent.
    generalize (H1 _ _ _ Hx).
    apply cl_monotone, H2.
  Qed.

  Hint Resolve cl_stable_imp_stable_l cl_stable_imp_stable_r cl_stable_lr_imp_stable.

  Notation sg := (@eq _).

  Notation cl_neutrality_1  := (forall a, cl (sg e ∘ sg a) a).
  Notation cl_neutrality_2  := (forall a, sg e ∘ sg a ⊆ cl (sg a)).
  Notation cl_commutativity := (forall a b, sg a ∘ sg b ⊆ cl (sg b ∘ sg a)).
  Notation cl_associativity := (forall a b c, sg a ∘ (sg b ∘ sg c) ⊆ cl ((sg a ∘ sg b) ∘ sg c)).

  Hypothesis cl_commute : cl_commutativity.

  Proposition composes_commute_1 A B : A ∘ B ⊆ cl (B ∘ A).
  Proof.
    intros _ [ a b c Ha Hb Hc ].
    apply cl_monotone with (sg b ∘ sg a).
    apply composes_monotone; apply sg_inc1; auto.
    apply cl_commute.
    constructor 1 with (3 := Hc); auto.
  Qed.

  Hint Resolve composes_commute_1.

  (* ⊆ ≃ ∩ ∪ ∘ *)

  Proposition composes_commute A B : cl (A∘B) ≃ cl (B∘A).
  Proof.
    split; intros x Hx; apply cl_idempotent; revert Hx; apply cl_monotone; auto.
  Qed.

  Proposition cl_stable_l_imp_r : cl_stability_l -> cl_stability_r.
  Proof.
    intros Hl A B x Hx.
    apply cl_idempotent.
    apply cl_monotone with (cl B ∘ A).
    apply inc1_trans with (cl ((cl B) ∘ A)); auto.
    rewrite <- cl_prop; auto.
    generalize (@composes_commute_1 B A); intros H.
    rewrite cl_prop in H; auto.
    apply composes_commute_1; auto.
  Qed.

  Proposition cl_stable_r_imp_l : cl_stability_r -> cl_stability_l.
  Proof.
    intros Hl A B.
    generalize (@composes_commute_1 B A); intros H.
    rewrite cl_prop in H; auto.
    apply inc1_trans with (B := cl (B ∘ cl A)),
          inc1_trans with (2 := H); auto.
    rewrite <- cl_prop; apply Hl.
  Qed.

  Hint Resolve cl_stable_l_imp_r cl_stable_r_imp_l.

  Proposition cl_stable_l_imp_stable : cl_stability_l -> cl_stability.    Proof. auto. Qed.
  Proposition cl_stable_r_imp_stable : cl_stability_r -> cl_stability.    Proof. auto. Qed.

  Hypothesis cl_stable_l : cl_stability_l.

  Proposition cl_stable_r : cl_stability_r.                               Proof. auto. Qed.
  Proposition cl_stable : cl_stability.                                   Proof. auto. Qed.

  Hint Resolve cl_stable_r cl_stable.

  Hypothesis cl_neutral_1 : cl_neutrality_1.
  Hypothesis cl_neutral_2 : cl_neutrality_2.
  Hypothesis cl_associative : cl_associativity.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ *)

  Definition Magicwand A B k := sg k ∘ A ⊆ B.
  Infix "⊸" := Magicwand (at level 51, right associativity).

  Proposition magicwand_spec A B C : A ∘ B ⊆ C <-> A ⊆ B ⊸ C.
  Proof.
    split; intros H x Hx.
    intros y Hy; apply H; revert Hy; apply composes_monotone; auto.
    apply sg_inc1; auto.
    destruct Hx as [ a b x Ha Hb Hx ].
    apply (H _ Ha).
    constructor 1 with a b; auto.
  Qed.

  Definition magicwand_adj_1 A B C := proj1 (magicwand_spec A B C).
  Definition magicwand_adj_2 A B C := proj2 (magicwand_spec A B C).

(*  Hint Resolve magicwand_adj_1 magicwand_adj_2. *)

  Proposition magicwand_monotone A A' B B' : A ⊆ A' -> B ⊆ B' -> A' ⊸ B ⊆ A ⊸ B'.
  Proof.
    intros ? HB; apply magicwand_adj_1, inc1_trans with (2 := HB).
    intros _ [? ? ? Ha ? Hc]; apply Ha, In_composes with (3 := Hc); auto.
  Qed.

  Hint Resolve magicwand_monotone.

  Proposition cl_magicwand_1 X Y : cl (X ⊸ cl Y) ⊆ X ⊸ cl Y.
  Proof.
    apply magicwand_adj_1,
          inc1_trans with (B := cl ((X ⊸ cl Y) ∘ X)); auto.
    rewrite <- cl_prop; apply magicwand_spec; auto.
  Qed.

  Proposition cl_magicwand_2 X Y : cl X ⊸ Y ⊆ X ⊸ Y.
  Proof. apply magicwand_monotone; auto. Qed.

  Hint Immediate cl_magicwand_1 cl_magicwand_2.

  Proposition cl_magicwand_3 X Y : X ⊸ cl Y ⊆ cl X ⊸ cl Y.
  Proof.
    intros c Hc y.
    apply inc1_trans with (B := cl (sg c ∘ X)); auto.
    rewrite <- cl_prop.
    intros ? [ a b d [] Hb ].
    intros; apply Hc.
    constructor 1 with c b; auto.
  Qed.

  Hint Immediate cl_magicwand_3.

  Proposition closed_magicwand X Y : closed Y -> closed (X ⊸ Y).
  Proof.
    simpl; intros ?.
    apply inc1_trans with (B := cl (X ⊸ cl Y)); auto.
    apply cl_monotone, magicwand_monotone; auto.
    apply inc1_trans with (B := X ⊸ cl Y); auto.
    apply magicwand_monotone; auto.
  Qed.

  Hint Resolve closed_magicwand.

  Proposition magicwand_eq_1 X Y : X ⊸ cl Y ≃ cl X ⊸ cl Y.
  Proof. split; auto. Qed.

  Proposition magicwand_eq_2 X Y : cl (X ⊸ cl Y) ≃ X ⊸ cl Y.
  Proof. split; auto. Qed.

  Proposition magicwand_eq_3 X Y : cl (X ⊸ cl Y) ≃ cl X ⊸ cl Y.
  Proof.
    split; auto.
    apply inc1_trans with (B := X ⊸ cl Y); auto.
  Qed.

  Hint Resolve magicwand_eq_1 magicwand_eq_2 magicwand_eq_3.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ *)

  Proposition cl_equiv_2 X Y : cl (cl X ∘ Y) ≃ cl (X ∘ Y).
  Proof.
    split.
    rewrite <- cl_prop; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition cl_equiv_3 X Y : cl (X ∘ cl Y) ≃ cl (X ∘ Y).
  Proof.
    split.
    rewrite <- cl_prop; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition cl_equiv_4 X Y : cl (cl X ∘ cl Y) ≃ cl (X ∘ Y).
  Proof.
    split.
    rewrite <- cl_prop; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Hint Immediate cl_equiv_2 cl_equiv_3 cl_equiv_4.

  Proposition composes_associative_1 A B C : A ∘ (B ∘ C) ⊆ cl ((A ∘ B) ∘ C).
  Proof.
    intros _ [a _ k Ha [b c y Hb Hc Hy] Hk].
    generalize (@cl_associative a b c k); intros H.
    spec all in H.
    apply In_composes with (3 := Hk); auto.
    apply In_composes with (3 := Hy); auto.
    revert H.
    apply cl_monotone.
    repeat apply composes_monotone; apply sg_inc1; auto.
  Qed.

  Hint Immediate composes_associative_1.

  Proposition composes_associative A B C : cl (A ∘ (B ∘ C)) ≃ cl ((A ∘ B) ∘ C).
  Proof.
    split; auto.
    rewrite <- cl_prop; auto.
    rewrite <- cl_prop; auto.
    apply inc1_trans with (1 := @composes_commute_1 _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (B := C ∘ cl (A ∘ B)); auto.
    apply composes_monotone; auto.
    apply inc1_trans with (B := C ∘ cl (B ∘ A)); auto.
    apply composes_monotone; auto.
    apply composes_commute.
    apply inc1_trans with (1 := @cl_stable_r _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (1 := @composes_associative_1 _ _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (1 := @composes_commute_1 _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (B := A ∘ cl (C ∘ B)); auto.
    apply composes_monotone; auto.
    apply inc1_trans with (B := A ∘ cl (B ∘ C)); auto.
    apply composes_monotone; auto.
    apply composes_commute.
  Qed.

  Hint Immediate composes_associative.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ *)

  Proposition composes_congruent_1 A B C : A ⊆ cl B -> C ∘ A ⊆ cl (C ∘ B).
  Proof.
    intros ?.
    apply inc1_trans with (B := cl (C ∘ cl B)); auto.
    apply cl_prop, cl_monotone, composes_monotone; auto.
    apply cl_equiv_3.
  Qed.

  Hint Resolve composes_congruent_1.

  Proposition composes_congruent A B C : cl A ≃ cl B -> cl (C ∘ A) ≃ cl (C ∘ B).
  Proof.
    intros [H1 H2].
    rewrite <- cl_prop in H1.
    rewrite <- cl_prop in H2.
    split; rewrite <- cl_prop;
    apply inc1_trans with (2 := @cl_stable_r _ _), composes_monotone; auto.
  Qed.

  Proposition composes_assoc_special A A' B B' : cl((A∘A') ∘ (B∘B')) ≃ cl ((A∘B) ∘ (A'∘B')).
  Proof.
    do 2 apply eq1_sym, eq1_trans with (2 := composes_associative _ _ _).
    apply composes_congruent.
    apply eq1_sym, eq1_trans with (1 := composes_commute _ _).
    apply eq1_sym, eq1_trans with (2 := composes_associative _ _ _).
    apply composes_congruent, composes_commute.
  Qed.

  Definition composes_assoc_special_1 A A' B B' := proj1 (composes_assoc_special A A' B B').

  Proposition composes_neutral_1 A : A ⊆ cl (sg e ∘ A).
  Proof.
    intros a Ha.
    generalize (cl_neutral_1 a).
    apply cl_monotone, composes_monotone; auto.
    apply sg_inc1; auto.
  Qed.

  Proposition composes_neutral_2 A : sg e ∘ A ⊆ cl A.
  Proof.
    intros _ [y a x [] Ha Hx].
    generalize (@cl_neutral_2 a x); intros H.
    spec all in H.
    constructor 1 with e a; auto.
    revert H; apply cl_monotone, sg_inc1; auto.
  Qed.

  Hint Resolve composes_neutral_1 composes_neutral_2.

  Proposition composes_neutral A : cl (sg e ∘ A) ≃ cl A.
  Proof. split; rewrite <- cl_prop; auto. Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Notation "x 'glb' y " := (x ∩ y) (at level 50, no associativity).
  Notation "x 'lub' y" := (cl (x ∪ y)) (at level 50, no associativity).

  Proposition closed_glb A B : closed A -> closed B -> closed (A glb B).
  Proof.
    simpl; intros HA HB x Hx; split;
      [ apply HA | apply HB ]; revert x Hx;
      apply cl_monotone; tauto.
  Qed.

  Proposition lub_out A B C : closed C -> A ⊆ C -> B ⊆ C -> A lub B ⊆ C.
  Proof.
    simpl.
    intros H1 H2 H3.
    apply inc1_trans with (2 := H1), cl_monotone.
    intros ? [ ]; auto.
  Qed.

  Proposition glb_in A B C : C ⊆ A -> C ⊆ B -> C ⊆ A glb B.
  Proof. simpl; split; auto. Qed.

  Proposition closed_lub A B : closed (A lub B).        Proof. simpl; apply cl_idempotent. Qed.
  Proposition glb_out_l A B  : A glb B ⊆ A .            Proof. simpl; tauto. Qed.
  Proposition glb_out_r A B  : A glb B ⊆ B.             Proof. simpl; tauto. Qed.
  Proposition lub_in_l A B   : A ⊆ A lub B.             Proof. apply inc1_trans with (2 := cl_increase _); tauto. Qed.
  Proposition lub_in_r A B   : B ⊆ A lub B.             Proof. apply inc1_trans with (2 := cl_increase _); tauto. Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Notation "x ⊛ y " := (cl (x ∘ y)) (at level 59).

  Proposition closed_times A B : closed (A⊛B).
  Proof. simpl; apply cl_idempotent. Qed.

  Proposition times_monotone A A' B B' : A ⊆ A' -> B ⊆ B' -> A⊛B ⊆ A'⊛B'.
  Proof. simpl; intros ? ?; apply cl_monotone, composes_monotone; auto. Qed.

  Notation top := (fun _ : M => True).
  Notation bot := (cl (fun _ => False)).
  Notation unit := (cl (sg e)).

  Proposition closed_top     : closed top.         Proof. simpl; intros; auto. Qed.
  Proposition closed_bot     : closed bot.         Proof. simpl; apply cl_idempotent. Qed.
  Proposition closed_unit    : closed unit.        Proof. simpl; apply cl_idempotent. Qed.
  Proposition top_greatest A : A ⊆ top.            Proof. simpl; tauto. Qed.

  Hint Resolve closed_glb closed_top.

  Fact closed_mglb ll : Forall closed ll -> closed (fold_right (fun x y => x ∩ y) top ll).
  Proof. induction 1; simpl; auto. Qed.

  Hint Resolve closed_mglb.

  Proposition bot_least A : closed A -> bot ⊆ A.
  Proof. intro H; apply inc1_trans with (2 := H), cl_monotone; tauto. Qed.

  Proposition unit_neutral_1 A : closed A -> unit ⊛ A ⊆ A.
  Proof.
    intros H; apply inc1_trans with (2 := H).
    rewrite <- cl_prop.
    apply inc1_trans with (1 := @cl_stable_l _ _).
    rewrite <- cl_prop.
    apply composes_neutral_2.
  Qed.

  Proposition unit_neutral_2 A : A ⊆ unit ⊛ A.
  Proof.
    intros a Ha; simpl.
    generalize (composes_neutral_1 _ _ Ha).
    apply cl_monotone, composes_monotone; auto.
  Qed.

(*  Hint Resolve unit_neutral_1 unit_neutral_2. *)

  Proposition unit_neutral A : closed A -> unit ⊛ A ≃ A.
  Proof.
    intros H; split.
    revert H; apply unit_neutral_1.
    apply unit_neutral_2.
  Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Proposition times_commute_1 A B : A⊛B ⊆ B⊛A.
  Proof. simpl; apply cl_inc, composes_commute_1. Qed.

  Hint Resolve unit_neutral times_commute_1.

  Proposition times_commute A B : A⊛B ≃ B⊛A.
  Proof. split; auto. Qed.

  Proposition unit_neutral' A : closed A -> A ⊛ unit ≃ A.
  Proof. intros ?; apply eq1_trans with (1 := times_commute _ _); auto. Qed.

  Proposition times_associative A B C : (A⊛B)⊛C ≃ A⊛(B⊛C).
  Proof.
    apply eq1_sym, eq1_trans with (1 := cl_equiv_3 _ _ ).
    apply eq1_sym, eq1_trans with (1 := cl_equiv_2 _ _ ).
    apply eq1_sym, composes_associative.
  Qed.

  Proposition times_associative_1 A B C : (A⊛B)⊛C ⊆ A⊛(B⊛C).     Proof. apply times_associative. Qed.
  Proposition times_associative_2 A B C : A⊛(B⊛C) ⊆ (A⊛B)⊛C.     Proof. apply times_associative. Qed.

  Hint Resolve times_associative_1 times_associative_2.

  Proposition times_congruence A A' B B' : A ≃ A' -> B ≃ B' -> A⊛B ≃ A'⊛B'.
  Proof.
    intros H1 H2.
    apply eq1_trans with (A ⊛ B').
    apply composes_congruent; auto.
    do 2 apply eq1_sym, eq1_trans with (1 := times_commute _ _).
    apply composes_congruent; auto.
  Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Proposition adjunction_1 A B C : closed C -> A ⊛ B ⊆ C -> A ⊆ B ⊸ C.
  Proof. intros ? H; apply magicwand_adj_1, inc1_trans with (2 := H); auto. Qed.

  Proposition adjunction_2 A B C : closed C -> A ⊆ B ⊸ C -> A ⊛ B ⊆ C.
  Proof. intros H ?; apply inc1_trans with (2 := H), cl_monotone, magicwand_adj_2; auto. Qed.

  Hint Resolve times_congruence adjunction_1 (* adjunction_2 *).

  Proposition adjunction A B C : closed C -> (A ⊛ B ⊆ C <-> A ⊆ B ⊸ C).
  Proof.
    split; [ apply adjunction_1 | apply  adjunction_2 ]; auto.
  Qed.

  Proposition times_bot_distrib_l A : bot ⊛ A ⊆ bot.
  Proof.
    apply adjunction_2; auto.
    apply bot_least; auto.
  Qed.

  Proposition times_bot_distrib_r A : A ⊛ bot ⊆ bot.
  Proof. apply inc1_trans with (1 := @times_commute_1 _ _), times_bot_distrib_l. Qed.

  Hint Immediate times_bot_distrib_l times_bot_distrib_r.

  Proposition times_lub_distrib_l A B C : (A lub B) ⊛ C ⊆ (A ⊛ C) lub (B ⊛ C).
  Proof.
    apply adjunction, lub_out; auto;
    apply adjunction; auto.
  Qed.

  Proposition times_lub_distrib_r A B C : C ⊛ (A lub B) ⊆ (C ⊛ A) lub (C ⊛ B).
  Proof.
    apply inc1_trans with (1 := @times_commute_1 _ _),
          inc1_trans with (1 := @times_lub_distrib_l _ _ _); auto.
    apply lub_out; auto.
  Qed.

(*  Section bang. *)

    (* J := { x | x ∈ unit /\ x ∈ x ⊛ x } with unit = cl e and x ⊛ x = cl (x∘x) *)

    Let J x := cl (sg e) x /\ (cl (sg x ∘ sg x)) x.

    Let In_J : forall x, cl (sg e) x -> (cl (sg x ∘ sg x)) x -> J x.
    Proof. split; auto. Qed.

    Let J_inv x : J x -> unit x /\ cl (sg x ∘ sg x) x.
    Proof. auto. Qed.

    Proposition J_inc_unit : J ⊆ unit.
    Proof. induction 1; trivial. Qed.

    Variable K : M -> Prop.

    Notation sub_monoid_hyp_1 := ((cl K) e).
    Notation sub_monoid_hyp_2 := (K ∘ K ⊆ K).
    Notation sub_J_hyp := (K ⊆ J).

    Hypothesis sub_monoid_1 : sub_monoid_hyp_1.
    Hypothesis sub_monoid_2 : sub_monoid_hyp_2.
    Hypothesis sub_J : sub_J_hyp.

    Proposition K_inc_unit : K ⊆ unit.
    Proof. apply (inc1_trans _ J); trivial; apply J_inc_unit. Qed.

   (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ❗ *)

    Proposition K_compose A B : (K ∩ A) ∘ (K ∩ B) ⊆ K ∩ (A ∘ B).
    Proof.
      intros x Hx.
      induction Hx as [ a b c [ ] [ ] Hc ]; split.
      + apply sub_monoid_2; constructor 1 with a b; auto.
      + constructor 1 with a b; auto.
    Qed.

    Let bang A := cl (K∩A).

    Notation "❗ A" := (bang A) (at level 40, no associativity).

    Fact store_inc_unit A : ❗ A ⊆ unit.
    Proof.
      apply inc1_trans with (cl K).
      + apply cl_monotone; tauto.
      + apply cl_inc, K_inc_unit.
    Qed.

    Hint Resolve store_inc_unit.

    Proposition closed_store A : closed (❗A).
    Proof. simpl; apply cl_idempotent. Qed.

    Proposition store_dec A : closed A -> ❗A ⊆ A.
    Proof.
      intros HA; simpl.
      apply inc1_trans with (cl A); trivial.
      apply cl_monotone.
      apply glb_out_r.
    Qed.

    Fact store_monotone A B : A ⊆ B -> ❗A ⊆ ❗B.
    Proof.
      intro; apply cl_monotone.
      intros ? []; split; auto.
    Qed.

    Proposition store_der A B : closed B -> ❗A ⊆ B -> ❗A ⊆ ❗B.
    Proof.
      unfold bang.
      intros ? ?; apply cl_monotone; intros x []; split; auto.
    Qed.

    Proposition store_unit_1 : unit ⊆ ❗top.
    Proof.
      apply cl_inc.
      intros ? []; apply cl_monotone with K; auto.
    Qed.

    Hint Resolve J_inc_unit.

    Proposition store_unit_2 : ❗top ⊆ unit.
    Proof.
      apply cl_inc; trivial.
      apply inc1_trans with J; auto.
      intros ? []; auto.
    Qed.

    Hint Resolve store_unit_1 store_unit_2.

    Proposition store_unit : unit ≃ ❗top.
    Proof. split; auto. Qed.

    (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ❗ *)

    Proposition store_comp A B : closed A -> closed B -> ❗A ⊛ ❗B ≃ ❗(A∩B).
    Proof.
      intros HA HB; split.
      + apply inc1_trans with (cl ((K glb A) ∘ (K glb B))).
        * apply cl_inc; trivial; apply cl_stable.
        * apply cl_monotone.
          intros x [ a b c [ H1 H2 ] [ H3 H4 ] Hc ].
          assert (H5 : unit a). { apply K_inc_unit; auto. }
          assert (H6 : unit b). { apply K_inc_unit; auto. }
          split; [ | split ].
          - apply sub_monoid_2; constructor 1 with a b; auto.
          - apply unit_neutral_1; auto; apply times_commute_1, cl_increase.
            constructor 1 with a b; auto.
          - apply unit_neutral_1; auto; apply cl_increase.
            constructor 1 with a b; auto.
      + apply cl_inc; trivial.
        intros x (H1 & H2 & H3).
        apply cl_monotone with (sg x ∘ sg x).
        2: { apply sub_J in H1; destruct H1; trivial. }
        intros d [ a b ? ? Hab ]; subst a b; constructor 1 with x x; auto;
          apply cl_increase; auto.
    Qed.

    Let ltimes := fold_right (fun x y => x ⊛ y) unit.
    Let lcap := fold_right (fun x y => x∩y) top.

    Proposition ltimes_store ll :
           Forall closed ll
        -> ltimes (map bang  ll)
         ≃ ❗(lcap ll).
    Proof.
      unfold ltimes, lcap.
      induction 1 as [ | A ll H1 H2 IH2 ]; auto.
      + simpl; auto.
      + simpl.
        apply eq1_trans with (❗A ⊛ ❗(fold_right (fun x y => x ∩ y) top ll)).
        * apply times_congruence; auto.
        * apply eq1_trans with (❗(A ∩ fold_right (fun x y => x ∩ y) top ll)); auto.
          apply store_comp; auto.
    Qed.

    Proposition store_compose_idem A : closed A -> ❗A ⊆ ❗A⊛❗A.
    Proof.
      intros HA.
      apply inc1_trans with (❗(A∩A)).
      + apply store_der.
        * apply closed_glb; trivial.
        * apply inc1_trans with A.
          - apply store_dec; trivial.
          - tauto.
      + apply (proj2 (store_comp HA HA)).
    Qed.

(*  End bang. *)

  Reserved Notation "'⟦' A '⟧'" (at level 49).
  Reserved Notation "'⟬߭' A '⟭'" (at level 49).

  Variable (v : ill_vars -> M -> Prop) (Hv : forall x, cl (v x) ⊆ v x).

  Fixpoint Form_sem f :=
    match f with
      | ⟘             => bot
      | ⟙             => top
      | 𝝐              => unit
      | £ x    => v x
      | a -o b => ⟦a⟧ ⊸ ⟦b⟧
      | a ⊗ b  => ⟦a⟧ ⊛ ⟦b⟧
      | a ⊕ b  => ⟦a⟧ lub ⟦b⟧
      | a & b  => ⟦a⟧ glb ⟦b⟧
      | !a     => ❗⟦a⟧
    end
  where "⟦ a ⟧" := (Form_sem a).

  Fact closed_Form_sem f : cl (⟦f⟧) ⊆ ⟦f⟧.
  Proof. induction f as [ | [] | | [] ]; simpl; unfold bang; auto. Qed.

  Definition list_Form_sem ll := fold_right (fun x y => x⊛y) unit (map Form_sem ll).

  Notation "⟬߭  ll ⟭" := (list_Form_sem ll).

  Fact list_Form_sem_cons f ll : ⟬߭f::ll⟭  = ⟦f⟧ ⊛ ⟬߭ll⟭.
  Proof. auto. Qed.

  Fact closed_list_Form_sem ll : cl (⟬߭ll⟭) ⊆ ⟬߭ll⟭.
  Proof. unfold list_Form_sem; induction ll; simpl; auto. Qed.

  Hint Resolve closed_Form_sem closed_list_Form_sem.

  Fact list_Form_sem_app ll mm : ⟬߭ll++mm⟭ ≃ ⟬߭ll⟭ ⊛⟬߭mm⟭.
  Proof.
    induction ll as [ | f ll IHll ]; simpl app; auto.
    + apply eq1_sym, unit_neutral; auto.
    + apply eq1_sym, eq1_trans with (1 := @times_associative _ _ _), eq1_sym.
      apply times_congruence; auto.
  Qed.

  Fact list_Form_sem_perm ll mm: ll ~p mm -> ⟬߭ll⟭  ≃ ⟬߭mm⟭ .
  Proof.
    induction 1 as [ | x l m _ IHl | x y l | l m k ]; auto.
    + apply composes_congruent, cl_eq1; auto.
    + simpl; do 2 apply eq1_sym, eq1_trans with (2 := @times_associative _ _ _).
      apply times_congruence; auto.
    + apply eq1_trans with (⟬߭m⟭ ); auto.
  Qed.

  Fact list_Form_sem_bang ll : ⟬߭‼ll⟭ ≃ ❗ (lcap (map Form_sem ll)).
  Proof.
    unfold list_Form_sem.
    assert (Forall closed (map Form_sem ll)) as Hll.
    { apply Forall_map, Forall_forall; auto. }
    apply eq1_trans with (2 := ltimes_store Hll).
    rewrite map_map.
    apply equal_eq1; clear Hll.
    induction ll as [ | a ll IHll ]; simpl; auto.
    rewrite IHll; auto.
  Qed.

  (* All the rules of the ILL sequent calculus (including cut) are closed
     under relational phase semantics, hence we deduce the following
     soundness theorem *)

  Theorem ill_Form_sem_sound Γ a : Γ ⊢ a -> ⟬߭Γ⟭  ⊆ ⟦a⟧.
  Proof.
    induction 1 as [ a
                   | Ga De a H1 H2 IH2
                   | Ga De a b c H1 IH1 H2 IH2
                   | Ga a b H1 IH1
                   | Ga a b c H1 IH1
                   | Ga a b c H1 IH1
                   | Ga a b H1 IH1 H2 IH2
                   | Ga a b H1 IH1
                   | Ga a H1 IH1
                   | Ga a b H1 IH1
                   | Ga a b H1 IH1

                   | Ga De a b H1 IH1 H2 IH2
                   | Ga a b c H1 IH1
                   | Ga De a b H1 IH1 H2 IH2
                   | Ga a b c H1 IH1 H2 IH2
                   | Ga a b H1 IH1
                   | Ga a b H1 IH1
                   | Ga a
                   | Ga
                   | Ga a H1 IH1
                   |
                   ]; simpl in *; auto.
      (* axiom *)
    + intro; apply unit_neutral'; auto.

      (* permutation *)
    + intros x Hx; apply IH2; revert Hx; apply list_Form_sem_perm; auto.

      (* -o left *)
    + intros x Hx.
      apply IH2.
      revert x Hx.
      apply inc1_trans with (((⟦ a ⟧ ⊸ ⟦ b ⟧) ⊛ ⟬߭Ga⟭)⊛ ⟬߭De⟭).
      * apply inc1_trans with (2 := @times_associative_2 _ _ _).
        apply times_monotone; auto.
        apply list_Form_sem_app.
      * apply times_monotone; auto.
        apply adjunction; auto.
        apply magicwand_monotone; auto.
    + apply adjunction; auto.
      rewrite list_Form_sem_cons in IH1.
      intros; apply IH1; auto.

      (* plus *)
    + apply inc1_trans with (2 := IH1), times_monotone; simpl; tauto.
    + apply inc1_trans with (2 := IH1), times_monotone; simpl; tauto.

      (* bang *)
    + apply inc1_trans with (2 := IH1), times_monotone; auto.
      apply cl_closed; auto; tauto.
    + intros x Hx.
      apply list_Form_sem_bang in Hx; revert x Hx.
      apply store_der; auto.
      intros x Hx; apply IH1, list_Form_sem_bang; auto.
    + intros x Hx; apply IH1.
      apply unit_neutral_1; auto.
      revert x Hx; apply times_monotone; auto.
      apply store_inc_unit.
    + intros x Hx; apply IH1.
      apply times_associative_1.
      revert x Hx; apply times_monotone; auto.
      simpl; intros x Hx; apply store_comp; auto.
      revert x Hx; apply store_monotone; tauto.

      (* cut rule *)
    + intros x Hx.
      apply list_Form_sem_app in Hx.
      apply IH2.
      revert x Hx; apply times_monotone; auto.

      (* times *)
    + intros x Hx; simpl.
      apply IH1.
      revert Hx; do 3 rewrite list_Form_sem_cons; simpl; auto.
    + intros x Hx; apply list_Form_sem_app in Hx.
      revert x Hx; apply times_monotone; auto.

      (* plus *)
    + intros x Hx.
      apply times_lub_distrib_l in Hx.
      revert Hx; apply cl_closed; auto.
      intros ? []; auto.

    + (* bot *)
      intros x Hx.
      apply times_bot_distrib_l in Hx.
      revert x Hx; apply bot_least; auto.

      (* unit *)
    + intros x Hx.
      rewrite list_Form_sem_cons in Hx; simpl in Hx.
      apply unit_neutral_1 in Hx; auto.
  Qed.

End Relational_phase_semantics.

Local Infix "∘" := (@Composes _ _) (at level 50, no associativity).

Check ill_Form_sem_sound.
Print Assumptions ill_Form_sem_sound.


Require Export NArith.
Require Import ZArith.
Require Import NatAux.

Open Scope N_scope.

Theorem Nle_le n m : (N.to_nat n <= N.to_nat m)%nat -> n <= m.
Proof.
case n; case m; unfold N.le; simpl; try (intros; discriminate).
intros p; elim p using Pind; simpl.
intros H1; inversion H1.
intros n1 _; rewrite nat_of_P_succ_morphism.
intros H1; inversion H1.
intros p1 p2 H1 H2; absurd (nat_of_P p2 > nat_of_P p1)%nat; auto with arith.
apply nat_of_P_gt_Gt_compare_morphism; auto.
Qed.

Theorem le_Nle n m : N.of_nat n <= N.of_nat m -> (n <= m)%nat.
Proof.
case n; case m; unfold N.le; simpl; auto with arith.
intros n1 H1; case H1; auto.
intros m1 n1 H1; case (Nat.le_gt_cases n1 m1); auto with arith.
intros H2; case H1.
apply nat_of_P_gt_Gt_compare_complement_morphism.
repeat rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith.
Qed.

Theorem Nle_le_rev n m : n <= m -> (N.to_nat n <= N.to_nat m)%nat.
Proof. intros; apply le_Nle; repeat rewrite N2Nat.id; auto. Qed.

Theorem Nlt_lt n m : (N.to_nat n < N.to_nat m)%nat -> n < m.
Proof.
case n; case m; unfold N.lt; simpl; try (intros; discriminate); auto.
intros H1; inversion H1.
intros p H1; inversion H1.
intros; apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
Qed.

Theorem lt_Nlt n m : N.of_nat n < N.of_nat m -> (n < m)%nat.
Proof.
case n; case m; unfold N.lt; simpl; try (intros; discriminate); auto with arith.
intros m1 n1 H1.
rewrite <- (Nat2N.id (S n1)); rewrite <- (Nat2N.id (S m1)).
simpl; apply nat_of_P_lt_Lt_compare_morphism; auto.
Qed.

Theorem Nlt_lt_rev n m : n < m -> (N.to_nat n < N.to_nat m)%nat.
Proof. intros; apply lt_Nlt; repeat rewrite N2Nat.id; auto. Qed.

Theorem Nge_ge n m : (N.to_nat n >= N.to_nat m)%nat -> n >= m.
Proof.
case n; case m; unfold N.ge; simpl; try (intros; discriminate); auto.
intros p; elim p using Pind; simpl.
intros H1; inversion H1.
intros n1 _; rewrite nat_of_P_succ_morphism.
intros H1; inversion H1.
intros p1 p2 H1 H2; absurd (nat_of_P p2 < nat_of_P p1)%nat; auto with arith.
apply nat_of_P_lt_Lt_compare_morphism; auto.
Qed.

Theorem ge_Nge n m : N.of_nat n >= N.of_nat m -> (n >= m)%nat.
Proof.
case n; case m; unfold N.ge; simpl; try (intros; discriminate); auto with arith.
intros n1 H1; case H1; auto.
intros m1 n1 H1.
case (Nat.le_gt_cases m1 n1); auto with arith.
intros H2; case H1.
apply nat_of_P_lt_Lt_compare_complement_morphism.
repeat rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith.
Qed.

Theorem Nge_ge_rev n m : n >= m -> (N.to_nat n >= N.to_nat m)%nat.
Proof. intros; apply ge_Nge; repeat rewrite N2Nat.id; auto. Qed.

Theorem Ngt_gt n m : (N.to_nat n > N.to_nat m)%nat -> n > m.
Proof.
case n; case m; unfold N.gt; simpl; try (intros; discriminate); auto.
intros H1; inversion H1.
intros p H1; inversion H1.
intros; apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
Qed.

Theorem gt_Ngt n m : N.of_nat n > N.of_nat m -> (n > m)%nat.
Proof.
case n; case m; unfold N.gt; simpl; try (intros; discriminate); auto with arith.
intros m1 n1 H1.
rewrite <- (Nat2N.id (S n1)); rewrite <- (Nat2N.id (S m1)).
simpl; apply nat_of_P_gt_Gt_compare_morphism; auto.
Qed.

Theorem Ngt_gt_rev n m : n > m -> (N.to_nat n > N.to_nat m)%nat.
Proof. intros; apply gt_Ngt; repeat rewrite N2Nat.id; auto. Qed.

Theorem Neq_eq_rev n m : n = m -> (N.to_nat n = N.to_nat m)%nat.
Proof. intros H; rewrite H; auto. Qed.

Theorem Nmult_lt_compat_l n m p : n < m -> 0 < p -> p * n < p * m.
Proof.
intros H1 H2; apply Nlt_lt; repeat rewrite N2Nat.inj_mul.
apply mult_lt_compat_l; apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_le_compat_l n m p : n <= m -> p * n <= p * m.
Proof.
intros H1; apply Nle_le; repeat rewrite N2Nat.inj_mul.
apply Nat.mul_le_mono_l; apply le_Nle; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_ge_compat_l n m p : n >= m -> p * n >= p * m.
Proof.
intros H1; apply Nge_ge; repeat rewrite N2Nat.inj_mul.
apply mult_ge_compat_l; apply ge_Nge; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_gt_compat_l n m p : n > m -> p > 0 -> p * n > p * m.
Proof.
intros H1 H2; apply Ngt_gt; repeat rewrite N2Nat.inj_mul.
apply mult_gt_compat_l; apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_lt_compat_rev_l1 n m p : p * n < p * m -> 0 < p.
Proof.
intros H1; apply Nlt_lt.
apply mult_lt_compat_rev_l1 with (nat_of_N n) (nat_of_N m).
repeat rewrite <- N2Nat.inj_mul; apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_lt_compat_rev_l2 n m p : p * n < p * m -> n < m.
Proof.
intros H1; apply Nlt_lt; apply mult_lt_compat_rev_l2 with (nat_of_N p).
repeat rewrite <- N2Nat.inj_mul; apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_gt_compat_rev_l1 n m p : p * n > p * m -> p > 0.
Proof.
intros H1; apply Ngt_gt.
apply mult_gt_compat_rev_l1 with (nat_of_N n) (nat_of_N m).
repeat rewrite <- N2Nat.inj_mul; apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_gt_compat_rev_l2 n m p : p * n > p * m -> n > m.
Proof.
intros H1; apply Ngt_gt; apply mult_gt_compat_rev_l2 with (nat_of_N p).
repeat rewrite <- N2Nat.inj_mul; apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_le_compat_rev_l n m p : p * n <= p * m -> 0 < p -> n <= m.
Proof.
intros H1 H2; apply Nle_le; apply mult_le_compat_rev_l with (nat_of_N p).
repeat rewrite <- N2Nat.inj_mul; apply le_Nle; repeat rewrite N2Nat.id; auto.
apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nmult_ge_compat_rev_l n m p : p * n >= p * m -> 0 < p -> n >= m.
Proof.
intros H1 H2; apply Nge_ge; apply mult_ge_compat_rev_l with (nat_of_N p).
repeat rewrite <- N2Nat.inj_mul; apply ge_Nge; repeat rewrite N2Nat.id; auto.
apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nlt_mult_0 a b : 0 < a -> 0 < b -> 0 < a * b.
Proof.
intros H1 H2; apply Nlt_lt; rewrite N2Nat.inj_mul; apply lt_mult_0;
  apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Ngt_mult_0 a b : a > 0 -> b > 0 -> a * b > 0.
Proof.
intros H1 H2; apply Ngt_gt; rewrite N2Nat.inj_mul; apply gt_mult_0;
    apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nlt_mult_rev_0_l a b : 0 < a * b -> 0 < a .
Proof.
intros H1; apply Nlt_lt; apply lt_mult_rev_0_l with (nat_of_N b).
rewrite <- N2Nat.inj_mul; apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nlt_mult_rev_0_r a b : 0 < a * b -> 0 < b .
Proof.
intros H1; apply Nlt_lt; apply lt_mult_rev_0_r with (nat_of_N a).
rewrite <- N2Nat.inj_mul; apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Ngt_mult_rev_0_l a b : a * b > 0 -> a > 0.
Proof.
intros H1; apply Ngt_gt; apply gt_mult_rev_0_l with (nat_of_N b).
rewrite <- N2Nat.inj_mul; apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Ngt_mult_rev_0_r a b : a * b > 0 -> b > 0 .
Proof.
intros H1; apply Ngt_gt; apply gt_mult_rev_0_r with (nat_of_N a).
rewrite <- N2Nat.inj_mul; apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nle_0_eq_0 n : n <= 0 -> n = 0.
Proof.
intros H1; rewrite <- (N2Nat.id n).
rewrite (le_0_eq_0 (nat_of_N n)); auto.
apply le_Nle; rewrite N2Nat.id; auto.
Qed.

Theorem Nge_0_eq_0 n : 0 >= n -> n = 0.
Proof.
intros H1; rewrite <- (N2Nat.id n).
rewrite (le_0_eq_0 (nat_of_N n)); auto.
change (0 >= nat_of_N n)%nat.
apply ge_Nge; rewrite N2Nat.id; auto.
Qed.

Import BinPos.

Ltac to_nat_op :=
  match goal with
  | H: (N.lt _ _) |- _ => generalize (Nlt_lt_rev _ _ H); clear H; intros H
  | H: (N.gt _ _) |- _ => generalize (Ngt_gt_rev _ _ H); clear H; intros H
  | H: (N.le _ _) |- _ => generalize (Nle_le_rev _ _ H); clear H; intros H
  | H: (N.ge _ _) |- _ => generalize (Nge_ge_rev _ _ H); clear H; intros H
  | H: (@eq N _ _) |- _ => generalize (Neq_eq_rev _ _ H); clear H; intros H
  | |- (N.lt _ _) => apply Nlt_lt
  | |- (N.le _ _) => apply Nle_le
  | |- (N.gt _ _) => apply Ngt_gt
  | |- (N.ge _ _) => apply Nge_ge
  | |- (@eq N _ _) => apply Nat2N.inj
  end.

Ltac set_to_nat :=
  let nn := fresh "nn" in
  match goal with
  | |- context [(N.to_nat (?X + ?Y)%N)] => rewrite N2Nat.inj_add
  | |- context [(N.to_nat (?X * ?Y)%N)] => rewrite N2Nat.inj_mul
  | |- context [(N.to_nat ?X)] => set (nn:=N.to_nat X) in * |- *
  | H: context [(N.to_nat (?X + ?Y)%N)] |- _ => rewrite N2Nat.inj_add in H
  | H: context [(N.to_nat (?X + ?Y)%N)] |- _ => rewrite N2Nat.inj_mul in H
  | H: context [(N.to_nat ?X)] |- _ => set (nn:=N.to_nat X) in * |- *
  end.

Ltac to_nat := repeat to_nat_op; repeat set_to_nat.

Theorem Nle_gt_trans n m p : m <= n -> m > p -> n > p.
Proof. intros; to_nat; apply Nat.lt_le_trans with nn1; auto. Qed.

Theorem Ngt_le_trans n m p : n > m -> p <= m -> n > p.
Proof. intros; to_nat; apply Nat.le_lt_trans with nn1; auto. Qed.

Theorem Nle_add_l x y : x <= y + x.
Proof. intros; to_nat; auto with arith. Qed.

Close Scope N_scope.


Require Import Nat
  PeanoNat Coq.Logic.EqdepFacts
  Coq.Logic.Eqdep_dec
  Coq.Arith.Peano_dec.

Section Vector.

  Inductive Vector (A : Type) : nat -> Type :=
  | Nil : Vector A 0
  | Cons n : A -> Vector A n -> Vector A (S n).

  Check Nil.
  Eval compute in Nil nat.
  Check Cons.
  Eval compute in Cons _ _ 10 (Nil nat).
  Eval compute in Cons _ _ 20 (Cons _ _ 10 (Nil nat)).

  Arguments Nil {A}.
  Arguments Cons {A n}.
  Eval compute in Cons 20 (Cons 10 Nil).

  Fixpoint vector_append_first {A : Type} {m n : nat}
    (u : Vector A m) (v : Vector A n) : Vector A (m + n) :=
    match u with
    | Nil => v
    | Cons h t => Cons h (vector_append_first t v)
    end.

  Fixpoint vector_append_second {A : Type} {m n : nat}
    (u : Vector A m) (v : Vector A n) : Vector A (m + n) :=
    match u as u' in Vector _ m'
      return m = m' -> Vector A (m' + n)
    with
    | Nil => fun Hm => v (* m = 0 *)
    | Cons h t => fun Hm => Cons h (vector_append_second t v)
      (* m = S m' for some m' *)
    end eq_refl.

  Fixpoint vector_append_third {A : Type} {m n : nat}
    (u : Vector A m) (v : Vector A n) : Vector A (m + n).
  Proof.
    refine(
      match u as u' in Vector _ m'
      return m = m' -> Vector A (m' + n)
    with
    | Nil => fun _ => v
    | Cons h t => fun _ =>
      (Cons h (vector_append_third _ _ _ t v))
    end eq_refl).
  Defined.

  Definition vector_append_fourth {A : Type} {m n : nat}
     (u : Vector A m) (v : Vector A n) : Vector A (m + n).
  Proof.
    generalize dependent n.
    generalize dependent m.
    refine(
      fix Fn m u {struct u} :=
      match u as u' in Vector _ m'
        return forall (pf : m = m'),
          u = eq_rect m' (fun w => Vector A w)
              u' m (eq_sym pf) ->
          forall n : nat,
          Vector A n -> Vector A (m' + n)
      with
      | Nil => fun _ _ _  v => v
      | Cons h t => fun _ _ _ v =>
      (Cons h (Fn _ t _ v))
      end eq_refl eq_refl).
  Defined.

  Lemma append_nil_left {A : Type} {n : nat} :
    forall (v : Vector A n),
    vector_append_fourth Nil v = v.
  Proof.
    refine (fun v => eq_refl).
  Defined.

  Definition cast_vector {A : Type} {m n : nat} :
    Vector A m -> m = n -> Vector A n.
  Proof.
    intros u H.
    refine
      match H with
      | eq_refl => u
      end.
  Defined.

  Lemma uip_nat {n : nat} (pf : n = n) : pf = eq_refl.
  Proof.
    apply UIP_dec,
    eq_nat_dec.
  Qed.

  Lemma append_nil_right_ind_gen_tactic {A : Type}
    {n m : nat} :
    forall (a : A) (u : Vector A n)
    (Ha : S n = S m)
    (Hb : n = m),
    cast_vector (Cons a u) Ha =
    Cons a (cast_vector u Hb).
  Proof.
    intros *.
    subst.
    assert (Hapf : Ha = eq_refl).
    apply uip_nat.
    rewrite Hapf.
    simpl.
    reflexivity.
  Defined.

  Lemma append_nil_right_ind_gen_prog {A : Type}
    {n m : nat} :
    forall (a : A) u
    (Ha : S m = S n)
    (Hb : m = n),
    cast_vector (Cons a u) Ha =
    Cons a (cast_vector u Hb).
  Proof.
    intros a u Ha.
    refine(
      match Ha as Ha' in (_ = S n')
        return forall (pf : n = n'),
        Ha = eq_rect (S n') _ Ha' (S n)
            (eq_S _ _ (eq_sym pf)) ->
        forall Hb : m = n',
        cast_vector (Cons a u) Ha' =
        Cons a (cast_vector u Hb)
      with
      | eq_refl => fun Hpf Hb Hbpf =>
        match Hbpf as Hbpf' in (_ = m')
        return forall (pf : m = m'),
          Hbpf' = eq_rect m _ eq_refl m' pf ->
          cast_vector (Cons a u) eq_refl =
          eq_rect (S m') _ (Cons a (cast_vector u Hbpf'))
          (S m) (eq_S _ _ (eq_sym pf))
        with
        | eq_refl => _
        end eq_refl _
      end eq_refl eq_refl).
    + intros *.
      cbn.
      rewrite (uip_nat pf).
      simpl.
      reflexivity.
    + simpl.
      apply uip_nat.
  Defined.

  Lemma append_nil_right_ind {A : Type} {n : nat} :
    forall (a : A) (u : Vector A n),
    cast_vector (Cons a u) (plus_n_O (S n)) =
    Cons a (cast_vector u (plus_n_O n)).
  Proof.
    intros *.
    apply append_nil_right_ind_gen_tactic.
  Qed.

  Lemma append_nil_right {A : Type} {n : nat} :
    forall (u : Vector A n),
    vector_append_fourth u Nil =
    cast_vector u (plus_n_O n).
  Proof.
    induction u.
    + simpl.
      refine
        match (plus_n_O 0) with
        | eq_refl => eq_refl
        end.
    + simpl.
      rewrite IHu.
      symmetry.
      apply append_nil_right_ind.
  Qed.

  (* generalisation is the key *)
  Lemma append_associative_gen {A : Type} :
    forall {m : nat} (u : Vector A m)
    {n o : nat} (v : Vector A n) (w : Vector A o)
    (Ha : m + n + o = m + (n + o)),
    vector_append_fourth u (vector_append_fourth v w) =
    cast_vector (vector_append_fourth (vector_append_fourth u v) w) Ha.
  Proof.
    refine(
      fix Fn m u {struct u} :=
      match u as u' in Vector _ m'
      return m = m' ->  _
      with
      | Nil => _
      | Cons _ _ => _
      end eq_refl).
      + intros Hb ? ? ? ? ?;
        simpl in * |- *.
        assert (Ht : Ha = eq_refl).
        apply uip_nat.
        subst; simpl.
        exact eq_refl.
      + intros Hb ? ? ? ? ?;
        simpl in * |- *.
        inversion Ha as (Haa).
        erewrite append_nil_right_ind_gen_prog
        with (Hb := Haa).
        f_equal.
        apply Fn.
  Defined.

  Lemma append_associative {A : Type} :
    forall {m : nat} (u : Vector A m)
    {n o : nat} (v : Vector A n) (w : Vector A o),
    vector_append_fourth u (vector_append_fourth v w) =
    cast_vector (vector_append_fourth (vector_append_fourth u v) w)
    (eq_sym (Nat.add_assoc m n o)).
  Proof.
    intros until w.
    eapply append_associative_gen.
  Defined.