Require Import Coq.Lists.List.
Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.RIneq.
Require Import Logic.Logic.
Require Import Logic.ProofRules.
Require Import Logic.ArithFacts.
Require Import Examples.System.
Require Import Examples.UtilPosition.
Require Import Examples.DiffEqSolutions.

Open Scope HP_scope.
Open Scope string_scope.

Module Type PositionShimParams <: SdistParams.

  (* The upper bound on y. *)
  Parameter ub : R.
  (* Max time between executions of the
     controller. *)
  Parameter d : R.
  Parameter d_gt_0 : (d > 0)%R.
  (* Our breaking acceleration. *)
  Parameter amin : R.
  Parameter amin_lt_0 : (amin < 0)%R.

End PositionShimParams.

Module PositionShim (Import Params : PositionShimParams).

  Module SdistUtil := SdistUtil(Params).
  Import SdistUtil.

  (* The continuous dynamics of the system *)
  Definition w : state->Formula :=
    fun st' =>
      st' "y" = "v" //\\ st' "v" = "a" //\\ st' "a" = 0.

  Definition Safe : Formula :=
    "y" <= ub.

  Definition SafeAcc (a : Term) (d : Term) : Formula :=
    Forall t : R,
      (0 <= t //\\ t <= d) -->>
      "y" + tdist "v" a t + sdist MAX("v" + a*t, 0) <= ub.

  Definition SafeAccZeroOrder (a : Term) (d : Term)
    : Formula :=
    (0 <= "v" + a*d -->>
     "y" + tdist "v" a d + sdist ("v" + a*d) <= ub) //\\
    (("v" + a*d <= 0 //\\ 0 < "v") -->>
     "y" + tdist "v" a (--"v"/a) <= ub).

  Definition Ctrl := SafeAccZeroOrder "a"! d.

  Definition IndInv := SafeAcc "a" "T".

  Definition Next : Formula :=
    Sys (Ctrl //\\ Unchanged ("v"::"y"::nil)) w d.

  Lemma SafeAccZeroOrder_refines :
    forall a,
      SafeAccZeroOrder a d //\\ "y" <= ub //\\ SafeAcc amin d
      |-- SafeAcc a d.
  Proof.
    intros. reason_action_tac.
    pose proof d_gt_0.
    unfold Rbasic_fun.Rmax. destruct_ite.
    - rewrite_real_zeros.
      destruct (RIneq.Rlt_dec 0 (pre "v"))%R.
      + assert (pre "v" + eval_term a pre post * d <= 0)%R
          by solve_nonlinear. intuition.
        assert (eval_term a pre post <> 0%R)
          by solve_nonlinear. intuition.
        eapply Rle_trans; eauto.
        field_simplify; auto. simpl.
        apply Rmult_le_reg_r with (r:=2%R);
          [ solve_linear | ].
        apply Rmult_le_reg_r
        with (r:=(-(eval_term a pre post))%R);
          [ solve_nonlinear | ].
        repeat rewrite Ropp_mult_distr_r_reverse.
        field_simplify; auto. simpl.
        unfold Rdiv. repeat rewrite RMicromega.Rinv_1.
        solve_nonlinear.
      + solve_nonlinear.
    - destruct (RIneq.Rle_dec
                  (pre "v" + eval_term a pre post * d) 0)%R.
      + destruct (RIneq.Rlt_dec 0 (pre "v"))%R.
        * intuition.
          assert (eval_term a pre post <> 0%R)
            by solve_nonlinear. intuition.
          pose proof amin_lt_0.
          assert (amin <> 0%R) by solve_linear.
          destruct
            (RIneq.Rle_dec amin (eval_term a pre post)).
          { eapply Rle_trans; eauto.
            field_simplify; auto. simpl.
            apply Rmult_le_reg_r with (r:=2%R);
              [ solve_linear | ].
            apply Rmult_le_reg_r
            with (r:=(-(eval_term a pre post))%R);
              [ solve_nonlinear | ].
            apply Rmult_le_reg_r with (r:=(-amin)%R);
              [ solve_linear | ].
            repeat rewrite Ropp_mult_distr_r_reverse.
            field_simplify; auto. simpl.
            unfold Rdiv. repeat rewrite RMicromega.Rinv_1.
            clear - r1. solve_nonlinear. }
          { specialize (H6 0%R). specialize_arith_hyp H6.
            revert H6. unfold Rbasic_fun.Rmax.
            repeat destruct_ite; rewrite_real_zeros.
            { solve_linear. }
            { intros. eapply Rle_trans; eauto.
              assert (pre "v"+eval_term a pre post*x > 0)%R
                by solve_linear.
              field_simplify; auto. simpl.
              apply Rmult_le_reg_r with (r:=2%R);
                [ solve_linear | ].
              apply Rmult_le_reg_r
              with (r:=(-(eval_term a pre post))%R);
                [ solve_nonlinear | ].
              apply Rmult_le_reg_r with (r:=(-amin)%R);
                [ solve_linear | ].
              repeat rewrite Ropp_mult_distr_r_reverse.
              field_simplify; auto. simpl.
              unfold Rdiv. repeat rewrite RMicromega.Rinv_1.
              clear - H9 n0 H7 H1 H. solve_nonlinear. } }
        * solve_nonlinear.
      + assert (0 <= pre "v" + eval_term a pre post * d)%R
          as Hvd by solve_linear. intuition.
        destruct
            (RIneq.Rle_dec amin (eval_term a pre post)).
        { eapply Rle_trans; eauto.
          pose proof amin_lt_0.
          assert (amin <> 0%R) by solve_linear.
          assert (0 <= pre "v" + eval_term a pre post * x)%R
            as Hvx by solve_linear.
          apply Rmult_le_reg_l with (r:=(-amin)%R);
            [ solve_linear | ].
          ring_simplify; simpl; field_simplify; auto; simpl.
          apply Rmult_le_reg_r with (r:=2%R);
            [ solve_linear | ].
          field_simplify; simpl.
          unfold Rdiv. repeat rewrite RMicromega.Rinv_1.
          clear - Hvd Hvx H4 r. solve_nonlinear. }
        { pose proof amin_lt_0.
          assert (amin <> 0%R) by solve_linear.
          specialize (H6 0%R). specialize_arith_hyp H6.
          revert H6. unfold Rbasic_fun.Rmax.
          repeat destruct_ite; rewrite_real_zeros.
          { intros. eapply Rle_trans; eauto.
            assert (pre "v"+eval_term a pre post*x > 0)%R
              by solve_linear.
            field_simplify; auto. simpl.
            apply Rmult_le_reg_r with (r:=2%R);
              [ solve_linear | ].
            apply Rmult_le_reg_r
            with (r:=(-(eval_term a pre post))%R);
              [ solve_nonlinear | ].
            apply Rmult_le_reg_r with (r:=(-amin)%R);
              [ solve_linear | ].
            repeat rewrite Ropp_mult_distr_r_reverse.
            field_simplify; auto. simpl.
            unfold Rdiv. repeat rewrite RMicromega.Rinv_1.
            clear - H8 r H5 n1 H. solve_nonlinear. }
          { intros. eapply Rle_trans; eauto.
            assert (pre "v"+eval_term a pre post*x > 0)%R
              by solve_linear.
            field_simplify; auto. simpl.
            apply Rmult_le_reg_r with (r:=2%R);
              [ solve_linear | ].
            apply Rmult_le_reg_r
            with (r:=(-(eval_term a pre post))%R);
              [ solve_nonlinear | ].
            apply Rmult_le_reg_r with (r:=(-amin)%R);
              [ solve_linear | ].
            repeat rewrite Ropp_mult_distr_r_reverse.
            field_simplify; auto. simpl.
            unfold Rdiv. repeat rewrite RMicromega.Rinv_1.
            clear - H8 n2 H5 n1 H. solve_nonlinear. } }
  Qed.

  Lemma SafeAcc_downclock :
    forall a t1 t2,
      t1 <= t2 //\\ SafeAcc a t2 |-- SafeAcc a t1.
  Proof.
    intros. reason_action_tac. intuition.
    apply H2. solve_linear.
  Qed.

  Lemma SafeAcc_Safe :
    forall a d,
      0 <= d //\\ SafeAcc a d |-- "y" <= ub.
  Proof.
    intros. reason_action_tac. intuition. specialize (H1 R0).
    specialize_arith_hyp H1. rewrite_real_zeros.
    unfold Rbasic_fun.Rmax in *. revert H1. destruct_ite.
    { rewrite_real_zeros. auto. }
    { intros. assert (-/2 < 0)%R by solve_linear.
      assert (/amin < 0)%R by (pose proof amin_lt_0; solve_linear).
      generalize dependent (-/2)%R.
      generalize dependent (/amin)%R.
      intros. solve_nonlinear. }
  Qed.

  Lemma SafeAcc_amin :
    forall a,
      SafeAcc a 0 |-- SafeAcc amin d.
  Proof.
    intros. reason_action_tac. specialize (H R0).
    specialize_arith_hyp H. revert H.
    unfold Rbasic_fun.Rmax. repeat destruct_ite.
    { rewrite_real_zeros. intros.
      pose proof (tdist_vel_neg "v" amin x).
      breakAbstraction.
      specialize
        (H1 (Stream.Cons pre (Stream.forever (fun _ => R0)))).
      simpl in *. solve_linear. }
    { rewrite_real_zeros. intros. pose proof amin_lt_0.
      solve_nonlinear. }
    { rewrite_real_zeros. intros.
      pose proof (sdist_tdist "v" x). breakAbstraction.
      specialize
        (H1 (Stream.Cons pre (Stream.forever (fun _ => R0)))).
      simpl in *. solve_linear. }
    { rewrite_real_zeros. intros. pose proof amin_lt_0.
      pose proof (sdist_tdist_tdist "v" x).
      specialize
        (H2 (Stream.Cons pre (Stream.forever (fun _ => R0)))).
      simpl in *. solve_linear. }
  Qed.

  Theorem TimedPreserves_Next :
    |-- TimedPreserves d IndInv Next.
  Proof.
    pose proof amin_lt_0 as amin_lt_0.
    pose proof d_gt_0 as d_gt_0.
    eapply Preserves_Sys; [ refine _ | | ].
    { simpl next; restoreAbstraction.
      unfold World.
      zero_deriv_tac "a".
      pose proof solve_dbl_int.
      apply (Proper_Rename_lentails {{ "t" ~> --"T" }}%rn
                                    {{ "t" ~> --"T" }}%rn) in H;
        [ | reflexivity ].
      rewrite <- Rename_Continuous_deriv_term'
        in H by sysrename_side_cond.
      rewrite <- Rename_ok in H by rw_side_condition.
      simpl rename_formula in H. restoreAbstraction.
      match type of H with
      | Continuous ?eqs |-- _ =>
        assert (mkEvolution w |-- eqs)
      end.
      { apply Evolution_lentails_lentails.
        red. clear H. intros. apply lforallR. intros.
        rewrite <- Rename_ok by rw_side_condition.
        simpl rename_formula. restoreAbstraction.
        simpl deriv_term_RenameList. unfold deriv_term_succeed.
        simpl deriv_term.
        simpl. restoreAbstraction. breakAbstraction.
        solve_linear.
        pose proof (H0 "y"). simpl in *. congruence.
        pose proof (H0 "v"). simpl in *. congruence.
        pose proof (H0 "a"). simpl in *. congruence.
        pose proof (H0 "t"). simpl in *. solve_linear. }
      rewrite H0. clear H0. rewrite H. clear H.
      unfold IndInv, SafeAcc. simpl next.
      restoreAbstraction.
      charge_split.
      { apply lforallR. intro.
        charge_intros; reason_action_tac; intuition;
        match goal with
        | [ H : forall _ : R, _ |- _ ]
          => specialize (H (x + pre "T" - post "T")%R)
        end; intuition;
        repeat match goal with
               | [ H : eq _ _ |- _ ]
                 => rewrite H in *
               end.
        specialize_arith_hyp H12.
        unfold Rbasic_fun.Rmax in *. revert H12.
        repeat destruct_ite; solve_linear. }
      { solve_linear. } }
    { unfold Discr, Ctrl, IndInv. rewrite next_And.
      pose proof (SafeAcc_downclock "a" "T" d).
      apply next_st_formula_entails in H;
        [ | simpl; tauto | simpl; tauto ].
      rewrite <- H. clear H. rewrite next_And.
      pose proof (SafeAccZeroOrder_refines "a").
      apply next_st_formula_entails in H;
      [ | simpl; tauto | simpl; tauto ].
      rewrite <- H. clear H.
      charge_assert (0 <= "T" //\\ SafeAcc "a" "T");
        [ charge_split; [ solve_linear | charge_assumption ] | ].
      rewrite (SafeAcc_downclock "a" 0 "T").
      rewrite SafeAcc_amin.
      charge_assert (0 <= "T" //\\ SafeAcc "a" "T");
        [ charge_split; [ solve_linear | charge_assumption ] | ].
      rewrite SafeAcc_Safe.
      charge_intros. charge_split.
      { charge_split.
        { simpl next. restoreAbstraction. charge_tauto. }
        { repeat rewrite next_And.
          breakAbstraction.
          intuition;
            repeat match goal with
                   | [ H : eq _ _ |- _ ]
                     => rewrite H
                   end; solve_linear. } }
      { simpl next. restoreAbstraction. charge_assumption. } }
  Qed.

  (* A proof that the inductive safety condition
     Inv implies the safety contition
     we actually care about, Safe. *)
  Lemma IndInv_impl_Safe :
    IndInv //\\ TimeBound d |-- Safe.
  Proof.
    pose proof d_gt_0.
    pose proof amin_lt_0.
    breakAbstraction. intuition.
    specialize (H2 R0). rewrite_real_zeros. intros.
    destruct (Rle_dec R0 (Stream.hd tr "v")).
    - intuition. specialize_arith_hyp H3.
      simpl_Rmax.
      assert (- / 2 < 0)%R by solve_linear.
      assert (/amin < 0)%R by solve_linear.
      generalize dependent (-/2)%R.
      generalize dependent (/amin)%R.
      intros. eapply Rle_trans; eauto.
      clear H3. solve_nonlinear.
    - simpl_Rmax. rewrite_real_zeros.
      solve_linear.
  Qed.

  Lemma SafeAcc_ZeroOrder_amin :
    forall a,
      SafeAcc a 0 |-- SafeAccZeroOrder amin d.
  Proof.
    unfold SafeAcc, SafeAccZeroOrder.
    pose proof amin_lt_0. pose proof d_gt_0.
    intros. reason_action_tac. split.
    { specialize (H1 R0). intros. specialize_arith_hyp H1.
      rewrite_real_zeros. assert (pre "v" > 0)%R by solve_nonlinear. simpl_Rmax.
      pose proof (sdist_tdist_tdist "v" d (Stream.Cons pre (Stream.forever (fun _ => R0)))).
      breakAbstraction. solve_linear. }
    { specialize (H1 0)%R. intros. rewrite_real_zeros. simpl_Rmax.
      pose proof (sdist_tdist "v" (- pre "v" * / amin)%R
                              (Stream.Cons pre (Stream.forever (fun _ => R0)))).
      breakAbstraction. solve_linear. }
  Qed.

  Definition Constraint := amin <= "a".

  Lemma SysNeverStuck_Discr :
    IndInv //\\ "T" = 0
    |-- Enabled ((0 <= "T"! <= d //\\ Sys_D Next) //\\
                  next Constraint).
  Proof.
    charge_assert (SafeAcc "a" 0).
    { rewrite <- (SafeAcc_downclock "a" 0 "T").
      solve_linear. }
    rewrite SafeAcc_ZeroOrder_amin. charge_clear.
    charge_intros. enable_ex_st'. pose proof d_gt_0.
    do 3 eexists; exists d; solve_linear.
  Qed.

  (* Map the interval onto the vertical dimension of
      the quadcopter. *)
  Require Import Examples.Quadcopter.

  Variable g : R.
  Hypothesis amin_lt_g : (amin > -g)%R.
  Variable angle_min : R.
  Hypothesis angle_min_le_0 : (angle_min < 0)%R.

  Let rename_quad : RenameList :=
    {{ "a" ~> "A"*cos("pitch")*cos("roll") - g &
       "y" ~> "z" & "v" ~> "vz" }}%rn.

  Let quad_inv : RenameList :=
    {{ "roll" ~> 0 & "pitch" ~> 0 & "A" ~> "a" + g &
       "z" ~> "y" & "vz" ~> "v" }}%rn.

  Let small_angle := small_angle angle_min.

  Lemma Constraint_small_angle :
    Constraint |-- Rename quad_inv small_angle.
  Proof.
    rewrite <- Rename_ok by eauto with rw_rename.
    breakAbstraction. intros. pose proof amin_lt_g.
    pose proof angle_min_le_0. solve_linear.
  Qed.

  Lemma quad_inv_ok :
    forall xs,
      List.forallb (fun x => if String.string_dec x "A"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "roll"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "pitch"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "z"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "vz"
                             then false else true) xs =
      true ->
      forall st x,
        List.In x xs ->
        eval_formula Constraint (Stream.forever st) ->
        subst_state rename_quad
                    (subst_state quad_inv st) x = st x.
  Proof.
    simpl. unfold Value, subst_state. simpl. intros.
    repeat destruct_ite; subst; simpl in *; try reflexivity.
    { rewrite Rtrigo_def.cos_0. solve_linear. }
    { rewrite List.forallb_forall in *. specialize (H "A").
      specialize (H0 "roll"). specialize (H1 "pitch").
      specialize (H2 "z"). specialize (H3 "vz").
      repeat destruct_ite; subst; simpl; try reflexivity;
        try match goal with
        | [ H : ?X -> _ |- _ ] =>
            match type of H4 with
            | X => specialize (H H4); simpl in *; discriminate
            end
        end. }
  Qed.

  Definition Next_quad : ActionFormula :=
    SysCompose
      (SysRename rename_quad
                 (deriv_term_RenameList rename_quad) Next)
      (Sys (next small_angle) ltrue d).

  Definition IndInv_quad := Rename rename_quad IndInv.

  Transparent ILInsts.ILFun_Ops.

  Lemma TimedPreserves_Next_quad :
    |-- TimedPreserves d IndInv_quad Next_quad.
  Proof with eauto with rw_rename.
    unfold IndInv_quad, Next_quad.
    rewrite SysCompose_abstract. unfold SysRename.
    rewrite Sys_rename_formula... rewrite SysRename_rule...
    rewrite TimedPreserves_Rename...
    rewrite <- TimedPreserves_Next. rewrite Rename_True.
    charge_tauto.
  Qed.

  Opaque ILInsts.ILFun_Ops.

  Require Import Logic.EnabledLemmas.
  Lemma SysNeverStuck_Discr_quad :
    IndInv_quad //\\ "T" = 0 |-- Enabled (Sys_D Next_quad).
  Proof.
    unfold Sys_D, IndInv_quad.
    rewrite_rename_equiv ("T" = 0) rename_quad.
    rewrite <- Rename_and.
    rewrite Rename_ok by eauto with rw_rename.
    eapply EnabledLemmas.subst_enabled_full
    with (R:=Constraint) (Q:=small_angle).
    { tlaIntuition. }
    { tlaIntuition. }
    { apply is_action_formula_ok; simpl; tauto. }
    { apply get_vars_next_state_vars; reflexivity. }
    { intros. eapply quad_inv_ok. 6: apply H.
      reflexivity. reflexivity. reflexivity. reflexivity.
      reflexivity. auto. }
    { apply Constraint_small_angle. }
    { pose proof SysNeverStuck_Discr. unfold Sys_D in H.
      rewrite H. apply Proper_Enabled_lentails.
      charge_tauto. }
  Qed.

  Theorem SysNeverStuck_Next :
    |-- SysNeverStuck d IndInv_quad Next_quad.
  Proof.
    eapply SysNeverStuck_Sys;
    [ pose proof d_gt_0 ; solve_linear | | ].
    { rewrite <- disjoint_state_enabled.
      { charge_split.
        { charge_clear. apply Enabled_TimeBound.
          pose proof d_gt_0. assumption. }
        { apply SysNeverStuck_Discr_quad. } }
      { apply formulas_disjoint_state; reflexivity. } }
    { admit. (** Provable, but we won't worry about it *) }
  Admitted.

  Definition Safe_quad : StateFormula :=
    Rename rename_quad Safe.

  Lemma IndInv_impl_Safe_quad :
    IndInv_quad //\\ TimeBound d |-- Safe_quad.
  Proof with (eauto with rw_rename).
    unfold Safe, TimeBound, IndInv_quad.
    rewrite_rename_equiv (0 <= "T" <= d) rename_quad.
    rewrite <- Rename_and.
    apply Proper_Rename_lentails; try reflexivity.
    apply IndInv_impl_Safe.
  Qed.

  Lemma W_quad_refines :
    W_quad g |-- Sys_w Next_quad.
  Proof.
    (* Mechanical reasoning about abstractions of
       differential equations. *)
  Admitted.

  (* Our main safety theorem. *)
  Theorem Position_safe :
    |-- (IndInv_quad //\\ TimeBound d) //\\
        []SysSystem (Quadcopter d g angle_min
                                (Sys_D Next_quad))
        -->> []Safe_quad.
  Proof.
    rewrite Inductively.Preserves_Inv_simple.
    { rewrite IndInv_impl_Safe_quad.
      charge_tauto. }
    { compute; tauto. }
    { apply SafeAndReactive_TimedPreserves.
      eapply Quadcopter_refine.
      { apply d_gt_0. }
      { pose proof angle_min_le_0. solve_linear. }
      { apply TimedPreserves_Next_quad. }
      { apply SysNeverStuck_Next. }
      { unfold Sys_D. unfold small_angle. charge_assumption. }
      { apply W_quad_refines. } }
  Qed.

End PositionShim.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics HoTT.Types.
Require Import HoTT.Spaces.No.Core HoTT.Spaces.No.Negation.

Local Open Scope path_scope.
Local Open Scope surreal_scope.

(** * Addition of surreal numbers *)

(** Addition requires the option sorts to be closed under finite sums. *)
Class HasAddition (S : OptionSort) :=
  { empty_options : InSort S Empty Empty
    ; sum_options : forall L R L' R',
        InSort S L R -> InSort S L' R' -> InSort S (L + L') (R + R')
  }.
Global Existing Instance empty_options.
Global Existing Instance sum_options.

Global Instance hasaddition_maxsort : HasAddition MaxSort
  := { empty_options := tt ;
       sum_options := fun _ _ _ _ _ _ => tt }.

Global Instance hasaddition_ordsort : HasAddition OrdSort
  := { empty_options := idmap ;
       sum_options := fun _ _ _ _ f g => sum_ind _ f g }.

Global Instance hasaddition_decsort : HasAddition DecSort.
Proof.
  constructor.
  - apply insort_decsort.
  - intros L R L' R' [? ?] [? ?]; split; exact _.
Qed.

Section Addition.
  Context `{Univalence}.
  Context {S : OptionSort@{i}} `{HasAddition S}.
  Let No := GenNo S.

  Section Inner.

    Context {L R : Type@{i} } {Sx : InSort@{i} S L R}
            (xL : L -> No) (xR : R -> No)
            (xcut : forall (l : L) (r : R), xL l < xR r).

    Let A := {g : No -> No &
              (forall x y : No, x <= y -> g x <= g y) *
              (forall x y : No, x < y -> g x < g y)}.

    Context (xL_plus : L -> A) (xR_plus : R -> A)
            (xL_lt_xR_plus : forall (l : L) (r : R) (x : No),
                               (xL_plus l).1 x < (xR_plus r).1 x).

    Definition plus_inner
    : { g : forall (y : No),
              { x_plus_y : No &
                (forall l, (xL_plus l).1 y < x_plus_y) *
                (forall r, x_plus_y < (xR_plus r).1 y) } &
        (forall y z : No, y <= z -> (g y).1 <= (g z).1) *
        (forall y z : No, y <  z -> (g y).1 <  (g z).1) }.
    Proof.
      simple refine (No_ind_package
                (fun y => { x_plus_y : No &
                            (forall l, (xL_plus l).1 y < x_plus_y) *
                            (forall r, x_plus_y < (xR_plus r).1 y) })
                (fun _ _ _ z w => z.1 <= w.1)
                (fun _ _ _ z w => z.1 < w.1)
                _ _ _ _ _).
      - intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR.
        pose (L'' := L + L').  pose (R'' := R + R').
        pose (zL := sum_ind (fun _ => No)
                            (fun l => (xL_plus l).1 {{ yL | yR // ycut }})
                            (fun l => (x_plus_yL l).1)
                    : L'' -> No).
        pose (zR := sum_ind (fun _ => No)
                            (fun r => (xR_plus r).1 {{ yL | yR // ycut }})
                            (fun r => (x_plus_yR r).1)
                    : R'' -> No).
        assert (zcut : forall (l:L'') (r:R''), zL l < zR r).
        { abstract (
          intros [l|l] [r|r]; cbn;
          [ apply xL_lt_xR_plus
          | transitivity ((xL_plus l).1 (yR r));
            [ apply (snd (xL_plus l).2), lt_ropt; exact _
            | exact (fst (x_plus_yR r).2 l) ]
          | transitivity ((xR_plus r).1 (yL l));
            [ exact (snd (x_plus_yL l).2 r)
            | apply (snd (xR_plus r).2), lt_lopt; exact _ ]
          | apply x_plus_yL_lt_yR ]). }
        assert (InSort S L'' R'') by (apply sum_options; exact _).
        exists ({{ zL | zR // zcut }}); split.
        + intros l.
          refine (lt_lopt zL zR zcut (inl l)).
        + intros r.
          refine (lt_ropt zL zR zcut (inl r)).
      - abstract (
        intros x y [a ?] [b ?] p q r s;
        rewrite transport_sigma; cbn in *;
        apply path_sigma_hprop, path_No; cbn;
        rewrite transport_const; assumption).
      - abstract (
        intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR
               L'' R'' ? zL zR zcut x_plus_zL x_plus_zR x_plus_zL_lt_zR
               yL_lt_z x_plus_yL_lt_z y_lt_zR x_plus_y_lt_zR;
        cbn in *;
        apply le_lr; [ intros [l|l] | intros [r|r] ]; cbn;
        [ refine (le_lt_trans (fst (xL_plus l).2 _ {{ zL | zR // zcut}} _) _);
          [ by (apply le_lr; assumption)
          | refine (lt_lopt _ _ _ (inl l)) ]
        | exact (x_plus_yL_lt_z l)
        | refine (lt_le_trans _
                    (fst (xR_plus r).2 {{ yL | yR // ycut}} _ _));
          [ refine (lt_ropt _ _ _ (inl r))
          | by (apply le_lr; assumption) ]
        | exact (x_plus_y_lt_zR r) ] ).
      - abstract (
        intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR
               L'' R'' ? zL zR zcut x_plus_zL x_plus_zR x_plus_zL_lt_zR
               l y_le_zL x_plus_y_le_zL; cbn;
        apply lt_l with (inr l);
        apply x_plus_y_le_zL ).
      - abstract (
        intros L' R' ? yL yR ycut x_plus_yL x_plus_yR x_plus_yL_lt_yR
               L'' R'' ? zL zR zcut x_plus_zL x_plus_zR x_plus_zL_lt_zR
               r yR_le_z x_plus_yR_le_z; cbn;
        apply lt_r with (inr r);
        apply x_plus_yR_le_z).
    Defined.

    (** We now prove a computation law for [plus_inner].  It holds definitionally, so we would like to prove it with just [:= 1] and then rewrite along it later, as we did above.  However, there is a subtlety in that the output should be a surreal defined by a cut, which in particular includes a proof of cut-ness, and that proof is rather long, so we would not like to see it in the type of this lemma.  Thus, instead we assert only that there *exists* some proof of cut-ness and an equality. *)
    Definition plus_inner_cut
               {L' R' : Type@{i} } {Sy : InSort@{i} S L' R'}
               (yL : L' -> No) (yR : R' -> No)
               (ycut : forall (l : L') (r : R'), yL l < yR r)
    : let L'' := L + L' in
      let R'' := R + R' in
      let zL := sum_ind (fun _ => No)
                        (fun l => (xL_plus l).1 {{ yL | yR // ycut }})
                        (fun l => (plus_inner.1 (yL l)).1)
                : L'' -> No in
      let zR := sum_ind (fun _ => No)
                        (fun r => (xR_plus r).1 {{ yL | yR // ycut }})
                        (fun r => (plus_inner.1 (yR r)).1)
                : R'' -> No in
      let Sz := sum_options L R L' R' _ _ in
      { zcut : forall (l:L'') (r:R''), zL l < zR r &
        (plus_inner.1 {{ yL | yR // ycut }}).1 = (@No_cut _ _ _ Sz zL zR zcut) }.
    Proof.
      (** Now we tell Coq that we want the equality to be definitional, and let it figure out what the proof of cut-ness has to be. *)
      eexists.
      (** Adding [rel_hnf] here speeds things up considerably, possibly because it puts the terms in a form where the evar can be instantiated without unfolding or reduction, preventing backtracking across the evar instantiation. *)
      rel_hnf. reflexivity.
    Qed.

  End Inner.

  Definition plus_outer
  : { f : No -> { g : No -> No &
                  (forall x y, x <= y -> g x <= g y) *
                  (forall x y, x <  y -> g x <  g y) } &
      (forall x y, x <= y -> forall z, (f x).1 z <= (f y).1 z) *
      (forall x y, x <  y -> forall z, (f x).1 z <  (f y).1 z) }.
  Proof.
    refine (No_rec_package
              {g : No -> No &
                (forall x y, x <= y -> g x <= g y) *
                (forall x y, x <  y -> g x <  g y) }
              (fun g h => forall x, g.1 x <= h.1 x)
              (fun g h => forall x, g.1 x <  h.1 x)
              (fun L R Sx xL xR xcut xL_plus xR_plus xL_lt_xR_plus =>
                 let g := plus_inner xL_plus xR_plus xL_lt_xR_plus in
                 ((fun y => (g.1 y).1) ; (g.2)))
               _ _ _ _).
    - abstract (
      intros [g ?] [h ?] p q;
      apply path_sigma_hprop; cbn in *;
      apply path_arrow; intros x;
      apply path_No; [ apply p | apply q ] ).
    - abstract (
      intros L R ? xL xR xcut xL_plus xR_plus xL_lt_xR_plus
           L' R' ? yL yR ycut yL_plus yR_plus yL_lt_yR_plus;
      intros xL_lt_y xL_lt_y_plus x_lt_yR x_lt_yR_plus z;
      lazy beta zeta in *; cbn [pr1] in *;
      pattern z; refine (No_ind_hprop _ _ z);
      intros L'' R'' ? zL zR zcut x_le_y_plus_zL x_le_y_plus_zR;
      destruct (plus_inner_cut xL_plus xR_plus xL_lt_xR_plus
                               zL zR zcut) as [xzcut p]; rewrite p;
      destruct (plus_inner_cut yL_plus yR_plus yL_lt_yR_plus
                               zL zR zcut) as [yzcut q];rewrite q;
      apply le_lr; [ intros [l|l] | intros [r|r] ];
      [ (** x^L + z < y + z *)
        specialize (xL_lt_y_plus l {{ zL | zR // zcut }});
        rewrite q in xL_lt_y_plus;
        exact xL_lt_y_plus
      | (** x + z^L < y + z *)
        refine (le_lt_trans (x_le_y_plus_zL l) _);
        refine (lt_lopt _ _ _ (inr l))
      | (** x + z < y^R + z *)
        specialize (x_lt_yR_plus r {{ zL | zR // zcut }});
        rewrite p in x_lt_yR_plus;
        exact x_lt_yR_plus
      | (** x + z < y + z^R *)
        refine (lt_le_trans _ (x_le_y_plus_zR r));
        refine (lt_ropt _ _ _ (inr r)) ]).
    - abstract (
      intros L R ? xL xR xcut xL_plus xR_plus xL_lt_xR_plus
             L' R' ? yL yR ycut yL_plus yR_plus yL_lt_yR_plus;
      intros l x_le_yL x_le_yL_plus z;
      lazy beta zeta in *; cbn [pr1] in *;
      pattern z; refine (No_ind_hprop _ _ z);
      intros L'' R'' ? zL zR zcut x_le_y_plus_zL x_le_y_plus_zR;
      destruct (plus_inner_cut xL_plus xR_plus xL_lt_xR_plus
                               zL zR zcut) as [xzcut p]; rewrite p;
      destruct (plus_inner_cut yL_plus yR_plus yL_lt_yR_plus
                               zL zR zcut) as [yzcut q];rewrite q;
      refine (le_lt_trans (x_le_yL_plus {{ zL | zR // zcut }}) _);
      refine (lt_lopt _ _ _ (inl l)) ).
    - abstract (
      intros L R ? xL xR xcut xL_plus xR_plus xL_lt_xR_plus
             L' R' ? yL yR ycut yL_plus yR_plus yL_lt_yR_plus;
      intros r xR_le_y xR_le_y_plus z;
      lazy beta zeta in *; cbn [pr1] in *;
      pattern z; refine (No_ind_hprop _ _ z);
      intros L'' R'' ? zL zR zcut x_le_y_plus_zL x_le_y_plus_zR;
      destruct (plus_inner_cut xL_plus xR_plus xL_lt_xR_plus
                               zL zR zcut) as [xzcut p]; rewrite p;
      destruct (plus_inner_cut yL_plus yR_plus yL_lt_yR_plus
                               zL zR zcut) as [yzcut q];rewrite q;
      refine (lt_le_trans _ (xR_le_y_plus {{ zL | zR // zcut }}));
      refine (lt_ropt _ _ _ (inl r)) ).
  Defined.

  Definition plus (x y : No) : No
    := (plus_outer.1 x).1 y.

  Infix "+" := plus : surreal_scope.

  Definition plus_le_l (x x' y : No) (p : x <= x')
  : (x + y) <= (x' + y)
    := fst (plus_outer.2) x x' p y.

  Definition plus_lt_l (x x' y : No) (p : x < x')
  : (x + y) < (x' + y)
    := snd (plus_outer.2) x x' p y.

  Definition plus_le_r (x y y' : No) (p : y <= y')
  : (x + y) <= (x + y')
    := fst (plus_outer.1 x).2 y y' p.

  Definition plus_lt_r (x y y' : No) (p : y < y')
  : (x + y) < (x + y')
    := snd (plus_outer.1 x).2 y y' p.

  (** See the remarks above [plus_inner_cut] to explain the type of this lemma. *)
  Definition plus_cut
             {L R : Type@{i} } {Sx : InSort@{i} S L R}
             (xL : L -> No) (xR : R -> No)
             (xcut : forall (l : L) (r : R), xL l < xR r)
             {L' R' : Type@{i} } {Sy : InSort@{i} S L' R'}
             (yL : L' -> No) (yR : R' -> No)
             (ycut : forall (l : L') (r : R'), yL l < yR r)
  : let L'' := (L + L')%type in
    let R'' := (R + R')%type in
    let x := {{ xL | xR // xcut }} in
    let y := {{ yL | yR // ycut }} in
    let zL := sum_ind (fun _ => No)
                      (fun l => (xL l) + y) (fun l => x + (yL l))
              : L'' -> No in
    let zR := sum_ind (fun _ => No)
                      (fun r => (xR r) + y) (fun r => x + (yR r))
              : R'' -> No in
    let Sz := sum_options L R L' R' _ _ in
    { zcut : forall (l:L'') (r:R''), zL l < zR r &
      x + y = @No_cut _ _ _ Sz zL zR zcut }
    := plus_inner_cut (Sx := Sx)
         (fun l => plus_outer.1 (xL l))
         (fun r => plus_outer.1 (xR r))
         (fun l r => snd plus_outer.2 (xL l) (xR r) (xcut l r))
         yL yR ycut.

  (** Because the conclusion of [plus_cut] is a sigma-type whose second component is the real equality we want to rewrite along, in order to rewrite along it we have to first destruct it.  This tactic takes care of that for us. *)
  Ltac do_plus_cut :=
    repeat match goal with
    | [ |- context ctx [ {{ ?xL | ?xR // ?xcut }} + {{ ?yL | ?yR // ?ycut }} ] ] =>
      let xycut := fresh "cut" in
      let p := fresh "p" in
      destruct (plus_cut xL xR xcut yL yR ycut) as [xycut p];
        rewrite p; clear p
    end.

  (** Conway proves the basic properties of arithmetic using "one-line proofs".  We can't quite do them in one line of Ltac, but the following tactic does help a lot.  Note that it is specific to addition.  It requires the caller to specify the equivalences along which to identify the indexing types for the options, as well as a rewriting tactic for evaluating those equivalences on constructors.  Unfortunately, it doesn't usually manage to finish the whole proof, since in general it can't guess how to use the inductive hypotheses.  It's usually fairly easy to finish all the cases it leaves over, but we do generally have to refer by name to the inductive hypotheses that were automatically named by [intros] here.  I haven't thought of a good solution to that. *)
  Local Opaque No_cut plus. (* required to make [rewrite] fail quickly *)
  Local Unset Keyed Unification. (* shaves another second or two off of [rewrite] *)
  Tactic Notation "one_line_proof" uconstr(eL) uconstr(eR) :=
    unfold No in *;
    repeat_No_ind_hprop;
    do_plus_cut;
    refine (path_No_easy _ _ _ _ eL eR _ _ _ _);
    intros;
    repeat match goal with
           | [ H : (?A + ?B)%type |- _ ] => destruct H
           end;
    repeat match goal with
           | [ |- context[@equiv_fun ?A ?B ?e ?v] ]
             => (* first check that we picked up either [eL] or [eR]; we can't use [unify] because it doesn't infer holes, and we can't Ltac-match on [eL] / [eR] because apparently matching on uconstr doesn't work when there are holes in the uconstr *)
             first [ let unif := constr:(idpath : e = eL) in idtac
                   | let unif := constr:(idpath : e = eR) in idtac ];
             (* assume that the term reduces to a constructor; use [hnf] to get that constructor *)
             let ef := constr:(@equiv_fun A B e v) in
             let ef' := (eval hnf in ef) in
             progress change ef with ef'
           end;
    repeat cbn [sum_ind];
    (* rewrite with induction hypotheses from [repeat_No_ind_hprop] and [do_plus_cut] *)
    repeat match goal with
           | [ |- ?x = ?x ] => reflexivity
           | [ |- ?a + _ = ?a + _ ] => apply ap
           | [ |- _ + ?a = _ + ?a ] => apply (ap (fun x => x + a))
           | [ e : Empty |- _ ] => elim e
           | [ IH : (forall lr, _ + _ = _) |- _ ]
             => rewrite IH; clear IH
           | [ IH : (forall lr, _ + _ = _ + _) |- _ ]
             => first [ rewrite IH | rewrite <- IH ]; clear IH
           | [ IH : (forall lr (y : GenNo _), _ + _ = _ + _) |- _ ]
             => first [ rewrite IH | rewrite <- IH ]; clear IH
           | [ IH : (forall lr (y z : GenNo _), _ + _ = _ + _) |- _ ]
             => first [ rewrite IH | rewrite <- IH ]; clear IH
           end.

  (** At last we are ready to prove that the surreal numbers are a commutative monoid under addition. *)

  Theorem plus_comm (x y : No) : x + y = y + x.
  Proof.
    one_line_proof (equiv_sum_symm _ _) (equiv_sum_symm _ _).
  Defined.

  Theorem plus_assoc (x y z : No) : (x + y) + z = x + (y + z).
  Proof.
    one_line_proof (equiv_sum_assoc _ _ _) (equiv_sum_assoc _ _ _);
      one_line_proof 1%equiv 1%equiv.
  Defined.

  Theorem plus_zero (x : No) : x + zero = x.
  Proof.
    unfold zero.
    one_line_proof (sum_empty_r _) (sum_empty_r _).
  Defined.

  Theorem zero_plus (x : No) : zero + x = x.
  Proof.
    unfold zero.
    one_line_proof (sum_empty_l _) (sum_empty_l _).
  Defined.

  (** If we also have negation, we can prove that it gives additive inverses, so that we have an abelian group. *)
  Context `{HasNegation S}.

  Definition plus_negate (x : No) : x + negate x = zero.
  Proof.
    unfold No in *;
    repeat_No_ind_hprop;
    destruct (negate_cut xL xR xcut) as [nxcut p];
    rewrite p; clear p;
    do_plus_cut.
    apply path_No.
    - apply le_lr; [ intros [l|r]; cbn [sum_ind] | intros [] ].
      + unfold zero in IHL; rewrite <- (IHL l); clear IHL.
        apply plus_lt_r.
        refine (lt_ropt _ _ _ l).
      + unfold zero in IHR; rewrite <- (IHR r); clear IHR.
        apply plus_lt_l.
        refine (lt_ropt _ _ _ r).
    - apply le_lr; [ intros [] | intros [r|l] ]; cbn [sum_ind].
      + unfold zero in IHR; rewrite <- (IHR r); clear IHR.
        apply plus_lt_r.
        refine (lt_lopt _ _ _ r).
      + unfold zero in IHL; rewrite <- (IHL l); clear IHL.
        apply plus_lt_l.
        refine (lt_lopt _ _ _ l).
  Defined.

  Definition sub (x y : No) : No := x + (negate y).

  Infix "-" := sub : surreal_scope.

End Addition.


From BY Require Export ListLemmas.
From BY Require Import Hierarchy.Definitions.
From stdpp Require Export list.

Section __.

  Context
    `{Setoid A}.

  Lemma map_seq_ext_equiv (f g : nat -> A) (n m k : nat)
        (Hequiv : forall i : nat, n <= i < m + k -> f i ≡ g (i + (m - n))%nat)
        (Hnm : n <= m) :
    map f (seq n k) ≡ map g (seq m k).
  Proof.
    generalize dependent m; generalize dependent n; induction k as [|k IHk]; intros; simpl.
    - reflexivity.
    - simpl; rewrite Hequiv by lia; replace (n + (m - n))%nat with m by lia.
      rewrite (IHk (S n) (S m)); [reflexivity| |lia].
      intros; rewrite Nat.sub_succ; apply Hequiv; lia. Qed.

  Global Instance rev_proper : Proper ((≡) ==> (≡)) (@rev A).
  Proof.
    do 2 red; induction x; intros; simpl.
    - inversion H1. reflexivity.
    - inversion H1. subst.
      simpl.
      rewrite (IHx k) .
      rewrite H4.
      reflexivity.
      assumption.
  Qed.

End __.


(* Rubik's cube. *)

From CGT Require Import A1_setup A2_lists B1_fmap B2_perm B3_word B5_print.
From CGT Require Import C3_subgroup_chain D1_word_search.

Require Import String.
Local Open Scope string_scope.

(***
:: Rubiks' cube ::

Here we implement the permutations of Rubik's cube, and show how we can solve an
instance of the cube. We use the same notation and face numbering as ruwix.com
(see the doc folder). Although central cells do not need a number (they remain
fixed), we reserve a number for them anyway for convenience (to exactly follow
the numbering given in the doc folder).
*)
Module Rubiks_cube.

(*
  \  i | j | k  /
   ┏━━━┳━━━┳━━━┓
 t ┃ a ┃ b ┃ c ┃ l
---┣━━━╋━━━╋━━━┫---
 s ┃ h ┃   ┃ d ┃ m
---┣━━━╋━━━╋━━━┫---
 r ┃ g ┃ f ┃ e ┃ n
   ┗━━━┻━━━┻━━━┛
  /  q | p | o  \
*)
Definition rotation (a b c d e f g h i j k l m n o p q r s t : positive) := [
  [a; g; e; c; a]; [b; h; f; d; b];
  [i; r; o; l; i]; [j; s; p; m; j]; [k; t; q; n; k]
].

Definition gen_names := ["e"; "U"; "L"; "F"; "R"; "B"; "D"].
Definition gen : list perm := map Cycles.pack [
  rotation 01 02 03 06 09 08 07 04   39 38 37   30 29 28   21 20 19   12 11 10;
  rotation 10 11 12 15 18 17 16 13   01 04 07   19 22 25   46 49 52   45 42 39;
  rotation 19 20 21 24 27 26 25 22   07 08 09   28 31 34   48 47 46   18 15 12;
  rotation 28 29 30 33 36 35 34 31   09 06 03   37 40 43   54 51 48   27 24 21;
  rotation 37 38 39 42 45 44 43 40   03 02 01   10 13 16   52 53 54   36 33 30;
  rotation 46 47 48 51 54 53 52 49   25 26 27   34 35 36   43 44 45   16 17 18
].

(***
:: Solving order ::

We might solve the cube in the same order as is often done by hand: first solve
the top, then the middle, and finally the bottom. It turns out that the last two
blocks cannot be permuted (I don't know if this is always the case), so we find
a chain of 18 subgroups. I call this order A.

There are some alternative orders: (B) first fix all corners and then all edges,
(C) a bitwise ordering produced by `values (union_range gen)`. It turns out that
A is better than B and C, but C is slightly better than B. Perhaps fixing all
corners first really restrains movement for solving the edges. It should also be
noted that the upper bound is _very_ sensitive to the word search parameters.
*)

Definition order := [
  (* top side in circular order *)
  01; 02; 03; 06; 09; 08; 07; 04;
  (* middle edges in circular order *)
  13; 22; 31; 40;
  (* bottom side in circular order *)
  46; 47; 48; 51; 54; 53; 52; 49
].

Definition chain := SGChain.build gen order.

(* Computing this subgroup chain takes around half a minute. *)
(* Compute SGS.save_orbits chain. *)

Definition orbits := [
  (01, 24%nat); (02, 24%nat); (03, 21%nat); (06, 22%nat);
  (09, 18%nat); (08, 20%nat); (07, 15%nat); (04, 18%nat);
  (13, 16%nat); (22, 14%nat); (31, 12%nat); (40, 10%nat);
  (46, 12%nat); (47, 08%nat); (48, 09%nat); (51, 06%nat);
  (54, 06%nat); (53, 02%nat)
].

(***
:: Number of configurations of Rubik's cube ::

Every configuration of Rubik's cube corresponds to a permutation generated by
rotations of the cube. Therefore the total number of configurations is equal to
the order of the permutation group we just defined. Using a theorem from group
theory we can compute this order as the product of all orbit lengths.
*)
Definition ord := fold_left Pos.mul (map Pos.of_nat (map snd orbits)) 1.
Compute ord.

(* Find a strong generating set. *)
Definition table := SGS.initialize orbits.
Definition sgs := SGS.fill table gen 40000 10000 20.

(***
:: Upper-bound on the length of solutions for Rubik's cube ::

Since every permutation can be factorized using a strong generating set, and
every such factorization uses one word from every row, we can compute the
maximum solution length by adding the length of the longest word in each row.

The upper bound computed from the selected subgroup chain and search parameters
is 176. This is not a very good upper bound; Rubik's cube can in general be
solved using at most 20 face turns (http://www.cube20.org/), but this result
required a specialized proof which took decades to discover.
*)
Compute
  let complete := SGS.complete sgs in
  let valid := SGS.valid sgs gen orbits in
  let word_length fw := List.length (snd fw) in
  let word_lengths := map (λ row, map word_length (values (snd row))) sgs in
  let upper_bound := sum_list (map max_list word_lengths) in
  (complete, valid, upper_bound).

End Rubiks_cube.


(* Case study of IND-CPA symmetric encryption + an authenticated channel realizes a secure channel.

   We assume a functionality, FKey, that securely broadcasts a key k to alice and bob.
   Alice wishes to communicate q messages to bob using an authenticated channel.
   The authenticated channel leaks each value to the adversary, and waits for an 'ok' message before delivering the in-flight
message.
   To do so securely, alice sends encryptions of her messages, which bob may decrypt using the shared key, k. *)

Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Ipdl.Big Pars Lib.Set Lib.Dist Ipdl.Approx.
Require Import CPA.

(* The definition of authenticated / secure network is
 given by the below definition, which is parameterized by a leakage function.
  When the network gets the i'th input, it forwards this value to the adversary using the leakage function. In an authenticated channel, the leakage is full; in a secure channel, the leakage simply is the empty bitstring, given by [tuple].

  The j'th value is delivered to bob only when the adversary inputs (ok ## j).
*)

Definition Net {chan} (q n : nat) {l : nat} (leakage : n.-bv -> l.-bv)
           (I O : q.-tuple (chan n.-bv)) (leak : q.-tuple (chan l.-bv)) (ok : q.-tuple (chan unit)) :=
  [||
       \||_(j < q) (leak ## j) ::= (x <-- Read (I ## j) ;; Ret (leakage x));
       \||_(j < q) (O ## j) ::= (_ <-- Read (ok ## j) ;; x <-- Read (I ## j) ;; Ret x)].

Definition Auth {chan} q n := @Net chan q n _ id.
Definition Sec {chan} q n := @Net chan q n _ (fun _ => [tuple]).

Definition FKey {chan} {k : nat} (genK : Dist k.-bv) (o : chan k.-bv) :=
  (o ::= (Samp genK)).

Module MultiChan (Import P : CPA).

  (* Alice's output channels are  'send ## j', which connects to the authenticated channel. Alice takes as input the channels 'i ## j', which come from the environment. *)
  Context (chan : Type -> Type).

  Definition alice (i : q.-tuple (chan msg.-bv)) (k : chan key.-bv) (send : q.-tuple (chan ctxt.-bv)) :=
    \||_(j < q) (send ## j) ::= (
                   m <-- Read (i ## j) ;; k <-- Read k ;; c <-- Samp (enc m k) ;; Ret c).

  Definition bob (recv : q.-tuple (chan ctxt.-bv)) (k : chan key.-bv) (o : q.-tuple (chan msg.-bv)) :=
    \||_(j < q) (o ## j) ::= (
             c <-- Read (recv ## j) ;; k <-- Read k ;; Ret (dec c k)).

  (* The real protocol . *)
  Definition real (i o : q.-tuple (chan msg.-bv)) (leak : q.-tuple (chan ctxt.-bv))
             (ok : q.-tuple (chan unit)) :=
    k <- new key.-bv ;;
    send <- newvec q @ ctxt.-bv ;;
    recv <- newvec q @ ctxt.-bv ;;
    pars [::
            FKey genK k ;
            alice i k send ;
            Auth q ctxt send recv leak ok;
            bob recv k o].

  (* The ideal protocol is simply the secure channel. *)
  Definition ideal (i o : q.-tuple (chan msg.-bv)) (leak : q.-tuple (chan 0.-bv)) (ok : q.-tuple (chan unit)) :=
    Sec q msg i o leak ok.

  (* The simulator receives as input the channels (leakI ## j) and (okR ## j), and must output on the channels (leakR ## j) and (okI ## j).
     It does so by generating the encryption key itself, and generating fake ciphertexts of the all-0's bitstring. By IND-CPA, these ciphertexts look like the real ones. *)

  Definition Sim (leakI : q.-tuple (chan 0.-bv)) (okI : q.-tuple (chan unit)) (leakR : q.-tuple (chan ctxt.-bv)) (okR : q.-tuple (chan unit)) :=
    k <- new key.-bv ;;
    pars [::
            k ::= (Samp genK) ;
            \||_(j < q) (leakR ## j) ::= (
                            _ <-- Read (tnth leakI j) ;; k <-- Read k ;; e <-- Samp (enc [tuple of nseq _ false] k) ;; Ret e);
            \||_(j < q) (okI ## j) ::= (x <-- Read (tnth okR j) ;; Ret x) ].

  (* We prove that the real protocol is approximately equivalent to the idel protocol connected to the simulator. *)
  Theorem MultiChan_Security i o leakR okR :
    real i o leakR okR =a_(lambda, comp_err err1 q)
 (leakI <- newvec q @ 0.-bv ;; okI <- newvec q @ unit ;; pars [:: ideal i o leakI okI; Sim leakI okI leakR okR]).

    (* First, eliminate ideal chans *)
    rewrite /ideal /Sec /Net /Sim /=.
    setoid_rewrite pars_pars; simpl.
    swap_tac 0 2.
    setoid_rewrite newPars; last by apply _.
    setoid_rewrite pars_pars; simpl.
    setoid_rewrite (New_newvec).
    swap_tac 0 3.
    swap_tac 1 2.
    setoid_rewrite pars_big_fold.
    rewrite New_newvec.
    swap_tac 0 1.
    swap_tac 1 3.
    setoid_rewrite pars_big_fold.
    symmetry.
    etrans.
    Intro => k.
    simp_all.
    apply EqRefl.

    (* Now rewrite using dec_correct *)
    symmetry.
    rewrite /real.
    etrans.

    Intro => k.
    rewrite /FKey /alice /Auth /bob /Net.
    swap_tac 0 2.
    setoid_rewrite pars_pars at 1; simpl.
    swap_tac 0 4.
    setoid_rewrite pars_big_fold at 1.
    Intro => send.
    simp_all.

    focus_tac 0.
    apply Eq_Outvec; intro.
    instantiate (1 := fun j =>
                   z <-- (x0 <-- Read (tnth send j) ;; x1 <-- Read k ;; Ret (dec x0 x1)) ;; _ <-- Read (tnth okR j) ;; Ret z).
    symmetry; simp_rxn.
    r_swap 0 2; done.
    rewrite -pars_big_fold.
    Intro => oks.
    swap_tac 0 3.
    swap_tac 1 2.
    swap_tac 3 4.
    rewrite (pars_split 3); simpl.
    swap_Outvec_at 1 0 1.
    rewrite Multi_dec_correct //=.
    rewrite -pars_cat //=.
    apply EqRefl.
    simpl.

    have h := (CPA_security i leakR).
    rewrite /CPA1 in h.
    symmetry.
    etrans.
    swap_tac 0 2.
    rewrite new_pars_pull.
    apply EqRefl.

    arewrite_inv h.
    simpl.
    apply AEq_zero.
    rewrite /CPA0.
    rewrite -new_pars_pull.
    Intro => k.
    symmetry.
    swap_tac 0 4.
    swap_tac 1 2.
    setoid_rewrite pars_big_fold.
    swap_tac 0 2.
    setoid_rewrite pars_big_fold.
    align.
    apply EqProt_big_r => x _ _.
    apply EqCongReact.
    rewrite /copy; simp_rxn.
    r_swap 0 1.
    done.

    apply EqProt_big_r => x _ _.
    apply EqCongReact.
    rewrite /copy; simp_rxn.
    r_swap 0 1.
    done.
    rewrite muln1 add_err0.
    done.
Qed.
  End MultiChan.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import SetsClass.SetsClass.
Require Import PV.Syntax.
Import Lang_SimpleWhile.
Require Import PV.DenotationalSemantics.
Import DntSem_SimpleWhile2 DntSem_SimpleWhile3 DntSem_SimpleWhile4.
Local Open Scope Z.
Local Open Scope sets.
Local Open Scope string.

(** 习题：*)
(** 下面的递归函数_[remove_skip]_定义了在程序语句中删除多余空语句的操作。*)

Fixpoint remove_skip (c: com): com :=
  match c with
  | CSeq c1 c2 =>
      match remove_skip c1, remove_skip c2 with
      | CSkip, _ => remove_skip c2
      | _, CSkip => remove_skip c1
      | _, _ => CSeq (remove_skip c1) (remove_skip c2)
      end
  | CIf e c1 c2 =>
      CIf e (remove_skip c1) (remove_skip c2)
  | CWhile e c1 =>
      CWhile e (remove_skip c1)
  | _ =>
      c
  end.

(** 下面请证明：_[remove_skip]_之后，确实不再有多余的空语句了。所谓没有空语句，
    是指不出现_[c; SKIP]_或_[SKIP; c]_这样的语句。首先定义：局部不存在多余的空语
    句。*)

Definition not_sequencing_skip (c: com): Prop :=
  match c with
  | CSeq CSkip _ => False
  | CSeq _ CSkip => False
  | _ => True
  end.

(** 其次定义语法树的所有子树中都不存在多余的空语句。*)

Fixpoint no_sequenced_skip (c: com): Prop :=
  match c with
  | CSeq c1 c2 =>
      not_sequencing_skip c /\
      no_sequenced_skip c1 /\ no_sequenced_skip c2
  | CIf e c1 c2 =>
      no_sequenced_skip c1 /\ no_sequenced_skip c2
  | CWhile e c1 =>
      no_sequenced_skip c1
  | _ =>
      True
  end.

(** 下面是需要证明的结论。*)

Theorem remove_skip_no_sequenced_skip: forall c,
  no_sequenced_skip (remove_skip c).
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 习题：*)
(** 下面我们定义一项简单的程序变换：右结合变换。例如，将_[(c1;c2);c3]_变换为
    _[c1;(c2;c3)]_。*)

(** 首先，这里定义一个辅助函数，该函数假设_[c]_与_[c0]_已经是右结合的，计算
    _[c; c0]_转换后的结果*)

Fixpoint CSeq_right_assoc (c c0: com): com :=
  match c with
  | CSeq c1 c2 => CSeq c1 (CSeq_right_assoc c2 c0)
  | _ => CSeq c c0
  end.

(** 现在，可以在_[CSeq_right_assoc]_的基础上定义右结合变换_[right_assoc]_。*)

Fixpoint right_assoc (c: com): com :=
  match c with
  | CSeq c1 c2 =>
      CSeq_right_assoc (right_assoc c1) (right_assoc c2)
  | CIf e c1 c2 =>
      CIf e (right_assoc c1) (right_assoc c2)
  | CWhile e c1 =>
      CWhile e (right_assoc c1)
  | _ =>
      c
  end.

(** 下面证明：经过右结合变换后，确实程序语句中不再有左结合的结构了。下面分为两步
    定义『无左结合结构』，即_[no_left_assoc]_。*)

Definition not_left_assoc (c: com): Prop :=
  match c with
  | CSeq (CSeq _ _) _ => False
  | _ => True
  end.

Fixpoint no_left_assoc (c: com): Prop :=
  match c with
  | CSeq c1 c2 =>
      not_left_assoc c /\
      no_left_assoc c1 /\ no_left_assoc c2
  | CIf e c1 c2 =>
      no_left_assoc c1 /\ no_left_assoc c2
  | CWhile e c1 =>
      no_left_assoc c1
  | _ =>
      True
  end.

(** 证明也需要分两步进行。请先证明关于_[CSeq_right_assoc]_的引理。*)

Lemma CSeq_right_assoc_no_left_assoc: forall c c0,
  no_left_assoc c ->
  no_left_assoc c0 ->
  no_left_assoc (CSeq_right_assoc c c0).
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 下面是需要证明的最终结论。*)

Theorem right_assoc_no_left_assoc: forall c,
  no_left_assoc (right_assoc c).
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 习题：*)
Example skip_seq_skip:
  eval_com (CSeq CSkip CSkip) == eval_com CSkip.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 习题：*)
Example inc_x_fact: forall s1 s2 n,
  eval_com (CAsgn "x" [["x" + 1]]) s1 s2 ->
  s1 "x" = n ->
  s2 "x" = n + 1.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)


Require Export Iron.Language.Simple.Exp.
Require Import Iron.Language.Simple.Ty.

(* Substitution of expressions in expressions preserves typing.
   Inductively, we must reason about performing substitutions at any
   depth, hence we must prove a property about (subst' d x2 x1) instead
   of the weaker (subst x2 x1) which assumes the substitution is taking
   place at top level. *)
Lemma subst_exp_exp_ix
 :  forall ix te x1 x2 t1 t2
 ,  get  ix te = Some t2
 -> TYPE te             x1 t1
 -> TYPE (delete ix te) x2 t2
 -> TYPE (delete ix te) (substX ix x2 x1) t1.
Proof.
 rip. gen ix te x2 t1.
 induction_type x1.

 Case "XVar".
  fbreak_nat_compare; burn.

  SCase "n > ix".
   eapply TYVar.
    destruct n; burn.
     simpl. nnat. down. apply get_delete_below. omega.

 Case "XLam".
  apply TYLam.
  rewrite delete_rewind.
  apply IHx1; burn.
Qed.

Theorem subst_exp_exp
 :  forall te x1 x2 t1 t2
 ,  TYPE (te :> t2) x1 t1
 -> TYPE te         x2 t2
 -> TYPE te (substX 0 x2 x1) t1.
Proof.
 rip. lets D: subst_exp_exp_ix 0 (te :> t2). burn.
Qed.


(** * System MALL for propositional multiplicative and additive linear logic

This file encodes the inference rules of the system MALL (two sided)
of propositional multiplicative additive linear logic.
 *)

Require Import LL.SL.FLL.Specifications.Bipoles.

(** ** Syntax *)
(* conjunction, disjunction and implication *)
Inductive MALLCon := TENSOR | PAR | WITH | OPLUS .

#[export]Instance MALLSyntax : OLSyntax:=
  {|
    OLType := nat;
    ccon := Empty_set ;
    ucon := Empty_set;
    bcon := MALLCon ;
    qcon := Empty_set
  |}.

(** ** Inference rules *)

(** *** Constants *)
Definition MALLrulesC (c:ccon) :=
  match c return ruleC with
  end.

(** *** Unary connectives *)
Definition MALLrulesU  (c:ucon) :=
  match c return ruleU with
  end.

(** *** Binary connectives *)
Definition MALLrulesB (c :bcon) :=
  match c with
  | TENSOR => {| rb_rgtBody := fun F G => MAnd (atom (up F)) (atom (up G) );
                 rb_lftBody  := fun F G => MOr (atom (down F) ) (atom (down G)) |}
  | PAR => {| rb_rgtBody := fun F G => MOr (atom (up F)) (atom (up G) );
              rb_lftBody  := fun F G => MAnd (atom (down F) ) (atom (down G)) |}
  | WITH => {| rb_rgtBody := fun F G => AAnd (atom (up F)) (atom (up G) );
                 rb_lftBody  := fun F G => AOr (atom (down F) ) (atom (down G)) |}
  | OPLUS => {| rb_rgtBody := fun F G => AOr (atom (up F)) (atom (up G) );
             rb_lftBody  := fun F G => AAnd (atom (down F) ) (atom (down G)) |}
  end.

(** *** Quantifiers *)
Definition MALLrulesQ (c :qcon) :=
  match c return ruleQ with
  end.

#[export] Instance MALLRules : OORules :=
  {|
    rulesC := MALLrulesC;
    rulesU := MALLrulesU ;
    rulesB := MALLrulesB;
    rulesQ := MALLrulesQ
  |}.


From Hammer Require Import Hammer.

Require Export Ensembles.
Require Export Constructive_sets.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Classical.
Require Export Classical_sets.

Section Sets_as_an_algebra.

Variable U : Type.

Lemma sincl_add_x :
forall (A B:Ensemble U) (x:U),
~ In U A x ->
Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.sincl_add_x".
intros A B x H' H'0; red.
lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
clear H'0; intro H'0; split.
apply incl_add_x with (x := x); tauto.
elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
intros x0 H'0.
red; intro H'2.
elim H'0; clear H'0.
rewrite <- H'2; auto with sets.
Qed.

Lemma incl_soustr_in :
forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.incl_soustr_in".
intros X x H'; red.
intros x0 H'0; elim H'0; auto with sets.
Qed.

Lemma incl_soustr :
forall (X Y:Ensemble U) (x:U),
Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.incl_soustr".
intros X Y x H'; red.
intros x0 H'0; elim H'0.
intros H'1 H'2.
apply Subtract_intro; auto with sets.
Qed.

Lemma incl_soustr_add_l :
forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.incl_soustr_add_l".
intros X x; red.
intros x0 H'; elim H'; auto with sets.
intro H'0; elim H'0; auto with sets.
intros t H'1 H'2; elim H'2; auto with sets.
Qed.

Lemma incl_soustr_add_r :
forall (X:Ensemble U) (x:U),
~ In U X x -> Included U X (Subtract U (Add U X x) x).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.incl_soustr_add_r".
intros X x H'; red.
intros x0 H'0; try assumption.
apply Subtract_intro; auto with sets.
red; intro H'1; apply H'; rewrite H'1; auto with sets.
Qed.
Hint Resolve incl_soustr_add_r: sets.

Lemma add_soustr_2 :
forall (X:Ensemble U) (x:U),
In U X x -> Included U X (Add U (Subtract U X x) x).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.add_soustr_2".
intros X x H'; red.
intros x0 H'0; try assumption.
elim (classic (x = x0)); intro K; auto with sets.
elim K; auto with sets.
Qed.

Lemma add_soustr_1 :
forall (X:Ensemble U) (x:U),
In U X x -> Included U (Add U (Subtract U X x) x) X.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.add_soustr_1".
intros X x H'; red.
intros x0 H'0; elim H'0; auto with sets.
intros y H'1; elim H'1; auto with sets.
intros t H'1; try assumption.
rewrite <- (Singleton_inv U x t); auto with sets.
Qed.

Lemma add_soustr_xy :
forall (X:Ensemble U) (x y:U),
x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.add_soustr_xy".
intros X x y H'; apply Extensionality_Ensembles.
split; red.
intros x0 H'0; elim H'0; auto with sets.
intro H'1; elim H'1.
intros u H'2 H'3; try assumption.
apply Add_intro1.
apply Subtract_intro; auto with sets.
intros t H'2 H'3; try assumption.
elim (Singleton_inv U x t); auto with sets.
intros u H'2; try assumption.
elim (Add_inv U (Subtract U X y) x u); auto with sets.
intro H'0; elim H'0; auto with sets.
intro H'0; rewrite <- H'0; auto with sets.
Qed.

Lemma incl_st_add_soustr :
forall (X Y:Ensemble U) (x:U),
~ In U X x ->
Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.incl_st_add_soustr".
intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets.
split.
elim H'0.
intros H'1 H'2.
generalize (Inclusion_is_transitive U).
intro H'4; red in H'4.
apply H'4 with (y := Y); auto using add_soustr_2 with sets.
red in H'0.
elim H'0; intros H'1 H'2; try exact H'1; clear H'0.
red; intro H'0; apply H'2.
rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
Qed.

Lemma Sub_Add_new :
forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.Sub_Add_new".
auto using incl_soustr_add_l with sets.
Qed.

Lemma Simplify_add :
forall (X X0:Ensemble U) (x:U),
~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.Simplify_add".
intros X X0 x H' H'0 H'1; try assumption.
rewrite (Sub_Add_new X x); auto with sets.
rewrite (Sub_Add_new X0 x); auto with sets.
rewrite H'1; auto with sets.
Qed.

Lemma Included_Add :
forall (X A:Ensemble U) (x:U),
Included U X (Add U A x) ->
Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.Included_Add".
intros X A x H'0; try assumption.
elim (classic (In U X x)).
intro H'1; right; try assumption.
exists (Subtract U X x).
split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
red in H'0.
red.
intros x0 H'2; try assumption.
lapply (Subtract_inv U X x x0); auto with sets.
intro H'3; elim H'3; intros K K'; clear H'3.
lapply (H'0 x0); auto with sets.
intro H'3; try assumption.
lapply (Add_inv U A x x0); auto with sets.
intro H'4; elim H'4;
[ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
elim K'; auto with sets.
intro H'1; left; try assumption.
red in H'0.
red.
intros x0 H'2; try assumption.
lapply (H'0 x0); auto with sets.
intro H'3; try assumption.
lapply (Add_inv U A x x0); auto with sets.
intro H'4; elim H'4;
[ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
absurd (In U X x0); auto with sets.
rewrite <- H'5; auto with sets.
Qed.

Lemma setcover_inv :
forall A x y:Ensemble U,
covers (Ensemble U) (Power_set_PO U A) y x ->
Strict_Included U x y /\
(forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.setcover_inv".
intros A x y H'; elim H'.
unfold Strict_Rel_of; simpl.
intros H'0 H'1; split; [ auto with sets | idtac ].
intros z H'2 H'3; try assumption.
elim (classic (x = z)); auto with sets.
intro H'4; right; try assumption.
elim (classic (z = y)); auto with sets.
intro H'5; try assumption.
elim H'1.
exists z; auto with sets.
Qed.

Theorem Add_covers :
forall A a:Ensemble U,
Included U a A ->
forall x:U,
In U A x ->
~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.Add_covers".
intros A a H' x H'0 H'1; try assumption.
apply setcover_intro; auto with sets.
red.
split; [ idtac | red; intro H'2; try exact H'2 ]; auto with sets.
apply H'1.
rewrite H'2; auto with sets.
red; intro H'2; elim H'2; clear H'2.
intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
intros x0 H'2; elim H'2.
intros H'5 H'6; try assumption.
generalize H'4; intro K.
red in H'4.
elim H'4; intros H'8 H'9; red in H'8; clear H'4.
lapply (H'8 x0); auto with sets.
intro H'7; try assumption.
elim (Add_inv U a x x0); auto with sets.
intro H'15.
cut (Included U (Add U a x) z).
intro H'10; try assumption.
red in K.
elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
rewrite H'15.
red.
intros x1 H'10; elim H'10; auto with sets.
intros x2 H'11; elim H'11; auto with sets.
Qed.

Theorem covers_Add :
forall A a a':Ensemble U,
Included U a A ->
Included U a' A ->
covers (Ensemble U) (Power_set_PO U A) a' a ->
exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.covers_Add".
intros A a a' H' H'0 H'1; try assumption.
elim (setcover_inv A a a'); auto with sets.
intros H'6 H'7.
clear H'1.
elim (Strict_Included_inv U a a'); auto with sets.
intros H'5 H'8; elim H'8.
intros x H'1; elim H'1.
intros H'2 H'3; try assumption.
exists x.
split; [ try assumption | idtac ].
clear H'8 H'1.
elim (H'7 (Add U a x)); auto with sets.
intro H'1.
absurd (a = Add U a x); auto with sets.
red; intro H'8; try exact H'8.
apply H'3.
rewrite H'8; auto with sets.
auto with sets.
red.
intros x0 H'1; elim H'1; auto with sets.
intros x1 H'8; elim H'8; auto with sets.
split; [ idtac | try assumption ].
red in H'0; auto with sets.
Qed.

Theorem covers_is_Add :
forall A a a':Ensemble U,
Included U a A ->
Included U a' A ->
(covers (Ensemble U) (Power_set_PO U A) a' a <->
(exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.covers_is_Add".
intros A a a' H' H'0; split; intro K.
apply covers_Add with (A := A); auto with sets.
elim K.
intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
apply Add_covers; intuition.
Qed.

Theorem Singleton_atomic :
forall (x:U) (A:Ensemble U),
In U A x ->
covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.Singleton_atomic".
intros x A H'.
rewrite <- (Empty_set_zero' U x).
apply Add_covers; auto with sets.
Qed.

Lemma less_than_singleton :
forall (X:Ensemble U) (x:U),
Strict_Included U X (Singleton U x) -> X = Empty_set U.
Proof. hammer_hook "Powerset_Classical_facts" "Powerset_Classical_facts.less_than_singleton".
intros X x H'; try assumption.
red in H'.
lapply (Singleton_atomic x (Full_set U));
[ intro H'2; try exact H'2 | apply Full_intro ].
elim H'; intros H'0 H'1; try exact H'1; clear H'.
elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
[ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
auto with sets.
elim H'1; auto with sets.
Qed.

End Sets_as_an_algebra.

Hint Resolve incl_soustr_in: sets.
Hint Resolve incl_soustr: sets.
Hint Resolve incl_soustr_add_l: sets.
Hint Resolve incl_soustr_add_r: sets.
Hint Resolve add_soustr_1 add_soustr_2: sets.
Hint Resolve add_soustr_xy: sets.


Require Import ExtLib.Data.Prop.
Require Import MirrorCore.OpenT.

Section quants.
  Context {typ : Set}.
  Variable typD : typ -> Type@{Urefl}.

  Fixpoint _foralls (ls : list typ)
  : (OpenT typD ls Prop) -> Prop :=
    match ls as ls return (OpenT typD ls Prop) -> Prop with
      | nil => fun P => P HList.Hnil
      | l :: ls => fun P => forall x : typD l,
                              _foralls ls (fun z => P (HList.Hcons x z))
    end.

  Fixpoint _exists (ls : list typ)
  : (OpenT typD ls Prop) -> Prop :=
    match ls as ls return (OpenT typD ls Prop) -> Prop with
      | nil => fun P => P HList.Hnil
      | l :: ls => fun P => exists x : typD l,
                              _exists ls (fun z => P (HList.Hcons x z))
    end.

  Fixpoint _impls (ls : list Prop) (P : Prop) :=
    match ls with
      | nil => P
      | l :: ls => l -> _impls ls P
    end.

  Section _and.
    Context {A B : Type}.
    Variables (a : A) (b : B).
    Fixpoint _and (ls : list (A -> B -> Prop)) :=
      match ls with
        | nil => True
        | l :: nil => l a b
        | l :: ls => l a b /\ _and ls
      end.
  End _and.

  Lemma _impls_sem
  : forall ls P,
      _impls ls P <-> (Forall (fun x => x) ls -> P).
  Proof.
    induction ls; simpl; intros.
    + intuition.
    + rewrite IHls. intuition.
      inversion H0. eapply H; eauto.
  Qed.
  Lemma _exists_iff
  : forall ls P Q,
      (forall x, P x <-> Q x) ->
      (@_exists ls P <-> @_exists ls Q).
  Proof.
    clear.
    induction ls; simpl; intros.
    + eapply H.
    + apply exists_iff; intro. eapply IHls.
      intro; eapply H.
  Qed.
  Lemma _forall_iff
  : forall ls P Q,
      (forall x, P x <-> Q x) ->
      (@_foralls ls P <-> @_foralls ls Q).
  Proof.
    clear.
    induction ls; simpl; intros.
    + eapply H.
    + apply forall_iff; intro. eapply IHls.
      intro; eapply H.
  Qed.

  Lemma _exists_sem
  : forall ls P,
      _exists ls P <-> exists x, P x.
  Proof.
    clear. induction ls; simpl; auto.
    - intuition. exists HList.Hnil. auto.
      destruct H. rewrite (HList.hlist_eta x) in H.
      assumption.
    - intros. split.
      + destruct 1.
        eapply IHls in H.
        destruct H. eauto.
      + destruct 1.
        exists (HList.hlist_hd x).
        eapply IHls.
        exists (HList.hlist_tl x).
        rewrite (HList.hlist_eta x) in H.
        assumption.
  Qed.
  Lemma _forall_sem
  : forall ls P,
      _foralls ls P <-> forall x, P x.
  Proof.
    clear. induction ls; simpl; auto.
    - intuition. rewrite (HList.hlist_eta x).
      assumption.
    - intros. split.
      + intros.
        rewrite (HList.hlist_eta x).
        eapply IHls in H.
        eapply H.
      + intros.
        eapply IHls.
        intros. eapply H.
  Qed.
End quants.


(** printing \2/ $\cup$ #∪# *)
(** printing <2= $\subseteq$ #⊆# *)
(** printing forall $\forall$ #∀# *)
(** printing -> $\rightarrow$ #→# *)
(** printing /\ $\land$ #∧# *)

Require Import Setoid Program.
Print LoadPath.
From Paco Require Import paco.

Section safety_equivalence.

  Context
  ( X Y:Type)
  ( halted: X -> Y -> Prop)
  ( int_step: X -> Y -> Y -> Prop)
  ( ext_step: X -> Y -> X -> Y -> Prop)
  ( valid: X -> Y -> Prop).

  Axiom determinism:
    forall x y y',
      valid x y  -> int_step x y y' ->
      forall x',
        valid x' y -> int_step x' y y'.

  Axiom valid_step:
    forall x y y',
      valid x y  -> int_step x y y' ->
      valid x y'.

  Section explicit_safety.

    (** *Normal explicit safety *)
    CoInductive exp_safety (x:X) (y:Y): Prop:=
    | halted_safety : halted x y -> exp_safety x y
    | internal_safety y': int_step x y y'  ->
                          (forall x',  valid x' y' -> exp_safety x' y') ->
                          exp_safety x y
    | external_safety x' y': ext_step x y x' y' ->
                             (forall x',  valid x' y' -> exp_safety x' y') ->
                             exp_safety x y.

    (*Parametrized version*)
    Inductive exp_safety_gen {_exp_safety} (x:X) (y:Y): Prop:=
    | paco_halted_safety : halted x y -> exp_safety_gen x y
    | paco_internal_safety y': int_step x y y'  ->
                               (forall x',  valid x' y' -> _exp_safety x' y') ->
                               exp_safety_gen x y
    | paco_external_safety x' y': ext_step x y x' y' ->
                                  (forall x',  valid x' y' -> _exp_safety x' y') ->
                                  exp_safety_gen x y.
    Definition paco_exp_safety := paco2 (@exp_safety_gen).

    (*Show that the paco representation is correct. *)
    Lemma exp_safety_paco_correct:
      forall x y, exp_safety x y <-> paco_exp_safety bot2 x y.
    Proof.
      intros x y; split; generalize x y; clear x y.
      - pcofix CO; intros x y HH.
        pfold. inversion HH;
          [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto ]; intros x'' VAL'.
      - cofix CO. intros x y HH.
        inversion HH; inversion paco_observe;
          inversion SIM;
          [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto ]; intros x'' VAL'; eapply CO.
        + specialize (LE _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
        + specialize (LE _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
    Qed.

  End explicit_safety.

  Section explicit_safetyN.
    Inductive stepN x y y': nat -> Prop :=
    | trivial_step: y = y' -> stepN x y y' 0
    | _stepN n _y: int_step x y _y -> stepN x _y y' n -> stepN x y y' (S n).

    (** *Safety with stepN *)
    Inductive exp_safetyN_gen {_exp_safety} (x:X) (y:Y): Prop:=
    | paco_halted_safetyN : halted x y -> exp_safetyN_gen x y
    | paco_internal_safetyN y' n: stepN x y y' (S n)  ->
                                  (forall x',  valid x' y' -> _exp_safety x' y') ->
                                  exp_safetyN_gen x y
    | paco_external_safetyN x' y': ext_step x y x' y' ->
                                   (forall x',  valid x' y' -> _exp_safety x' y') ->
                                   exp_safetyN_gen x y.
    Definition paco_exp_safetyN := paco2 (@exp_safetyN_gen).

    Lemma determinismN:
      forall n,
      forall x y y',
        valid x y  -> stepN x y y' n ->
        forall x',
          valid x' y -> stepN x' y y' n.
    Proof. induction n.
           - intros; econstructor.
             inversion H0; assumption.
           - intros.
             inversion H0; subst.
             econstructor.
             eapply (determinism x y _y); eauto.
             eapply IHn; eauto.
             eapply valid_step; eauto.
             eapply valid_step; eauto.
             eapply (determinism x y _y); eauto.
    Qed.

    Lemma valid_stepN:
      forall n,
      forall x y y',
        valid x y  -> stepN x y y' n ->
        valid x y'.
    Proof. induction n; intros ? ? ? VAL HH; inversion HH; subst.
           - exact VAL.
           - apply (IHn _ _y); try assumption.
             apply (valid_step x y _y VAL H0).
    Qed.

    Lemma safetyN_equivalence:
      forall x y,
        valid x y ->
        paco_exp_safety bot2 x y <-> paco_exp_safetyN bot2 x y.
    Proof.
      intros x y VAL.
      split; generalize x y VAL; clear VAL x y.
      - pcofix CO.
        intros x y VAL HH.
        inversion HH; inversion paco_observe.
        inversion SIM; subst; clear SIM.
        + pfold.
          econstructor 1; eassumption.
        + pfold.
          econstructor 2. apply (_stepN x y y' 0 y'); auto.
          constructor; reflexivity.
          intros x' AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
        + pfold.
          econstructor 3. eauto.
          intros x'0 AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
      - pcofix CO.
        intros x y VAL HH; inversion HH; clear HH.
        inversion paco_observe; inversion SIM; subst; clear paco_observe SIM.
        + pfold.
          econstructor 1; eassumption.
        + cut (valid x y').
          { intros VAL'.
            assert (LE':= LE).
            specialize (LE _ (H0 _ VAL')).
            destruct LE. 2: compute in *; tauto.
            generalize dependent y; generalize x.
            induction n.
            * (*base case*)
              intros ? ? VAL H. inversion H. inversion H4; subst; clear H H4.
              pfold. econstructor 2. eassumption.
              intros x' AA.
              right.
              eapply CO; try assumption.
              specialize (LE' _ (H0 _ AA)).
              destruct LE'; [ | compute in *; tauto].
              unfold paco_exp_safetyN.
              apply H.
            * (*inductive step*)
              intros. inversion H; subst; clear H.
              pfold; econstructor 2; eauto.
              intros.
              unfold upaco2.
              left; eapply IHn; eauto.
              eapply (determinismN _ x0 _y y' ) with (x'0:= x'); eauto.
              eapply valid_step; eauto.
          }
          { (*Prove the cut*)
            eapply valid_stepN; eauto.
          }
        + pfold.
          econstructor 3. eauto.
          intros x'0 AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
    Qed.

  End explicit_safetyN.

  Section explicit_safetyN_stutter.

  Context {core_data: Type}
          {core_ord : core_data -> core_data -> Prop}
          (core_ord_wf: well_founded core_ord).

  (** *Safety with Stutter and stepN*)
  CoInductive exp_safetyN_stutter (cd:core_data) (x:X) (y:Y): Prop:=
  | halted_safetyN_stut : halted x y -> exp_safetyN_stutter cd x y
  | internal_safetyN_stut cd' y' n: stepN x y y' (S n)  ->
                            (forall x',  valid x' y' -> exp_safetyN_stutter cd' x' y') ->
                            exp_safetyN_stutter cd x y
  | external_safetyN_stut cd' x' y': ext_step x y x' y' ->
                            (forall x',  valid x' y' -> exp_safetyN_stutter cd' x' y') ->
                            exp_safetyN_stutter cd x y
  | stutter cd': core_ord cd' cd ->
                 exp_safetyN_stutter cd' x y ->
                 exp_safetyN_stutter cd x y.

  (*Paco version*)
  Inductive exp_safetyN_stutter_gen {_exp_safety} (cd:core_data) (x:X) (y:Y): Prop:=
  | paco_halted_safetyN_stut : halted x y -> exp_safetyN_stutter_gen cd x y
  | paco_internal_safetyN_stut cd' y' n: stepN x y y' (S n)  ->
                            (forall x',  valid x' y' -> _exp_safety cd' x' y') ->
                            exp_safetyN_stutter_gen cd x y
  | paco_external_safetyN_stut cd' x' y': ext_step x y x' y' ->
                            (forall x',  valid x' y' -> _exp_safety cd' x' y') ->
                            exp_safetyN_stutter_gen cd x y
  | paco_stutter cd': core_ord cd' cd ->
                 _exp_safety cd' x y ->
                 exp_safetyN_stutter_gen cd x y.
  Definition paco_exp_safetyN_stutter := paco3 (@exp_safetyN_stutter_gen).

  (*Show that the paco representation is correct. *)
  Lemma exp_safetyN_stutter_paco_correct:
    forall cd x y, exp_safetyN_stutter cd x y <-> paco_exp_safetyN_stutter bot3 cd x y.
  Proof.
    intros cd x y; split; generalize cd x y; clear cd x y.
    - pcofix CO; intros cd x y HH.
      pfold. inversion HH;
        [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto |
            econstructor 4; eauto ].
    - cofix CO; intros cd x y HH.
      inversion HH. inversion paco_observe; inversion SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |
          econstructor 4; eauto ].
      + intros x'' VAL'; eapply CO.
        specialize (LE _ (H0 _ VAL')).
        destruct LE. 2: compute in *; tauto.
        constructor; apply H1.
      + intros x'' VAL'; eapply CO.
        specialize (LE _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          constructor; apply H1.
      + eapply CO .
        specialize (LE _ (H0)).
        destruct LE. 2: compute in *; tauto.
        constructor; apply H1.
  Qed.

  (*The stutter doesn't matter*)
  Lemma speach_therapy:
    forall cd x y,
      paco_exp_safetyN bot2 x y <->
      paco_exp_safetyN_stutter bot3 cd x y.
  Proof.
    intros cd x y.
    split; generalize cd x y; clear cd x y.
    - pcofix CO.
      intros cd x y HH.
      inversion HH; subst; clear HH.
      pfold.
      inversion paco_observe; inversion SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto ]; intros x0 VAL'.
      + specialize (LE _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. apply CO. eapply H1.

      + specialize (LE _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. apply CO. eapply H1.
    - pcofix CO.
      intros cd x y HH; pfold.
      generalize cd x y HH; clear HH y x cd.
      (*set up the well formed induction*)
      apply (@well_founded_ind _ core_ord core_ord_wf
                               (fun cd => forall (x : X) (y : Y),
                                      paco_exp_safetyN_stutter bot3 cd x y ->
                                      exp_safetyN_gen x y)); auto.

      (*now do the cofixpoint induction*)

      intros x wf_ind x' y HH; inversion HH; subst; clear HH.
      inversion paco_observe; inversion SIM; clear paco_observe SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |].
      + intros x0 VAL'. specialize (LE _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco2. right. eapply CO. constructor; eapply H1.
      + intros x0 VAL'. specialize (LE _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco2. right. eapply CO. constructor; eapply H1.
      + eapply wf_ind in H; [ exact H|].
        pfold. specialize (LE _ (H0)).
        destruct LE; [| compute in *; tauto].
        simpl in H1.

        clear - H1.
        match goal with
          [H1: ?P ?AA ?BB ?CC |- _ ] =>
          pose (curry3 (P AA BB))
        end.

        (* there must be e problem, where soemthing is unfolded too much.
           pacon.paco shouldn't be exposed.
         *)
        eassert (HH1: @paco3
                  core_data (fun _ : core_data => X) (fun (_ : core_data) (_ : X) => Y)
                  (fun R0 =>
                     @exp_safetyN_stutter_gen
                       R0
                  )
                  bot3
                  cd' ((fun _ => x') cd') ((fun _ _ => y) cd' _)
                ).
        { eapply H1. }
        punfold HH1.

        (*punfold H1.*)
        {
          clear.

          unfold monotone3.
          intros ? **.
          inversion IN;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |
          econstructor 4; eauto ].
        }
        Grab Existential Variables.
        all: eauto.
  Qed.
  End explicit_safetyN_stutter.

  Section The_Equivalence.

  Context (core_data: Type)
          (core_ord : core_data -> core_data -> Prop)
          (core_ord_wf: well_founded core_ord)
          (default: core_data).

  Theorem safety_stutter_stepN_equiv:
    forall x y,
      valid x y ->
      exp_safety x y <-> exists cd, @exp_safetyN_stutter _ core_ord cd x y.
  Proof.
    intros x y VAL; split; intros HH.
    - exists default.
      apply exp_safetyN_stutter_paco_correct.
      apply speach_therapy; [assumption|].
      apply safetyN_equivalence; [assumption|].
      apply exp_safety_paco_correct; assumption.
    - destruct HH as [cd HH].
      apply exp_safety_paco_correct.
      apply safetyN_equivalence; [assumption|].
      eapply speach_therapy with (cd0:=cd); [eassumption|].
      apply exp_safetyN_stutter_paco_correct; assumption.
  Qed.

  End The_Equivalence.

End safety_equivalence.


(*|
#######################################
How to introduce a new variable in Coq?
#######################################

:Link: https://stackoverflow.com/q/33005260
|*)

(*|
Question
********

I was wondering if there is a way to introduce an entirely new
variable during the proof of a theorem in Coq?

For a complete example, consider the following property `from here
<http://www.cis.upenn.edu/~bcpierce/sf/current/Prop.html>`__ about the
evenness of the length of a list.
|*)

Require Import List. (* .none *)
Import ListNotations. (* .none *)
Inductive ev_list {X : Type}: list X -> Prop :=
| el_nil : ev_list []
| el_cc  : forall x y l, ev_list l -> ev_list (x :: y :: l).

(*|
Now I want to prove that for any list ``l`` if its ``length`` is even,
then ``ev_list l`` holds:

.. coq:: none
|*)

Inductive ev : nat -> Prop :=
| ev_O  : ev O
| ev_SS : forall n, ev n -> ev (S (S n)).

(*||*)

Lemma ev_length__ev_list' : forall X (l : list X), ev (length l) -> ev_list l.
Proof.
  intros X l H.

(*| which gives: |*)

  Show. (* .unfold .messages *)

(*|
Now, I'd like to "define" a new free variable ``n`` and a hypothesis
``n = length l``. In hand-written math, I think we can do this, and
then do induction about ``n``. But is there a way to do the same in
Coq?

Note. the reasons I ask are that:

1. I don't want to introduce this ``n`` artificially into the
   statement of the theorem itself, as is done in the page linked
   earlier, which IMHO is unnatural.
2. I tried to ``induction H.``, but it seems not working. Coq wasn't
   able to do case analysis on ``length l``'s ``ev``-ness, and no
   induction hypothesis (IH) was generated.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

This is a common issue in Coq proofs. You can use the ``remember``
tactic:
|*)

  remember (length l) as n.

(*|
If you're doing induction on ``H`` as well, you might also have to
generalize over ``l`` beforehand, by doing
|*)

  generalize dependent l.
  induction H.

(*|
Answer (eponier)
****************

If you want to add a new variable only for your induction, you can use directly
|*)

  Restart. (* .none *) intros X l H. (* .none *)
  induction (length l) eqn:H0.
Admitted. (* .none *)

(*|
Answer (Konstantin Weitz)
*************************

According to the Curry-Howard Isomorphism, hypothesis in your context
are just variables. You can define new variables with a function. The
following ``refine`` tactic extends the goal with a fresh variable
``n`` (that is set to ``length l``) and a proof ``e`` that ``n =
length l`` (that is set to ``eq_refl``).
|*)

Reset ev_length__ev_list'. (* .none *)
Lemma ev_length__ev_list' : forall X (l : list X), ev (length l) -> ev_list l.
Proof.
  intros X l H.
  refine ((fun n (e:n = length l) => _) (length l) eq_refl).
  (* proof *)
Admitted.


Require Import HoTT.Basics HoTT.Colimits.Pushout.

(** * Pushouts of "dependent spans". *)

Section SpanPushout.
  Context {X Y : Type} (Q : X -> Y -> Type).

  Definition SPushout := @Pushout@{up _ _ up} (sig@{up _} (fun (xy : X * Y) => Q (fst xy) (snd xy))) X Y
                                  (fst o pr1) (snd o pr1).
  Definition spushl : X -> SPushout := pushl.
  Definition spushr : Y -> SPushout := pushr.
  Definition spglue {x:X} {y:Y} : Q x y -> spushl x = spushr y
    := fun q => pglue ((x,y) ; q).

  Definition SPushout_rec (R : Type)
             (spushl' : X -> R) (spushr' : Y -> R)
             (sglue' : forall x y (q : Q x y), spushl' x = spushr' y)
    : SPushout -> R.
  Proof.
    srapply (@Pushout_rec {xy:X * Y & Q (fst xy) (snd xy)} X Y
                          (fst o pr1) (snd o pr1) R spushl' spushr').
    intros [[x y] q]; cbn in *.
    apply sglue'; assumption.
  Defined.

  Definition SPushout_ind (R : SPushout -> Type)
             (spushl' : forall x, R (spushl x))
             (spushr' : forall y, R (spushr y))
             (sglue' : forall x y (q : Q x y),
                 transport R (spglue q) (spushl' x) = (spushr' y))
    : forall p, R p.
  Proof.
    srapply (@Pushout_ind {xy:X * Y & Q (fst xy) (snd xy)} X Y
                          (fst o pr1) (snd o pr1) R spushl' spushr').
    intros [[x y] q]; cbn in *.
    apply sglue'; assumption.
  Defined.

  Definition spushout_ind_beta_sglue (R : SPushout -> Type)
             (spushl' : forall x, R (spushl x))
             (spushr' : forall y, R (spushr y))
             (spglue' : forall x y (q : Q x y),
                 transport R (spglue q) (spushl' x) = (spushr' y))
             (x:X) (y:Y) (q:Q x y)
    : apD (SPushout_ind R spushl' spushr' spglue') (spglue q) = spglue'  x y q
    := Pushout_ind_beta_pglue _ _ _ _ ((x,y);q).

End SpanPushout.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(*Require Export SysPara.*)
Require Export SM3.
Require Export ECAlg.

(*5.5 trunk from right *)
(*TODO I really cannot understand its definition *)
Definition ENTL (ID : bL) :=
  NtobL_len 16 (N.of_nat (List.length (ID))).

Open Scope list.

Section signature_sec.

Context {U : Type}{fd : ECField U}.
Variable hash : bL -> bL.
Definition grp := GE fd.

Definition cop := Cop fd.

Definition ComputeZ (ENTL_A ID_A a b xG yG xA yA : bL) :=
  hash (ENTL_A ++ ID_A ++ a ++ b ++ xG ++ yG ++ xA ++ yA).

Section gml_sec.
Variable gml : grp -> N -> grp.

Definition TrySigWithk (G : grp)(n dA e k : N)
   : option (N * N) :=
  match gml G k with
  | InfO _ => None
  | Cop _ (x1, y1) =>
      let r := P_add n e (uwp x1) in
        if orb (N.eqb r 0) (N.eqb (r + k) n) then None else
        let s := P_mul n (P_inv n (P_add n 1 dA)) (P_sub n k (P_mul n r dA)) in
          if N.eqb s 0 then None else
          Some (r, s)
  end.

Fixpoint TrySigWithList (G : grp)(n dA e : N)(klist : list N) : option (N * N) :=
  match klist with
  | [] => None
  | h :: tl =>
      match TrySigWithk G n dA e h with
      | None => TrySigWithList G n dA e tl
      | Some (r, s) => Some (r, s)
      end
  end.

End gml_sec.

(* 6.1 *)
(* TODO How to generate klist? *)
Definition SigWithList (curve : ECurve)
  (nbL xGbL yGbL ENTL_A ID_A dAbL xAbL yAbL M : bL)(klist : list N)
  : option (bL * (bL * bL)) :=
  let gml :=
    match curve with
    | pf_curve a' _ _ => pf_mul a'
    (*| bf_curve a' _ _ => pf_mul a'*) (*TODO bf case*)
    end in
  let (a, b) := match curve with
    | pf_curve a' b' _ (*| bf_curve a' b' _*) => (uwp a', uwp b')
  end in
  let Z_A := ComputeZ ENTL_A ID_A (NtoBbL a) (NtoBbL b) xGbL yGbL xAbL yAbL in
  let e := bLtoN (hash (Z_A ++ M)) in
    match TrySigWithList gml (GE_wp fd (bLtoN xGbL, bLtoN yGbL))
      (bLtoN nbL) (bLtoN dAbL) e klist with
      | None => None
      | Some (r, s) => Some (M, ((NtoBbL r), (NtoBbL s)))
    end.

(*

Definition SigWithList_pf (p a b n xG yG ENTL_A ID_A dA xA yA M : bL)(klist : list N)
   : option (bL * (bL * bL)) :=
   SigWithList hash (pf_mul (bLtoN p) (bLtoN a)) a b n xG yG ENTL_A ID_A dA xA yA M klist.

Definition SigWithList_bfp (m gp : N)(a b n xG yG ENTL_A ID_A dA xA yA M : bL)(klist : list N)
   : option (bL * (bL * bL)) :=
   SigWithList hash (bfp_mul m gp (bLtoN a)) a b n xG yG ENTL_A ID_A dA xA yA M klist.

Definition SigWithZAList_bfp (m gp : N)(a b n xG yG ZA dA xA yA M : bL)(klist : list N)
   : option (bL * (bL * bL)) :=
   SigWithZAList hash (bfp_mul m gp (bLtoN a)) a b n xG yG ZA dA M klist.

*)
(* true if x \in [lower, upper] *)
Definition inRange (x lower upper : N) : bool :=
  andb (leb lower x) (leb x upper).

Open Scope N_scope.

(* None if passed, otherwise Some error message *)
Definition VeriSig_inner (gml : grp -> N -> grp)(gad : grp -> grp -> grp)
  (n xG yG xA yA r' s' : N)(Z_A M' : bL) : option string :=
  if negb (inRange r' 1 (n - 1)) then Some "r' out of range" else
  if negb (inRange s' 1 (n - 1)) then Some "s' out of range" else
  let e' := bLtoN (hash (Z_A ++ M')) in
  let t := P_add n r' s' in
  if t =? 0 then Some "t = 0" else
  let G := GE_wp fd (xG, yG) in
  let PA := GE_wp fd (xA, yA) in
  match gad (gml G s') (gml PA t) with
  | InfO _ => Some "s'G + tPA = InfO"
  | Cop _ (x1', y1') =>
      let R := P_add n e' (uwp x1') in
      if R =? r' then None else Some "R != r'"
  end.

Definition VeriSig (curve : ECurve)(n xG yG xA yA r' s' Z_A M' : bL)
 : option string :=
  let (gml, gad) :=
    match curve with
    | pf_curve a _ _ => (pf_mul a, pf_add a)
    (*| bf_curve a _ _ => (pf_mul a, pf_add a)*) (*TODO bf case*)
    end in
  VeriSig_inner gml gad (bLtoN n) (bLtoN xG) (bLtoN yG)
   (bLtoN xA) (bLtoN yA) (bLtoN r') (bLtoN s') Z_A M'.

(*
Definition VeriSig_pf (p a n xG yG xA yA : N)(r'bL s'bL Z_A M' : bL) : option string :=
  VeriSig_inner (pf_mul p a) (pf_add p a) n xG yG xA yA r'bL s'bL Z_A M'.

Definition VeriSig_bfp  (m gp a n xG yG xA yA : N)(r'bL s'bL Z_A M' : bL) : option string :=
  VeriSig hash (bfp_mul m gp a) (bfp_add m gp a) n xG yG xA yA r'bL s'bL Z_A M'.
*)
End signature_sec.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* 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.

Require Import Zquot.

(* Why3 comment *)
(* div is replaced with (ZArith.BinInt.Z.quot x x1) by the coq driver *)

(* Why3 comment *)
(* mod1 is replaced with (ZArith.BinInt.Z.rem x x1) by the coq driver *)

(* Why3 goal *)
Lemma Div_mod : forall (x:Z) (y:Z), (~ (y = 0%Z)) ->
  (x = ((y * (ZArith.BinInt.Z.quot x y))%Z + (ZArith.BinInt.Z.rem x y))%Z).
intros x y _.
apply Z.quot_rem'.
Qed.

(* Why3 goal *)
Lemma Div_bound : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  ((0%Z <= (ZArith.BinInt.Z.quot x y))%Z /\
  ((ZArith.BinInt.Z.quot x y) <= x)%Z).
intros x y (Hx,Hy).
split.
now apply Z.quot_pos.
destruct (Z_eq_dec y 1) as [H|H].
rewrite H, Z.quot_1_r.
apply Zle_refl.
destruct (Zle_lt_or_eq 0 x Hx) as [H'|H'].
apply Zlt_le_weak.
apply Z.quot_lt with (1 := H').
omega.
now rewrite <- H', Zquot_0_l.
Qed.

(* Why3 goal *)
Lemma Mod_bound : forall (x:Z) (y:Z), (~ (y = 0%Z)) ->
  (((-(ZArith.BinInt.Z.abs y))%Z < (ZArith.BinInt.Z.rem x y))%Z /\
  ((ZArith.BinInt.Z.rem x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
destruct (Zle_or_lt 0 x) as [Hx|Hx].
refine ((fun H => conj (Zlt_le_trans _ 0 _ _ (proj1 H)) (proj2 H)) _).
clear -Zy ; zify ; omega.
now apply Zrem_lt_pos.
refine ((fun H => conj (proj1 H) (Zle_lt_trans _ 0 _ (proj2 H) _)) _).
clear -Zy ; zify ; omega.
apply Zrem_lt_neg with (2 := Zy).
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma Div_sign_pos : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  (0%Z <= (ZArith.BinInt.Z.quot x y))%Z.
intros x y (Hx, Hy).
now apply Z.quot_pos.
Qed.

(* Why3 goal *)
Lemma Div_sign_neg : forall (x:Z) (y:Z), ((x <= 0%Z)%Z /\ (0%Z < y)%Z) ->
  ((ZArith.BinInt.Z.quot x y) <= 0%Z)%Z.
intros x y (Hx, Hy).
generalize (Z.quot_pos (-x) y).
rewrite Zquot_opp_l.
omega.
Qed.

(* Why3 goal *)
Lemma Mod_sign_pos : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ ~ (y = 0%Z)) ->
  (0%Z <= (ZArith.BinInt.Z.rem x y))%Z.
intros x y (Hx, Zy).
now apply Zrem_lt_pos.
Qed.

(* Why3 goal *)
Lemma Mod_sign_neg : forall (x:Z) (y:Z), ((x <= 0%Z)%Z /\ ~ (y = 0%Z)) ->
  ((ZArith.BinInt.Z.rem x y) <= 0%Z)%Z.
intros x y (Hx, Zy).
now apply Zrem_lt_neg.
Qed.

(* Why3 goal *)
Lemma Rounds_toward_zero : forall (x:Z) (y:Z), (~ (y = 0%Z)) ->
  ((ZArith.BinInt.Z.abs ((ZArith.BinInt.Z.quot x y) * y)%Z) <= (ZArith.BinInt.Z.abs x))%Z.
intros x y Zy.
rewrite Zmult_comm.
zify.
generalize (Z.mul_quot_le x y).
generalize (Z.mul_quot_ge x y).
omega.
Qed.

(* Why3 goal *)
Lemma Div_1 : forall (x:Z), ((ZArith.BinInt.Z.quot x 1%Z) = x).
exact Z.quot_1_r.
Qed.

(* Why3 goal *)
Lemma Mod_1 : forall (x:Z), ((ZArith.BinInt.Z.rem x 1%Z) = 0%Z).
exact Z.rem_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (x < y)%Z) ->
  ((ZArith.BinInt.Z.quot x y) = 0%Z).
exact Z.quot_small.
Qed.

(* Why3 goal *)
Lemma Mod_inf : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (x < y)%Z) ->
  ((ZArith.BinInt.Z.rem x y) = x).
exact Z.rem_small.
Qed.

(* Why3 goal *)
Lemma Div_mult : forall (x:Z) (y:Z) (z:Z), ((0%Z < x)%Z /\ ((0%Z <= y)%Z /\
  (0%Z <= z)%Z)) ->
  ((ZArith.BinInt.Z.quot ((x * y)%Z + z)%Z x) = (y + (ZArith.BinInt.Z.quot z x))%Z).
intros x y z (Hx&Hy&Hz).
rewrite (Zplus_comm y).
rewrite <- Z_quot_plus.
now rewrite Zplus_comm, Zmult_comm.
apply Zmult_le_0_compat with (2 := Hz).
apply Zplus_le_0_compat with (1 := Hz).
apply Zmult_le_0_compat with (1 := Hy).
now apply Zlt_le_weak.
intros H.
now rewrite H in Hx.
Qed.

(* Why3 goal *)
Lemma Mod_mult : forall (x:Z) (y:Z) (z:Z), ((0%Z < x)%Z /\ ((0%Z <= y)%Z /\
  (0%Z <= z)%Z)) ->
  ((ZArith.BinInt.Z.rem ((x * y)%Z + z)%Z x) = (ZArith.BinInt.Z.rem z x)).
intros x y z (Hx&Hy&Hz).
rewrite Zplus_comm, Zmult_comm.
apply Z_rem_plus.
apply Zmult_le_0_compat with (2 := Hz).
apply Zplus_le_0_compat with (1 := Hz).
apply Zmult_le_0_compat with (1 := Hy).
now apply Zlt_le_weak.
Qed.