From mathcomp
     Require Import ssreflect ssrnat ssrbool ssrfun eqtype seq div fintype
     tuple finfun bigop.
Add LoadPath "../mylib".
Require Export mylib.
Require Export NNet_sub_def.

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

Module Import NNetDef.
(* ***************************** *)
Module neuron1.

   Record class_of (I O C:Type) :=
    Class {
        action : C -> I -> O;
        op : O -> O -> O;
        _ : associative op
      }.

  Section Packing.

    Structure type :=
      Pack {NNetI; NNetO; NNetC; _: class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT return
                           class_of (NNetI cT) (NNetO cT) (NNetC cT) in c.

  End Packing.

  Module Exports.

    Notation neuron1Type := type.
    Definition NNetI := NNetI.
    Definition NNetO := NNetO.
    Definition NNetC := NNetC.
    Definition NNaction S := action (class S).
    Definition NNop S := op (class S).

  End Exports.
End neuron1.
Import neuron1.Exports.

Section neuron1_lemma.

  Variable (S:neuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.

  Lemma NNopA : associative op.
  Proof. rewrite /op. by case : S => NNetI NNetO NNetC []. Qed.

  Definition neuron1 Idim (coeff:C ^ Idim) b : I ^ Idim -> O :=
    fun input => \big[op/b]_(i < Idim) action (coeff i) (input i).

  Definition MP1parameter Idim Odim : Type :=
    ((C ^ Idim) ^ Odim : Type) * O ^ Odim.

  Definition coeff_zero c0 Idim Odim : (C ^ Idim) ^ Odim : Type :=
    [ffun => [ffun => c0]].

  Definition bias_zero o0 Odim : O ^ Odim := [ffun => o0].

  Definition MP1parameter_zero o0 c0 Idim Odim : MP1parameter Idim Odim :=
    (coeff_zero c0 Idim Odim,bias_zero o0 Odim).

  Definition MP1 Idim Odim (p:MP1parameter Idim Odim) :
    I ^ Idim -> O ^ Odim :=
    fun input => [ffun j => neuron1 (p.1 j) (p.2 j) input].

(* ***************************** *)

  Lemma neuron1_Idim0 (coeff:C ^ 0) b input :
    neuron1 coeff b input = b.
  Proof. by rewrite /neuron1 big_ord0. Qed.

  Lemma MP1_Idim0 Odim (p:MP1parameter 0 Odim) input:
    MP1 p input = p.2.
  Proof. apply /ffunP => i. rewrite ffunE. exact : neuron1_Idim0. Qed.

  Lemma neuron1_op_bias Idim (coeff:C ^ Idim) b b' input:
    neuron1 coeff (op b b') input = op (neuron1 coeff b input) b'.
  Proof. by rewrite /neuron1 big_idx_assoc; last exact NNopA. Qed.

  Lemma MP1_op_bias Idim Odim (coeff:(C ^ Idim) ^ Odim: Type)
        (bias bias':O ^ Odim) input:
    MP1 (coeff,[ffun j => op (bias j) (bias' j)]) input
    = [ffun j => op (MP1 (coeff,bias) input j) (bias' j)].
  Proof. apply /ffunP => j. by rewrite !ffunE -/neuron1 neuron1_op_bias. Qed.

  Lemma neuron1_appI Idim Idim' (coeff:C ^ (Idim + Idim')) b input:
    neuron1 coeff b input =
    neuron1 (index_projl coeff)
            (neuron1 (index_projr coeff) b (index_projr input))
            (index_projl input).
  Proof.
    rewrite /neuron1 big_split_ord_nested.
    rewrite (eq_bigr (fun i => action (index_projl coeff i)
                                      (index_projl input i)))=>[|i _];
      last by rewrite !ffunE.
    congr bigop. apply : eq_bigr => i _. by rewrite !ffunE.
  Qed.

  Lemma MP1_appI Idim Idim' Odim (p:MP1parameter (Idim + Idim') Odim) input:
    MP1 p input =
    MP1 ([ffun i => index_projl (p.1 i)],
         MP1 ([ffun i => index_projr (p.1 i)],p.2) (index_projr input))
        (index_projl input).
  Proof. apply /ffunP => j. rewrite !ffunE. exact : neuron1_appI. Qed.

  Lemma MP1_sumO Idim Odim Odim'
        (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim) ^ Odim' : Type) bias bias' input:
    MP1 ((index_app coeff coeff'),(index_app bias bias')) input =
    index_app (MP1 (coeff,bias) input) (MP1 (coeff',bias') input).
  Proof.
    apply /ffunP => j. rewrite !ffunE /=.
    case splitP =>/= j' Heq /=; by rewrite !ffunE.
  Qed.

  Lemma MP1_appO Idim Odim Odim' (p:MP1parameter Idim (Odim + Odim')) input:
    MP1 p input =
    index_app (MP1 (index_projl p.1, index_projl p.2) input)
              (MP1 (index_projr p.1, index_projr p.2) input).
  Proof. by rewrite -MP1_sumO !index_app_proj. Qed.

  Lemma index_projl_MP1 Idim Odim Odim'
        (p:MP1parameter Idim (Odim + Odim')) input:
    index_projl (MP1 p input) = MP1 (index_projl p.1, index_projl p.2) input.
  Proof. by rewrite MP1_appO index_projl_app. Qed.

  Lemma index_projr_MP1 Idim Odim Odim'
        (p:MP1parameter Idim (Odim + Odim')) input:
    index_projr (MP1 p input) = MP1 (index_projr p.1, index_projr p.2) input.
  Proof. by rewrite MP1_appO index_projr_app. Qed.

(* ***************************** *)

  Definition cast_MP1parameter Idim1 Odim1 Idim2 Odim2
             (eqIdim : Idim1 = Idim2) (eqOdim : Odim1 = Odim2)
             (p:MP1parameter Idim1 Odim1) : MP1parameter Idim2 Odim2 :=
    ecast Idim2 _ eqIdim (ecast Odim2 _ eqOdim p).

  Lemma cast_MP1parameter_id Idim Odim eqIdim eqOdim (p:MP1parameter Idim Odim):
    cast_MP1parameter eqIdim eqOdim p = p.
  Proof. by rewrite !eq_axiomK. Qed.

  Lemma cast_MP1parameterK Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MP1parameter eqIdim eqOdim)
           (cast_MP1parameter (esym eqIdim) (esym eqOdim)).
  Proof. by case : Idim2 / eqIdim; case : Odim2 / eqOdim. Qed.

  Lemma cast_MP1parameterKV Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MP1parameter (esym eqIdim) (esym eqOdim))
           (cast_MP1parameter eqIdim eqOdim).
  Proof. by case : Idim2 / eqIdim; case : Odim2 / eqOdim. Qed.

  Lemma cast_MP1parameter_trans Idim1 Odim1 Idim2 Odim2 Idim3 Odim3
        eqIdim12 eqIdim23 eqOdim12 eqOdim23 (p:MP1parameter Idim1 Odim1):
    @cast_MP1parameter _ _ Idim3 Odim3 eqIdim23 eqOdim23
                       (@cast_MP1parameter _ _ Idim2 Odim2 eqIdim12 eqOdim12 p)
    = cast_MP1parameter (etrans eqIdim12 eqIdim23) (etrans eqOdim12 eqOdim23) p.
  Proof. by case : Idim3 / eqIdim23; case : Odim3 / eqOdim23. Qed.

  Lemma cast_MP1parameter_inj Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2):
    injective (cast_MP1parameter eqIdim eqOdim).
  Proof. exact : can_inj (cast_MP1parameterK _ _). Qed.

  Lemma cast_MP1parameterE Idim1 Odim1 Idim2 Odim2
        (eqIdim : Idim1 = Idim2) (eqOdim : Odim1 = Odim2)
        (p:MP1parameter Idim1 Odim1):
    cast_MP1parameter eqIdim eqOdim p =
    (cast_index eqOdim [ffun i => cast_index eqIdim (p.1 i)],
     cast_index eqOdim p.2).
  Proof.
    case : Idim2 / eqIdim. case : Odim2 /eqOdim.
    rewrite cast_MP1parameter_id !cast_index_id. case : p => p1 p2.
    congr(_,_). apply /ffunP => i. by rewrite ffunE cast_index_id.
  Qed.

  Lemma MP1_cast Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2)
        (p:MP1parameter Idim1 Odim1) input:
    MP1 (cast_MP1parameter eqIdim eqOdim p) (cast_index eqIdim input) =
    cast_index eqOdim (MP1 p input).
  Proof.
    apply /ffunP => i. rewrite cast_MP1parameterE ffunE !cast_indexE !ffunE /=.
    rewrite /neuron1 (big_cast_ord _ _ eqIdim).
    apply : eq_bigr => j _. by rewrite !cast_indexE cast_ordK.
  Qed.

End neuron1_lemma.

(* ***************************** *)
Module mononeuron1.

  Record mixin_of (S:neuron1Type) :=
    Mixin {
        id: NNetO S;
        _: left_id id (@NNop S);
        _: right_id id (@NNop S)
      }.

  Section Packing.

    Structure class_of (I O C:Type) :=
      Class {
          neuron1_class : neuron1.class_of I O C;
          mixin : mixin_of (neuron1.Pack neuron1_class)
        }.
    Structure type := Pack {NNetI; NNetO; NNetC; _: class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.

    Definition neuron1 := neuron1.Pack (neuron1_class class).

  End Packing.

  Module Exports.

    Notation mononeuron1Type := type.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : mononeuron1Type >-> neuron1Type.
    Canonical neuron1.
    Definition NNid S := id (mixin (class S)).

  End Exports.
End mononeuron1.
Import mononeuron1.Exports.

(* ***************************** *)
Section mononeuron1_lemma.

  Variable (S:mononeuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.

  Lemma NNop0o : left_id id op.
  Proof. rewrite /op /id. by case : S => NNetI NNetO NNetC [class []]. Qed.

  Lemma NNopo0 : right_id id op.
  Proof. rewrite /op /id. by case : S => NNetI NNetO NNetC [class []]. Qed.

  Canonical NNop_monoid := Monoid.Law (@NNopA S) NNop0o NNopo0.

  Definition bias0 := bias_zero id.

  Lemma neuron1_bias Idim (coeff:C ^ Idim) b input:
    neuron1 coeff b input = op (neuron1 coeff id input) b.
  Proof. by rewrite /op -neuron1_op_bias -/op NNop0o. Qed.

  Lemma MP1_bias Idim Odim (coeff:(C ^ Idim) ^ Odim: Type) bias input:
    MP1 (coeff,bias) input =
    [ffun j => op (MP1 (coeff,bias0 _) input j) (bias j)].
  Proof. apply /ffunP => j. by rewrite !ffunE -/neuron1 neuron1_bias. Qed.

End mononeuron1_lemma.

(* ***************************** *)
Module idCneuron1.

  Record mixin_of (V:mononeuron1Type) :=
    Mixin {
        idC: NNetC V;
        _: forall x, NNaction idC x = @NNid V
      }.

  Section Packing.

    Structure class_of (I O C:Type) :=
      Class {
          mono_class:mononeuron1.class_of I O C;
          mixin:mixin_of (mononeuron1.Pack mono_class)
        }.
    Structure type := Pack {NNetI; NNetO; NNetC; _: class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (mono_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).

  End Packing.

  Module Exports.

    Notation idCneuron1Type := type.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : idCneuron1Type >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : idCneuron1Type >-> mononeuron1Type.
    Canonical mononeuron1.
    Definition NNidC S := idC (class S).

  End Exports.
End idCneuron1.
Export idCneuron1.Exports.

Section idCneuron1_lemma.

  Variable (S:idCneuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let parameter := @MP1parameter S.

  Definition coeff0 := coeff_zero idC.
  Definition MP1parameter0 := MP1parameter_zero id idC.

  Lemma action_idl x: action idC x = id.
  Proof.
    rewrite /action /idC /id. by case : S x => NNetI NNetO NNetC [class []].
  Qed.

  Lemma neuron1_idC Idim (input:I ^ Idim) b:
    neuron1 [ffun _ => idC] b input = b.
  Proof.
    rewrite neuron1_bias /neuron1 big1; first exact : NNop0o.
    move => i _. rewrite ffunE. exact : action_idl.
  Qed.

  Lemma MP1_coeff0 Idim Odim (bias:O ^ Odim) (input:I ^ Idim):
    MP1 (coeff0 _ _,bias) input = bias.
  Proof. by apply /ffunP => j; rewrite !ffunE neuron1_idC. Qed.

  Definition coeff_app Idim Odim Idim' Odim'
             (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim': Type)
    :=
    index_app
      [ffun j:'I_Odim => (index_app (coeff j) [ffun _ :'I_Idim' => idC])]
      [ffun j:'I_Odim' => (index_app [ffun _ :'I_Idim => idC] (coeff' j))].

  Definition MP1parameter_sum Idim1 Odim1 Idim2 Odim2
             (p1:parameter Idim1 Odim1) (p2:parameter Idim2 Odim2) :
    parameter (Idim1 + Idim2) (Odim1 + Odim2) :=
    (coeff_app p1.1 p2.1,index_app p1.2 p2.2).

  Lemma MP1parameter_sumA Idim1 Odim1 Idim2 Odim2 Idim3 Odim3
        (p1:parameter Idim1 Odim1) (p2:parameter Idim2 Odim2)
        (p3:parameter Idim3 Odim3):
    MP1parameter_sum p1 (MP1parameter_sum p2 p3) =
    cast_MP1parameter (esym (addnA _ _ _)) (esym (addnA _ _ _))
                      (MP1parameter_sum (MP1parameter_sum p1 p2) p3).
  Proof.
    rewrite /MP1parameter_sum cast_MP1parameterE /=.
    congr(_,_); last exact : index_appA. apply /ffunP => i.
    rewrite cast_indexE esymK !ffunE !cast_ord_addnA /=.
    case : splitP => j _/=; last (rewrite !ffunE /=; case : splitP => k _/=);
      rewrite ?split_lshift ?split_rshift /= !ffunE /=
              ?split_lshift ?split_rshift /= ?ffunE -?index_appA =>//.
    - congr index_app. apply /ffunP => k /=. rewrite !ffunE /=.
      by case : splitP => ? _/=; rewrite ffunE.
    - rewrite index_appA. congr cast_index. congr index_app. apply /ffunP => t.
      rewrite !ffunE /=. by case : split => ? /=; rewrite ffunE.
  Qed.

  Lemma MP1parameter_sum0 Idim1 Idim2 Odim1 Odim2:
    MP1parameter_sum (MP1parameter0 Idim1 Odim1) (MP1parameter0 Idim2 Odim2) =
    (MP1parameter0 _ _).
  Proof.
    rewrite /MP1parameter_sum /MP1parameter0.
    by congr(_,_); apply /ffunP => i;
      rewrite !ffunE /=; case : splitP => i' _/=; rewrite !ffunE //;
      apply /ffunP => j; rewrite !ffunE /=; case : splitP => j' /=;
      rewrite !ffunE.
  Qed.

End idCneuron1_lemma.

(* ***************************** *)
Module comoneuron1.

  Record mixin_of (S:mononeuron1Type) :=
    Mixin { _: commutative (@NNop S)}.

  Section Packing.

    Record class_of (I O C:Type) :=
      Class {
          mono_class : mononeuron1.class_of I O C;
          mixin : mixin_of (mononeuron1.Pack mono_class)
        }.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (mono_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).

  End Packing.

  Module Exports.

    Notation comoneuron1Type := type.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : comoneuron1Type >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comoneuron1Type >-> mononeuron1Type.
    Canonical mononeuron1.

  End Exports.
End comoneuron1.
Export comoneuron1.Exports.

Section comoneuron1_lemma.

  Variable (S:comoneuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.

  Lemma NNopC : commutative op.
  Proof. rewrite /op. by case : S => NNetI NNetO NNetC [class []]. Qed.

  Canonical NNop_comoid := Monoid.ComLaw NNopC.

  Lemma NNopCA : left_commutative op. Proof. exact : Monoid.mulmCA. Qed.
  Lemma NNopAC : right_commutative op. Proof. exact : Monoid.mulmAC. Qed.
  Lemma NNopACA : interchange op op. Proof. exact : Monoid.mulmACA. Qed.

  Lemma neuron1_sumI Idim Idim'
        (coeff:C ^ Idim) (coeff':C ^ Idim') b b' input:
    neuron1 (index_app coeff coeff') (op b b') input
    = op (neuron1 coeff b (index_projl input))
         (neuron1 coeff' b' (index_projr input)).
  Proof.
    rewrite neuron1_bias [_ _ b _]neuron1_bias [_ _ b' _]neuron1_bias.
    rewrite NNopACA /neuron1. congr(op _ _). rewrite big_split_ord.
    congr (op _ _); apply: eq_bigr => i _.
    - congr(action _ _); first exact : index_app_lshift. by rewrite ffunE.
    - congr(action _ _); first exact : index_app_rshift. by rewrite ffunE.
  Qed.

  Lemma MP1_sumI Idim Idim' Odim
      (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim: Type)
      (bias bias':O ^ Odim) input:
    MP1 ([ffun j => index_app (coeff j) (coeff' j)],
         [ffun j => op (bias j) (bias' j)]) input
    = [ffun j => op (MP1 (coeff,bias) (index_projl input) j)
                    (MP1 (coeff',bias') (index_projr input) j)].
  Proof. apply /ffunP => j. by rewrite !ffunE neuron1_sumI. Qed.

  Lemma neuron1_appl Idim Idim'
        (coeff:C ^ Idim) (coeff':C ^ Idim') b input:
    neuron1 (index_app coeff coeff') b input
    = op (neuron1 coeff b (index_projl input))
         (neuron1 coeff' id (index_projr input)).
  Proof. by rewrite -neuron1_sumI /id /op NNopo0. Qed.

  Lemma neuron1_appr Idim Idim'
        (coeff:C ^ Idim) (coeff':C ^ Idim') b input:
    neuron1 (index_app coeff coeff') b input
    = op (neuron1 coeff id (index_projl input))
         (neuron1 coeff' b (index_projr input)).
  Proof. by rewrite -neuron1_sumI /id /op NNop0o. Qed.

  Lemma MP1_appl Idim Idim' Odim
      (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim: Type)
      (bias :O ^ Odim) input:
    MP1 ([ffun j => index_app (coeff j) (coeff' j)],bias) input
    = [ffun j => op (MP1 (coeff,bias) (index_projl input) j)
                    (MP1 (coeff',bias0 _ _) (index_projr input) j)].
  Proof. apply /ffunP => j. by rewrite !ffunE neuron1_appl. Qed.

  Lemma MP1_appr Idim Idim' Odim
      (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim: Type)
      (bias :O ^ Odim) input:
    MP1 ([ffun j => index_app (coeff j) (coeff' j)],bias) input
    = [ffun j => op (MP1 (coeff,bias0 _ _) (index_projl input) j)
                    (MP1 (coeff',bias) (index_projr input) j)].
  Proof. apply /ffunP => j. by rewrite !ffunE neuron1_appr. Qed.

  Lemma neuron1_linear Idim coeff b (input1 input2:I ^ Idim) k:
    let input1' := [ffun i => if i == k then input2 i else input1 i] in
    let input2' := [ffun i => if i == k then input1 i else input2 i] in
    op (neuron1 coeff b input1) (neuron1 coeff b input2) =
    op (neuron1 coeff b input1') (neuron1 coeff b input2').
  Proof.
    rewrite /= ![_ _ b _]neuron1_bias /op !NNopA -/op. congr op.
    rewrite ![op (_ _ b) _]NNopAC. congr op.
    rewrite /neuron1 !(bigD1 k is_true_true).
    rewrite ![op _ (_ (_ (coeff k) _)_)]NNopACA !ffunE eq_refl.
    congr op; first exact : NNopC.
    by congr op; apply : eq_bigr => i /negbTE; rewrite ffunE =>->.
  Qed.

  Lemma MP1_linear Idim Odim (p:MP1parameter S Idim Odim)
        (input1 input2:I ^ Idim) k:
    let input1' := [ffun i => if i == k then input2 i else input1 i] in
    let input2' := [ffun i => if i == k then input1 i else input2 i] in
    [ffun j => op (MP1 p input1 j) (MP1 p input2 j)]
    = [ffun j => op (MP1 p input1' j) (MP1 p input2' j)].
  Proof. apply /ffunP => j. rewrite !ffunE. exact : neuron1_linear. Qed.

End comoneuron1_lemma.

Module comidCneuron1.

  Record class_of (I O C:Type) :=
    Class {
        mono_class : mononeuron1.class_of I O C;
        como_mixin : comoneuron1.mixin_of (mononeuron1.Pack mono_class);
        idC_mixin : idCneuron1.mixin_of (mononeuron1.Pack mono_class)
      }.

  Definition como_class I O C m := comoneuron1.Class (@como_mixin I O C m).
  Definition idC_class I O C m := idCneuron1.Class (@idC_mixin I O C m).

  Section Packing.

    Record type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (mono_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition comoneuron1 := comoneuron1.Pack (como_class class).
    Definition idCneuron1 := idCneuron1.Pack (idC_class class).

  End Packing.

  Module Exports.

    Notation comidCneuron1Type := type.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion como_mixin : class_of >-> comoneuron1.mixin_of.
    Coercion idC_mixin : class_of >-> idCneuron1.mixin_of.
    Coercion como_class : class_of >-> comoneuron1.class_of.
    Coercion idC_class : class_of >-> idCneuron1.class_of.
    Coercion neuron1 : comidCneuron1Type >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comidCneuron1Type >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : comidCneuron1Type >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion idCneuron1 : comidCneuron1Type >-> idCneuron1Type.
    Canonical idCneuron1.

  End Exports.
End comidCneuron1.
Export comidCneuron1.Exports.

Section comidCneuron1_lemma.

  Variable (S:comidCneuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let parameter := @MP1parameter S.

  Lemma MP1_sum Idim1 Odim1 Idim2 Odim2
        (p1:parameter Idim1 Odim1) (p2:parameter Idim2 Odim2) input:
    MP1 (MP1parameter_sum p1 p2) input =
    index_app (MP1 p1 (index_projl input)) (MP1 p2 (index_projr input)).
  Proof.
    apply /ffunP => i. rewrite !ffunE /=.
    case : splitP => j Heq /=; rewrite !ffunE /=.
    - by rewrite -[p1.2 j]NNopo0 neuron1_sumI neuron1_idC !NNopo0.
    - by rewrite -[p2.2 j]NNop0o neuron1_sumI neuron1_idC !NNop0o.
  Qed.

End comidCneuron1_lemma.

(* ***************************** *)
Module NNet.

  Record mixin_of (S:neuron1Type) :=
    Mixin {activation : NNetO S -> NNetI S}.

  Section Packing.

    Structure class_of (I O C:Type) :=
      Class {
          neuron1_class: neuron1.class_of I O C;
          mixin: mixin_of (neuron1.Pack neuron1_class)
        }.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).

  End Packing.

  Module Exports.

    Notation NNetType := type.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : NNetType >-> neuron1Type.
    Canonical neuron1.
    Definition NNactivation (S:NNetType) := activation (class S).
    Definition NNactf (S:NNetType) dim (f:NNetO S ^ dim)
      := finfun ((@NNactivation S) \o f).

  End Exports.
End NNet.
Export NNet.Exports.

Section NNet_lemma.

  Variable (S:NNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let actf := @NNactf S.
  Let parameter := MP1parameter S.

  Lemma actf_app dim dim' (f:O ^ dim) (f':O ^ dim'):
    NNactf (index_app f f') = index_app (NNactf f) (NNactf f').
  Proof. by rewrite /NNactf index_app_additive. Qed.

  Fixpoint MPparameter Idim l Odim : Type :=
    match l with
    | [::] => parameter Idim Odim
    | Hdim :: l' => parameter Idim Hdim * MPparameter Hdim l' Odim
    end.

  Fixpoint MPparameter_zero o0 c0 {Idim l Odim} : MPparameter Idim l Odim :=
    match l return MPparameter Idim l Odim with
    | [::] => MP1parameter_zero o0 c0 _ _
    | _ :: _ => (MP1parameter_zero o0 c0 _ _, MPparameter_zero o0 c0)
    end.

  Fixpoint MPfunction Idim l Odim :
    MPparameter Idim l Odim -> I ^ Idim -> O ^ Odim :=
    match l return MPparameter Idim l Odim -> I ^ Idim -> O ^ Odim with
    | [::] => fun p => MP1 p
    | Hdim :: l' => fun p => MPfunction p.2 \o @actf _ \o MP1 p.1
    end.

  Definition cast_MPparameter Idim1 l1 Odim1 Idim2 l2 Odim2
             (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2)
             (p:MPparameter Idim1 l1 Odim1) : MPparameter Idim2 l2 Odim2 :=
    ecast Odim2 _ eqOdim (ecast l2 _ eql (ecast Idim2 _ eqIdim p)).

  Lemma cast_MPparameter_id Idim l Odim eqIdim eql eqOdim
        (p:MPparameter Idim l Odim):
    cast_MPparameter eqIdim eql eqOdim p = p.
  Proof. by rewrite !eq_axiomK. Qed.

  Lemma cast_MPparameterK Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MPparameter eqIdim eql eqOdim)
           (cast_MPparameter (esym eqIdim) (esym eql) (esym eqOdim)).
  Proof. by case : Idim2 / eqIdim; case : l2 / eql; case : Odim2 / eqOdim. Qed.

  Lemma cast_MPparameterKV Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MPparameter (esym eqIdim) (esym eql) (esym eqOdim))
           (cast_MPparameter eqIdim eql eqOdim).
  Proof. by case : Idim2 / eqIdim; case : l2 / eql; case : Odim2 / eqOdim. Qed.

  Lemma cast_MPparameter_trans Idim1 l1 Odim1 Idim2 l2 Odim2 Idim3 l3 Odim3
        eqIdim12 eqIdim23 eql12 eql23 eqOdim12 eqOdim23
        (p:MPparameter Idim1 l1 Odim1):
    @cast_MPparameter _ _ _ Idim3 l3 Odim3 eqIdim23 eql23 eqOdim23
                      (@cast_MPparameter _ _ _ Idim2 l2 Odim2
                                         eqIdim12 eql12 eqOdim12 p)
    = cast_MPparameter (etrans eqIdim12 eqIdim23) (etrans eql12 eql23)
                       (etrans eqOdim12 eqOdim23) p.
  Proof.
      by case : Idim3 / eqIdim23; case : l3 / eql23;case : Odim3 / eqOdim23.
  Qed.

  Lemma cast_MPparameter_inj Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2):
    injective (cast_MPparameter eqIdim eql eqOdim).
  Proof. exact : can_inj (cast_MPparameterK _ _ _). Qed.

  Fixpoint cast_MPparameter_ind Idim1 l1 Odim1 Idim2 l2 Odim2:
    MPparameter Idim1 l1 Odim1 -> MPparameter Idim2 l2 Odim2 -> Prop :=
    match l1,l2 return MPparameter Idim1 l1 Odim1 ->
                       MPparameter Idim2 l2 Odim2 -> Prop with
    | [::],[::] => fun p1 p2 => exists eqIdim eqOdim,
                       cast_MP1parameter eqIdim eqOdim p1 = p2
    | _ :: _,_ :: _ => fun p1 p2 => exists eqIdim eqHdim,
                           cast_MP1parameter eqIdim eqHdim p1.1 = p2.1 /\
                           cast_MPparameter_ind p1.2 p2.2
    | _,_ => fun _ _ => False
    end.

  Lemma cast_MPparameterP Idim1 l1 Odim1 Idim2 l2 Odim2 eqIdim eql eqOdim
        (p1:MPparameter Idim1 l1 Odim1) (p2:MPparameter Idim2 l2 Odim2):
    cast_MPparameter eqIdim eql eqOdim p1 = p2 <-> cast_MPparameter_ind p1 p2.
  Proof.
    split.
    - case : Idim2 / eqIdim p2; case : l2 / eql; case : Odim2 / eqOdim => p2.
      rewrite cast_MPparameter_id =><-{p2}.
      elim : l1 =>[|Hdim1 l1 IHl1] in Idim1 p1 *;
                    by exists (erefl _), (erefl _).
    - case : Idim2 / eqIdim p2; case : l2 / eql; case : Odim2 / eqOdim => p2.
      rewrite cast_MPparameter_id.
      elim : l1 =>[|Hdim1 l1 IHl] in Idim1 p1 p2 *.
      + move =>[eqIdim] [eqOdim] <-. by rewrite cast_MP1parameter_id.
      + move : p1 p2 => [p11 p12] [p21 p22] [eqIdim] [eqHdim] []/=<- /IHl <-.
          by rewrite cast_MP1parameter_id.
  Qed.

  Lemma MPfunction_cast Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2) p input:
    MPfunction (cast_MPparameter eqIdim eql eqOdim p)
               (cast_index eqIdim input) =
    cast_index eqOdim (MPfunction p input).
  Proof.
    case : Idim2 / eqIdim p; case : l2 / eql; case : Odim2 / eqOdim => p.
    by rewrite cast_MPparameter_id !cast_index_id.
  Qed.

  Fixpoint MPparameter_app Idim l1 Hdim l2 Odim :
    MPparameter Idim l1 Hdim -> MPparameter Hdim l2 Odim ->
    MPparameter Idim (l1 ++ Hdim :: l2) Odim :=
    match l1 return MPparameter Idim l1 Hdim ->
                    MPparameter Hdim l2 Odim ->
                    MPparameter Idim (l1 ++ Hdim :: l2) Odim with
    | [::] => fun p1 p2 => (p1, p2)
    | dim :: l1' => fun p1 p2 => (p1.1, (MPparameter_app p1.2 p2))
    end.

  Lemma MPparameter_appA Idim l1 Hdim1 l2 Hdim2 l3 Odim
        (p1:MPparameter Idim l1 Hdim1)
        (p2:MPparameter Hdim1 l2 Hdim2)
        (p3:MPparameter Hdim2 l3 Odim) :
    MPparameter_app p1 (MPparameter_app p2 p3) =
    cast_MPparameter (erefl _) (esym (catA _ _ _)) (erefl _)
                     (MPparameter_app (MPparameter_app p1 p2) p3).
  Proof.
    symmetry. apply /cast_MPparameterP.
    elim : l1 =>[|dim l1' IHl1]/= in Idim p1 *; exists (erefl _), (erefl _);
    split=>//. exact /cast_MPparameterP.
  Qed.

  Lemma MPfunction_app Idim l1 Hdim l2 Odim
        (p1:MPparameter Idim l1 Hdim) (p2:MPparameter Hdim l2 Odim) :
    MPfunction (MPparameter_app p1 p2)
    =1 MPfunction p2 \o @actf _ \o MPfunction p1.
  Proof.
    elim : l1 =>[|dim l1' IHl1] in Idim p1 *=> input //=. by rewrite IHl1.
  Qed.

  Fixpoint MPparameter_rcons Idim l Hdim Odim :
    MPparameter Idim l Hdim -> parameter Hdim Odim ->
    MPparameter Idim (rcons l Hdim) Odim :=
    match l return MPparameter Idim l Hdim ->
                   parameter Hdim Odim ->
                   MPparameter Idim (rcons l Hdim) Odim with
    | [::] => fun p1 p2 => (p1,p2)
    | x :: l' => fun p1 p2 => (p1.1,MPparameter_rcons p1.2 p2)
    end.

  Fixpoint MPparameter_last Idim l Hdim Odim :
    MPparameter Idim (rcons l Hdim) Odim -> parameter Hdim Odim :=
    match l return MPparameter Idim (rcons l Hdim) Odim ->
                   parameter Hdim Odim with
    | [::] => fun p => p.2
    | a :: l' => fun p => MPparameter_last p.2
    end.

  Fixpoint MPparameter_belast Idim l Hdim Odim :
    MPparameter Idim (rcons l Hdim) Odim -> MPparameter Idim l Hdim :=
    match l return MPparameter Idim (rcons l Hdim) Odim ->
                   MPparameter Idim l Hdim with
    | [::] => fun p => p.1
    | a :: l' => fun p => (p.1,MPparameter_belast p.2)
    end.

  Lemma MPparameter_last_rcons Idim l Hdim Odim
        (p1:MPparameter Idim l Hdim) (p2:parameter Hdim Odim):
    MPparameter_last (MPparameter_rcons p1 p2) = p2.
  Proof. by elim : l =>[|a l IHl] in Idim p1 p2 *=>//=. Qed.

  Lemma MPparameter_belast_rcons Idim l Hdim Odim
        (p1:MPparameter Idim l Hdim) (p2:parameter Hdim Odim):
    MPparameter_belast (MPparameter_rcons p1 p2) = p1.
  Proof.
    elim : l =>[|a l IHl] in Idim p1 p2 *=>//=. rewrite IHl. by case : p1.
  Qed.

  Lemma MPfunction_rcons Idim l Hdim Odim
        (p:MPparameter Idim (rcons l Hdim) Odim) :
    MPfunction p
    =1 MP1 (MPparameter_last p) \o @actf _ \o
       MPfunction (MPparameter_belast p).
  Proof.
    elim : l =>[|l dim IHl] in Idim p *=> input //=. by rewrite IHl /=.
  Qed.

  Lemma MPfunction_in0 Idim l Odim (p:MPparameter Idim l Odim):
    0 \in l -> exists y, MPfunction p =1 (fun => y).
  Proof.
    move => H.
    elim /last_ind : l H Odim p =>[|l Hdim IHl]//=.
    rewrite mem_rcons => /orP [/eqP<-|/IHl H] Odim p.
    - exists (MPparameter_last p).2 => input.
        by rewrite MPfunction_rcons /= MP1_Idim0.
    - case : (H _ (MPparameter_belast p)) => y0 Hy0.
      exists (MP1 (MPparameter_last p) (actf y0)) => input.
        by rewrite MPfunction_rcons /= Hy0.
  Qed.

End NNet_lemma.

(* ***************************** *)
Module monoNNet.

    Record class_of (I O C:Type) : Type :=
      Class {
          neuron1_class : neuron1.class_of I O C;
          mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
          NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
        }.

    Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
    Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition NNet := NNet.Pack (NNet_class class).

  End Packing.

  Module Exports.

    Notation monoNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion neuron1 : monoNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : monoNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion NNet : monoNNetType >-> NNetType.
    Canonical NNet.

  End Exports.
End monoNNet.
Export monoNNet.Exports.

Section monoNNet_lemma.

  Variable (S:monoNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let parameter := MP1parameter S.
  Let MPparameter := MPparameter S.

End monoNNet_lemma.

(* ***************************** *)
Module idCNNet.

  Record class_of (I O C:Type) :=
    Class {
        neuron1_class : neuron1.class_of I O C;
        mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
        idC_mixin : idCneuron1.mixin_of
                      (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
      }.

  Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
  Definition idC_class I O C m := idCneuron1.Class (@idC_mixin I O C m).
  Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).
  Definition monoNNet_class I O C m :=
    monoNNet.Class (@mono_class I O C m) (NNet_class m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition idCneuron1 := idCneuron1.Pack (idC_class class).
    Definition NNet := NNet.Pack (NNet_class class).
    Definition monoNNet := monoNNet.Pack (monoNNet_class class).

  End Packing.

  Module Exports.

    Notation idCNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion idC_mixin : class_of >-> idCneuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion idC_class : class_of >-> idCneuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion monoNNet_class : class_of >-> monoNNet.class_of.
    Coercion neuron1 : idCNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : idCNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion idCneuron1 : idCNNetType >-> idCneuron1Type.
    Canonical idCneuron1.
    Coercion NNet : idCNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : idCNNetType >-> monoNNetType.
    Canonical monoNNet.

  End Exports.
End idCNNet.
Export idCNNet.Exports.

Section idCNNet_lemma.

  Variable (S:idCNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let parameter := MP1parameter S.
  Let MPparameter := MPparameter S.

  Definition MPparameter0 := @MPparameter_zero S id idC.

  Fixpoint MPparameter_sum Idim1 l1 Odim1 Idim2 l2 Odim2 :
           MPparameter Idim1 l1 Odim1 ->
           MPparameter Idim2 l2 Odim2 ->
           MPparameter (Idim1 + Idim2) (l1 +l l2) (Odim1 + Odim2) :=
    match l1, l2 return
          MPparameter Idim1 l1 Odim1 ->
          MPparameter Idim2 l2 Odim2 ->
          MPparameter (Idim1 + Idim2) (l1 +l l2) (Odim1 + Odim2) with
    | [::],[::] => fun p1 p2 => MP1parameter_sum p1 p2
    | [::],_ => fun p1 _ => MP1parameter_sum p1 (MP1parameter0 _ _ _)
    | _,[::] => fun _ p2 => MP1parameter_sum (MP1parameter0 _ _ _) p2
    | _ :: _,_ :: _ => fun p1 p2 =>
                         (MP1parameter_sum p1.1 p2.1, MPparameter_sum p1.2 p2.2)
    end.

  Lemma MPparameter_sumA Idim1 l1 Odim1 Idim2 l2 Odim2 Idim3 l3 Odim3
        (p1:MPparameter Idim1 l1 Odim1) (p2:MPparameter Idim2 l2 Odim2)
        (p3:MPparameter Idim3 l3 Odim3):
    MPparameter_sum p1 (MPparameter_sum p2 p3) =
    cast_MPparameter (esym (addnA _ _ _))
                     (esym (seqopA addnA _ _ _))
                     (esym (addnA _ _ _))
                     (MPparameter_sum (MPparameter_sum p1 p2) p3).
  Proof.
    elim : l1 =>[|Hdim1 l1 IHl1] in Idim1 p1 Idim2 l2 p2 Idim3 l3 p3 *;
      case : l2 =>[|Hdim2 l2] in Idim2 p2 Idim3 l3 p3 *;
      case : l3 =>[|Hdim3 l3] in Idim3 p3 *;
      symmetry; apply /cast_MPparameterP;
      exists (esym (addnA _ _ _)), (esym (addnA _ _ _))=>/=;
      rewrite -?MP1parameter_sum0 -MP1parameter_sumA =>//.
    split=>//.
    apply /(cast_MPparameterP (esym (addnA _ _ _)) (esym (seqopA addnA _ _ _))
                              (esym (addnA _ _ _))).
    symmetry. exact : IHl1.
  Qed.

End idCNNet_lemma.

Module comoNNet.

  Record class_of (I O C:Type) :=
    Class {
        neuron1_class : neuron1.class_of I O C;
        mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
        como_mixin : comoneuron1.mixin_of
                       (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
      }.

  Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
  Definition como_class I O C m := comoneuron1.Class (@como_mixin I O C m).
  Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).
  Definition monoNNet_class I O C m :=
    monoNNet.Class (@mono_class I O C m) (NNet_class m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition comoneuron1 := comoneuron1.Pack (como_class class).
    Definition NNet := NNet.Pack (NNet_class class).
    Definition monoNNet := monoNNet.Pack (monoNNet_class class).

  End Packing.

  Module Exports.

    Notation comoNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion como_mixin : class_of >-> comoneuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion como_class : class_of >-> comoneuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion monoNNet_class : class_of >-> monoNNet.class_of.
    Coercion neuron1 : comoNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comoNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : comoNNetType >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion NNet : comoNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : comoNNetType >-> monoNNetType.
    Canonical monoNNet.

  End Exports.
End comoNNet.
Export comoNNet.Exports.

Section comoNNet_lemma.
End comoNNet_lemma.

(* ***************************** *)
Module comidCNNet.

  Record class_of (I O C:Type) :=
    Class {
        neuron1_class : neuron1.class_of I O C;
        mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
        como_mixin : comoneuron1.mixin_of
                       (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        idC_mixin : idCneuron1.mixin_of
                      (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
      }.

  Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
  Definition como_class I O C m := comoneuron1.Class (@como_mixin I O C m).
  Definition idC_class I O C m := idCneuron1.Class (@idC_mixin I O C m).
  Definition comidC_class I O C m :=
    comidCneuron1.Class (@como_class I O C m) (idC_class m).
  Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).
  Definition monoNNet_class I O C m :=
    monoNNet.Class (@mono_class I O C m) (NNet_class m).
  Definition comoNNet_class I O C m :=
    comoNNet.Class (@como_class I O C m) (NNet_class m).
  Definition idCNNet_class I O C m :=
    idCNNet.Class  (@idC_class I O C m) (NNet_class m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition comoneuron1 := comoneuron1.Pack (como_class class).
    Definition idCneuron1 := idCneuron1.Pack (idC_class class).
    Definition comidCneuron1 := comidCneuron1.Pack (comidC_class class).
    Definition NNet := NNet.Pack (NNet_class class).
    Definition monoNNet := monoNNet.Pack (monoNNet_class class).
    Definition comoNNet := comoNNet.Pack (comoNNet_class class).
    Definition idCNNet := idCNNet.Pack (idCNNet_class class).

  End Packing.

  Module Exports.

    Notation comidCNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion como_mixin : class_of >-> comoneuron1.mixin_of.
    Coercion idC_mixin : class_of >-> idCneuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion como_class : class_of >-> comoneuron1.class_of.
    Coercion idC_class : class_of >-> idCneuron1.class_of.
    Coercion comidC_class : class_of >-> comidCneuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion monoNNet_class : class_of >-> monoNNet.class_of.
    Coercion comoNNet_class : class_of >-> comoNNet.class_of.
    Coercion idCNNet_class : class_of >-> idCNNet.class_of.
    Coercion neuron1 : comidCNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comidCNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : comidCNNetType >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion idCneuron1 : comidCNNetType >-> idCneuron1Type.
    Canonical idCneuron1.
    Coercion comidCneuron1 : comidCNNetType >-> comidCneuron1Type.
    Canonical comidCneuron1.
    Coercion NNet : comidCNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : comidCNNetType >-> monoNNetType.
    Canonical monoNNet.
    Coercion comoNNet : comidCNNetType >-> comoNNetType.
    Canonical comoNNet.
    Coercion idCNNet : comidCNNetType >-> idCNNetType.
    Canonical idCNNet.

  End Exports.
End comidCNNet.
Export comidCNNet.Exports.

Section comidCNNet_lemma.

  Variable (S:comidCNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let op := @NNop S.
  Let action := @NNaction S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let actf := @NNactf S.
  Let parameter := MP1parameter S.
  Let MPparameter := MPparameter S.

  Lemma MPfunction_sum Idim1 l1 Odim1 Idim2 l2 Odim2
        (p1:MPparameter Idim1 l1 Odim1) (p2:MPparameter Idim2 l2 Odim2) input:
    size l1 = size l2 ->
    MPfunction (MPparameter_sum p1 p2) input =
    index_app (MPfunction p1 (index_projl input))
              (MPfunction p2 (index_projr input)).
  Proof.
    elim : l1 l2 =>[|Hdim1 l1 IHl1][|Hdim2 l2]//= in Idim1 p1 Idim2 p2 input *;
      rewrite MP1_sum =>//[][] /IHl1 =>->.
      by rewrite !actf_app index_projl_app index_projr_app.
  Qed.

End comidCNNet_lemma.

(* ***************************** *)
Module eqneuron1.

  Section Packing.

    Record type := Pack {NNetI:eqType; NNetO; NNetC;
                         neuron1_class : neuron1.class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition neuron1 := neuron1.Pack (neuron1_class cT).

  End Packing.

  Module Exports.

    Notation eqneuron1Type := type.
    Coercion NNetI : eqneuron1Type >-> eqType.
    Coercion neuron1_class : eqneuron1Type >-> neuron1.class_of.
    Coercion neuron1 : eqneuron1Type >-> neuron1Type.
    Canonical neuron1.

  End Exports.
End eqneuron1.
Export eqneuron1.Exports.

Section eqneuron1_lemma.

  Variable (V:eqneuron1Type).
  Let I := NNetI V.
  Let O := NNetO V.
  Let C := NNetC V.
  Let action := @NNaction V.
  Let op := @NNop V.

End eqneuron1_lemma.

(* ***************************** *)
Module eqcomoNNet.

  Section Packing.

    Structure type := Pack {NNetI:eqType; NNetO; NNetC;
                            comNNet_class :comoNNet.class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return comoNNet.class_of
                                    (NNetI cT) (NNetO cT) (NNetC cT) in c.
    Definition neuron1 := neuron1.Pack class.
    Definition mononeuron1 := mononeuron1.Pack class.
    Definition comoneuron1 := comoneuron1.Pack class.
    Definition NNet := NNet.Pack class.
    Definition monoNNet := monoNNet.Pack class.
    Definition comoNNet := comoNNet.Pack class.
    Definition eqneuron1 := eqneuron1.Pack class.

  End Packing.

  Module Exports.

    Notation eqcomoNNetType := type.
    Coercion NNetI : eqcomoNNetType >-> eqType.
    Coercion neuron1 : eqcomoNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : eqcomoNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : eqcomoNNetType >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion NNet : eqcomoNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : eqcomoNNetType >-> monoNNetType.
    Canonical monoNNet.
    Coercion comoNNet : eqcomoNNetType >-> comoNNetType.
    Canonical comoNNet.
    Coercion eqneuron1 : eqcomoNNetType >-> eqneuron1Type.
    Canonical eqneuron1.

  End Exports.
End eqcomoNNet.
Export eqcomoNNet.Exports.

Section eqcomoNNet_lemma.

  Variable (V:eqcomoNNetType).
  Let I := NNetI V.
  Let O := NNetO V.
  Let C := NNetC V.
  Let action := @NNaction V.
  Let op := @NNop V.
  Let id := @NNid V.
  Let actf := @NNactf V.

End eqcomoNNet_lemma.

End NNetDef.

Export neuron1.Exports mononeuron1.Exports comoneuron1.Exports
       idCneuron1.Exports comidCneuron1.Exports NNet.Exports monoNNet.Exports
       comoNNet.Exports idCNNet.Exports comidCNNet.Exports
       eqneuron1.Exports eqcomoNNet.Exports.


From Equations Require Import Equations.
Require Import Coq.Classes.RelationClasses.

Require Import Psatz.

Require Export SystemFR.SizeLemmas.
Require Export SystemFR.NoTypeFVar.

Equations strictly_positive (T: tree) (vars: list nat): Prop
    by wf (type_nodes T) lt :=
  strictly_positive (fvar _ type_var) _ := True;
  strictly_positive (lvar _ _) _ := True;

  strictly_positive T_unit _ := True;
  strictly_positive T_bool _ := True;
  strictly_positive T_nat _ := True;
  strictly_positive T_top _ := True;
  strictly_positive T_bot _ := True;

  strictly_positive (T_equiv _ _) _ := True;

  strictly_positive (T_prod T1 T2) vars := strictly_positive T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_arrow T1 T2) vars := no_type_fvar T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_forall T1 T2) vars := no_type_fvar T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_sum T1 T2) vars := strictly_positive T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_refine T p) vars := strictly_positive T vars;
  strictly_positive (T_type_refine T1 T2) vars := no_type_fvar T1 vars /\ no_type_fvar T2 vars;
  strictly_positive (T_intersection T1 T2) _ :=
    strictly_positive T1 vars /\ strictly_positive T2 vars;

  (* could be relaxed *)
  strictly_positive (T_union T1 T2) vars :=
    no_type_fvar T1 vars /\ no_type_fvar T2 vars;
  strictly_positive (T_exists T1 T2) vars := no_type_fvar T1 vars /\ no_type_fvar T2 vars;

  strictly_positive (T_abs T) vars := strictly_positive T vars;
  strictly_positive (T_rec n T0 Ts) vars :=
    strictly_positive T0 vars /\ strictly_positive Ts vars /\ (
      (no_type_fvar T0 vars /\ no_type_fvar Ts vars) \/
      exists X,
        ~(X ∈ pfv Ts type_var) /\
        strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil)
    );

  strictly_positive _ vars := False.

Solve All Obligations with (repeat step || autorewrite with bsize in *; try lia; eauto with lia).

Fail Next Obligation.

(* see https://github.com/coq/coq/issues/3814 *)
#[export]
Instance: subrelation eq Basics.impl.
Proof.
  steps.
Qed.

#[export]
Instance: subrelation eq (Basics.flip Basics.impl).
Proof.
  steps.
Qed.

Ltac simp_spos_hyp :=
  match goal with
  | H: _ |- _ => rewrite_strat topdown hints strictly_positive in H
  end.

Ltac simp_spos_goal := rewrite_strat topdown hints strictly_positive.

Ltac simp_spos := simp_spos_hyp || simp_spos_goal.


Require Import SfLib.
Require Import util.
Require Import STLC_types.
Require Import STLC_terms.

Reserved Notation "t1 '==>' t2" (at level 40).
(* Note: Induction should be fine here. No descent into the list of a literal
   is required. *)
Inductive step : term -> term -> Prop :=
| ST_AppLambda : forall x T t12 v2,
                   value v2 -> (TApp (TLambda x T t12) v2) ==> [x := v2]t12
| ST_App1 : forall t1 t1' t2, t1 ==> t1' -> TApp t1 t2 ==> TApp t1' t2
| ST_App2 : forall v1 t2 t2', value v1 -> t2 ==> t2' -> TApp v1 t2 ==> TApp v1 t2'
| ST_IfTrue : forall t1 t2, TIf TTrue t1 t2 ==> t1
| ST_IfFalse : forall t1 t2, TIf TFalse t1 t2 ==> t2
| ST_If : forall t1 t1' t2 t3, t1 ==> t1' -> TIf t1 t2 t3 ==> TIf t1' t2 t3
| ST_Plus : forall n m, TPlus (TNum n) (TNum m) ==> TNum (n + m)
| ST_PlusL : forall l l' r, l ==> l' -> TPlus l r ==> TPlus l' r
| ST_PlusR : forall l r r', value l -> r ==> r' -> TPlus l r ==> TPlus l r'
| ST_EqNatT : forall n m, beq_nat n m = true ->
                          TEqNat (TNum n) (TNum m) ==> TTrue
| ST_EqNatF : forall n m, beq_nat n m = false ->
                          TEqNat (TNum n) (TNum m) ==> TFalse
| ST_EqNatL : forall l l' r, l ==> l' -> TEqNat l r ==> TEqNat l' r
| ST_EqNatR : forall l r r', value l -> r ==> r' -> TEqNat l r ==> TEqNat l r'
| ST_Literal : forall li lv ri rv i v v', value (TLiteral li lv) ->
                                               length li = length lv ->
                                               v ==> v' ->
                                               TLiteral (li ++ (i :: ri))
                                                        (lv ++ (v :: rv)) ==>
                                                 TLiteral (li ++ (i :: ri))
                                                          (lv ++ (v' :: rv))
| ST_Access : forall li lv i v, value (TLiteral li lv) ->
                                  lookup i li lv = Some v ->
                                  TAccess (TLiteral li lv) i ==> v
| ST_AccessS : forall r r' i, r ==> r' -> TAccess r i ==> TAccess r' i
    where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppLambda" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2"      | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse"   | Case_aux c "ST_If"
  | Case_aux c "ST_Plus"      | Case_aux c "ST_PlusL"
  | Case_aux c "ST_PlusR"     | Case_aux c "ST_EqNatT"
  | Case_aux c "ST_EqNatF"    | Case_aux c "ST_EqNatL"
  | Case_aux c "ST_EqNatR"    | Case_aux c "ST_Literal"
  | Case_aux c "ST_Access"    | Case_aux c "ST_AccessS"].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Lemma values_no_step : forall (t : term), value t -> ((exists t', t ==> t') -> False).
Proof with auto.
  intros t HValue HStep.
  value_cases (induction HValue) Case; try (inversion HStep as [t' HStep']; inversion HStep'; subst)...
  Case "v_literal".
    apply Forall_app in H.
    inversion H. inversion H1; subst.
    apply H7. exists v'...
Qed.

Theorem step_determinism : forall (t t'1 t'2 : term),
  t ==> t'1 -> t ==> t'2 -> t'1 = t'2.
Proof with eauto.
  intros. generalize dependent t'1. generalize dependent t'2.
  term_cases (induction t) Case; intros; try solve by inversion.
  Case "TApp".
    inversion H; inversion H0; subst; try solve by inversion...
    SCase "steps with ST_AppLambda".
      inversion H5; subst...
    SCase "t2 is a value but steps".
      apply values_no_step in H4. inversion H4. exists t2'...
    SCase "t1 steps".
      assert (t1' = t1'0). apply IHt1...
      subst...
    SCase "t1 steps and is a value".
      apply values_no_step in H7. inversion H7. exists t1'...
    SCase "t2 steps and is a value".
      apply values_no_step in H9. inversion H9. exists t2'...
    SCase "t1 is a value but steps".
      apply values_no_step in H3. inversion H3. exists t1'...
    SCase "t2 steps".
      assert (t2' = t2'0). apply IHt2...
      subst...
  Case "TIf".
    inversion H; inversion H0; subst; try solve by inversion...
    assert (t1' = t1'0). apply IHt1...
    subst...
  Case "TPlus".
    inversion H; inversion H0; subst; try solve by inversion...
    SCase "t1 and t2 are numbers".
      inversion H5; inversion H6; subst...
    SCase "t1 steps".
      assert (l' = l'0). apply IHt1...
      subst...
    SCase "t1 steps and is a value".
      apply values_no_step in H7. inversion H7... exists l'...
    SCase "t1 is a value and steps".
      apply values_no_step in H3. inversion H3... exists l'...
    SCase "t2 steps".
      assert (r' = r'0). apply IHt2...
      subst...
  Case "TEqNat".
    inversion H; inversion H0; subst; try solve by inversion...
    SCase "t1 and t2 are numbers; true/false".
      inversion H7; inversion H5; subst.
      rewrite -> H8 in H4.
      inversion H4.
    SCase "t1 and t2 are numbers; false/true".
      inversion H7; inversion H5; subst.
      rewrite -> H8 in H4.
      inversion H4.
    SCase "t1 steps".
      assert (l' = l'0). apply IHt1...
      subst...
    SCase "t1 steps and is a value".
      apply values_no_step in H7. inversion H7. exists l'...
    SCase "t1 is a value and steps".
      apply values_no_step in H3. inversion H3. exists l'...
    SCase "t2 steps".
      assert (r' = r'0). apply IHt2...
      subst...
  Case "TLiteral".
    inversion H0; inversion H1; subst... clear H0 H1.
    inversion H4; inversion H10; subst.
    apply append_length in H8; inversion H8; clear H8; subst...
    inversion H2; subst; clear H2.
    Focus 2.
    apply append_length in H9; inversion H9; subst...
    apply append_length in H8; inversion H8; subst...
    inversion H2; subst.
    assert (v' = v'0). apply Forall_app in H; inversion H.
      inversion H12; subst.
      apply H16...
    subst.
    inversion H3; subst...
inversion H8; subst...
inversion H9. inversion H12; subst...

 clear H9... subst. apply append_length in H8...
    assert (lv1 = lv0).
    admit.
  Case "TAccess".
    inversion H; inversion H0; subst... clear H H0.
    SCase "literal is a value".
      inversion H6; subst.
      rewrite -> H5 in H10.
      inversion H10...
    SCase "literal is a value but steps".
      apply values_no_step in H3. inversion H3. exists r'...
    SCase "literal is a value but steps".
      apply values_no_step in H7. inversion H7. exists r'...
    SCase "literal steps".
      assert (r' = r'0). apply IHt...
      subst...

Admitted.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the dynamic semantics of heap objects, pg. 60.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsHeapObjects.
Require Export Tacticals.

Require Export TestUtilities.

Example test_get_pdot : get vi0 [] vi0.
Proof.
  apply get_pdot; Crunch.
Qed.

Example test_get_l: get (cpair vi0 vi1) [i_pe zero_pe] vi0.
Proof.
  apply get_l;
  eauto 20 with Chapter3.
Qed.

Example test_get_r:
  get (cpair vi0 vi1) [i_pe one_pe] vi1.
Proof.
  apply get_r;
  eauto 20 with Chapter3.
Qed.

Example test_get_pack:
  get (pack
         (cross cint cint)
         (i_e (i_i 0))
         (etype aliases alpha A cint))
      [u_pe]
      (i_e (i_i 0)).
Proof.
  apply get_pack;
  eauto 20 with Chapter3.
Qed.

Example test_set_ip: set vi0 [] vi1 vi1.
Proof.
  apply set_ip;
  eauto 20 with Chapter3.
Qed.

Example test_set_l:
  set (cpair (i_e (i_i 0)) (i_e (i_i 1)))
      ([i_pe zero_pe] ++ [])
      (i_e (i_i 2))
      (cpair (i_e (i_i 2)) (i_e (i_i 1))).
Proof.
  apply set_l;
  eauto 20 with Chapter3.
Qed.

Example test_set_r:
  set (cpair (i_e (i_i 0)) (i_e (i_i 1)))
      ([i_pe one_pe] ++ [])
      (i_e (i_i 2))
      (cpair (i_e (i_i 0)) (i_e (i_i 2))).
Proof.
  apply set_r;
  eauto 20 with Chapter3.
Qed.

Example test_set_pack:
  set (pack tau' v1 (etype q alpha k tau))
      (u_pe :: p0) v (pack tau' v' (etype q alpha k tau)).
Proof.
  apply set_pack;
  eauto 20 with Chapter3.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.

(* Why3 goal *)
Definition div: Z -> Z -> Z.
intros x y.
case (Z_le_dec 0 (Zmod x y)) ; intros H.
exact (Zdiv x y).
exact (Zdiv x y + 1)%Z.
Defined.

(* Why3 goal *)
Definition mod1: Z -> Z -> Z.
intros x y.
exact (x - y * div x y)%Z.
Defined.

(* Why3 goal *)
Lemma Div_mod : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> (x = ((y * (div x
  y))%Z + (mod1 x y))%Z).
intros x y Zy.
unfold mod1, div.
case Z_le_dec ; intros H ; ring.
Qed.

(* Why3 goal *)
Lemma Div_bound : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  ((0%Z <= (div x y))%Z /\ ((div x y) <= x)%Z).
intros x y (Hx,Hy).
unfold div.
case Z_le_dec ; intros H.
split.
apply Z_div_pos with (2 := Hx).
now apply Zlt_gt.
destruct (Z_eq_dec y 1) as [H'|H'].
rewrite H', Zdiv_1_r.
apply Zle_refl.
rewrite <- (Zdiv_1_r x) at 2.
apply Zdiv_le_compat_l with (1 := Hx).
omega.
elim H.
apply Z_mod_lt.
now apply Zlt_gt.
Qed.

(* Why3 goal *)
Lemma Mod_bound : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> ((0%Z <= (mod1 x
  y))%Z /\ ((mod1 x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
zify.
assert (H1 := Z_mod_neg x y).
assert (H2 := Z_mod_lt x y).
unfold mod1, div.
case Z_le_dec ; intros H0.
rewrite Zmult_comm, <- Zmod_eq_full with (1 := Zy).
omega.
replace (x - y * (x / y + 1))%Z with (x - x / y * y - y)%Z by ring.
rewrite <- Zmod_eq_full with (1 := Zy).
omega.
Qed.

(* Why3 goal *)
Lemma Mod_1 : forall (x:Z), ((mod1 x 1%Z) = 0%Z).
intros x.
unfold mod1, div.
rewrite Zmod_1_r, Zdiv_1_r, Zmult_1_l.
apply Zminus_diag.
Qed.

(* Why3 goal *)
Lemma Div_1 : forall (x:Z), ((div x 1%Z) = x).
intros x.
unfold div.
now rewrite Zmod_1_r, Zdiv_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (x < y)%Z) -> ((div x
  y) = 0%Z).
intros x y Hxy.
unfold div.
case Z_le_dec ; intros H.
now apply Zdiv_small.
elim H.
now rewrite Zmod_small.
Qed.

(* Why3 goal *)
Lemma Div_inf_neg : forall (x:Z) (y:Z), ((0%Z < x)%Z /\ (x <= y)%Z) ->
  ((div (-x)%Z y) = (-1%Z)%Z).
intros x y Hxy.
assert (h: (x < y \/ x = y)%Z) by omega.
destruct h.
(* case 0 < x < y *)
assert (h1: (x mod y = x)%Z).
  rewrite Zmod_small; auto with zarith.
assert (h2: ((-x) mod y = y - x)%Z).
  rewrite Z_mod_nz_opp_full.
  rewrite h1; auto.
rewrite h1; auto with zarith.
unfold div.
case Z_le_dec; auto with zarith.
intros h3.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.

(* case x = y *)
subst.
assert (h1: (y mod y = 0)%Z).
  rewrite Z_mod_same_full; auto with zarith.
assert (h2: ((-y) mod y = 0)%Z).
  rewrite Z_mod_zero_opp_full; auto with zarith.
unfold div.
case Z_le_dec; rewrite h2; auto with zarith.
intro.
rewrite Z_div_zero_opp_full; auto with zarith.
rewrite Z_div_same_full; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_0 : forall (y:Z), (~ (y = 0%Z)) -> ((mod1 0%Z y) = 0%Z).
intros y Hy.
unfold mod1, div.
rewrite Zmod_0_l.
simpl.
now rewrite Zdiv_0_l, Zmult_0_r.
Qed.

(* Why3 goal *)
Lemma Div_1_left : forall (y:Z), (1%Z < y)%Z -> ((div 1%Z y) = 0%Z).
intros y Hy.
rewrite Div_inf; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Div_minus1_left : forall (y:Z), (1%Z < y)%Z -> ((div (-1%Z)%Z
  y) = (-1%Z)%Z).
intros y Hy.
unfold div.
assert (h1: (1 mod y = 1)%Z).
apply Zmod_1_l; auto.
assert (h2: ((-(1)) mod y = y-1)%Z).
  rewrite Z_mod_nz_opp_full; auto with zarith.
case Z_le_dec; auto with zarith.
intro.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_1_left : forall (y:Z), (1%Z < y)%Z -> ((mod1 1%Z y) = 1%Z).
intros y Hy.
unfold mod1.
rewrite Div_1_left; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_minus1_left : forall (y:Z), (1%Z < y)%Z -> ((mod1 (-1%Z)%Z
  y) = (y - 1%Z)%Z).
intros y Hy.
unfold mod1.
rewrite Div_minus1_left; auto with zarith.
Qed.

Open Scope Z_scope.

(* Why3 goal *)
Lemma Div_mult : forall (x:Z) (y:Z) (z:Z), (0%Z < x)%Z ->
  ((div ((x * y)%Z + z)%Z x) = (y + (div z x))%Z).
intros x y z h.
unfold div.
destruct (Z_le_dec 0 (z mod x)).
destruct (Z_le_dec 0 ((x*y+z) mod x)).
rewrite Zmult_comm.
rewrite Z_div_plus_full_l; auto with zarith.
generalize (Z_mod_lt (x * y + z) x); auto with zarith.
generalize (Z_mod_lt z x); auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_mult : forall (x:Z) (y:Z) (z:Z), (0%Z < x)%Z ->
  ((mod1 ((x * y)%Z + z)%Z x) = (mod1 z x)).
intros x y z h.
unfold mod1.
rewrite Div_mult.
ring.
auto with zarith.
Qed.


(* File: ML_int.v    (last edited on 25/10/2000  (c) Klaus Weich  *)

(* Axiomisation of the ML type "int" *)

Axiom Int : Set.
Axiom Less : Int -> Int -> Prop.
Axiom Equal : Int -> Int -> Prop.
Axiom int_succ : forall x : Int, {y : Int | Less x y}.
Axiom int_null : Int.

Axiom equal_dec : forall x y : Int, {Equal x y} + {~ Equal x y}.
Axiom less_dec : forall x y : Int, {Less x y} + {~ Less x y}.

Axiom
  notequal_notless_greater :
    forall x y : Int, ~ Equal x y -> ~ Less x y -> Less y x.

Axiom less_trans : forall x y z : Int, Less x y -> Less y z -> Less x z.
Axiom equal_less_less : forall x y z : Int, Equal x y -> Less y z -> Less x z.
Axiom less_equal_less : forall x y z : Int, Less x y -> Equal y z -> Less x z.
Axiom equal_sym : forall x y : Int, Equal x y -> Equal y x.
Axiom equal_trans : forall x y z : Int, Equal x y -> Equal y z -> Equal x z.
Axiom equal_refl : forall x : Int, Equal x x.
Axiom equal_eq : forall x y : Int, Equal x y -> x = y.

Axiom less_irrefl : forall x : Int, Less x x -> False.

Lemma equal_dec_refl :
 forall (i : Int) (A : Set) (a b : A),
 match equal_dec i i with
 | left _ => a
 | right _ => b
 end = a.
intros i A a b.
elim (equal_dec i i).
intros; trivial.
intros notequal; elimtype False; apply notequal.
apply equal_refl.
Qed.

Inductive max_int_spec (i0 i1 : Int) : Set :=
    Max_Int_Intro :
      forall j : Int,
      Less i0 j \/ Equal i0 j ->
      Less i1 j \/ Equal i1 j -> max_int_spec i0 i1.

Lemma max_int : forall i0 i1 : Int, max_int_spec i0 i1.
intros i0 i1.
elim (equal_dec i0 i1).
intros eq_i0_i1.
exists i0.
right.
apply equal_refl.
right.
apply equal_sym; assumption.

intros not_eq_i0_i1.
elim (less_dec i0 i1).
intros less_i0_i1.
exists i1.
left; assumption.
right.
apply equal_refl.

intros ge_i0_i1.
exists i0.
right.
apply equal_refl.
left.
apply notequal_notless_greater; assumption.
Qed.


Require Import FP.Data.Function.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.Proxy.
Require Import FP.Structures.EqvRel.
Require Import FP.Relations.Setoid.

Import ProperNotation.

Class MPipe (m:Type->Type) :=
  { mpipe : forall {A B C}, (A -> m B) -> (B -> m C) -> A -> m C }.

Section MPipe.
  Context {m} {MPipe_:MPipe m}.

  Definition mcompose {A B C} : (B -> m C) -> (A -> m B) -> A -> m C := flip mpipe.
End MPipe.

Module KleisliNotation.
  Infix ">=>" := mpipe (at level 53, right associativity).
  Infix "<=<" := mcompose (at level 53, right associativity).
End KleisliNotation.

Section KleisliWF.
  Variable (m:Type->Type).
  Context {FUnit_:FUnit m} {MPipe_:MPipe m}.
  Variable (EqvEnv_:EqvEnv).
  Context {RPromote:forall {A} {aER:EqvRel A}, EqvRel (m A)}.

  Class KleisliWF :=
    { mpipe_left_unit :
        forall
          {A} {aER:EqvRel A}
          {B} {bER:EqvRel B}
          (f:A -> m B) (f':A -> m B) {fP:(env_R ==> env_R) f f'}
          (a:A) (a':A) {aP:env_R a a'},
            env_R
            (mpipe funit f a)
            (f' a')
    ; mpipe_right_unit :
        forall
          {A} {aER:EqvRel A}
          {B} {bER:EqvRel B}
          (f:A -> m B) (f':A -> m B) {fP:(env_R ==> env_R) f f'}
          (a:A) (a':A) {aP:env_R a a'},
            env_R
            (mpipe f funit a)
            (f' a')
    ; mpipe_associativity :
        forall
          {A} {aER:EqvRel A}
          {B} {bER:EqvRel B}
          {C} {cER:EqvRel C}
          {D} {dER:EqvRel D}
          (f:A -> m B) (f':A -> m B) {fP:(env_R ==> env_R) f f'}
          (g:B -> m C) (g':B -> m C) {gP:(env_R ==> env_R) g g'}
          (h:C -> m D) (h':C -> m D) {hP:(env_R ==> env_R) h h'}
          (a:A) (a':A) {aP:env_R a a'},
            env_R
            (mpipe (mpipe f g) h a)
            (mpipe f (mpipe g h) a)
    }.
End KleisliWF.


Require Import QArith micromega.Lia.

Local Open Scope Q_scope.

Definition alphaQ_high w : Q := (633/1024) ^ w.

Definition alphaQ (w : Z) : Q :=
  if (w <=? 66)%Z then
  match w with
  | 0%Z => 1 | 1%Z => 1 | 2%Z => 689491/2^20 | 3%Z => 779411/2^21
  | 4%Z => 880833/2^22 | 5%Z => 165219/2^20 | 6%Z => 97723/2^20 | 7%Z => 882313/2^24
  | 8%Z => 306733/2^23 | 9%Z => 92045/2^22 | 10%Z => 439213/2^25 | 11%Z => 281681/2^25
  | 12%Z => 689007/2^27 | 13%Z => 824303/2^28 | 14%Z => 257817/2^27 | 15%Z => 634229/2^29
  | 16%Z => 386245/2^29 | 17%Z => 942951/2^31 | 18%Z => 583433/2^31 | 19%Z => 713653/2^32
  | 20%Z => 432891/2^32 | 21%Z => 133569/2^31 | 22%Z => 328293/2^33 | 23%Z => 800421/2^35
  | 24%Z => 489233/2^35 | 25%Z => 604059/2^36 | 26%Z => 738889/2^37 | 27%Z => 112215/2^35
  | 28%Z => 276775/2^37 | 29%Z => 84973/2^36 | 30%Z => 829297/2^40 | 31%Z => 253443/2^39
  | 32%Z => 625405/2^41 | 33%Z => 95625/2^39 | 34%Z => 465055/2^42 | 35%Z => 286567/2^42
  | 36%Z => 175951/2^42 | 37%Z => 858637/2^45 | 38%Z => 65647/2^42 | 39%Z => 40469/2^42
  | 40%Z => 24751/2^42 | 41%Z => 240917/2^46 | 42%Z => 593411/2^48 | 43%Z => 364337/2^48
  | 44%Z => 889015/2^50 | 45%Z => 543791/2^50 | 46%Z => 41899/2^47 | 47%Z => 205005/2^50
  | 48%Z => 997791/2^53 | 49%Z => 307191/2^52 | 50%Z => 754423/2^54 | 51%Z => 57527/2^51
  | 52%Z => 281515/2^54 | 53%Z => 694073/2^56 | 54%Z => 212249/2^55 | 55%Z => 258273/2^56
  | 56%Z => 636093/2^58 | 57%Z => 781081/2^59 | 58%Z => 952959/2^60 | 59%Z => 291475/2^59
  | 60%Z => 718599/2^61 | 61%Z => 878997/2^62 | 62%Z => 534821/2^62 | 63%Z => 329285/2^62
  | 64%Z => 404341/2^63 | 65%Z => 986633/2^65 | 66%Z => 603553/2^65 | _ => 0 end
  else alphaQ_high w.

Definition alphaQ_nat_high (w : nat) : Q := (633/1024) ^ (Z.of_nat w).

Definition alphaQ_nat (w : nat) : Q :=
  match w with
  | 0%nat => 1 | 1%nat => 1 | 2%nat => 689491/2^20 | 3%nat => 779411/2^21
  | 4%nat => 880833/2^22 | 5%nat => 165219/2^20 | 6%nat => 97723/2^20 | 7%nat => 882313/2^24
  | 8%nat => 306733/2^23 | 9%nat => 92045/2^22 | 10%nat => 439213/2^25 | 11%nat => 281681/2^25
  | 12%nat => 689007/2^27 | 13%nat => 824303/2^28 | 14%nat => 257817/2^27 | 15%nat => 634229/2^29
  | 16%nat => 386245/2^29 | 17%nat => 942951/2^31 | 18%nat => 583433/2^31 | 19%nat => 713653/2^32
  | 20%nat => 432891/2^32 | 21%nat => 133569/2^31 | 22%nat => 328293/2^33 | 23%nat => 800421/2^35
  | 24%nat => 489233/2^35 | 25%nat => 604059/2^36 | 26%nat => 738889/2^37 | 27%nat => 112215/2^35
  | 28%nat => 276775/2^37 | 29%nat => 84973/2^36 | 30%nat => 829297/2^40 | 31%nat => 253443/2^39
  | 32%nat => 625405/2^41 | 33%nat => 95625/2^39 | 34%nat => 465055/2^42 | 35%nat => 286567/2^42
  | 36%nat => 175951/2^42 | 37%nat => 858637/2^45 | 38%nat => 65647/2^42 | 39%nat => 40469/2^42
  | 40%nat => 24751/2^42 | 41%nat => 240917/2^46 | 42%nat => 593411/2^48 | 43%nat => 364337/2^48
  | 44%nat => 889015/2^50 | 45%nat => 543791/2^50 | 46%nat => 41899/2^47 | 47%nat => 205005/2^50
  | 48%nat => 997791/2^53 | 49%nat => 307191/2^52 | 50%nat => 754423/2^54 | 51%nat => 57527/2^51
  | 52%nat => 281515/2^54 | 53%nat => 694073/2^56 | 54%nat => 212249/2^55 | 55%nat => 258273/2^56
  | 56%nat => 636093/2^58 | 57%nat => 781081/2^59 | 58%nat => 952959/2^60 | 59%nat => 291475/2^59
  | 60%nat => 718599/2^61 | 61%nat => 878997/2^62 | 62%nat => 534821/2^62 | 63%nat => 329285/2^62
  | 64%nat => 404341/2^63 | 65%nat => 986633/2^65 | 66%nat => 603553/2^65 | _ => alphaQ_nat_high w
  end.

Lemma alphaQ_nat_67 w : (67 <= w)%nat -> alphaQ_nat w = alphaQ_nat_high w.
Proof. intros; repeat (destruct w; [lia|]). reflexivity. Qed.

Lemma alphaQ31 i : (31 <= i < 67)%Z -> ((alphaQ i) ^ 49 < 1 / (2 ^ ((34 * i - 23))))%Q.
Proof.
  intros.
  repeat match goal with
         | [ H: (?a <= ?b < ?a)%Z |- _ ] => fail 1
         | [ H : (?a <= ?b < ?c)%Z |- _ ] => destruct (Z.eq_dec a b) as [E|E]; [subst; reflexivity|
                                                                             let H2 := fresh in assert (H2 : (a + 1 <= b < c)%Z) by lia; clear E; simpl in H2; clear H]
         end.
  lia.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e224m2e96p1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


From stdpp Require Import numbers list.

Fixpoint rangeReversed (n : nat) : list nat :=
  match n with
  | 0 => []
  | S n => n :: rangeReversed n
  end.

(* generates [0, 1, 2, ..., n - 1] *)
Definition range (n : nat) := reverse (rangeReversed n).

(* generates [left, left + 1, left + 2, ... right - 1, right] *)
Definition range2 (left right : nat) := map (fun x => x + left) (range (right - left + 1)).

Lemma rangeZero : range 0 = [].
Proof. easy. Qed.

Lemma rangeOne : range 1 = [0].
Proof. easy. Qed.

Lemma rangeSucc (n : nat) : range (S n) = range n ++ [n].
Proof.
  induction n; try easy; unfold range; simpl; rewrite reverse_cons; reflexivity.
Qed.

Lemma range2LeftLeft (left : nat) : range2 left left = [left].
Proof.
  unfold range2.
  assert (H : left - left + 1 = 1). { lia. }
  rewrite H, rangeOne, map_cons. easy.
Qed.

Lemma range2LeftSucc (left : nat) : range2 left (S left) = [left; S left].
Proof.
  unfold range2.
  assert (H : S left - left + 1 = 2). { lia. }
  rewrite H, rangeSucc, map_app, rangeOne. easy.
Qed.

Lemma range2LeftAdd (left delta : nat) : range2 left (S (left + delta)) = range2 left (left + delta) ++ [S (left + delta)].
Proof.
  unfold range2.
  assert (H : S (left + delta) - left + 1 = S (S delta)). { lia. }
  assert (H' : left + delta - left + 1 = S delta). { lia. }
  rewrite H, H', ?rangeSucc, ?map_app. simpl. rewrite Nat.add_comm. reflexivity.
Qed.


(* Julien Narboux *)
(* Formalization of *)
(* Tarski's axiomatic *)

Require Export Ch07_midpoint.

Unset Regular Subst Tactic.

Definition Per := fun A B C =>
  exists C', is_midpoint B C C' /\ Cong A C A C'.

Lemma l8_2 : forall A B C, Per A B C -> Per C B A.
Proof.
intros.
unfold Per in *.
DecompExAnd H C'.
assert (exists A', is_midpoint B A A').
apply symmetric_point_construction.
DecompEx H A'.
assert (Cong C' A' C A).
eapply l7_13;eauto.
assert (Cong A C' A' C).
eapply l7_13;eauto.
eapply l7_2.
eauto.
eauto.
exists A'.
intuition.
unfold is_midpoint in *;intuition.
eapply cong_transitivity with (C:=A) (D:=C').
sTarski.
sTarski.
Qed.

Hint Resolve l8_2 : Perp.

Ltac Perp := eauto with Perp.

Lemma l8_3 : forall A B C A',
 Per A B C -> A<>B -> Col B A A' -> Per A' B C.
Proof.
intros.
unfold Per in H.
DecompExAnd H C'.
unfold Per.
exists C'.
intuition.
eapply (l4_17).
unfold not;apply H0.
eauto with Col.
auto.
unfold is_midpoint in H3;intuition.
Qed.

Lemma l8_4 : forall A B C C',
  Per A B C -> is_midpoint B C C' -> Per A B C'.
Proof.
intros.
unfold Per in H.
DecompExAnd H C''.
assert (C' =C'').
eapply symmetric_point_unicity.
apply H0.
apply H2.
smart_subst C''.
unfold Per.
exists C.
intuition.
Qed.

Lemma l8_5 : forall A B, Per A B B.
intros.
unfold Per.
exists B;intuition.
Qed.

Hint Resolve l8_5 : Perp.

Lemma l8_6 : forall A B C A',
  Per A B C -> Per A' B C -> Bet A C A' -> B=C.
intros.
unfold Per in *.
DecompExAnd H C'.
suppose (Cong A' C A' C').
assert (C=C').
eapply l4_19.
2:apply H4.
2:apply H.
assumption.
subst C'.
eapply l7_3.
assumption.
DecompExAnd H0 C''.
assert (Cong C C C' C'').
eapply l7_13.
apply l7_2.
apply H3.
apply l7_2.
apply H2.
treat_equalities.
auto.
Qed.

Ltac let_symmetric C P A :=
let id1:=fresh in (assert (id1:(exists A', is_midpoint P A A'));
[apply symmetric_point_construction|DecompEx id1 C]).

Lemma l8_7 : forall A B C, Per A B C -> Per A C B -> B=C.
Proof.
intros.
unfold Per in H.
DecompExAnd H C'.
let_symmetric A' C A.
cases_equality B C.
auto.
assert (Per C' C A).
eapply (l8_3 ).
eapply l8_2.
apply H0.
assumption.
unfold is_midpoint in H2;intuition;Col.
assert (Cong A C' A' C').
unfold Per in H4.
DecompExAnd H4 Z.
assert (A'=Z).
eapply symmetric_point_unicity;eauto.
subst Z.
sTarski.
unfold is_midpoint in *;intuition.
assert (Cong A' C A' C').
eapply cong_transitivity with (C:=A) (D:=C');sTarski.
eapply cong_transitivity with (C:=A) (D:=C);sTarski.
assert (Per A' B C).
unfold Per.
exists C'.
unfold is_midpoint;intuition.
eapply l8_6.
apply H9.
unfold Per.
exists C'.
unfold is_midpoint;intuition.
apply H3.
Between.
Qed.

Hint Resolve l8_7 : Perp.

Lemma l8_8 : forall A B, Per A B A -> A=B.
Proof with Perp.
intros.
eapply l8_7...
Qed.

Lemma l8_9 : forall A B C, Per A B C -> Col A B C -> A=B \/ C=B.
Proof with Perp.
intros.
cases_equality A B.
left;auto.
right.
assert (Per C B C).
eapply l8_3...
eauto with Col.
Perp.
Qed.

Lemma l8_10 : forall A B C A' B' C',
  Per A B C -> Cong_3 A B C A' B' C' -> Per A' B' C'.
Proof with Perp.
intros.
cases_equality B C.
unfold Cong_3 in H0;intuition.
treat_equalities...
assert (B'<>C').
unfold Cong_3 in H0;intuition.
treat_equalities...
unfold Per in H.
DecompExAnd H D.
let_symmetric D' B' C'.
assert (OFSC C B D A C' B' D' A').
unfold OFSC,Cong_3,is_midpoint in *;intuition.
eapply cong_transitivity with (C:=B) (D:=C);sTarski.
eapply cong_transitivity with (C:=B') (D:=C');sTarski.
assert (Cong D A D' A').
eapply five_segments_with_def;eauto.
unfold OFSC,Cong_3,is_midpoint in *;intuition.
clean_duplicated_hyps.
assert (Cong A' C' A' D').
eapply cong_transitivity with (C:=A) (D:=C);sTarski.
eapply cong_transitivity with (C:=A) (D:=D);sTarski.
unfold Per.
exists D'.
intuition.
unfold is_midpoint...
Qed.

Definition Perp_in := fun X A B C D =>
   A<>B /\ C<>D /\ Col X A B /\ Col X C D /\
   (forall U V,  Col U A B -> Col V C D -> Per U X V).

Definition Perp := fun A B C D => exists X, Perp_in X A B C D.

Lemma l8_12 : forall A B C D X, Perp_in X A B C D ->  Perp_in X C D A B.
Proof with Perp.
unfold Perp_in.
intros;intuition.
Qed.

Lemma l8_13_2 : forall A B C D X,
   A <> B -> C <> D -> Col X A B -> Col X C D ->
  (exists U, exists V :Point, Col U A B /\ Col V C D /\ U<>X /\ V<>X /\ Per U X V) ->
  Perp_in X A B C D.
Proof.
intros.
DecompEx H3 U.
DecompEx H4 V.
decompose [and] H3;clear H3.
unfold Perp_in.
repeat split;auto.
intros.
assert (Per U0 X V).
eapply l8_3; try apply H9;auto.
assert (Col A X U0).
eapply col_transitivity_1;Col.
assert (Col B U U0).
eapply col_transitivity_1;Col.
assert (Col A U X).
eapply col_transitivity_1;Col.
assert (Col B U X).
eapply col_transitivity_1;Col.
cases_equality B U.
smart_subst U.
assert (Col B X U0).
eapply col_transitivity_2;Col.
Col.
assert (Col U U0 X).
eapply col_transitivity_2;Col.
Col.
apply l8_2.
eapply  l8_3.
apply l8_2.
apply H10.
auto.
assert (Col D V V0).
eapply col_transitivity_1;Col.
assert (Col C V V0).
eapply col_transitivity_1;Col.
assert (Col C V X).
eapply col_transitivity_1;Col.
assert (Col C V0 X).
eapply col_transitivity_1;Col.
cases_equality C X.
smart_subst X.
auto.
eapply col_transitivity_1;Col.
Qed.

Definition DistLn := fun A B C D =>
(exists X, Col X A B /\ ~Col X C D) \/ (exists X, ~ Col X A B /\ Col X C D).

Lemma l8_14_1 : forall A B, ~ Perp A B A B.
Proof.
unfold Perp.
unfold not;intros.
DecompEx H X.
unfold Perp_in in H0.
decompose [and] H0;clear H0.
clear H3 H2.
assert (Per A X A).
apply H5;Tarski.
assert (A=X);Perp.
assert (Per B X B).
apply H5;Tarski.
subst X.
assert (B=A);Perp.
Qed.

Hint Resolve l8_14_1 : Perp.

(*
Lemma l8_14_1 : forall A B C D, Perp A B C D -> DistLn A B C D.
Proof.
unfold Perp.
intros.

DecompEx H X.
unfold Perp_in in H0.
decompose [and] H0;clear H0.
unfold DistLn.
elim (classic (exists X0 : Point, Col X0 A B /\ ~ Col X0 C D));intro.
left;auto.
right.
suppose (forall X0, ~ Col X0 A B \/ Col X0 C D).
exists X.
split;auto.
assert
*)

Lemma l8_14_2_1a : forall X A B C D,
 Perp_in X A B C D -> Perp A B C D.
Proof with Perp.
unfold Perp.
intros.
exists X.
intuition.
Qed.

Lemma l8_14_2_1b : forall X A B C D Y,
 Perp_in X A B C D -> Col Y A B -> Col Y C D -> X=Y.
Proof with Perp.
intros.
unfold Perp_in in H.
decompose [and] H;clear H.
assert (Per Y X Y).
apply H7...
symmetry.
eapply l8_8...
Qed.

Lemma l8_14_2_1b_bis : forall A B C D X,
 Perp A B C D -> Col X A B -> Col X C D -> Perp_in X A B C D.
Proof with Perp.
intros.
unfold Perp in H.
DecompEx H Y.
assert (X=Y).
symmetry.
eapply l8_14_2_1b;eauto.
subst.
auto.
Qed.

Hint Resolve  l8_14_2_1b_bis : Perp.

Lemma l8_14_2_2 : forall X A B C D,
 Perp A B C D -> (forall Y, Col Y A B -> Col Y C D -> X=Y) ->
 Perp_in X A B C D.
Proof with Perp.
intros.
unfold Perp in H.
DecompEx H X0.
assert (X=X0).
apply H0;unfold Perp_in in H1;intuition.
subst...
Qed.

Lemma l8_14_3 : forall A B C D X Y,
  Perp_in X A B C D -> Perp_in Y A B C D -> X=Y.
Proof with Perp.
intros.
unfold Perp_in in *.
decompose [and] H;clear H.
decompose [and] H0;clear H0.
eapply l8_8.
eapply H10;auto.
Qed.

Lemma l8_15_1 : forall A B C X,
  A<>B -> Col A B X -> Perp A B C X ->
  Perp_in X A B C X.
Proof with Perp.
intros.
unfold Perp in H1.
DecompEx H1 X0.
unfold Perp_in in *.
intuition.
assert (Per X X0 X).
apply H6;Col;Tarski...
assert (X =X0)...
subst X0.
apply H6...
Qed.

Lemma l8_15_2 : forall A B C X,
 A<>B -> Col A B X -> Perp_in X A B C X ->
  Perp A B C X.
Proof with Perp.
intros.
unfold Perp.
exists X.
auto.
Qed.

Lemma l8_16_1 : forall A B C U X,
  A<>B -> Col A B X -> Col A B U -> U<>X -> Perp A B C X -> ~ Col A B C /\ Per C X U.
Proof with Perp.
intros.
assert (Perp_in X  A B C X).
eapply l8_15_1...
assert (Per C X U).
unfold Perp, Perp_in in *.
DecompEx H3 X0.
intuition.
split;auto.
assert (C<>X).
unfold not;intro.
subst X.
unfold Perp_in in H4;intuition.
assert (~ Col U C X).
unfold not;intro.
assert (C=X \/ U=X).
eapply l8_9...
Col.
intuition.
unfold not;intro.
assert (Col A X C).
eapply col_transitivity_1;Col.
assert (Col A C U).
eapply col_transitivity_1;Col.
assert (A<>C).
unfold not;intro.
unfold Perp_in in *;intuition.
smart_subst C.
assert (A<>B);auto.
assert (Col A X U).
eapply col_transitivity_1;Col.
intuition.
assert (Col C U X).
eapply col_transitivity_2;Col.
intuition.
Qed.

Lemma l8_16_2 : forall A B C U X,
  A<>B -> Col A B X -> Col A B U -> U<>X ->
 ~ Col A B C -> Per C X U ->Perp A B C X.
Proof with Perp.
intros.
assert (C<>X).
unfold not;intro.
smart_subst X;auto.
assert (Perp_in X A B C X).
eapply l8_13_2...
Col.
Tarski.
exists U.
exists C.
intuition.
exists X...
Qed.

Lemma l8_18_unicity : forall A B C X Y,
  ~ Col A B C ->
  Col A B X -> Perp A B C X ->
  Col A B Y -> Perp A B C Y ->
  X=Y.
Proof with Perp.
intros.
assert (Perp_in X A B C X).
eapply l8_15_1.
unfold not;intro;subst B;auto.
intuition.
Col.
assumption.
assert (Perp_in Y A B C Y).
eapply l8_15_1.
unfold not;intro;subst B;auto.
intuition.
Col.
assumption.
unfold Perp_in in *.
decompose [and] H4;clear H4.
decompose [and] H5;clear H5.
eapply l8_7 with (A:=C).
apply l8_2.
apply H11.
Col.
Tarski.
apply l8_2.
apply H15.
assumption.
Tarski.
Qed.

Ltac show_distinct X Y := assert (X<>Y);[unfold not;intro;treat_equalities|idtac].

Lemma l8_18_existence : forall A B C,
  ~ Col A B C -> exists X,
  Col A B X /\ Perp A B C X.
Proof with Tarski.
intros.
assert (exists Y, Bet B A Y /\ Cong A Y A C)...
DecompExAnd H0 Y.
assert (exists P : Point, is_midpoint P C Y).
eapply l7_25.
apply cong_symmetry;eauto.
DecompEx H0 P.
assert (Per A P Y).
unfold Per.
exists C;intuition;Tarski.
assert (exists Z, Bet A Y Z /\ Cong Y Z Y P)...
DecompExAnd H4 Z.
assert (exists Q, Bet P Y Q /\ Cong Y Q Y A)...
DecompExAnd H4 Q.
let_symmetric Q' Z Q.
assert (exists C', Bet Q' Y C' /\ Cong Y C' Y C)...
DecompExAnd H4 C'.
assert (OFSC A Y Z Q Q Y P A).
unfold OFSC;intuition.
show_distinct A Y...
assert (Cong Z Q P A).
eapply five_segments_with_def;eauto.
assert (Cong_3 A P Y Q Z Y).
unfold Cong_3;intuition.
assert (Per Q Z Y).
eapply l8_10.
2:apply H14.
auto.
assert (Cong Y Q Y Q').
assert (Per Y Z Q);Perp.
unfold Per in H16;intuition.
elim H16;intro Q'';intros.
decompose [and] H17.
assert (Q''=Q').
eapply symmetric_point_unicity.
apply H18.
auto.
subst Q''.
auto.
assert (exists X : Point, is_midpoint X C C').
eapply l7_25.
apply cong_symmetry;eauto.
DecompEx H17 X.
assert (Per Y X C).
unfold Per.
exists C';intuition.
show_distinct Q Y...
cases_equality C C'.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
show_distinct P Y...
assert (Col A B C)...
intuition.
show_distinct A B...
show_distinct A C...
show_distinct B C...
show_distinct Y C...
assert (Col P Y Q)...
assert (Col P Y C)...
assert (Col P Q C).
eapply col_transitivity_1;try apply H1;auto.
assert (Col Y Q C).
eapply col_transitivity_2;try apply H1;auto.
assert (Col Y Q' P).
eapply col_transitivity_1;try apply H21;auto.
assert (Col C Q' P).
eapply col_transitivity_2;try apply H21;auto.
assert (Col A Y B)...
assert (Col A Y Z)...
assert (Col A B Z).
eapply col_transitivity_1;try apply H10;auto.
assert (Col Y B Z).
eapply col_transitivity_2;try apply H10;auto.
assert (Col Q Y P)...
assert (Col Q' Y P).
Col.
assert (Col P Q Q').
eapply col_transitivity_1;try apply H1;auto.
Col.
assert (Col Y Q Q').
eapply col_transitivity_2;try apply H1;auto.
Col.
assert (Col Z Q Q')...
Col.
show_distinct Q' Q...
assert (Col P B C).
eapply col_transitivity_1;try apply H1;auto.
intuition.
assert (Col Q' P Y).
eapply col_transitivity_1;try apply H42;Col.
assert (Col Q' Z Y).
eapply col_transitivity_1;try apply H42;Col.
show_distinct Z Y...
assert (Col Z A Q').
eapply col_transitivity_1;try apply H45;Col.
assert (Col Y A Q').
eapply col_transitivity_2;try apply H45;Col.
show_distinct Z A...
assert (Col Z B Q').
eapply col_transitivity_1;try apply H48;Col.
assert (Col A B Q').
eapply col_transitivity_2;try apply H48;Col.
assert (Col B Y Q').
eapply col_transitivity_2;try apply H12;Col.
show_distinct Y Q'...
assert (Col Y Q B).
eapply col_transitivity_1;try apply H52;Col.
show_distinct Y B...
assert (Col Y B C).
eapply col_transitivity_1;try apply H52;Col.
assert (B<>Y)...
assert (Col B A C).
eapply col_transitivity_1;try apply H56;Col.
assert (Col A B C)...
Col.
intuition.
(* Now we know that C<> C' ! *)
suppose (OFSC Q Y C Z Q' Y C' Z).
assert (Cong C Z C' Z).
eapply five_segments_with_def;eauto.
assert (Col Z Y X).
eapply upper_dim.
apply H20.
apply cong_commutativity.
assumption.
sTarski.
unfold is_midpoint in H18;intuition.
show_distinct Y Z.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
auto.
show_distinct C X.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
auto.
show_distinct Y X.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
auto.
clean_trivial_hyps.
clean_duplicated_hyps.
Focus 2.
assert (Perp_in X Y Z C X).
eapply l8_13_2...
Col.
exists Y.
exists C.
repeat split...
assert (Col A B X).
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
clean_trivial_hyps.
clean_duplicated_hyps.
assert (Col A Y B)...
assert (Col A Y Z)...
assert (Col Y B Z).
eapply col_transitivity_2.
apply H10.
auto.
auto.
assert (Col Y Z X)...
Col.
assert (Col Y B X).
eapply col_transitivity_1.
apply H24.
Col.
Col.
assert (X<>Y)...
assert (Col X A B).
eapply col_transitivity_1.
apply H39.
assert (Col Y Z X)...
assert (Col Y Z A)...
assert (Col Y X A).
eapply col_transitivity_1;try apply H24;auto.
Col.
Col.
Col.
exists X.
split...
unfold Perp.
exists X.
unfold Perp_in.
repeat split.
unfold not;intro;subst B;intuition.
assumption.
Col.
Tarski.
unfold Perp_in in H27.
decompose [and] H27;clear H27.
intros.
apply H34.
2:assumption.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
assert (Col A Y Z)...
assert (Col A B U)...
Col.
assert (Col A B Y).
Col.
assert (Col A Y Z).
assert (Col A U Y).
assert (A<>B).
unfold not;intro.
subst B;intuition.
eapply col_transitivity_1.
apply H53.
auto.
auto.
auto.
assert (Col Y U Z).
assert (Y<>A)...
eapply col_transitivity_1.
apply H54.
2:Col.
assert (Col A Y U).
eapply col_transitivity_1.
assert (A<>B)...
unfold not;intro;subst B;intuition.
apply H55.
Col.
Col.
Col.
Col.
Focus 2.
unfold OFSC;repeat split;sTarski...
2:unfold OFSC ,is_midpoint, Cong_3 in *;DecompAndAll.
2:apply cong_right_commutativity.
2:assumption.
unfold is_midpoint in H1.
DecompAndAll.
show_distinct P Y...
clear  H6 H2 H3 H7 H9 H5 H12 H13 H14 H15 H16 H18 H17 H22 H0 H.
Between.
(* retour de focus *)
show_distinct A B...
show_distinct A C...
show_distinct B C...
show_distinct Y C...
show_distinct P Y...
show_distinct A Y...
show_distinct A Z...
show_distinct Y B...
show_distinct Y Z...
show_distinct C' Y...
show_distinct Q Q'...
assert (Col P B C).
eapply col_transitivity_1;try apply H32;Col.
intuition.
show_distinct Y Q...
clear H17 H0 H3 H7 H9 H12 H13 H15 H16 H22 H26 H27 H29 H30 H21 H33 H34 H38 H40.
assert (Col B A Y)...
assert (Col A Y Z)...
assert (Col P Y Q)...
assert (Col P Y C)...
assert (Col P Q C).
eapply col_transitivity_1;try apply H32;auto.
assert (Col Y Q C).
eapply col_transitivity_2;try apply H32;auto.
assert (Col Q' Y  C')...
assert (Col Q Z Q')...
assert (Col C Y C')...
clear H18 H23 H35 H4 H5 H11 H8 H2 H6.
assert (Col A Z B).
eapply col_transitivity_1;try apply H36;Col.
assert (Col Y Z B).
eapply col_transitivity_2;try apply H36;Col.
assert (Col C' C Q').
eapply col_transitivity_1;try apply H42;Col.
assert (Col Y C Q').
eapply col_transitivity_2;try apply H42;Col.
assert (Col C P Q').
eapply col_transitivity_1;try apply H25;Col.
assert (Col Y P Q').
eapply col_transitivity_2;try apply H25;Col.
assert (Col Y Q Q').
eapply col_transitivity_2;try apply H32;Col.
assert (Col P Q Q').
eapply col_transitivity_2;try apply H32;Col.
assert (Col Q Z P).
eapply col_transitivity_1;try apply H43;Col.
assert (Col Q Z Y).
eapply col_transitivity_1;try apply H43;Col.
assert (Col Q' Z P).
eapply col_transitivity_2;try apply H43;Col.
assert (Col Q' Z Y).
eapply col_transitivity_2;try apply H43;Col.
assert (Col Q' P Y).
eapply col_transitivity_2;try apply H43;Col.
assert (Col Y Z C).
eapply col_transitivity_1;try apply H43;Col.
assert (Col Y A C).
eapply col_transitivity_1;try apply H41;Col.
assert (Col A B C).
eapply col_transitivity_1;try apply H10;Col.
intuition.
Qed.

Lemma l8_20_1 : forall A B C C' D P,
  Per A B C -> is_midpoint P C' D ->
  is_midpoint A C' C -> is_midpoint B D C ->
   Per B A P.
Proof.
intros.
let_symmetric B' A B.
let_symmetric D' A D.
let_symmetric P' A P.
cases_equality A B.

subst B.
Perp.
(*
split;Perp.
intros.
unfold not;intro.
subst P.
assert (C=D').
eapply symmetric_point_unicity;eauto.
subst D'.
assert (C=D).
eapply symmetric_point_unicity.
apply H1.
auto.
subst D.
assert (A=C).
Midpoint.
auto.
*)
assert (Per B' B C).
eapply l8_3.
apply H.
auto.
unfold is_midpoint in H4;intuition;Col.

assert (Per B B' C').

eapply l8_10.
apply H7.
unfold Cong_3;repeat split;Tarski.
eapply l7_13.
apply H4.
apply H1.
eapply l7_13.
eapply l7_2.
apply H4.
apply H1.

suppose (Cong B C' B D').
suppose (IFSC C' P D B D' P' C B).
assert (Cong P B P' B).
eapply l4_2;eauto.
unfold Per.
exists P'.
intuition.
(*
unfold not;intros.
subst P.
assert (C=D).
eapply symmetric_point_unicity;try apply H1;eauto.
smart_subst D.
assert (B=C).
eapply l7_3;eauto.
auto.
*)
unfold IFSC in *;repeat split.
unfold is_midpoint in *;DecompAndAll;auto.
Focus 5.
unfold is_midpoint in H2;DecompAndAll.
sTarski.
4:sTarski.
eapply (l7_15).
apply H5.
apply H6.
apply H1.
unfold is_midpoint in H0;DecompAndAll;Between.
assert (Cong C D' C' D).
eapply (l7_13 A C D' C' D);Midpoint.
sTarski.

assert (Cong P C' P' C).
eapply l7_13.
apply l7_2.
apply H6.
apply l7_2.
apply H1.

eapply cong_transitivity with (C:=P) (D:=C').
unfold is_midpoint in H0;DecompAndAll.
sTarski.
auto.

unfold Per in H8.
DecompExAnd H8 D0.
suppose (D0=D').
subst D0;auto.

assert (is_midpoint B' C' D').
unfold is_midpoint;split.
eapply l7_15.
apply l7_2.
apply H1.
apply H4.
apply H5.
unfold is_midpoint in H2;decompose [and] H2;Between.
eapply l7_16.
apply  l7_2.
apply H1.
apply H4.
apply H4.
apply H5.
unfold is_midpoint in H2;decompose [and] H2;sTarski.
eapply symmetric_point_unicity;eauto.
Qed.

Lemma l8_20_2 : forall A B C C' D P,
  Per A B C -> is_midpoint P C' D ->
  is_midpoint A C' C -> is_midpoint B D C ->
   B<>C -> A<>P.
Proof.
intros.
unfold not;intros.
subst P.
assert (C=D).
eapply symmetric_point_unicity;try apply H1;eauto.
smart_subst D.
assert (B=C).
eapply l7_3;eauto.
auto.
Qed.

Lemma l8_21_aux : forall A B C,
 A<> B -> ~ Col A B C -> exists P, exists T, Perp A B P A /\ Col A B T /\ Bet C T P.
Proof with Tarski.
intros.
assert (exists X : Point, Col A B X /\ Perp A B C X).
eapply l8_18_existence...
DecompExAnd H1 X.
assert (Per A X C).
assert (Perp_in X A B C X).
eapply l8_15_1;auto.
unfold Perp_in in H1.
DecompAndAll.
apply H9;Tarski.

assert (HH:=H1).
unfold Per in H1.
DecompExAnd H1 C'.

let_symmetric C'' A C.

assert (exists P, is_midpoint P C' C'').
eapply l7_25.
unfold is_midpoint in H2.
decompose [and] H2.

eapply cong_transitivity with (C:=C) (D:=A).
2:apply H7.
sTarski.
DecompEx H1 P.

assert (Per X A P).

eapply l8_20_1.
apply HH.
apply l7_2.
apply H7.
Midpoint.
Midpoint.

show_distinct X C.
unfold is_midpoint in*;DecompAndAll.
intuition.

assert (A<>P).
eapply l8_20_2.
apply HH.
apply l7_2.
apply H7.
Midpoint.
Midpoint.
auto.

assert (exists T, Bet P T C /\ Bet A T X).
eapply l3_17 with (A:=C'') (A':=C');unfold is_midpoint in *;intuition.
DecompExAnd H10 T.

cases_equality A X.
exists P.
exists T.
treat_equalities.
repeat split;Tarski;Between.

unfold Perp.
assert (Perp_in A A B C A).
eapply l8_15_1;auto.
Tarski.
unfold Perp_in in H3.
decompose [and] H3;clear H3.
exists A.
unfold Perp_in;repeat split;Tarski;auto.
intros.
eapply H16;auto.
assert (Col A P C).
Col.
assert (Col A P V).
Col.
assert (Col A C V).
eapply col_transitivity_1;try apply H9;auto.
Col.

assert (Col A B T).
eapply col_transitivity_1.
apply H10.
unfold is_midpoint;intuition.
unfold is_midpoint;intuition.
exists P.
exists T.
repeat split;Between.
unfold Perp.
exists A.
eapply l8_13_2;auto.
Tarski.
Tarski.

exists X.
exists P.
repeat split.
Col.
Tarski.
auto.
auto.
auto.
Qed.

Lemma l8_21 : forall A B C,
 A<> B ->  exists P, exists T, Perp A B P A /\ Col A B T /\ Bet C T P.
Proof with Tarski.
intros.
cases_col A B C.
assert (exists C', ~ Col A B C').
eapply l6_25...
DecompEx H1 C'.

assert (  exists P : Point,
         (exists T : Point, Perp A B P A /\ Col A B T /\ Bet C' T P)).
apply (l8_21_aux A B C');auto.
DecompEx H1 P.
DecompEx H3 T.
exists P.
exists C.
intuition.

eapply l8_21_aux;auto.
Qed.

Lemma perp_symmetry : forall A B C D, Perp A B C D -> Perp C D A B.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_commutativity : forall A B C D, Perp A B C D -> Perp B A D C.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_left_commutativity : forall A B C D, Perp A B C D -> Perp B A C D.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_right_commutativity : forall A B C D, Perp A B C D -> Perp A B D C.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_in_left_commutativity : forall A B C D X,
Perp_in X A B C D -> Perp_in X B A C D.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Lemma perp_in_right_commutativity : forall A B C D X,
Perp_in X A B C D -> Perp_in X A B D C.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Lemma perp_in_commutativity : forall A B C D X,
Perp_in X A B C D -> Perp_in X B A D C.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Lemma perp_in_symmetry : forall A B C D X,
Perp_in X A B C D -> Perp_in X C D A B.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Hint Resolve perp_symmetry perp_commutativity perp_left_commutativity perp_right_commutativity : sPerp.
Hint Resolve perp_in_symmetry perp_in_commutativity perp_in_left_commutativity perp_in_right_commutativity : sPerp.

Ltac sPerp := eauto with sPerp.

Lemma perp_per_1 : forall A B C, A<>B -> Perp A B C A -> Per B A C.
Proof.
intros.
assert (Perp_in A A B C A).
eapply l8_15_1;auto.
Tarski.
unfold Perp_in in H1.
intuition.
Qed.

Lemma perp_per_2 : forall A B C, A<>B -> Perp A B A C -> Per B A C.
Proof.
intros.
assert (Perp A B C A);eauto with sPerp.
apply perp_per_1;auto.
Qed.

Hint Resolve perp_per_1 perp_per_2 : Perp.

Lemma perp_col : forall A B C D E,
 A<>E ->
 Perp A B C D -> Col A B E -> Perp A E C D.
Proof with Col.
unfold Perp,Perp_in.
intros.
DecompExAnd H0 X.
exists X.
repeat split;auto.
assert (Col A E X).
eapply col_transitivity_1;try apply H3...
Col.
intros.
apply H8.

assert (Col A B U).
eapply col_transitivity_1;try apply H...
Col.
Col.
Qed.

Hint Resolve perp_col : Perp.

Lemma perp_not_eq_1 : forall A B C D,
 Perp A B C D -> A<>B.
Proof.
unfold Perp.
intros.
DecompEx H X.
unfold Perp_in in H0.
intuition.
Qed.

Lemma perp_not_eq_2 : forall A B C D,
 Perp A B C D -> C<>D.
Proof.
intros.
assert (Perp C D A B);sPerp.
eapply perp_not_eq_1;eauto.
Qed.

Hint Resolve perp_not_eq_1 perp_not_eq_2 : Perp.

Lemma perp_perp_in : forall A B C,
Perp A B C A -> Perp_in A A B C A.
Proof.
intros.
apply l8_15_1;Perp.
Tarski.
Qed.

Hint Resolve perp_perp_in : Perp.


Require Import logic.

(* Here we define a parameterized module Invariance that expects as a
   parameter a module D of module type DYN. This parameterization
   allows us to give a generic proof of the theorem
   InvarianceUnderBisimulation.

   We can later take this functor and apply it to a module D of type
   DYN to obtain a module with a proof of the theorem for a concrete
   set of dynamic operators.

   The reader can find a more detailed explanation on modules in the
   file logic.v.

*)

Module Invariance (D: DYN).

(* We use the functor DynLogic to define a dynamic logic with the
   dynamic operators defined in D.

*)
Module DynLogic := DynLogic D.

(* This Import command makes the components of the module DynLogic D
   available by their short names. So for instance, we can write
   pointed_model instead of DynLogic.pointed_model.

 *)
Import DynLogic.

Theorem InvarianceUnderBisimulation :
  forall 𝔐 𝔐' : pointed_model,
  𝔐 ⇆ 𝔐' -> 𝔐 ≡ 𝔐'.

Proof.
  move=> 𝔐 𝔐' bis φ.
  move: 𝔐 𝔐' bis.
  elim: φ => [prop | | φ IHφ ψ IHψ | f φ IH] /=
             𝔐 𝔐'.
  + move=> [Z [bis HZ]].
    rewrite !to_st_val !to_st_point.
    by apply ((get_AH bis) ?? HZ).

  + by [].

  + move=>bis.
    split; move=> HImpl Hsat;
      apply (IHψ ?? bis);
      apply HImpl;
      by apply (IHφ ?? bis).

  + move=> [Z [bis HZ]].
    split.

    - move=> [q [HqinfW Hsatq]].
      apply ((get_Zig bis) ?? HZ) in HqinfW
        as [q' [Hq'infW' HZqq']].
      exists q'.
      split; first by [].
      apply (IH q) ; last by [].
      exists Z.
      by rewrite !to_st_to_pm.

    - move=> [q' [Hq'infW' Hsatq']].
      apply ((get_Zag bis) ?? HZ) in Hq'infW'
          as [q [HqinfW HZqq']].
      exists q.
      split; first by [].
      eapply (IH q); last by eassumption.
      exists Z.
      by rewrite !to_st_to_pm.
Qed.

End Invariance.