Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Init.Nat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.
Require Import maps.
Require Import imp.

(*
「停止しないこと」と「間違った設定によって行き詰まること」を区別するために１ステップ評価を実装する
 *)

Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm.

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n => n
  | P a1 a2 => evalF a1 + evalF a2
  end.

(*
                               ---------                               (E_Const)
                               C n ==> n

                               t1 ==> n1
                               t2 ==> n2
                           -------------------                         (E_Plus)
                           P t1 t2 ==> n1 + n2
 *)

Reserved Notation " t '==>' n " (at level 50, left associativity).

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
      C n ==> n
  | E_Plus : forall t1 t2 n1 n2,
      t1 ==> n1 ->
      t2 ==> n2 ->
      P t1 t2 ==> (n1 + n2)
where " t '==>' n " := (eval t n).

Module SimpleArith1.

(*
                     -------------------------------        (ST_PlusConstConst)
                     P (C n1) (C n2) --> C (n1 + n2)

                              t1 --> t1'
                         --------------------                        (ST_Plus1)
                         P t1 t2 --> P t1' t2

                              t2 --> t2'
                      ----------------------------                   (ST_Plus2)
                      P (C n1) t2 --> P (C n1) t2'

 *)

Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall n1 t2 t2',
      t2 --> t2' ->
      P (C n1) t2 --> P (C n1) t2'

  where " t '-->' t' " := (step t t').

Example test_step_1 :
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
      -->
      P
        (C (0 + 3))
        (P (C 2) (C 4)).
Proof.
  apply ST_Plus1. apply ST_PlusConstConst. Qed.

Example test_step_2 :
      P
        (C 0)
        (P
          (C 2)
          (P (C 0) (C 3)))
      -->
      P
        (C 0)
        (P
          (C 2)
          (C (0 + 3))).
Proof.
  apply ST_Plus2. apply ST_Plus2. apply ST_PlusConstConst. Qed.

End SimpleArith1.

Definition relation (X : Type) := X -> X -> Prop.

Definition deterministic {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Module SimpleArith2.
Import SimpleArith1.

Theorem step_deterministic:
  deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2.
  - inversion Hy2.
    + reflexivity.
    + inversion H2.
    + inversion H2.
  - inversion Hy2.
    +
      rewrite <- H0 in Hy1. inversion Hy1.
    +
      rewrite <- (IHHy1 t1'0).
      reflexivity. assumption.
    +
      rewrite <- H in Hy1. inversion Hy1.
  - inversion Hy2.
    +
      rewrite <- H1 in Hy1. inversion Hy1.
    + inversion H2.
    +
      rewrite <- (IHHy1 t2'0).
      reflexivity. assumption.
Qed.

End SimpleArith2.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Ltac solve_by_invert :=
  solve_by_inverts 1.

Module SimpleArith3.
Import SimpleArith1.

Theorem step_deterministic_alt: deterministic step.
Proof.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2;
    inversion Hy2; subst; try solve_by_invert.
  - reflexivity.
  -
    apply IHHy1 in H2. rewrite H2. reflexivity.
  -
    apply IHHy1 in H2. rewrite H2. reflexivity.
Qed.

End SimpleArith3.

(*値*)
Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).

(*
                     -------------------------------        (ST_PlusConstConst)
                     P (C n1) (C n2) --> C (n1 + n2)

                              t1 --> t1'
                         --------------------                        (ST_Plus1)
                         P t1 t2 --> P t1' t2

                               value v1
                              t2 --> t2'
                         --------------------                        (ST_Plus2)
 *)

Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
          P (C n1) (C n2)
      --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' ->
        P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        P v1 t2 --> P v1 t2'

  where " t '-->' t' " := (step t t').

Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros. generalize dependent y2.
  induction H; intros y2 H1;
    inversion H1; subst; try solve_by_invert.
  - reflexivity.
  -
    apply IHstep in H4. rewrite H4. reflexivity.
  -
    inversion H5; inversion H; subst; try solve_by_invert.
  -
    inversion H5; inversion H0; subst; try solve_by_invert.
  -
    apply IHstep in H6. rewrite H6. reflexivity.
Qed.

(*
定理 強進行 (Strong Progress): t が項であるならば、 tは値であるか、そうでなければある項t'が存在して t --> t' となる。
 *)
Theorem strong_progress : forall t,
  value t \/ (exists t', t --> t').
Proof.
  induction t.
  - left. apply v_const.
  - right. destruct IHt1 as [IHt1 | [t1' Ht1]].
    + destruct IHt2 as [IHt2 | [t2' Ht2]].
      * inversion IHt1. inversion IHt2.
        exists (C (n + n0)).
        apply ST_PlusConstConst.
      *
        exists (P t1 t2').
        apply ST_Plus2. apply IHt1. apply Ht2.
    +
      exists (P t1' t2).
      apply ST_Plus1. apply Ht1.
Qed.

Definition normal_form {X : Type} (R : relation X) (t : X) : Prop :=
  ~ exists t', R t t'.

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  unfold normal_form. intros v H. inversion H.
  intros contra. inversion contra. inversion H1.
Qed.

Lemma nf_is_value : forall t,
  normal_form step t -> value t.
Proof.   unfold normal_form. intros t H.
  assert (G : value t \/ exists t', t --> t').
  { apply strong_progress. }
  destruct G as [G | G].
  - apply G.
  - exfalso. apply H. assumption.
Qed.

Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof.
  split. apply nf_is_value. apply value_is_nf.
Qed.

(*Temp1 ~ 3 は間違った定義*)
Module Temp1.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n)
  | v_funny : forall t1 n2,
                value (P t1 (C n2)).
Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      P v1 t2 --> P v1 t2'

  where " t '-->' t' " := (step t t').

Lemma value_not_same_as_normal_form :
  exists v, value v /\ ~ normal_form step v.
Proof.
  exists (P (C 1) (C 2)).  split. apply v_funny. unfold normal_form. unfold not. intros H. apply H.
  exists (C 3). apply ST_PlusConstConst.
Qed.

End Temp1.

Module Temp2.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).
Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_Funny : forall n,
      C n --> P (C n) (C 0)
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      P v1 t2 --> P v1 t2'

  where " t '-->' t' " := (step t t').

Lemma value_not_same_as_normal_form :
  exists v, value v /\ ~ normal_form step v.
Proof.
  exists (C 0). split. apply v_const. unfold normal_form, not. intros. apply H.
  exists (P (C 0) (C 0)). apply ST_Funny.
Qed.

End Temp2.

Module Temp3.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).

Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2

  where " t '-->' t' " := (step t t').

(*ST_Plus2 がないことに注意します。*)

Lemma value_not_same_as_normal_form :
  exists t, ~ value t /\ normal_form step t.
Proof.
  exists ( P (C 0) (P (C 2) (C 0))).
  split. unfold not. intros. inversion H. unfold normal_form, not. intros. inversion H. inversion H0; subst.
  inversion H4.
Qed.

End Temp3.

Module Temp4.

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

Inductive value : tm -> Prop :=
  | v_tru : value tru
  | v_fls : value fls.

Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      test tru t1 t2 --> t1
  | ST_IfFalse : forall t1 t2,
      test fls t1 t2 --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      test t1 t2 t3 --> test t1' t2 t3

  where " t '-->' t' " := (step t t').

Theorem strong_progress : forall t,
  value t \/ (exists t', t --> t').
Proof.
  intros. induction t.
  - left. apply v_tru.
  - left. apply v_fls.
  - inversion IHt1. right. inversion H.
    + (*t1 = true*)
      exists t2. apply ST_IfTrue.
    + (*t1 = false*)
      exists t3. apply ST_IfFalse.
    + (*t1 --> x*)
      inversion H. right. exists (test x t2 t3). apply ST_If; assumption.
Qed.

Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros. generalize dependent y2. induction H; intros; inversion H0; subst; try reflexivity; try solve_by_inverts.
  inversion H4. inversion H4. inversion H. inversion H.
  apply IHstep in H5. rewrite H5. reflexivity.
Qed.

Module Temp5.
Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      test tru t1 t2 --> t1
  | ST_IfFalse : forall t1 t2,
      test fls t1 t2 --> t2
  | ST_IfSame : forall t1 t2,
      test t1 t2 t2 --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      test t1 t2 t3 --> test t1' t2 t3

  where " t '-->' t' " := (step t t').

Definition bool_step_prop4 :=
         test
            (test tru tru tru)
            fls
            fls
     -->
         fls.

Example bool_step_prop4_holds :
  bool_step_prop4.
Proof.
  unfold bool_step_prop4. apply ST_IfSame.
Qed.

Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros.  generalize dependent y1. induction H0; intros; inversion H; subst; try reflexivity.
  inversion H4. inversion H4.
  admit.
  inversion H0. inversion H0.
  admit.
  apply IHstep in H5. rewrite H5. reflexivity.
Abort.

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  unfold normal_form, not. intros. inversion H0. inversion H; subst. inversion H1. inversion H1.
Qed.

Theorem strong_progress : forall t,
  value t \/ (exists t', t --> t').
Proof.
  induction t.
  - left. apply v_tru.
  - left. apply v_fls.
  -
    right. destruct t1.
    + exists t2. apply ST_IfTrue.
    + exists t3. apply ST_IfFalse.
    + inversion IHt1. inversion H. inversion H. exists (test x t2 t3). apply ST_If; assumption.
Qed.

Lemma nf_is_value : forall t,
    normal_form step t -> value t.
Proof.
  unfold normal_form. intros.
  generalize strong_progress. intros []. apply H0. apply H in H0. inversion H0.
Qed.

End Temp5.
End Temp4.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation " t '-->*' t' " := (multi step t t') (at level 40).

Theorem multi_R : forall (X : Type) (R : relation X) (x y : X),
    R x y -> (multi R) x y.
Proof.
  intros X R x y H.
  apply multi_step with y. apply H. apply multi_refl.
Qed.

Theorem multi_trans :
  forall (X : Type) (R : relation X) (x y z : X),
      multi R x y ->
      multi R y z ->
      multi R x z.
Proof.
  intros X R x y z G H.
  induction G.
    - assumption.
    -
      apply multi_step with y. assumption.
      apply IHG. assumption.
Qed.

Lemma test_multistep_1:
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
   -->*
      C ((0 + 3) + (2 + 4)).
Proof.
  apply multi_step with
            (P (C (0 + 3))
               (P (C 2) (C 4))).
  { apply ST_Plus1. apply ST_PlusConstConst. }
  apply multi_step with
            (P (C (0 + 3))
               (C (2 + 4))).
  { apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  apply multi_R.
  { apply ST_PlusConstConst. }
Qed.

Lemma test_multistep_1':
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
  -->*
      C ((0 + 3) + (2 + 4)).
Proof.
  eapply multi_step. { apply ST_Plus1. apply ST_PlusConstConst. }
  eapply multi_step. { apply ST_Plus2. apply v_const.
                       apply ST_PlusConstConst. }
  eapply multi_step. { apply ST_PlusConstConst. }
  apply multi_refl.
Qed.

Lemma test_multistep_2:
  C 3 -->* C 3.
Proof.
  apply multi_refl.
Qed.

Lemma test_multistep_3:
      P (C 0) (C 3)
   -->*
      P (C 0) (C 3).
Proof. apply multi_refl. Qed.

Lemma test_multistep_4:
      P
        (C 0)
        (P
          (C 2)
          (P (C 0) (C 3)))
  -->*
      P
        (C 0)
        (C (2 + (0 + 3))).
Proof.
  eapply multi_step. { apply ST_Plus2. apply v_const.
                       apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  eapply multi_step. { apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  apply multi_refl.
Qed.

Definition step_normal_form := normal_form step.

Definition normal_form_of (t t' : tm) :=
  (t -->* t' /\ step_normal_form t').

Theorem normal_forms_unique:
  deterministic normal_form_of.
Proof.
  unfold deterministic. unfold normal_form_of.
  intros x y1 y2 P1 P2.
  inversion P1 as [P11 P12]; clear P1.
  inversion P2 as [P21 P22]; clear P2.
  generalize dependent y2.
  induction P11.
  intros. apply nf_is_value in P12. apply nf_is_value in P22.
  inversion P12 as [n1]. inversion P22 as [n2]. subst. inversion P21. reflexivity. inversion H.
    intros. apply IHP11.
      assumption.
      inversion P21. subst. apply nf_is_value in P22. inversion P22. subst. inversion H. subst.
      assert  (y = y0). eapply step_deterministic. apply H. assumption. symmetry in H2. subst. assumption.
      assumption.
Qed.

Definition normalizing {X : Type} (R : relation X) :=
  forall t, exists t',
    (multi R) t t' /\ normal_form R t'.

Lemma multistep_congr_1 : forall t1 t1' t2,
     t1 -->* t1' ->
     P t1 t2 -->* P t1' t2.
Proof.
  intros t1 t1' t2 H. induction H.
  - apply multi_refl.
  - apply multi_step with (P y t2).
    + apply ST_Plus1. apply H.
    + apply IHmulti.
Qed.

Lemma multistep_congr_2 : forall t1 t2 t2',
     value t1 ->
     t2 -->* t2' ->
     P t1 t2 -->* P t1 t2'.
Proof.
  intros. induction H0. apply multi_refl.
  eapply multi_step. apply ST_Plus2; try eassumption.
  apply IHmulti.
Qed.

Theorem step_normalizing :
  normalizing step.
Proof.
  unfold normalizing.
  induction t.
  -
    exists (C n).
    split.
    + apply multi_refl.
    +

      rewrite nf_same_as_value. apply v_const.
  -
    destruct IHt1 as [t1' [Hsteps1 Hnormal1]].
    destruct IHt2 as [t2' [Hsteps2 Hnormal2]].
    rewrite nf_same_as_value in Hnormal1.
    rewrite nf_same_as_value in Hnormal2.
    inversion Hnormal1 as [n1 H1].
    inversion Hnormal2 as [n2 H2].
    rewrite <- H1 in Hsteps1.
    rewrite <- H2 in Hsteps2.
    exists (C (n1 + n2)).
    split.
    +
      apply multi_trans with (P (C n1) t2).
      * apply multistep_congr_1. apply Hsteps1.
      * apply multi_trans with
        (P (C n1) (C n2)).
        { apply multistep_congr_2. apply v_const. apply Hsteps2. }
        apply multi_R. { apply ST_PlusConstConst. }
    +
      rewrite nf_same_as_value. apply v_const.
Qed.

Theorem eval__multistep : forall t n,
  t ==> n -> t -->* C n.
Proof.
  intros. induction H. constructor.
  apply multistep_congr_1 with (t2:= t2) in IHeval1. apply multistep_congr_2 with (t1:= (C n1)) in IHeval2.
  apply multi_trans with (y:= (P (C n1) t2)); try assumption. apply multi_trans with (y:= (P (C n1) (C n2))); try assumption.
  apply multi_R. apply ST_PlusConstConst. apply v_const.
Qed.

Lemma step__eval : forall t t' n,
     t --> t' ->
     t' ==> n ->
     t ==> n.
Proof.
  intros t t' n Hs. generalize dependent n.
  induction Hs; intros.
  inversion H. apply E_Plus; apply E_Const.
  inversion H; subst. apply IHHs in H2. apply E_Plus; assumption.
  inversion H0; subst. apply IHHs in H5. apply E_Plus; assumption.
Qed.

Theorem multistep__eval : forall t t',
  normal_form_of t t' -> exists n, t' = C n /\ t ==> n.
Proof.
  unfold normal_form_of. intros.
  inversion H. induction H0; subst.
  assert (value x). apply nf_is_value. assumption.
  inversion H0. exists n. split.
  reflexivity. constructor.
  assert(exists n : nat, z = C n /\ y ==> n).
  apply IHmulti; try split; assumption.
  inversion H3. inversion H4.
  exists x0. split. assumption.
  eapply step__eval; eassumption.
Qed.

Theorem evalF_eval : forall t n,
  evalF t = n <-> t ==> n.
Proof.
  split; intros.
  - generalize dependent n. induction t.
    simpl. intros. rewrite <- H. constructor.
    simpl. intros. rewrite <- H. constructor. apply IHt1. reflexivity.
    apply IHt2; reflexivity.
  - induction H; try reflexivity. subst. constructor.
Qed.

Module Combined.

Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n)
  | v_tru : value tru
  | v_fls : value fls.

Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      P v1 t2 --> P v1 t2'
  | ST_IfTrue : forall t1 t2,
      test tru t1 t2 --> t1
  | ST_IfFalse : forall t1 t2,
      test fls t1 t2 --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      test t1 t2 t3 --> test t1' t2 t3

  where " t '-->' t' " := (step t t').

Theorem step_deterministic_alt: deterministic step.
Proof.
  unfold deterministic. intros. generalize dependent y2.
  induction H; intros y2 Hy2; inversion Hy2; subst; try solve_by_invert; try try reflexivity.
  apply IHstep in H3; subst; reflexivity.
  induction H2; inversion H. induction H; inversion H4.
  apply IHstep in H5. rewrite H5. reflexivity.
  apply IHstep in H4. rewrite H4. reflexivity.
Qed.

(*強進行 strong_progress は成り立たない*)
End Combined.

(*スモールステップImp*)
Inductive aval : aexp -> Prop :=
  | av_num : forall n, aval (ANum n).

Reserved Notation " t '/' st '-->a' t' "
                  (at level 40, st at level 39).

Inductive astep : state -> aexp -> aexp -> Prop :=
  | AS_Id : forall st i,
      AId i / st -->a ANum (st i)
  | AS_Plus1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (APlus a1 a2) / st -->a (APlus a1' a2)
  | AS_Plus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (APlus v1 a2) / st -->a (APlus v1 a2')
  | AS_Plus : forall st n1 n2,
      APlus (ANum n1) (ANum n2) / st -->a ANum (n1 + n2)
  | AS_Minus1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (AMinus a1 a2) / st -->a (AMinus a1' a2)
  | AS_Minus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (AMinus v1 a2) / st -->a (AMinus v1 a2')
  | AS_Minus : forall st n1 n2,
      (AMinus (ANum n1) (ANum n2)) / st -->a (ANum (minus n1 n2))
  | AS_Mult1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (AMult a1 a2) / st -->a (AMult a1' a2)
  | AS_Mult2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (AMult v1 a2) / st -->a (AMult v1 a2')
  | AS_Mult : forall st n1 n2,
      (AMult (ANum n1) (ANum n2)) / st -->a (ANum (mult n1 n2))

    where " t '/' st '-->a' t' " := (astep st t t').

Reserved Notation " t '/' st '-->b' t' "
                  (at level 40, st at level 39).

Inductive bstep : state -> bexp -> bexp -> Prop :=
| BS_Eq1 : forall st a1 a1' a2,
    a1 / st -->a a1' ->
    (BEq a1 a2) / st -->b (BEq a1' a2)
| BS_Eq2 : forall st v1 a2 a2',
    aval v1 ->
    a2 / st -->a a2' ->
    (BEq v1 a2) / st -->b (BEq v1 a2')
| BS_Eq : forall st n1 n2,
    (BEq (ANum n1) (ANum n2)) / st -->b
    (if (n1 =? n2) then BTrue else BFalse)
| BS_LtEq1 : forall st a1 a1' a2,
    a1 / st -->a a1' ->
    (BLe a1 a2) / st -->b (BLe a1' a2)
| BS_LtEq2 : forall st v1 a2 a2',
    aval v1 ->
    a2 / st -->a a2' ->
    (BLe v1 a2) / st -->b (BLe v1 a2')
| BS_LtEq : forall st n1 n2,
    (BLe (ANum n1) (ANum n2)) / st -->b
             (if (n1 <=? n2) then BTrue else BFalse)
| BS_NotStep : forall st b1 b1',
    b1 / st -->b b1' ->
    (BNot b1) / st -->b (BNot b1')
| BS_NotTrue : forall st,
    (BNot BTrue) / st -->b BFalse
| BS_NotFalse : forall st,
    (BNot BFalse) / st -->b BTrue
| BS_AndTrueStep : forall st b2 b2',
    b2 / st -->b b2' ->
    (BAnd BTrue b2) / st -->b (BAnd BTrue b2')
| BS_AndStep : forall st b1 b1' b2,
    b1 / st -->b b1' ->
    (BAnd b1 b2) / st -->b (BAnd b1' b2)
| BS_AndTrueTrue : forall st,
    (BAnd BTrue BTrue) / st -->b BTrue
| BS_AndTrueFalse : forall st,
    (BAnd BTrue BFalse) / st -->b BFalse
| BS_AndFalse : forall st b2,
    (BAnd BFalse b2) / st -->b BFalse

where " t '/' st '-->b' t' " := (bstep st t t').

Reserved Notation " t '/' st '-->' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).

Open Scope imp_scope.
Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st i a a',
      a / st -->a a' ->
      (i ::= a) / st --> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st --> SKIP / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      (c1 ;; c2) / st --> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st --> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b / st -->b b' ->
      TEST b THEN c1 ELSE c2 FI / st
      -->
      (TEST b' THEN c1 ELSE c2 FI) / st
  | CS_IfTrue : forall st c1 c2,
      TEST BTrue THEN c1 ELSE c2 FI / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      TEST BFalse THEN c1 ELSE c2 FI / st --> c2 / st
  | CS_While : forall st b c1,
      WHILE b DO c1 END / st
      -->
      (TEST b THEN c1;; WHILE b DO c1 END ELSE SKIP FI) / st

  where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).

Close Scope imp_scope.

(*並行Imp*)
Module CImp.

Inductive com : Type :=
  | CSkip : com
  | CAss : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CPar : com -> com -> com.
Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x 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 "'TEST' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (CIf b c1 c2) (at level 80, right associativity).
Notation "'PAR' c1 'WITH' c2 'END'" :=
  (CPar c1 c2) (at level 80, right associativity).

Inductive cstep : (com * state) -> (com * state) -> Prop :=

  | CS_AssStep : forall st i a a',
      a / st -->a a' ->
      (i ::= a) / st --> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st --> SKIP / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      (c1 ;; c2) / st --> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st --> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b /st -->b b' ->
          (TEST b THEN c1 ELSE c2 FI) / st
      --> (TEST b' THEN c1 ELSE c2 FI) / st
  | CS_IfTrue : forall st c1 c2,
      (TEST BTrue THEN c1 ELSE c2 FI) / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      (TEST BFalse THEN c1 ELSE c2 FI) / st --> c2 / st
  | CS_While : forall st b c1,
          (WHILE b DO c1 END) / st
      --> (TEST b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st

  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st --> c1' / st' ->
      (PAR c1 WITH c2 END) / st --> (PAR c1' WITH c2 END) / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st --> c2' / st' ->
      (PAR c1 WITH c2 END) / st --> (PAR c1 WITH c2' END) / st'
  | CS_ParDone : forall st,
      (PAR SKIP WITH SKIP END) / st --> SKIP / st
  where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).

Definition cmultistep := multi cstep.

Notation " t '/' st '-->*' t' '/' st' " :=
   (multi cstep (t,st) (t',st'))
   (at level 40, st at level 39, t' at level 39).

(*
変数Xに任意の数を入れた状態でストップできる
 *)
Definition par_loop : com :=
  PAR
    Y ::= 1
  WITH
    WHILE Y = 0 DO
      X ::= X + 1
    END
  END.

Example par_loop_example_0:
  exists st',
       par_loop / empty_st -->* SKIP / st'
    /\ st' X = 0.
Proof.
  eapply ex_intro. split.
  unfold par_loop.
  eapply multi_step. apply CS_Par1.
    apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity. Qed.

Example par_loop_example_2:
  exists st',
       par_loop / empty_st -->* SKIP / st'
    /\ st' X = 2.
Proof.
  eapply ex_intro. split.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.

  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.

  eapply multi_step. apply CS_Par1. apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity. Qed.

Lemma par_body_n__Sn : forall n st,
  st X = n /\ st Y = 0 ->
  par_loop / st -->* par_loop / (X !-> S n ; st).
Proof.
  intros n st [H H1]; subst.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
  apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
  apply BS_Eq. rewrite H1. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish. rewrite plus_comm. simpl.
  apply multi_refl.
Qed.

Lemma par_body_n : forall n st,
  st X = 0 /\ st Y = 0 ->
  exists st',
    par_loop / st -->*  par_loop / st' /\ st' X = n /\ st' Y = 0.
Proof.
  induction n; intros.
    exists st. split. apply multi_refl.
      assumption.
    assert(exists st' : state,
        par_loop / st -->* par_loop / st' /\ st' X = n /\ st' Y = 0).
    apply IHn. assumption. inversion H0.
    exists (t_update x X (S n)).
    split;
    inversion H1 as [H2 H3].
    eapply multi_trans. apply H2.
    eapply par_body_n__Sn.
    assumption. split.
    rewrite t_update_eq. reflexivity.
    inversion H3 as [H4 H5].
    rewrite t_update_neq. assumption.
    destruct (eqb_string X Y)  eqn:IH; inversion IH.
    apply eqb_string_false_iff in IH.  assumption.
  Qed.

Theorem par_loop_any_X:
  forall n, exists st',
    par_loop / empty_st -->* SKIP / st'
    /\ st' X = n.
Proof.
  intros n.
  destruct (par_body_n n empty_st).
    split; unfold t_update; reflexivity.

  rename x into st.
  inversion H as [H' [HX HY]]; clear H.
  exists (Y !-> 1 ; st). split.
  eapply multi_trans with (par_loop,st). apply H'.
  eapply multi_step. apply CS_Par1. apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id. rewrite t_update_eq.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  apply multi_refl.

  rewrite t_update_neq. assumption. intro X; inversion X.
Qed.

End CImp.

Definition stack := list nat.
Definition prog := list sinstr.

Inductive stack_step : state -> prog * stack -> prog * stack -> Prop :=
  | SS_Push : forall st stk n p',
    stack_step st (SPush n :: p', stk) (p', n :: stk)
  | SS_Load : forall st stk i p',
    stack_step st (SLoad i :: p', stk) (p', st i :: stk)
  | SS_Plus : forall st stk n m p',
    stack_step st (SPlus :: p', n::m::stk) (p', (m+n)::stk)
  | SS_Minus : forall st stk n m p',
    stack_step st (SMinus :: p', n::m::stk) (p', (m-n)::stk)
  | SS_Mult : forall st stk n m p',
    stack_step st (SMult :: p', n::m::stk) (p', (m*n)::stk).

Theorem stack_step_deterministic : forall st,
  deterministic (stack_step st).
Proof.
  unfold deterministic. intros st x y1 y2 H1 H2.
  induction H1; inversion H2; reflexivity.
Qed.

Definition stack_multistep st := multi (stack_step st).

(*normalize タクティック*)
Example step_example1 :
  (P (C 3) (P (C 3) (C 4)))
  -->* (C 10).
Proof.
  apply multi_step with (P (C 3) (C 7)).
    apply ST_Plus2.
      apply v_const.
      apply ST_PlusConstConst.
  apply multi_step with (C 10).
    apply ST_PlusConstConst.
  apply multi_refl.
Qed.

Hint Constructors step value.
Example step_example1' :
  (P (C 3) (P (C 3) (C 4)))
  -->* (C 10).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.

Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

Example step_example1'' :
  (P (C 3) (P (C 3) (C 4)))
  -->* (C 10).
Proof.
  normalize.
Qed.

Example step_example1''' : exists e',
  (P (C 3) (P (C 3) (C 4)))
  -->* e'.
Proof.
  eapply ex_intro. normalize.
Qed.


Require Import Axiom_Skolem.

Definition lem (p:Prop) : Prop := p \/ ~p.

Definition ifRel (a b:Type) (p:Prop) (f g:a -> b) (x:a) (y:b) : Prop :=
    (p /\ y = f x) \/ (~p /\ y = g x).

Arguments ifRel {a} {b} _ _ _ _ _.

Lemma ifRelFunctional : forall (a b:Type) (p:Prop) (f g:a -> b) (x:a) (y y':b),
    (ifRel p f g x y) -> (ifRel p f g x y') -> y = y'.
Proof.
    intros a b p f g x y y'.
    unfold ifRel. intros [[Hp H1]|[Hp H1]] [[Hq H2]|[Hq H2]].
    - rewrite <- H2 in H1. exact H1.
    - exfalso. apply Hq. exact Hp.
    - exfalso. apply Hp. exact Hq.
    - rewrite <- H2 in H1. exact H1.
Qed.

Arguments ifRelFunctional {a} {b} _ _ _ _ _ _ _ _.

Lemma ifRelTotal : forall (a b:Type) (p:Prop) (f g:a -> b),
    lem p -> forall (x:a), exists (y:b), (ifRel p f g x y).
Proof.
    unfold ifRel. intros a b p f g [H|H] x.
    - exists (f x). left. split.
        + exact H.
        + reflexivity.
    - exists (g x). right. split.
        + exact H.
        + reflexivity.
Qed.

Arguments ifRelTotal {a} {b} _ _ _ _ _.

Definition ifFunc (a b:Type) (p:Prop) (q:lem p) (f g:a -> b) (x:a) : b :=
    proj1_sig (skolem
        (ifRel p f g x)
        (ifRelTotal p f g q x)
        (ifRelFunctional p f g x)).

Arguments ifFunc {a} {b} _ _ _ _ _.

Definition ifFunc_proof (a b:Type) (p:Prop) (q:lem p) (f g:a -> b) (x:a) :
    (ifRel p f g x (ifFunc p q f g x))
:=
    proj2_sig (skolem
        (ifRel p f g x)
        (ifRelTotal p f g q x)
        (ifRelFunctional p f g x)).

Arguments ifFunc_proof {a} {b} _ _ _ _ _.

Lemma ifFunc_correct_true : forall (a b:Type)(p:Prop)(q:lem p)(f g:a -> b)(x:a),
    p -> ifFunc p q f g x = f x.
Proof.
    intros a b p q f g x Hp.
    assert (ifRel p f g x (ifFunc p q f g x)) as [[H1 H2]|[H1 H2]].
        { exact (ifFunc_proof p q f g x). }
    - exact H2.
    - exfalso. apply H1. exact Hp.
Qed.

Lemma ifFunc_correct_false : forall (a b:Type)(p:Prop)(q:lem p)(f g:a -> b)(x:a),
    ~p -> ifFunc p q f g x = g x.
Proof.
    intros a b p q f g x Hp.
    assert (ifRel p f g x (ifFunc p q f g x)) as [[H1 H2]|[H1 H2]].
        { exact (ifFunc_proof p q f g x). }
    - exfalso. apply Hp. exact H1.
    - exact H2.
Qed.


Require Export Iron.Language.SystemF2Cap.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.EquivT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.KindT.

(* If two closed types are equivalent, and we substitute some third
   type into both, then the results are also equivalent.

   NOTE: The more general form where t1 and t2 are open should also
         be true, but we don't need it for the main proofs.
*)
Lemma equivT_closed_liftTT_liftTT
 :  forall sp t1 t2 k d
 ,  EquivT nil sp t1 t2 k
 -> EquivT nil sp (liftTT 1 d t1) (liftTT 1 d t2) k.
Proof.
 intros.
 have (ClosedT t1).
 have (ClosedT t2).
 rrwrite (liftTT 1 d t1 = t1).
 rrwrite (liftTT 1 d t2 = t2).
 auto.
Qed.
Hint Resolve equivT_closed_liftTT_liftTT.


From RelationalCalculus Require Import Basic_Notations Basic_Lemmas Relation_Properties Functions_Mappings Dedekind Domain.
Require Import Logic.FunctionalExtensionality.

Module main (def : Relation).
Import def.
Module Basic_Lemmas := Basic_Lemmas.main def.
Module Relation_Properties := Relation_Properties.main def.
Module Functions_Mappings := Functions_Mappings.main def.
Module Dedekind := Dedekind.main def.
Module Domain := Domain.main def.
Import Basic_Lemmas Relation_Properties Functions_Mappings Dedekind Domain.

(** %
\section{剰余合成関係の性質}
\subsection{基本的な性質}
\begin{screen}
\begin{lemma}[double\_residual]
Let $\alpha :A \rel B$, $\beta :B \rel C$ and $\gamma :C \rel D$. Then
$$
\alpha \rhd (\beta \rhd \gamma) = (\alpha \cdot \beta) \rhd \gamma.
$$
\end{lemma}
\end{screen}
% **)
Lemma double_residual
 {A B C D : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel C D}:
 alpha △ (beta △ gamma) = (alpha ・ beta) △ gamma.
Proof.
apply inc_lower.
move => delta.
split; move => H.
apply inc_residual.
rewrite comp_inv comp_assoc.
rewrite -inc_residual -inc_residual.
apply H.
rewrite inc_residual inc_residual.
rewrite -comp_assoc -comp_inv.
apply inc_residual.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_to\_complement]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then
$$
\alpha \rhd \beta = (\alpha \cdot \beta^-)^-.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_to_complement {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha △ beta = (alpha ・ beta ^) ^.
Proof.
apply inc_lower.
move => gamma.
split; move => H.
rewrite bool_lemma2 complement_invol cap_comm.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
replace (beta ^ ∩ (alpha # ・ gamma)) with (φ B C).
rewrite comp_empty_r.
apply inc_refl.
apply Logic.eq_sym.
rewrite cap_comm.
apply bool_lemma2.
apply inc_residual.
apply H.
apply inc_empty_alpha.
apply inc_residual.
apply bool_lemma2.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
rewrite inv_invol.
replace  (gamma ∩ (alpha ・ beta ^)) with (φ A C).
rewrite comp_empty_r.
apply inc_refl.
apply Logic.eq_sym.
rewrite -(@complement_invol _ _ (alpha ・ beta ^)).
apply bool_lemma2.
apply H.
apply inc_empty_alpha.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_residual\_inc]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then
$$
\alpha^\sharp \cdot (\alpha \rhd \beta) \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_residual_inc {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha # ・ (alpha △ beta) ⊆ beta.
Proof.
apply inc_residual.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_residual\_inv]
Let $\alpha :A \rel B$ and $\gamma :A \rel C$. Then
$$
\gamma \sqsubseteq \alpha \rhd \alpha^\sharp \cdot \gamma.
$$
\end{lemma}
\end{screen}
% **)
Lemma inc_residual_inv {A B C : eqType} {alpha : Rel A B} {gamma : Rel A C}:
 gamma ⊆ (alpha △ (alpha # ・ gamma)).
Proof.
apply inc_residual.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[id\_inc\_residual]
Let $\alpha :A \rel B$. Then
$$
id_A \sqsubseteq \alpha \rhd \alpha^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma id_inc_residual {A B : eqType} {alpha : Rel A B}: Id A ⊆ (alpha △ alpha #).
Proof.
apply inc_residual.
rewrite comp_id_r.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_universal]
Let $\alpha :A \rel B$. Then
$$
\alpha \rhd \nabla_{BC} = \nabla_{AC}.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_universal {A B C : eqType} {alpha : Rel A B}: alpha △ ∇ B C = ∇ A C.
Proof.
apply inc_antisym.
apply inc_alpha_universal.
apply inc_residual.
apply inc_alpha_universal.
Qed.

(** %
\subsection{単調性と分配法則}
\begin{screen}
\begin{lemma}[residual\_inc\_compat]
Let $\alpha, {\alpha}' :A \rel B$ and $\beta, {\beta}' :B \rel C$. Then
$$
{\alpha}' \sqsubseteq \alpha \land \beta \sqsubseteq {\beta}' \Rightarrow \alpha \rhd \beta \sqsubseteq {\alpha}' \rhd {\beta}'.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_inc_compat
 {A B C : eqType} {alpha alpha' : Rel A B} {beta beta' : Rel B C}:
 alpha' ⊆ alpha -> beta ⊆ beta' -> (alpha △ beta) ⊆ (alpha' △ beta').
Proof.
move => H H0.
apply inc_residual.
apply (fun H' => @inc_trans _ _ _ _ _ H' H0).
move : (@inc_refl _ _ (alpha △ beta)) => H1.
apply inc_residual in H1.
apply (fun H' => @inc_trans _ _ _ _ _ H' H1).
apply comp_inc_compat_ab_a'b.
apply inc_inv.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_inc\_compat\_l]
Let $\alpha :A \rel B$ and $\beta, {\beta}' :B \rel C$. Then
$$
\beta \sqsubseteq {\beta}' \Rightarrow \alpha \rhd \beta \sqsubseteq \alpha \rhd {\beta}'.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_inc_compat_l
 {A B C : eqType} {alpha : Rel A B} {beta beta' : Rel B C}:
 beta ⊆ beta' -> (alpha △ beta) ⊆ (alpha △ beta').
Proof.
move => H.
apply (@residual_inc_compat _ _ _ _ _ _ _ (@inc_refl _ _ _) H).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_inc\_compat\_r]
Let $\alpha, {\alpha}' :A \rel B$ and $\beta :B \rel C$. Then
$$
{\alpha}' \sqsubseteq \alpha \Rightarrow \alpha \rhd \beta \sqsubseteq {\alpha}' \rhd \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_inc_compat_r
 {A B C : eqType} {alpha alpha' : Rel A B} {beta : Rel B C}:
 alpha' ⊆ alpha -> (alpha △ beta) ⊆ (alpha' △ beta).
Proof.
move => H.
apply (@residual_inc_compat _ _ _ _ _ _ _ H (@inc_refl _ _ _)).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_capP\_distr\_l, residual\_cap\_distr\_l]
Let $\alpha :A \rel B$, $f:(D \rel E) \to (B \rel C)$ and $P$ : predicate. Then
$$
\alpha \rhd (\sqcap_{P(\beta)} f(\beta)) = \sqcap_{P(\beta)} (\alpha \rhd f(\beta)).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_capP_distr_l {A B C D E : eqType}
 {alpha : Rel A B} {f : Rel D E -> Rel B C} {P : Rel D E -> Prop}:
 alpha △ (∩_{P} f) = ∩_{P} (fun beta : Rel D E => alpha △ f beta).
Proof.
apply inc_lower.
move => gamma.
split; move => H.
apply inc_capP.
move => beta H0.
apply inc_residual.
move : beta H0.
apply inc_capP.
apply inc_residual.
apply H.
apply inc_residual.
apply inc_capP.
move => beta H0.
apply inc_residual.
move : beta H0.
apply inc_capP.
apply H.
Qed.

Lemma residual_cap_distr_l
 {A B C : eqType} {alpha : Rel A B} {beta gamma : Rel B C}:
 alpha △ (beta ∩ gamma) = (alpha △ beta) ∩ (alpha △ gamma).
Proof.
rewrite cap_to_capP (@cap_to_capP _ _ _ _ _ _ id).
apply residual_capP_distr_l.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_cupP\_distr\_r, residual\_cup\_distr\_r]
Let $f:(D \rel E) \to (A \rel B)$, $\beta :B \rel C$ and $P$ : predicate. Then
$$
(\sqcup_{P(\alpha)} f(\alpha)) \rhd \beta = \sqcap_{P(\alpha)} (f(\alpha) \rhd \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_cupP_distr_r {A B C D E : eqType}
 {beta : Rel B C} {f : Rel D E -> Rel A B} {P : Rel D E -> Prop}:
 (∪_{P} f) △ beta = ∩_{P} (fun alpha : Rel D E => f alpha △ beta).
Proof.
apply inc_lower.
move => gamma.
split; move => H.
apply inc_capP.
move => alpha H0.
apply inc_residual.
move : alpha H0.
apply inc_cupP.
rewrite -comp_cupP_distr_r -inv_cupP_distr.
apply inc_residual.
apply H.
apply inc_residual.
rewrite inv_cupP_distr comp_cupP_distr_r.
apply inc_cupP.
move => alpha H0.
apply inc_residual.
move : alpha H0.
apply inc_capP.
apply H.
Qed.

Lemma residual_cup_distr_r
 {A B C : eqType} {alpha beta : Rel A B} {gamma : Rel B C}:
 (alpha ∪ beta) △ gamma = (alpha △ gamma) ∩ (beta △ gamma).
Proof.
rewrite (@cup_to_cupP _ _ _ _ _ _ id) (@cap_to_capP _ _ _ _ _ _ (fun x => x △ gamma)).
apply residual_cupP_distr_r.
Qed.

(** %
\subsection{剰余合成と関数}
\begin{screen}
\begin{lemma}[total\_residual]
Let $\alpha :A \to B$ be a total relation and $\beta :B \rel C$. Then
$$
\alpha \rhd \beta \sqsubseteq \alpha \cdot \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma total_residual {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 total_r alpha -> (alpha △ beta) ⊆ (alpha ・ beta).
Proof.
move => H.
apply (@inc_trans _ _ _ ((alpha ・ alpha #) ・ (alpha △ beta))).
apply (comp_inc_compat_b_ab H).
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inv_residual_inc.
Qed.

(** %
\begin{screen}
\begin{lemma}[univalent\_residual]
Let $\alpha :A \to B$ be a univalent relation and $\beta :B \rel C$. Then
$$
\alpha \cdot \beta \sqsubseteq \alpha \rhd \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma univalent_residual {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 univalent_r alpha -> (alpha ・ beta) ⊆ (alpha △ beta).
Proof.
move => H.
apply (@inc_trans _ _ _ _ _ (@inc_residual_inv _ _ _ alpha _)).
apply residual_inc_compat_l.
rewrite -comp_assoc.
apply (comp_inc_compat_ab_b H).
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_residual1]
Let $\alpha :A \to B$ be a function and $\beta :B \rel C$. Then
$$
\alpha \rhd \beta = \alpha \cdot \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_residual1 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 function_r alpha -> alpha △ beta = alpha ・ beta.
Proof.
elim => H H0.
apply inc_antisym.
apply (total_residual H).
apply (univalent_residual H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_id]
Let $\alpha :A \rel B$. Then
$$
id_A \rhd \alpha = \alpha.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_id {A B : eqType} {alpha : Rel A B}:
 Id A △ alpha = alpha.
Proof.
move : (@function_residual1 _ _ _ (Id A) alpha (@id_function A)) => H.
rewrite comp_id_l in H.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[universal\_residual]
Let $\alpha :A \to B$. Then
$$
\nabla_{AA} \rhd \alpha \sqsubseteq \alpha.
$$
\end{lemma}
\end{screen}
% **)
Lemma universal_residual {A B : eqType} {alpha : Rel A B}:
 ∇ A A △ alpha ⊆ alpha.
Proof.
apply (@inc_trans _ _ _ (Id A △ alpha)).
apply residual_inc_compat_r.
apply inc_alpha_universal.
rewrite residual_id.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_residual2]
Let $\alpha :A \to B$ be a function, $\beta :B \rel C$ and $\gamma :C \rel D$. Then
$$
\alpha \cdot (\beta \rhd \gamma) = (\alpha \cdot \beta) \rhd \gamma.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_residual2
 {A B C D : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel C D}:
 function_r alpha -> alpha ・ (beta △ gamma) = (alpha ・ beta) △ gamma.
Proof.
move => H.
rewrite -(@function_residual1 _ _ _ _ _ H).
apply double_residual.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_residual3]
Let $\alpha :A \rel B$, $\beta :B \rel C$ be relations and $\gamma :D \to C$ be a function. Then
$$
(\alpha \rhd \beta) \cdot \gamma^\sharp = \alpha \rhd (\beta \cdot \gamma^\sharp).
$$
\end{lemma}
\end{screen}
% **)
Lemma function_residual3
 {A B C D : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel D C}:
 function_r gamma -> (alpha △ beta) ・ gamma # = alpha △ (beta ・ gamma #).
Proof.
move => H.
apply inc_lower.
move => delta.
split; move => H0.
apply inc_residual.
rewrite -(@function_move2 _ _ _ _ _ _ H).
rewrite comp_assoc.
apply inc_residual.
rewrite (@function_move2 _ _ _ _ _ _ H).
apply H0.
rewrite -(@function_move2 _ _ _ _ _ _ H).
apply inc_residual.
rewrite -comp_assoc.
rewrite (@function_move2 _ _ _ _ _ _ H).
apply inc_residual.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_residual4]
Let $\alpha :A \rel B$, $\gamma :C \rel D$ be relations and $\beta :B \to C$ be a function. Then
$$
\alpha \cdot \beta \rhd \gamma = \alpha \rhd \beta \cdot \gamma.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_residual4
 {A B C D : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel C D}:
 function_r beta -> (alpha ・ beta) △ gamma = alpha △ (beta ・ gamma).
Proof.
move => H.
rewrite -double_residual.
by [rewrite (function_residual1 H)].
Qed.

(** %
\section{Galois 同値とその系}
\begin{screen}
\begin{lemma}[galois]
Let $\alpha :A \rel B$, $\beta :B \rel C$ and $\gamma :A \rel C$. Then
$$
\gamma \sqsubseteq \alpha \rhd \beta \Leftrightarrow \alpha \sqsubseteq \gamma \rhd \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma galois {A B C : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel A C}:
 gamma ⊆ (alpha △ beta) <-> alpha ⊆ (gamma △ beta #).
Proof.
split; move => H.
apply inc_residual.
apply inv_inc_move.
rewrite comp_inv inv_invol.
apply inc_residual.
apply H.
apply inc_residual.
apply inv_inc_invol.
rewrite comp_inv inv_invol.
apply inc_residual.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[galois\_corollary1]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then
$$
\alpha \sqsubseteq (\alpha \rhd \beta) \rhd \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma galois_corollary1 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha ⊆ ((alpha △ beta) △ beta #).
Proof.
rewrite -galois.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[galois\_corollary2]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then
$$
((\alpha \rhd \beta) \rhd \beta^\sharp) \rhd \beta = \alpha \rhd \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma galois_corollary2 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 ((alpha △ beta) △ beta #) △ beta = alpha △ beta.
Proof.
apply inc_antisym.
apply residual_inc_compat_r.
apply galois_corollary1.
move : (@galois_corollary1 _ _ _ (alpha △ beta) (beta #)) => H.
rewrite inv_invol in H.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[galois\_corollary3]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then
$$
\alpha = (\alpha \rhd \beta) \rhd \beta^\sharp \Leftrightarrow \exists \gamma :A \rel C, \alpha = \gamma \rhd \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma galois_corollary3 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 alpha = (alpha △ beta) △ beta # <-> (exists gamma : Rel A C, alpha = gamma △ beta #).
Proof.
split; move => H.
exists (alpha △ beta).
apply H.
elim H => gamma H0.
rewrite H0.
move : (@galois_corollary2 _ _ _ gamma (beta #)) => H1.
rewrite inv_invol in H1.
by [rewrite H1].
Qed.

(** %
\section{その他の性質}
\begin{screen}
この節では, 特記が無い限り, 記号は以下の図式に従って割り振られるものとする.
$$
\xymatrix{
X \ar@{-_>}[r]^\alpha \ar@/^8mm/@{-_>}[rr]^\delta & Y \ar@{-_>}[r]^{\beta ,{\beta}'} \ar@{-_>}[d]^\eta & Z \ar@{-_>}[r]^\gamma & W \\
& V \ar@{-_>}[ru]_\tau & & \\
}
$$
\end{screen}
% **)

(** %
\begin{screen}
\begin{lemma}[residual\_property1]
$$
(\alpha \rhd \beta) \cdot \gamma \sqsubseteq \alpha \rhd \beta \cdot \gamma.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property1
 {W X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {gamma : Rel Z W}:
 ((alpha △ beta) ・ gamma) ⊆ (alpha △ (beta ・ gamma)).
Proof.
apply (@inc_trans _ _ _ (alpha △ (alpha # ・ ((alpha △ beta) ・ gamma)))).
apply inc_residual_inv.
apply residual_inc_compat_l.
rewrite -comp_assoc.
apply comp_inc_compat_ab_a'b.
apply inv_residual_inc.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property2]
$$
(\alpha \rhd \beta) \cdot (\beta^\sharp \rhd \eta) \sqsubseteq \alpha \rhd \eta.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property2
 {V X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {eta : Rel Y V}:
 ((alpha △ beta) ・ (beta # △ eta)) ⊆ (alpha △ eta).
Proof.
apply (@inc_trans _ _ _ _ _ (residual_property1)).
apply residual_inc_compat_l.
move : (@inv_residual_inc _ _ _ (beta #) eta).
by [rewrite inv_invol].
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property3]
$$
\alpha \rhd \beta \sqsubseteq \alpha \cdot \eta \rhd \eta^\sharp \cdot \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property3
 {V X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {eta : Rel Y V}:
 (alpha △ beta) ⊆ ((alpha ・ eta) △ (eta # ・ beta)).
Proof.
apply (@inc_trans _ _ _ _ _ (@inc_residual_inv _ _ _ (alpha ・ eta) (alpha △ beta))).
apply residual_inc_compat_l.
rewrite comp_inv comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inv_residual_inc.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property4a, residual\_property4b]
$$
(\alpha \rhd \beta) \cdot \gamma \sqsubseteq (\alpha \rhd \beta \cdot \gamma) \sqcap \nabla_{XZ} \cdot \gamma \sqsubseteq (\alpha \rhd \beta \cdot \gamma) \cdot \gamma^\sharp \cdot \gamma.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property4a
 {W X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {gamma : Rel Z W}:
 ((alpha △ beta) ・ gamma) ⊆ ((alpha △ (beta ・ gamma)) ∩ (∇ X Z ・ gamma)).
Proof.
rewrite -(@cap_universal _ _ (alpha △ beta)).
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply cap_inc_compat_r.
apply residual_property1.
Qed.

Lemma residual_property4b
 {W X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {gamma : Rel Z W}:
 ((alpha △ (beta ・ gamma)) ∩ (∇ X Z ・ gamma)) ⊆ ((alpha △ (beta ・ gamma)) ・ (gamma # ・ gamma)).
Proof.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (dedekind2)).
rewrite cap_comm cap_universal comp_assoc.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property5]
Let $\tau$ be a univalent relation. Then,
$$
(\alpha \rhd \beta) \cdot \tau^\sharp = (\alpha \rhd \beta \cdot \tau^\sharp) \sqcap \nabla_{XZ} \cdot \tau^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property5
 {V X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {tau : Rel V Z}:
 univalent_r tau ->
 (alpha △ beta) ・ tau # = (alpha △ (beta ・ tau #)) ∩ (∇ X Z ・ tau #).
Proof.
move => H.
apply inc_antisym.
rewrite -(@cap_universal _ _ (alpha △ beta)).
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply cap_inc_compat_r.
apply residual_property1.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (dedekind2)).
rewrite cap_comm cap_universal inv_invol.
apply comp_inc_compat_ab_a'b.
apply (@inc_trans _ _ _ _ _ (residual_property1)).
apply residual_inc_compat_l.
rewrite comp_assoc.
apply (comp_inc_compat_ab_a H).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property6]
$$
\alpha \rhd (\gamma^\sharp \rhd \beta^\sharp)^\sharp = (\gamma^\sharp \rhd (\alpha \rhd \beta)^\sharp)^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property6
 {W X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {gamma : Rel Z W}:
 alpha △ (gamma # △ beta #) # = (gamma # △ (alpha △ beta) #) #.
Proof.
apply inc_lower.
move => delta.
split; move => H.
apply inv_inc_move.
apply inc_residual.
apply inv_inc_move.
apply inc_residual.
rewrite -comp_inv comp_assoc.
apply inv_inc_move.
apply inc_residual.
apply inv_inc_invol.
rewrite comp_inv inv_invol.
apply inc_residual.
apply H.
apply inc_residual.
apply inv_inc_move.
apply inc_residual.
apply inv_inc_move.
rewrite comp_inv inv_invol inv_invol comp_assoc.
apply inc_residual.
apply inv_inc_invol.
rewrite comp_inv.
apply inc_residual.
apply inv_inc_move.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property7a, residual\_property7b]
$$
\alpha \rhd (\beta \Rightarrow {\beta}') \sqsubseteq (\alpha \cdot \beta \Rightarrow \alpha \cdot {\beta}') \sqsubseteq \alpha \rhd (\beta \Rightarrow \alpha^\sharp \cdot \alpha \cdot {\beta}').
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property7a {X Y Z : eqType} {alpha : Rel X Y} {beta beta' : Rel Y Z}:
 (alpha △ (beta >> beta')) ⊆ ((alpha ・ beta) >> (alpha ・ beta')).
Proof.
apply inc_rpc.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
apply comp_inc_compat_ab_ab'.
rewrite cap_comm.
apply inc_rpc.
apply inv_residual_inc.
Qed.

Lemma residual_property7b {X Y Z : eqType} {alpha : Rel X Y} {beta beta' : Rel Y Z}:
 ((alpha ・ beta) >> (alpha ・ beta')) ⊆ (alpha △ (beta >> (alpha # ・ (alpha ・ beta')))).
Proof.
rewrite inc_residual inc_rpc.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
apply comp_inc_compat_ab_ab'.
rewrite inv_invol -inc_rpc.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property8]
Let $\alpha$ be a univalent relation. Then,
$$
\alpha \rhd (\beta \Rightarrow {\beta}') = (\alpha \cdot \beta \Rightarrow \alpha \cdot {\beta}').
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property8 {X Y Z : eqType} {alpha : Rel X Y} {beta beta' : Rel Y Z}:
 univalent_r alpha -> alpha △ (beta >> beta') = (alpha ・ beta) >> (alpha ・ beta').
Proof.
move => H.
apply inc_antisym.
apply residual_property7a.
apply (@inc_trans _ _ _ _ _ residual_property7b).
apply residual_inc_compat_l.
apply rpc_inc_compat_l.
rewrite -comp_assoc.
apply (comp_inc_compat_ab_b H).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property9]
Let $\alpha$ be a univalent relation. Then,
$$
\alpha \rhd \beta = (\alpha \cdot \nabla_{YZ} \Rightarrow \alpha \cdot \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property9 {X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z}:
 univalent_r alpha -> alpha △ beta = (alpha ・ ∇ Y Z) >> (alpha ・ beta).
Proof.
move => H.
by [rewrite -(residual_property8 H) rpc_universal_alpha].
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property10]
Let $\alpha$ be a univalent relation. Then,
$$
\alpha \cdot \beta = \domain{\alpha} \cdot (\alpha \rhd \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property10 {X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z}:
 univalent_r alpha -> alpha ・ beta = domain alpha ・ (alpha △ beta).
Proof.
move => H.
apply inc_antisym.
replace (alpha ・ beta) with (domain alpha ・ (alpha ・ beta)).
apply comp_inc_compat_ab_ab'.
rewrite inc_residual -comp_assoc.
apply (comp_inc_compat_ab_b H).
by [rewrite -comp_assoc domain_comp_alpha1].
apply (@inc_trans _ _ _ ((alpha ・ alpha #) ・ (alpha △ beta))).
apply comp_inc_compat_ab_a'b.
apply cap_l.
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inv_residual_inc.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property11]
$$
(\alpha \cdot \beta \Rightarrow \delta) \sqsubseteq \alpha \rhd (\beta \Rightarrow \alpha^\sharp \cdot \delta).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property11
 {X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z} {delta : Rel X Z}:
 ((alpha ・ beta) >> delta) ⊆ (alpha △ (beta >> (alpha # ・ delta))).
Proof.
apply inc_residual.
apply inc_rpc.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
rewrite inv_invol.
apply comp_inc_compat_ab_ab'.
apply inc_rpc.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property12a, residual\_property12b]
Let $u \sqsubseteq id_X$. Then,
$$
u \rhd \alpha = u \cdot \nabla_{XY} \Rightarrow \alpha = u \rhd u \cdot \alpha.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property12a {X Y : eqType} {u : Rel X X} {alpha : Rel X Y}:
 u ⊆ Id X -> u △ alpha = (u ・ ∇ X Y) >> alpha.
Proof.
move => H.
apply inc_antisym.
assert (univalent_r u).
apply (fun H' => @inc_trans _ _ _ _ _ H' H).
apply comp_inc_compat_ab_b.
rewrite -inv_id.
apply (@inc_inv _ _ _ _ H).
rewrite (residual_property9 H0).
apply rpc_inc_compat_l.
apply (comp_inc_compat_ab_b H).
apply (@inc_trans _ _ _ _ _ residual_property11).
apply residual_inc_compat_l.
rewrite rpc_universal_alpha.
apply comp_inc_compat_ab_b.
rewrite -inv_id.
apply (@inc_inv _ _ _ _ H).
Qed.

Lemma residual_property12b {X Y : eqType} {u : Rel X X} {alpha : Rel X Y}:
 u ⊆ Id X -> u △ alpha = u △ (u ・ alpha).
Proof.
move => H.
apply inc_antisym.
rewrite (residual_property12a H).
apply (@inc_trans _ _ _ _ _ residual_property11).
apply residual_inc_compat_l.
rewrite rpc_universal_alpha.
apply comp_inc_compat_ab_a'b.
rewrite (dedekind_id1 H).
apply inc_refl.
apply residual_inc_compat_l.
apply (comp_inc_compat_ab_b H).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property13]
$$
(\alpha \cdot \nabla_{YZ} \sqcap \delta) \rhd \gamma = (\alpha \cdot \nabla_{YW} \Rightarrow (\delta \rhd \gamma)).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property13
 {W X Y Z : eqType} {alpha : Rel X Y} {gamma : Rel Z W} {delta : Rel X Z}:
 ((alpha ・ ∇ Y Z) ∩ delta) △ gamma = (alpha ・ ∇ Y W) >> (delta △ gamma).
Proof.
apply inc_antisym.
rewrite inc_rpc inc_residual.
remember (((alpha ・ ∇ Y Z) ∩ delta) △ gamma) as sigma1.
apply (@inc_trans _ _ _ (((alpha ・ ∇ Y Z) ∩ delta) # ・ sigma1)).
apply (@inc_trans _ _ _ (((alpha ・ ∇ Y Z) ∩ delta) # ・ (sigma1 ∩ (alpha ・ ∇ Y W)))).
assert ((delta # ・ (sigma1 ∩ (alpha ・ ∇ Y W))) ⊆ (delta # ・ sigma1)).
apply comp_inc_compat_ab_ab'.
apply cap_l.
apply inc_def1 in H.
rewrite H.
apply (@inc_trans _ _ _ _ _ (dedekind2)).
apply comp_inc_compat_ab_a'b.
rewrite (@inv_cap_distr _ _ _ delta) cap_comm.
apply cap_inc_compat_r.
rewrite inv_cap_distr.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_l)).
apply (@inc_trans _ _ _ _ _ (cap_r)).
rewrite comp_inv comp_inv -comp_assoc (@inv_universal Y Z).
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
apply comp_inc_compat_ab_ab'.
apply cap_l.
rewrite Heqsigma1.
apply inc_residual.
apply inc_refl.
rewrite inc_residual.
remember ((alpha ・ ∇ Y W) >> (delta △ gamma)) as sigma2.
apply (@inc_trans _ _ _ (delta # ・ ((alpha ・ ∇ Y W) ∩ sigma2))).
apply (@inc_trans _ _ _ (((alpha ・ ∇ Y Z) ∩ delta) # ・ ((alpha ・ ∇ Y W) ∩ sigma2))).
assert ((((alpha ・ ∇ Y Z) ∩ delta) # ・ sigma2) ⊆ (delta # ・ sigma2)).
apply comp_inc_compat_ab_a'b.
apply inc_inv.
apply cap_r.
apply inc_def1 in H.
rewrite H.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
apply comp_inc_compat_ab_ab'.
rewrite cap_comm inv_invol.
apply cap_inc_compat_r.
apply (@inc_trans _ _ _ ((alpha ・ ∇ Y Z) ・ (delta # ・ sigma2))).
apply comp_inc_compat_ab_a'b.
apply cap_l.
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inc_alpha_universal.
apply comp_inc_compat_ab_a'b.
apply inc_inv.
apply cap_r.
rewrite Heqsigma2.
rewrite -inc_residual cap_comm -inc_rpc.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property14]
Let $\nabla_{XX} \cdot \alpha \sqsubseteq \alpha$. Then,
$$
\nabla_{XX} \cdot (\alpha \rhd \beta) \sqsubseteq \alpha \rhd \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property14 {X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z}:
 (∇ X X ・ alpha) ⊆ alpha -> (∇ X X ・ (alpha △ beta)) ⊆ (alpha △ beta).
Proof.
move => H.
apply (@inc_trans _ _ _ (∇ X X ・ (∇ X X △ (alpha △ beta)))).
apply comp_inc_compat_ab_ab'.
rewrite double_residual.
apply (residual_inc_compat_r H).
rewrite -inv_universal -inc_residual inv_universal.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property15]
Let $\beta \cdot \nabla_{ZZ} \sqsubseteq \beta$. Then,
$$
(\alpha \rhd \beta) \cdot \nabla_{ZZ} \sqsubseteq \alpha \rhd \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property15 {X Y Z : eqType} {alpha : Rel X Y} {beta : Rel Y Z}:
 (beta ・ ∇ Z Z) ⊆ beta -> ((alpha △ beta) ・ ∇ Z Z) ⊆ (alpha △ beta).
Proof.
move => H.
apply (@inc_trans _ _ _ _ _ (residual_property1)).
apply (residual_inc_compat_l H).
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property16]
$$
id_X \sqsubseteq \alpha \rhd \alpha^\sharp \land (\alpha \rhd \alpha^\sharp) \cdot (\alpha \rhd \alpha^\sharp) \sqsubseteq \alpha \rhd \alpha^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property16 {X Y : eqType} {alpha : Rel X Y}:
 Id X ⊆ (alpha △ alpha #) /\
 ((alpha △ alpha #) ・ (alpha △ alpha #)) ⊆ (alpha △ alpha #).
Proof.
split.
rewrite inc_residual comp_id_r.
apply inc_refl.
move : (@residual_property2 _ _ _ _ alpha (alpha #) (alpha #)) => H.
rewrite inv_invol in H.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_property17]
Let $P(y):=$ ``$y :I \rel Y$ is a function''. Then,
$$
\sqcup_{P(y)} y^\sharp \cdot y = id_Y \Rightarrow \alpha \rhd \beta = \sqcap_{P(y)} (\alpha \cdot y^\sharp \cdot \nabla_{IZ} \Rightarrow \alpha \cdot y^\sharp \cdot y \cdot \beta).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_property17 {X Y Z : eqType}
 {alpha : Rel X Y} {beta : Rel Y Z} {P : Rel i Y -> Prop}:
 P = (fun y : Rel i Y => function_r y) ->
 ∪_{P} (fun y : Rel i Y => y # ・ y) = Id Y ->
 alpha △ beta = ∩_{P} (fun y : Rel i Y =>
  ((alpha ・ y #) ・ ∇ i Z) >> ((alpha ・ y #) ・ (y ・ beta))).
Proof.
move => H H0.
replace (alpha △ beta) with ((alpha ・ Id Y) △ beta).
rewrite -H0 comp_cupP_distr_l residual_cupP_distr_r.
apply capP_eq.
move => y H1.
rewrite H in H1.
rewrite -comp_assoc (function_residual4 H1).
apply residual_property9.
rewrite /univalent_r.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
by [rewrite comp_id_r].
Qed.

(** %
\section{順序の関係と左剰余合成}
\subsection{max, sup, min, inf}
\begin{screen}
$\xi : X \rel X$ を集合 $X$ における順序と見なしたときの, 関係 $\rho : V \rel X$ の 最大値(max), 上限(sup), 最小値(min), 下限(inf)はそれぞれ, 以下のように定義される.
\begin{itemize}
\item $max(\rho , \xi):= \rho \sqcap (\rho \rhd \xi)$
\item $sup(\rho , \xi):= (\rho \rhd \xi) \sqcap ((\rho \rhd \xi) \rhd \xi^\sharp)$
\item $min(\rho , \xi):= \rho \sqcap (\rho \rhd \xi^\sharp) (= max(\rho , \xi^\sharp))$
\item $inf(\rho , \xi):= (\rho \rhd \xi^\sharp) \sqcap ((\rho \rhd \xi^\sharp) \rhd \xi) (= sup(\rho , \xi^\sharp))$
\end{itemize}
\end{screen}
% **)
Definition max {V X : eqType} (rho : Rel V X) (xi : Rel X X)
 := rho ∩ (rho △ xi).
Definition sup {V X : eqType} (rho : Rel V X) (xi : Rel X X)
 := (rho △ xi) ∩ ((rho △ xi) △ xi #).
Definition min {V X : eqType} (rho : Rel V X) (xi : Rel X X)
 := rho ∩ (rho △ xi #).
Definition inf {V X : eqType} (rho : Rel V X) (xi : Rel X X)
 := (rho △ xi #) ∩ ((rho △ xi #) △ xi).

(** %
\begin{screen}
\begin{lemma}[max\_inc\_sup]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
max(\rho , \xi) \sqsubseteq sup(\rho , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma max_inc_sup {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 max rho xi ⊆ sup rho xi.
Proof.
rewrite /max/sup.
rewrite cap_comm.
apply cap_inc_compat_l.
apply galois_corollary1.
Qed.

(** %
\begin{screen}
\begin{lemma}[min\_inc\_inf]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
min(\rho , \xi) \sqsubseteq inf(\rho , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma min_inc_inf {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 min rho xi ⊆ inf rho xi.
Proof.
rewrite /min/inf.
rewrite cap_comm.
apply cap_inc_compat_l.
move : (@galois_corollary1 _ _ _ rho (xi #)) => H.
rewrite inv_invol in H.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inf\_to\_sup]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
inf(\rho , \xi) = sup(\rho \rhd \xi^\sharp , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma inf_to_sup {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 inf rho xi = sup (rho △ xi #) xi.
Proof.
rewrite /sup/inf.
rewrite cap_comm.
move : (@galois_corollary2 _ _ _ rho (xi #)) => H.
rewrite inv_invol in H.
by [rewrite H].
Qed.

(** %
\begin{screen}
\begin{lemma}[sup\_to\_inf]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
sup(\rho , \xi) = inf(\rho \rhd \xi , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma sup_to_inf {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 sup rho xi = inf (rho △ xi) xi.
Proof.
rewrite /sup/inf.
rewrite cap_comm.
by [rewrite galois_corollary2].
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_inc\_sup1, residual\_inc\_sup2]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
sup(\rho , \xi) \sqsubseteq \rho \rhd \xi \sqsubseteq sup(\rho , \xi) \rhd \xi.
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_inc_sup1 {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 sup rho xi ⊆ (rho △ xi).
Proof.
apply cap_l.
Qed.

Lemma residual_inc_sup2 {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 (rho △ xi) ⊆ ((sup rho xi) △ xi).
Proof.
rewrite galois.
apply cap_r.
Qed.

(** %
\begin{screen}
\begin{lemma}[max\_inc\_xi\_cap]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
(max(\rho , \xi))^\sharp \cdot max(\rho , \xi) \sqsubseteq \xi \sqcap \xi^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma max_inc_xi_cap {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 (max rho xi # ・ max rho xi) ⊆ (xi ∩ xi #).
Proof.
rewrite /max.
rewrite inv_cap_distr.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply cap_inc_compat.
apply inc_residual.
apply cap_r.
apply inv_inc_move.
rewrite comp_inv inv_invol.
apply inc_residual.
apply residual_inc_compat_r.
apply cap_l.
Qed.

(** %
\begin{screen}
\begin{lemma}[sup\_inc\_xi\_cap]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
(sup(\rho , \xi))^\sharp \cdot sup(\rho , \xi) \sqsubseteq \xi \sqcap \xi^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma sup_inc_xi_cap {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 (sup rho xi # ・ sup rho xi) ⊆ (xi ∩ xi #).
Proof.
move : (@max_inc_xi_cap _ _ (rho △ xi) (xi #)).
rewrite /max/sup.
by [rewrite inv_invol (@cap_comm _ _ xi)].
Qed.

(** %
\begin{screen}
\begin{lemma}[transitive\_sup1]
Let $\rho :V \rel X$, $\xi :X \rel X$ and $\xi \cdot \xi \sqsubseteq \xi$. Then,
$$
sup(\rho , \xi) \cdot (\xi \sqcap \xi^\sharp) = sup(\rho , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma transitive_sup1 {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 (xi ・ xi) ⊆ xi -> sup rho xi ・ (xi ∩ xi #) = sup rho xi.
Proof.
move => H.
apply inc_antisym.
rewrite /sup.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_l)).
apply cap_inc_compat.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply (@inc_trans _ _ _ _ _ (cap_l)).
apply (@inc_trans _ _ _ _ _ (residual_property1)).
apply (residual_inc_compat_l H).
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply (@inc_trans _ _ _ _ _ (cap_r)).
apply (@inc_trans _ _ _ _ _ (residual_property1)).
apply residual_inc_compat_l.
rewrite -comp_inv inv_inc_move inv_invol.
apply H.
apply (@inc_trans _ _ _ _ _ (relation_rel_inv_rel)).
rewrite comp_assoc.
apply (comp_inc_compat_ab_ab' sup_inc_xi_cap).
Qed.

(** %
\begin{screen}
\begin{lemma}[transitive\_sup2]
Let $\rho :V \rel X$, $\xi :X \rel X$ and $\xi \cdot \xi \sqsubseteq \xi$. Then,
$$
sup(\rho , \xi) \cdot \xi = \domain{sup(\rho , \xi)} \cdot (\rho \rhd \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma transitive_sup2 {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 (xi ・ xi) ⊆ xi -> sup rho xi ・ xi = domain (sup rho xi) ・ (rho △ xi).
Proof.
move => H.
apply inc_antisym.
replace (sup rho xi ・ xi) with (domain (sup rho xi) ・ (sup rho xi ・ xi)).
apply comp_inc_compat_ab_ab'.
apply (@inc_trans _ _ _ ((rho △ xi) ・ xi)).
apply (comp_inc_compat_ab_a'b cap_l).
apply (@inc_trans _ _ _ _ _ (residual_property1) (residual_inc_compat_l H)).
by [rewrite -comp_assoc domain_comp_alpha1].
apply (@inc_trans _ _ _ (domain (sup rho xi) ・ (sup rho xi △ xi))).
apply comp_inc_compat_ab_ab'.
apply galois.
apply cap_r.
rewrite /domain.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply (@inc_trans _ _ _ _ _ (cap_l)).
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inc_residual.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[domain\_sup\_inc]
Let $\rho :V \rel X$ and $\xi :X \rel X$. Then,
$$
\domain{sup(\rho , \xi)} \cdot \rho \sqsubseteq sup(\rho , \xi) \cdot \xi^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma domain_sup_inc {V X : eqType} {rho : Rel V X} {xi : Rel X X}:
 (domain (sup rho xi) ・ rho) ⊆ (sup rho xi ・ xi #).
Proof.
apply (@inc_trans _ _ _ (domain (sup rho xi) ・ (sup rho xi △ xi #))).
apply comp_inc_compat_ab_ab'.
rewrite -galois.
apply cap_l.
rewrite /domain.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply (@inc_trans _ _ _ _ _ (cap_l)).
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
apply inc_residual.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[sup\_function]
Let $\rho :V \rel X$, $\xi :X \rel X$ be relations and $f:W \to V$ be a function. Then,
$$
f \cdot sup(\rho , \xi) = sup(f \cdot \rho , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma sup_function {V W X : eqType} {rho : Rel V X} {xi : Rel X X} {f : Rel W V}:
 function_r f -> f ・ sup rho xi = sup (f ・ rho) xi.
Proof.
move => H.
rewrite /sup.
rewrite (function_cap_distr_l H).
by [rewrite (function_residual2 H) (function_residual2 H) (function_residual2 H)].
Qed.

(** %
\begin{screen}
\begin{lemma}[max\_univalent]
Let $\rho :V \rel X$, $\xi :X \rel X$ be relations and $\varphi :W \rel V$ be a univalent relation. Then,
$$
\varphi \cdot max(\rho , \xi) = max(\varphi \cdot \rho , \xi).
$$
\end{lemma}
\end{screen}
% **)
Lemma max_univalent {V W X : eqType}
 {rho : Rel V X} {xi : Rel X X} {phi : Rel W V}:
 univalent_r phi -> phi ・ max rho xi = max (phi ・ rho) xi.
Proof.
move => H.
rewrite /max.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_l)).
apply cap_inc_compat_l.
apply (@inc_trans _ _ _ _ _ (univalent_residual H)).
rewrite double_residual.
apply inc_refl.
apply (@inc_trans _ _ _ _ _ (dedekind1)).
apply comp_inc_compat_ab_ab'.
apply cap_inc_compat_l.
rewrite -inc_residual double_residual.
apply inc_refl.
Qed.

(** %
\subsection{左剰余合成}
\begin{screen}
関係 $\alpha :X \rel Y$, $\beta :Y \rel Z$ に対し, 左剰余合成を $\alpha \lhd \beta := (\beta^\sharp \rhd \alpha^\sharp)^\sharp$ で定義する.
\end{screen}
% **)
Definition leftres {X Y Z : eqType} (alpha : Rel X Y) (beta : Rel Y Z)
 := (beta # △ alpha #) #.

(** %
\begin{screen}
\begin{lemma}[inc\_leftres]
Let $\alpha :X \rel Y$, $\beta :Y \rel Z$ and $\delta :X \rel Z$. Then,
$$
\delta \sqsubseteq \alpha \lhd \beta \Leftrightarrow \delta \cdot \beta^\sharp \sqsubseteq \alpha.
$$
\end{lemma}
\end{screen}
% **)
Lemma inc_leftres {X Y Z : eqType}
 {alpha : Rel X Y} {beta : Rel Y Z} {delta : Rel X Z}:
 delta ⊆ leftres alpha beta <-> (delta ・ beta #) ⊆ alpha.
Proof.
rewrite /leftres.
by [rewrite inv_inc_move inc_residual -comp_inv inv_inc_move inv_invol].
Qed.

(** %
\begin{screen}
\begin{lemma}[residual\_leftres\_assoc]
Let $\alpha :X \rel Y$, $\beta :Y \rel Z$ and $\gamma :Z \rel W$. Then,
$$
(\alpha \rhd \beta) \lhd \gamma = \alpha \rhd (\beta \lhd \gamma).
$$
\end{lemma}
\end{screen}
% **)
Lemma residual_leftres_assoc {W X Y Z : eqType}
 {alpha : Rel X Y} {beta : Rel Y Z} {gamma : Rel Z W}:
 leftres (alpha △ beta) gamma = alpha △ leftres beta gamma.
Proof.
apply inc_lower.
move => delta.
by [rewrite inc_leftres inc_residual -comp_assoc -inc_leftres -inc_residual].
Qed.

End main.


Require Import Coq.Lists.List Coq.micromega.Psatz.
Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil.
Require Import Coq.ZArith.ZArith Coq.ZArith.Zdiv.
Require Import Coq.omega.Omega Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith.
Require Import Crypto.BaseSystem.
Require Import Crypto.Util.Notations.
Import Morphisms.
Local Open Scope Z.

Local Infix ".+" := add.

Local Hint Extern 1 (@eq Z _ _) => ring.

Section BaseSystemProofs.
  Context `(base_vector : BaseVector).

  Lemma decode'_truncate : forall bs us, decode' bs us = decode' bs (firstn (length bs) us).
  Proof.
    unfold decode'; intros; f_equal; apply combine_truncate_l.
  Qed.

  Lemma decode'_splice : forall xs ys bs,
    decode' bs (xs ++ ys) =
    decode' (firstn (length xs) bs) xs + decode'  (skipn (length xs) bs) ys.
  Proof.
    unfold decode'.
    induction xs; destruct ys, bs; boring.
    + rewrite combine_truncate_r.
      do 2 rewrite Z.add_0_r; auto.
    + unfold accumulate.
      apply Z.add_assoc.
  Qed.

  Lemma add_rep : forall bs us vs, decode' bs (add us vs) = decode' bs us + decode' bs vs.
  Proof.
    unfold decode', accumulate; induction bs; destruct us, vs; boring; ring.
  Qed.

  Lemma decode_nil : forall bs, decode' bs nil = 0.
    auto.
  Qed.
  Hint Rewrite decode_nil.

  Lemma decode_base_nil : forall us, decode' nil us = 0.
  Proof.
    intros; rewrite decode'_truncate; auto.
  Qed.

  Hint Rewrite decode_base_nil.

  Lemma mul_each_rep : forall bs u vs,
    decode' bs (mul_each u vs) = u * decode' bs vs.
  Proof.
    unfold decode', accumulate; induction bs; destruct vs; boring; ring.
  Qed.

  Lemma base_eq_1cons: base = 1 :: skipn 1 base.
  Proof.
    pose proof (b0_1 0) as H.
    destruct base; compute in H; try discriminate; boring.
  Qed.

  Lemma decode'_cons : forall x1 x2 xs1 xs2,
    decode' (x1 :: xs1) (x2 :: xs2) = x1 * x2 + decode' xs1 xs2.
  Proof.
    unfold decode', accumulate; boring; ring.
  Qed.
  Hint Rewrite decode'_cons.

  Lemma decode_cons : forall x us,
    decode base (x :: us) = x + decode base (0 :: us).
  Proof.
    unfold decode; intros.
    rewrite base_eq_1cons.
    autorewrite with core; ring_simplify; auto.
  Qed.

  Lemma decode'_map_mul : forall v xs bs,
    decode' (map (Z.mul v) bs) xs =
    Z.mul v (decode' bs xs).
  Proof.
    unfold decode'.
    induction xs; destruct bs; boring.
    unfold accumulate; simpl; nia.
  Qed.

  Lemma decode_map_mul : forall v xs,
    decode (map (Z.mul v) base) xs =
    Z.mul v (decode base xs).
  Proof.
    unfold decode; intros; apply decode'_map_mul.
  Qed.

  Lemma sub_rep : forall bs us vs, decode' bs (sub us vs) = decode' bs us - decode' bs vs.
  Proof.
    induction bs; destruct us; destruct vs; boring; ring.
  Qed.

  Lemma nth_default_base_nonzero : forall d, d <> 0 ->
    forall i, nth_default d base i <> 0.
  Proof.
    intros.
    rewrite nth_default_eq.
    destruct (nth_in_or_default i base d).
    + auto using Z.positive_is_nonzero, base_positive.
    + congruence.
  Qed.

  Lemma nth_default_base_pos : forall d, 0 < d ->
    forall i,  0 < nth_default d base i.
  Proof.
    intros.
    rewrite nth_default_eq.
    destruct (nth_in_or_default i base d).
    + apply Z.gt_lt; auto using base_positive.
    + congruence.
  Qed.

  Lemma mul_each_base : forall us bs c,
      decode' bs (mul_each c us) = decode' (mul_each c bs) us.
  Proof.
    induction us; destruct bs; boring; ring.
  Qed.

  Hint Rewrite (@nth_default_nil Z).
  Hint Rewrite (@firstn_nil Z).
  Hint Rewrite (@skipn_nil Z).

  Lemma base_app : forall us low high,
      decode' (low ++ high) us = decode' low (firstn (length low) us) + decode' high (skipn (length low) us).
  Proof.
    induction us; destruct low; boring.
  Qed.

  Lemma base_mul_app : forall low c us,
      decode' (low ++ mul_each c low) us = decode' low (firstn (length low) us) +
      c * decode' low (skipn (length low) us).
  Proof.
    intros.
    rewrite base_app; f_equal.
    rewrite <- mul_each_rep.
    rewrite mul_each_base.
    reflexivity.
  Qed.

  Lemma zeros_rep : forall bs n, decode' bs (zeros n) = 0.
    induction bs; destruct n; boring.
  Qed.
  Lemma length_zeros : forall n, length (zeros n) = n.
    induction n; boring.
  Qed.
  Hint Rewrite length_zeros.

  Lemma app_zeros_zeros : forall n m, zeros n ++ zeros m = zeros (n + m)%nat.
  Proof.
    induction n; boring.
  Qed.
  Hint Rewrite app_zeros_zeros.

  Lemma zeros_app0 : forall m, zeros m ++ 0 :: nil = zeros (S m).
  Proof.
    induction m; boring.
  Qed.
  Hint Rewrite zeros_app0.

  Lemma nth_default_zeros : forall n i, nth_default 0 (BaseSystem.zeros n) i = 0.
  Proof.
    induction n; intros; [ cbv [BaseSystem.zeros]; apply nth_default_nil | ].
    rewrite <-zeros_app0, nth_default_app.
    rewrite length_zeros.
    destruct (lt_dec i n); auto.
    destruct (eq_nat_dec i n); subst.
    + rewrite Nat.sub_diag; apply nth_default_cons.
    + apply nth_default_out_of_bounds.
      cbv [length]; omega.
  Qed.

  Lemma rev_zeros : forall n, rev (zeros n) = zeros n.
  Proof.
    induction n; boring.
  Qed.
  Hint Rewrite rev_zeros.

  Hint Unfold nth_default.

  Lemma decode_single : forall n bs x,
    decode' bs (zeros n ++ x :: nil) = nth_default 0 bs n * x.
  Proof.
    induction n; destruct bs; boring.
  Qed.
  Hint Rewrite decode_single.

  Lemma peel_decode : forall xs ys x y, decode' (x::xs) (y::ys) = x*y + decode' xs ys.
  Proof.
    boring.
  Qed.
  Hint Rewrite zeros_rep peel_decode.

  Lemma decode_Proper : Proper (Logic.eq ==> (Forall2 Logic.eq) ==> Logic.eq) decode'.
  Proof.
    repeat intro; subst.
    revert y y0 H0; induction x0; intros.
    + inversion H0. rewrite !decode_nil.
      reflexivity.
    + inversion H0; subst.
      destruct y as [|y0 y]; [rewrite !decode_base_nil; reflexivity | ].
      specialize (IHx0 y _ H4).
      rewrite !peel_decode.
      f_equal; auto.
  Qed.

  Lemma decode_highzeros : forall xs bs n, decode' bs (xs ++ zeros n) = decode' bs xs.
  Proof.
    induction xs; destruct bs; boring.
  Qed.

  Lemma mul_bi'_zeros : forall n m, mul_bi' base n (zeros m) = zeros m.
    induction m; boring.
  Qed.
  Hint Rewrite mul_bi'_zeros.

  Lemma nth_error_base_nonzero : forall n x,
    nth_error base n = Some x -> x <> 0.
  Proof.
    eauto using (@nth_error_value_In Z), Z.gt0_neq0, base_positive.
  Qed.

  Hint Rewrite plus_0_r.

  Lemma mul_bi_single : forall m n x,
    (n + m < length base)%nat ->
    decode base (mul_bi base n (zeros m ++ x :: nil)) = nth_default 0 base m * x * nth_default 0 base n.
  Proof.
    unfold mul_bi, decode.
    destruct m; simpl; simpl_list; simpl; intros. {
      pose proof nth_error_base_nonzero as nth_nonzero.
      case_eq base; [intros; boring | intros z l base_eq].
      specialize (b0_1 0); intro b0_1'.
      rewrite base_eq in *.
      rewrite nth_default_cons in b0_1'.
      rewrite b0_1' in *.
      unfold crosscoef.
      autounfold; autorewrite with core.
      unfold nth_default.
      nth_tac.
      rewrite Z.mul_1_r.
      rewrite Z_div_same_full.
      destruct x; ring.
      eapply nth_nonzero; eauto.
    } {
      ssimpl_list.
      autorewrite with core.
      rewrite app_assoc.
      autorewrite with core.
      unfold crosscoef; simpl; ring_simplify.
      rewrite Nat.add_1_r.
      rewrite base_good by auto.
      rewrite Z_div_mult by (apply base_positive; rewrite nth_default_eq; apply nth_In; auto).
      rewrite <- Z.mul_assoc.
      rewrite <- Z.mul_comm.
      rewrite <- Z.mul_assoc.
      rewrite <- Z.mul_assoc.
      destruct (Z.eq_dec x 0); subst; try ring.
      rewrite Z.mul_cancel_l by auto.
      rewrite <- base_good by auto.
      ring.
      }
  Qed.

  Lemma set_higher' : forall vs x, vs++x::nil = vs .+ (zeros (length vs) ++ x :: nil).
    induction vs; boring; f_equal; ring.
  Qed.

  Lemma set_higher : forall bs vs x,
    decode' bs (vs++x::nil) = decode' bs vs + nth_default 0 bs (length vs) * x.
  Proof.
    intros.
    rewrite set_higher'.
    rewrite add_rep.
    f_equal.
    apply decode_single.
  Qed.

  Lemma zeros_plus_zeros : forall n, zeros n = zeros n .+ zeros n.
    induction n; auto.
    simpl; f_equal; auto.
  Qed.

  Lemma mul_bi'_n_nil : forall n, mul_bi' base n nil = nil.
  Proof.
    unfold mul_bi; auto.
  Qed.
  Hint Rewrite mul_bi'_n_nil.

  Lemma add_nil_l : forall us, nil .+ us = us.
    induction us; auto.
  Qed.
  Hint Rewrite add_nil_l.

  Lemma add_nil_r : forall us, us .+ nil = us.
    induction us; auto.
  Qed.
  Hint Rewrite add_nil_r.

  Lemma add_first_terms : forall us vs a b,
    (a :: us) .+ (b :: vs) = (a + b) :: (us .+ vs).
    auto.
  Qed.
  Hint Rewrite add_first_terms.

  Lemma mul_bi'_cons : forall n x us,
    mul_bi' base n (x :: us) = x * crosscoef base n (length us) :: mul_bi' base n us.
  Proof.
    unfold mul_bi'; auto.
  Qed.

  Lemma add_same_length : forall us vs l, (length us = l) -> (length vs = l) ->
    length (us .+ vs) = l.
  Proof.
    induction us, vs; boring.
    erewrite (IHus vs (pred l)); boring.
  Qed.

  Hint Rewrite app_nil_l.
  Hint Rewrite app_nil_r.

  Lemma add_snoc_same_length : forall l us vs a b,
    (length us = l) -> (length vs = l) ->
    (us ++ a :: nil) .+ (vs ++ b :: nil) = (us .+ vs) ++ (a + b) :: nil.
  Proof.
    induction l, us, vs; boring; discriminate.
  Qed.

  Lemma mul_bi'_add : forall us n vs l
    (Hlus: length us = l)
    (Hlvs: length vs = l),
    mul_bi' base n (rev (us .+ vs)) =
    mul_bi' base n (rev us) .+ mul_bi' base n (rev vs).
  Proof.
    (* TODO(adamc): please help prettify this *)
    induction us using rev_ind;
      try solve [destruct vs; boring; congruence].
    destruct vs using rev_ind; boring; clear IHvs; simpl_list.
    erewrite (add_snoc_same_length (pred l) us vs _ _); simpl_list.
    repeat rewrite mul_bi'_cons; rewrite add_first_terms; simpl_list.
    rewrite (IHus n vs (pred l)).
    replace (length us) with (pred l).
    replace (length vs) with (pred l).
    rewrite (add_same_length us vs (pred l)).
    f_equal; ring.

    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
    erewrite length_snoc; eauto.
   Qed.

  Lemma zeros_cons0 : forall n, 0 :: zeros n = zeros (S n).
    auto.
  Qed.

  Lemma add_leading_zeros : forall n us vs,
    (zeros n ++ us) .+ (zeros n ++ vs) = zeros n ++ (us .+ vs).
  Proof.
    induction n; boring.
  Qed.

  Lemma rev_add_rev : forall us vs l, (length us = l) -> (length vs = l) ->
    (rev us) .+ (rev vs) = rev (us .+ vs).
  Proof.
    induction us, vs; boring; try solve [subst; discriminate].
    rewrite (add_snoc_same_length (pred l) _ _ _ _) by (subst; simpl_list; omega).
    rewrite (IHus vs (pred l)) by omega; auto.
  Qed.
  Hint Rewrite rev_add_rev.

  Lemma mul_bi'_length : forall us n, length (mul_bi' base n us) = length us.
  Proof.
    induction us, n; boring.
  Qed.
  Hint Rewrite mul_bi'_length.

  Lemma add_comm : forall us vs, us .+ vs = vs .+ us.
  Proof.
    induction us, vs; boring; f_equal; auto.
  Qed.

  Hint Rewrite rev_length.

  Lemma mul_bi_add_same_length : forall n us vs l,
    (length us = l) -> (length vs = l) ->
    mul_bi base n (us .+ vs) = mul_bi base n us .+ mul_bi base n vs.
  Proof.
    unfold mul_bi; boring.
    rewrite add_leading_zeros.
    erewrite mul_bi'_add; boring.
    erewrite rev_add_rev; boring.
  Qed.

  Lemma add_zeros_same_length : forall us, us .+ (zeros (length us)) = us.
  Proof.
    induction us; boring; f_equal; omega.
  Qed.

  Hint Rewrite add_zeros_same_length.
  Hint Rewrite minus_diag.

  Lemma add_trailing_zeros : forall us vs, (length us >= length vs)%nat ->
    us .+ vs = us .+ (vs ++ (zeros (length us - length vs)%nat)).
  Proof.
    induction us, vs; boring; f_equal; boring.
  Qed.

  Lemma length_add_ge : forall us vs, (length us >= length vs)%nat ->
    (length (us .+ vs) <= length us)%nat.
  Proof.
    intros.
    rewrite add_trailing_zeros by trivial.
    erewrite add_same_length by (pose proof app_length; boring); omega.
  Qed.

  Lemma add_length_le_max : forall us vs,
      (length (us .+ vs) <= max (length us) (length vs))%nat.
  Proof.
    intros; case_max; (rewrite add_comm; apply length_add_ge; omega) ||
                                        (apply length_add_ge; omega) .
  Qed.

  Lemma sub_nil_length: forall us : digits, length (sub nil us) = length us.
  Proof.
     induction us; boring.
  Qed.

  Lemma sub_length : forall us vs,
      (length (sub us vs) = max (length us) (length vs))%nat.
  Proof.
    induction us, vs; boring.
    rewrite sub_nil_length; auto.
  Qed.

  Lemma mul_bi_length : forall us n, length (mul_bi base n us) = (length us + n)%nat.
  Proof.
    pose proof mul_bi'_length; unfold mul_bi.
    destruct us; repeat progress (simpl_list; boring).
  Qed.
  Hint Rewrite mul_bi_length.

  Lemma mul_bi_trailing_zeros : forall m n us,
    mul_bi base n us ++ zeros m = mul_bi base n (us ++ zeros m).
  Proof.
    unfold mul_bi.
    induction m; intros; try solve [boring].
    rewrite <- zeros_app0.
    rewrite app_assoc.
    repeat progress (boring; rewrite rev_app_distr).
  Qed.

  Lemma mul_bi_add_longer : forall n us vs,
    (length us >= length vs)%nat ->
    mul_bi base n (us .+ vs) = mul_bi base n us .+ mul_bi base n vs.
  Proof.
    boring.
    rewrite add_trailing_zeros by auto.
    rewrite (add_trailing_zeros (mul_bi base n us) (mul_bi base n vs))
      by (repeat (rewrite mul_bi_length); omega).
    erewrite mul_bi_add_same_length by
      (eauto; simpl_list; rewrite length_zeros; omega).
    rewrite mul_bi_trailing_zeros.
    repeat (f_equal; boring).
  Qed.

  Lemma mul_bi_add : forall n us vs,
    mul_bi base n (us .+ vs) = (mul_bi base n  us) .+ (mul_bi base n vs).
  Proof.
    intros; pose proof mul_bi_add_longer.
    destruct (le_ge_dec (length us) (length vs)). {
      rewrite add_comm.
      rewrite (add_comm (mul_bi base n us)).
      boring.
    } {
      boring.
    }
  Qed.

  Lemma mul_bi_rep : forall i vs,
    (i + length vs < length base)%nat ->
    decode base (mul_bi base i vs) = decode base vs * nth_default 0 base i.
  Proof.
    unfold decode.
    induction vs using rev_ind; intros; try solve [unfold mul_bi; boring].
    assert (i + length vs < length base)%nat by
      (rewrite app_length in *; boring).

    rewrite set_higher.
    ring_simplify.
    rewrite <- IHvs by auto; clear IHvs.
    rewrite <- mul_bi_single by auto.
    rewrite <- add_rep.
    rewrite <- mul_bi_add.
    rewrite set_higher'.
    auto.
  Qed.

  Local Notation mul' := (mul' base).
  Local Notation mul := (mul base).

  Lemma mul'_rep : forall us vs,
    (length us + length vs <= length base)%nat ->
    decode base (mul' (rev us) vs) = decode base us * decode base vs.
  Proof.
    unfold decode.
    induction us using rev_ind; boring.

    assert (length us + length vs < length base)%nat by
      (rewrite app_length in *; boring).

    ssimpl_list.
    rewrite add_rep.
    boring.
    rewrite set_higher.
    rewrite mul_each_rep.
    rewrite mul_bi_rep by auto.
    unfold decode; ring.
  Qed.

  Lemma mul_rep : forall us vs,
    (length us + length vs <= length base)%nat ->
    decode base (mul us vs) = decode base us * decode base vs.
  Proof.
    exact mul'_rep.
  Qed.

  Lemma mul'_length: forall us vs,
      (length (mul' us vs) <= length us + length vs)%nat.
  Proof.
    pose proof add_length_le_max.
    induction us; boring.
    unfold mul_each.
    simpl_list; case_max; boring; omega.
  Qed.

  Lemma mul_length: forall us vs,
      (length (mul us vs) <= length us + length vs)%nat.
  Proof.
    intros; unfold BaseSystem.mul.
    rewrite mul'_length.
    rewrite rev_length; omega.
  Qed.

  Lemma add_length_exact : forall us vs,
      length (us .+ vs) = max (length us) (length vs).
  Proof.
    induction us; destruct vs; boring.
  Qed.

  Hint Rewrite add_length_exact : distr_length.

  Lemma mul'_length_exact_full: forall us vs,
      (length (mul' us vs) = match length us with
                             | 0 => 0%nat
                             | _ => pred (length us + length vs)
                             end)%nat.
  Proof.
    induction us; intros; try solve [boring].
    unfold BaseSystem.mul'; fold mul'.
    unfold mul_each.
    rewrite add_length_exact, map_length, mul_bi_length, length_cons.
    destruct us.
    + rewrite Max.max_0_r. simpl; omega.
    + rewrite Max.max_l; [ omega | ].
      rewrite IHus by ( congruence || simpl in *; omega).
      simpl; omega.
  Qed.

  Hint Rewrite mul'_length_exact_full : distr_length.

  (* TODO(@jadephilipoom, from jgross): one of these conditions isn't
  needed.  Should it be dropped, or was there a reason to keep it? *)
  Lemma mul'_length_exact: forall us vs,
      (length us <= length vs)%nat -> us <> nil ->
      (length (mul' us vs) = pred (length us + length vs))%nat.
  Proof.
    intros; rewrite mul'_length_exact_full; destruct us; simpl; congruence.
  Qed.

  Lemma mul_length_exact_full: forall us vs,
      (length (mul us vs) = match length us with
                            | 0 => 0
                            | _ => pred (length us + length vs)
                            end)%nat.
  Proof.
    intros; unfold BaseSystem.mul; autorewrite with distr_length; reflexivity.
  Qed.

  Hint Rewrite mul_length_exact_full : distr_length.

  (* TODO(@jadephilipoom, from jgross): one of these conditions isn't
  needed.  Should it be dropped, or was there a reason to keep it? *)
  Lemma mul_length_exact: forall us vs,
      (length us <= length vs)%nat -> us <> nil ->
      (length (mul us vs) = pred (length us + length vs))%nat.
  Proof.
    intros; unfold BaseSystem.mul.
    rewrite mul'_length_exact; rewrite ?rev_length; try omega.
    intro rev_nil.
    match goal with H : us <> nil |- _ => apply H end.
    apply length0_nil; rewrite <-rev_length, rev_nil.
    reflexivity.
  Qed.
  Definition encode'_zero z max  : encode' base z max 0%nat = nil := eq_refl.
  Definition encode'_succ z max i : encode' base z max (S i) =
    encode' base z max i ++ ((z mod (nth_default max base (S i))) / (nth_default max base i)) :: nil := eq_refl.
  Opaque encode'.
  Hint Resolve encode'_zero encode'_succ.

  Lemma encode'_length : forall z max i, length (encode' base z max i) = i.
  Proof.
    induction i; auto.
    rewrite encode'_succ, app_length, IHi.
    cbv [length].
    omega.
  Qed.

  (* States that each element of the base is a positive integer multiple of the previous
     element, and that max is a positive integer multiple of the last element. Ideally this
     would have a better name. *)
  Definition base_max_succ_divide max := forall i, (S i <= length base)%nat ->
    Z.divide (nth_default max base i) (nth_default max base (S i)).

  Lemma encode'_spec : forall z max, 0 < max ->
    base_max_succ_divide max -> forall i, (i <= length base)%nat ->
    decode' base (encode' base z max i) = z mod (nth_default max base i).
  Proof.
    induction i; intros.
    + rewrite encode'_zero, b0_1, Z.mod_1_r.
      apply decode_nil.
    + rewrite encode'_succ, set_higher.
      rewrite IHi by omega.
      rewrite encode'_length, (Z.add_comm (z mod nth_default max base i)).
      replace (nth_default 0 base i) with (nth_default max base i) by
        (rewrite !nth_default_eq; apply nth_indep; omega).
      match goal with H1 : base_max_succ_divide _, H2 : (S i <= length base)%nat, H3 : 0 < max |- _ =>
        specialize (H1 i H2);
        rewrite (Znumtheory.Zmod_div_mod _ _ _ (nth_default_base_pos _ H _)
                                               (nth_default_base_pos _ H _) H0) end.
      rewrite <-Z.div_mod by (apply Z.positive_is_nonzero, Z.lt_gt; auto using nth_default_base_pos).
      reflexivity.
  Qed.

  Lemma encode_rep : forall z max, 0 <= z < max ->
    base_max_succ_divide max -> decode base (encode base z max) = z.
  Proof.
    unfold encode; intros.
    rewrite encode'_spec, nth_default_out_of_bounds by (omega || auto).
    apply Z.mod_small; omega.
  Qed.

End BaseSystemProofs.

Hint Rewrite @add_length_exact @mul'_length_exact_full @mul_length_exact_full @encode'_length @sub_length : distr_length.

Section MultiBaseSystemProofs.
  Context base0 (base_vector0 : @BaseVector base0) base1 (base_vector1 : @BaseVector base1).

  Lemma decode_short_initial : forall (us : digits),
      (firstn (length us) base0 = firstn (length us) base1)
      -> decode base0 us = decode base1 us.
  Proof.
    intros us H.
    unfold decode, decode'.
    rewrite (combine_truncate_r us base0), (combine_truncate_r us base1), H.
    reflexivity.
  Qed.

  Lemma mul_rep_two_base : forall (us vs : digits),
      (length us + length vs <= length base1)%nat
      -> firstn (length us) base0 = firstn (length us) base1
      -> firstn (length vs) base0 = firstn (length vs) base1
      -> (decode base0 us) * (decode base0 vs) = decode base1 (mul base1 us vs).
  Proof.
      intros.
      rewrite mul_rep by trivial.
      apply f_equal2; apply decode_short_initial; assumption.
  Qed.

End MultiBaseSystemProofs.