Require Import Crypto.Algebra.Field.
Require Import Crypto.Algebra.ScalarMult.
Require Import Crypto.Util.Sum Crypto.Util.Prod Crypto.Util.LetIn.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.ZUtil.Peano.
Require Import Crypto.Util.Tactics.SetoidSubst.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Curves.Montgomery.Affine.
Require Import Crypto.Curves.Montgomery.AffineInstances.
Require Import Crypto.Curves.Montgomery.XZ BinPos.
Require Import Coq.Classes.Morphisms.
Require Import Coq.omega.Omega.
Require Import Coq.micromega.Lia.

Module M.
  Section MontgomeryCurve.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}
            {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 3}
            {char_ge_5:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 5}
            {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12}
            {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Notation "'∞'" := (inr tt) : core_scope.
    Local Notation "( x , y )" := (inl (pair x y)).

    Context {a b: F} {b_nonzero:b <> 0}.
    Context {a24:F} {a24_correct:(1+1+1+1)*a24 = a-(1+1)}.
    Local Notation Madd := (M.add(a:=a)(b_nonzero:=b_nonzero)(char_ge_3:=char_ge_3)).
    Local Notation Mopp := (M.opp(a:=a)(b_nonzero:=b_nonzero)).
    Local Notation Mpoint := (@M.point F Feq Fadd Fmul a b).
    Local Notation to_xz := (M.to_xz(Fzero:=Fzero)(Fone:=Fone)(Feq:=Feq)(Fadd:=Fadd)(Fmul:=Fmul)(a:=a)(b:=b)).
    Local Notation xzladderstep := (M.xzladderstep(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul)).

    (** This tactic is to solve goals that fsatz also solves, but to
        do so faster in some cases common in this file. It may also
        work around deficiencies in the Coq 8.6 (released) version of
        [nsatz]; it has some heuristics for clearing hypotheses and
        running [exfalso], and then tries [fsatz] *)
    Local Ltac maybefast :=
      try lazymatch goal with
          | [ fld : Hierarchy.field (T:=?F) (eq:=?Feq), Feq_dec : DecidableRel ?Feq |- _ ]
            => lazymatch goal with
               | [ H : ?x * 1 = ?y * ?z, H' : ?x <> 0, H'' : ?z = 0 |- _ ]
                 => clear -H H' H'' fld Feq_dec; exfalso; fsatz
               | [ H : ?x * 0 = 1 * ?y, H' : ?y <> 0 |- _ ]
                 => clear -H H' fld Feq_dec; exfalso; fsatz
               | _
                 => match goal with
                    | [ H : ?b * ?lhs = ?rhs, H' : ?b * ?lhs' = ?rhs', Heq : ?x = ?y, Hb : ?b <> 0 |- _ ]
                      => exfalso;
                         repeat match goal with H : Ring.char_ge _ |- _ => revert H end;
                         let rhs := match (eval pattern x in rhs) with ?f _ => f end in
                         let rhs' := match (eval pattern y in rhs') with ?f _ => f end in
                         unify rhs rhs';
                         match goal with
                         | [ H'' : ?x = ?Fopp ?x, H''' : ?x <> ?Fopp (?Fopp ?y) |- _ ]
                           => let lhs := match (eval pattern x in lhs) with ?f _ => f end in
                              let lhs' := match (eval pattern y in lhs') with ?f _ => f end in
                              unify lhs lhs';
                              clear -H H' Heq H'' H''' Hb fld Feq_dec; intros
                         | [ H'' : ?x <> ?Fopp ?y, H''' : ?x <> ?Fopp (?Fopp ?y) |- _ ]
                           => let lhs := match (eval pattern x in lhs) with ?f _ => f end in
                              let lhs' := match (eval pattern y in lhs') with ?f _ => f end in
                              unify lhs lhs';
                              clear -H H' Heq H'' H''' Hb fld Feq_dec; intros
                         end;
                         fsatz
                    | [ H : ?x * (?y * ?z) = 0 |- _ ]
                      => exfalso;
                         repeat match goal with
                                | [ H : ?x * 1 = ?y * ?z |- _ ]
                                  => is_var x; is_var y; is_var z;
                                     revert H
                                end;
                         generalize fld;
                         let lhs := match type of H with ?lhs = _ => lhs end in
                         repeat match goal with
                                | [ x : F |- _ ] => lazymatch type of H with
                                                    | context[x] => fail
                                                    | _ => clear dependent x
                                                    end
                                end;
                         intros _; intros;
                         fsatz
                    end
               end
          end.

    (* TODO(#152): deduplicate between curves files *)
    Ltac prept_step :=
      match goal with
      | _ => progress intros
      | _ => progress autounfold with points_as_coordinates in *
      | _ => progress destruct_head'_True
      | _ => progress destruct_head'_unit
      | _ => progress destruct_head'_prod
      | _ => progress destruct_head'_sig
      | _ => progress destruct_head'_bool
      | _ => progress destruct_head'_sum
      | _ => progress destruct_head'_and
      | _ => progress destruct_head'_or
      | H: context[dec ?P] |- _ => destruct (dec P)
      | |- context[dec ?P]      => destruct (dec P)
      | |- ?P => lazymatch type of P with Prop => split end
      end.
    Ltac prept := repeat prept_step.
    Ltac t_fast := prept; trivial; try contradiction.
    Ltac t := t_fast; maybefast; fsatz.

    Create HintDb points_as_coordinates discriminated.
    Hint Unfold Proper respectful Reflexive Symmetric Transitive : points_as_coordinates.
    Hint Unfold Let_In : points_as_coordinates.
    Hint Unfold fst snd proj1_sig : points_as_coordinates.
    Hint Unfold fieldwise fieldwise' : points_as_coordinates.
    Hint Unfold M.add M.opp M.point M.coordinates M.xzladderstep M.donnaladderstep M.boringladderstep M.to_xz : points_as_coordinates.

    Lemma donnaladderstep_same x1 Q Q' :
      fieldwise (n:=2) (fieldwise (n:=2) Feq)
                (xzladderstep x1 Q Q')
                (M.donnaladderstep(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul) x1 Q Q').
    Proof. t. Qed.

    Lemma boringladderstep_same (ap2d4:F) (ap2d4_correct:(1+1+1+1)*a24 = a+1+1) x1 Q Q' :
      fieldwise (n:=2) (fieldwise (n:=2) Feq)
                (xzladderstep x1 Q Q')
                (M.boringladderstep(ap2d4:=ap2d4)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul) x1 Q Q').
    Proof. t. Qed.

    Definition projective (P:F*F) :=
      if dec (snd P = 0) then fst P <> 0 else True.
    Definition eq (P Q:F*F) := fst P * snd Q = fst Q * snd P.
    Definition ladder_invariant x1 Q Q' :=
      match M.coordinates (Madd Q (Mopp Q')) with
      | ∞ => False                  (* Q <> Q' *)
      | (x,y) => x = x1 /\ x1 <> 0  (* Q-Q' <> (0, 0) *)
      end.
    Hint Unfold projective eq ladder_invariant : points_as_coordinates.

    Lemma to_xz_add_coordinates (x1:F) (xz x'z':F*F)
          (Hxz:projective xz) (Hz'z':projective x'z')
          (Q Q':Mpoint)
          (HQ:eq xz (to_xz Q)) (HQ':eq x'z' (to_xz Q'))
          (HI:ladder_invariant x1 Q Q')
      :  projective (snd (xzladderstep x1 xz x'z'))
      /\ eq (fst (xzladderstep x1 xz x'z')) (to_xz (Madd Q Q ))
      /\ eq (snd (xzladderstep x1 xz x'z')) (to_xz (Madd Q Q')).
    Proof. Time t_fast. Time par: abstract (maybefast; fsatz). Time Qed.
    (* 12 ;; 24 ;; 3 *)

    Context {a2m4_nonsquare:forall r, r*r <> a*a - (1+1+1+1)}.

    Lemma projective_fst_xzladderstep x1 Q (HQ:projective Q) Q'
      :  projective (fst (xzladderstep x1 Q Q')).
    Proof.
      specialize (a2m4_nonsquare (fst Q/snd Q  - fst Q/snd Q)).
      destruct (dec (snd Q = 0)); t.
    Qed.

    Local Definition a2m4_nz : a*a - (1+1+1+1) <> 0.
    Proof. specialize (a2m4_nonsquare 0). fsatz. Qed.

    Lemma difference_preserved Q Q' :
          M.eq
            (Madd (Madd Q Q) (Mopp (Madd Q Q')))
            (Madd Q (Mopp Q')).
    Proof.
      pose proof (let (_, h, _, _) := AffineInstances.M.MontgomeryWeierstrassIsomorphism b_nonzero (a:=a) a2m4_nz in h) as commutative_group.
      rewrite Group.inv_op.
      rewrite <-Hierarchy.associative.
      rewrite Group.cancel_left.
      rewrite Hierarchy.commutative.
      rewrite <-Hierarchy.associative.
      rewrite Hierarchy.left_inverse.
      rewrite Hierarchy.right_identity.
      reflexivity.
    Qed.

    Lemma ladder_invariant_preserved x1 Q Q' (H:ladder_invariant x1 Q Q')
      : ladder_invariant x1 (Madd Q Q) (Madd Q Q').
    Proof.
      cbv [ladder_invariant] in *.
      pose proof difference_preserved Q Q' as Hrw.
      (* FIXME: what we actually want to do here is to rewrite with in
      match argument with
      [sumwise (fieldwise (n:=2) Feq) (fun _ _ => True)] *)
      cbv [M.eq] in *; break_match; break_match_hyps;
        destruct_head' @and; repeat split; subst;
          try solve [intuition congruence].
      congruence (* congruence failed, idk WHY *)
      || (match goal with
            [H:?f1 = ?x1, G:?f = ?f1 |- ?f = ?x1] => rewrite G; exact H
          end).
    Qed.

    Lemma ladder_invariant_swap x1 Q Q' (H:ladder_invariant x1 Q Q')
      : ladder_invariant x1 Q' Q.
    Proof. t. Qed.

    Lemma to_xz_add x1 xz x'z' Q Q'
          (Hxz : projective xz) (Hx'z' : projective x'z')
          (HQ : eq xz (to_xz Q)) (HQ' : eq x'z' (to_xz Q'))
          (HI : ladder_invariant x1 Q Q')
      :    projective (fst (xzladderstep x1 xz x'z'))
        /\ projective (snd (xzladderstep x1 xz x'z'))
        /\ eq (fst (xzladderstep x1 xz x'z')) (to_xz (Madd Q Q ))
        /\ eq (snd (xzladderstep x1 xz x'z')) (to_xz (Madd Q Q'))
        /\ ladder_invariant x1 (Madd Q Q) (Madd Q Q').
    Proof.
      destruct (to_xz_add_coordinates x1 xz x'z' Hxz Hx'z' Q Q' HQ HQ' HI) as [? [? ?]].
      eauto 99 using projective_fst_xzladderstep, ladder_invariant_preserved.
    Qed.

    Definition to_x (xz:F*F) : F :=
      if dec (snd xz = 0) then 0 else fst xz / snd xz.
    Hint Unfold to_x : points_as_coordinates.

    Lemma to_x_to_xz Q : to_x (to_xz Q) = match M.coordinates Q with
                                          | ∞ => 0
                                          | (x,y) => x
                                          end.
    Proof. t. Qed.

    Lemma proper_to_x_projective xz x'z'
           (Hxz:projective xz) (Hx'z':projective x'z')
           (H:eq xz x'z') : Feq (to_x xz) (to_x x'z').
    Proof. destruct (dec (snd xz = 0)), (dec(snd x'z' = 0)); t. Qed.

    Lemma to_x_zero x : to_x (pair x 0) = 0.
    Proof. t. Qed.

    Hint Unfold M.eq : points_as_coordinates.
    Global Instance Proper_to_xz : Proper (M.eq ==> eq) to_xz.
    Proof. t. Qed.

    Global Instance  Reflexive_eq : Reflexive eq.
    Proof. t. Qed.
    Global Instance  Symmetric_eq : Symmetric eq.
    Proof. t. Qed.
    Lemma transitive_eq {p} q {r} : projective q -> eq p q -> eq q r -> eq p r.
    Proof. t. Qed.

    Lemma projective_to_xz Q : projective (to_xz Q).
    Proof. t. Qed.

    Global Instance Proper_ladder_invariant : Proper (Feq ==> M.eq ==> M.eq ==> iff) ladder_invariant.
    Proof. t. Qed.

    Local Notation montladder := (M.montladder(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul)(Fzero:=Fzero)(Fone:=Fone)(Finv:=Finv)(cswap:=fun b x y => if b then pair y x else pair x y)).
    Local Notation scalarmult := (@ScalarMult.scalarmult_ref Mpoint Madd M.zero Mopp).

    Import Crypto.Experiments.Loops.
    Import Coq.ZArith.BinInt.

    Lemma to_x_inv00 (HFinv:Finv 0 = 0) x z : to_x (pair x z) = x * Finv z.
    Proof. t_fast; setoid_subst_rel Feq; rewrite ?HFinv in *; fsatz. Qed.

    Lemma Z_shiftr_testbit_1 n i: Logic.eq (n>>i)%Z (Z.div2 (n >> i) + Z.div2 (n >> i) + Z.b2z (Z.testbit n i))%Z.
    Proof. rewrite ?Z.testbit_odd, ?Z.add_diag, <-?Z.div2_odd; reflexivity. Qed.

    (* We prove montladder correct by considering the zero and non-zero case
       separately. *)

    Lemma montladder_correct_0
          (HFinv : Finv 0 = 0)
          (n : Z)
          (scalarbits : Z) (point : F)
          (Hz : point = 0)
          (Hn : (0 <= n < 2^scalarbits)%Z)
          (Hscalarbits : (0 <= scalarbits)%Z)
      : montladder scalarbits (Z.testbit n) point = 0.
    Proof.
      cbv beta delta [M.montladder].
      (* [while.by_invariant] expects a goal like [?P (while _ _ _ _)], make it so: *)
      lazymatch goal with |- context [while ?t ?b ?l ?i] => pattern (while t b l i) end.
      eapply (while.by_invariant
                (fun '(x2, z2, x3, z3, swap, i) =>
                   (i < scalarbits)%Z /\
                   z2 = 0 /\
                   if dec (Logic.eq i (Z.pred scalarbits)) then x3 = 0 else z3 = 0)
                (fun s => Z.to_nat (Z.succ (snd s))) (* decreasing measure *) ).
      { (* invariant holds in the beginning *) cbn.
        split; [lia|split;[reflexivity|t]]. }
      { intros [ [ [ [ [x2 z2] x3] z3] swap] i] [Hi [Hz2 Hx3z3]].
        destruct (i >=? 0)%Z eqn:Hbranch; (* did the loop continue? *)
          rewrite Z.geb_ge_iff in Hbranch.
        { (* if loop continued, invariant is preserved *)
          destruct (dec (Logic.eq i (Z.pred scalarbits))).
          { (* first loop iteration *)
            cbv -[xzladderstep xorb Z.testbit Z.pred dec Z.lt];
            destruct (xorb swap (Z.testbit n i));
            split; [lia|t|lia|t]. }
          { (* subsequent loop iterations *)
            cbv -[xzladderstep xorb Z.testbit Z.pred dec Z.lt].
            destruct (xorb swap (Z.testbit n i));
              (split; [lia| split; [t| break_match;[lia|t]]]). } }
        { (* if loop exited, invariant implies postcondition *)
          break_match; break_match_hyps; setoid_subst_rel Feq; fsatz. } }
      { (* fuel <= measure *) cbn. rewrite Z.succ_pred. reflexivity. }
      { (* measure decreases *) intros [? i].
        destruct (i >=? 0)%Z eqn:Hbranch;rewrite Z.geb_ge_iff in Hbranch; [|exact I].
        cbv [Let_In]; break_match; cbn; rewrite Z.succ_pred; apply Znat.Z2Nat.inj_lt; lia. }
    Qed.

    Lemma montladder_correct_nz
          (HFinv : Finv 0 = 0)
          (n : Z) (P : M.point)
          (scalarbits : Z) (point : F)
          (Hnz : point <> 0)
          (Hn : (0 <= n < 2^scalarbits)%Z)
          (Hscalarbits : (0 <= scalarbits)%Z)
          (Hpoint : point = to_x (to_xz P))
      : montladder scalarbits (Z.testbit n) point = to_x (to_xz (scalarmult n P)).
    Proof.
      pose proof (let (_, h, _, _) := AffineInstances.M.MontgomeryWeierstrassIsomorphism b_nonzero (a:=a) a2m4_nz in h) as commutative_group.
      cbv beta delta [M.montladder].
      (* [while.by_invariant] expects a goal like [?P (while _ _ _ _)], make it so: *)
      lazymatch goal with |- context [while ?t ?b ?l ?i] => pattern (while t b l i) end.
      eapply (while.by_invariant
                (fun '(x2, z2, x3, z3, swap, i) =>
                   (i >= -1)%Z /\
                   projective (pair x2 z2) /\
                   projective (pair x3 z3) /\
                   let q := if (swap:bool) then (pair x3 z3) else (pair x2 z2) in
                   let q' := if (swap:bool) then (pair x2 z2) else (pair x3 z3) in
                   let r := (n >> Z.succ i)%Z in
                   eq q (to_xz (scalarmult r P)) /\
                   eq q' (to_xz (scalarmult (Z.succ r) P)) /\
                   ladder_invariant point (scalarmult r P) (scalarmult (Z.succ r) P))
                (fun s => Z.to_nat (Z.succ (snd s))) (* decreasing measure *) ).
      { (* invariant holds in the beginning *) cbn.
        rewrite ?Z.succ_pred, ?Z.lt_pow_2_shiftr, <-?Z.one_succ by tauto.
        repeat split; [lia|t..]. }
      { intros [ [ [ [ [x2 z2] x3] z3] swap] i] [Hi [Hx2z2 [Hx3z3 [Hq [Hq' Hladder]]]]].
        destruct (i >=? 0)%Z eqn:Hbranch; (* did the loop continue? *)
          rewrite Z.geb_ge_iff in Hbranch.
        { (* if loop continued, invariant is preserved *)
          let group _ := ltac:(repeat rewrite ?scalarmult_add_l, ?scalarmult_0_l, ?scalarmult_1_l, ?Hierarchy.left_identity, ?Hierarchy.right_identity, ?Hierarchy.associative, ?(Hierarchy.commutative _ P); reflexivity) in
          destruct (Z.testbit n i) eqn:Hbit in *;
            destruct swap eqn:Hswap in *;
            repeat match goal with
                   | _ => solve [ congruence | assumption | lia ]
                   | _ => progress cbv beta delta [Let_In]
                   | _ => progress cbn [xorb Z.b2z]
                   | _ => progress autorewrite with cancel_pair in *
                   | _ => rewrite <-!@surjective_pairing
                   | _ => progress inversion_prod
                   | _ => progress subst
                   | _ => break_match_hyps_step ltac:(fun _ => idtac)
                   | _ => break_match_step ltac:(fun _ => idtac)
                   | H:projective ?xz, G:projective ?x'z', HQ: eq ?xz (to_xz ?Q), HQ': eq ?x'z' (to_xz ?Q')
                     |- context [xzladderstep ?p ?xz ?x'z']
                     => let pf := constr:(to_xz_add p xz x'z' _ _ H G HQ HQ' ltac:(auto using ladder_invariant_swap)) in
                        unique pose proof (proj1 pf); destruct (proj2 pf) as [? [? [? ?]]] (* because there is no unique destruct *)
                   | _ => progress rewrite ?Z.succ_pred, ?Z.shiftr_succ, <-?Z.div2_spec, <-?Z.add_1_r in *
                   | |- context [scalarmult (n>>i) ] => rewrite (Z_shiftr_testbit_1 n i), Hbit; cbn [Z.b2z]
                   | |- context [scalarmult (n>>i+1) ] => rewrite (Z_shiftr_testbit_1 n i), Hbit; cbn [Z.b2z]
                   | |- ?P => match type of P with Prop => split end
                   | H: eq (?f _) (to_xz ?LHS) |- eq (?f _) (to_xz ?RHS)
                     => eapply (transitive_eq (to_xz LHS) ltac:(auto using projective_to_xz) H); f_equiv; group ()
                   | H: ladder_invariant _ _ _ |- ladder_invariant _ _ _
                     => refine (proj1 (Proper_ladder_invariant _ _ (reflexivity _)  _ _ _  _ _ _) H); group ()
                   | H: ladder_invariant _ _ _ |- ladder_invariant _ _ _
                     => refine (proj1 (Proper_ladder_invariant _ _ (reflexivity _)  _ _ _  _ _ _) (ladder_invariant_swap _ _ _ H)); group ()
                   | |- ?P => match type of P with Prop => split end
                   end. }
        { (* if loop exited, invariant implies postcondition *)
          destruct_head' @and; autorewrite with cancel_pair in *.
          replace i with ((-(1))%Z) in * by lia; clear Hi Hbranch.
          rewrite Z.succ_m1, Z.shiftr_0_r in *.
          destruct swap eqn:Hswap; rewrite <-!to_x_inv00 by assumption;
            eauto using projective_to_xz, proper_to_x_projective. } }
      { (* fuel <= measure *) cbn. rewrite Z.succ_pred. reflexivity. }
      { (* measure decreases *) intros [? i].
        destruct (i >=? 0)%Z eqn:Hbranch;rewrite Z.geb_ge_iff in Hbranch; [|exact I].
        cbv [Let_In]; break_match; cbn; rewrite Z.succ_pred; apply Znat.Z2Nat.inj_lt; lia. }
    Qed.

    (* Using montladder_correct_0 in the combined correctness theorem requires
       additionally showing that the right-hand-side is 0. This comes from there
       being two points such that to_x gives 0: infinity and (0, 0). *)

    Lemma opp_to_x_to_xz_0
          (P : M.point)
          (H : 0 = to_x (to_xz P))
      : 0 = to_x (to_xz (Mopp P)).
    Proof. t. Qed.

    Lemma add_to_x_to_xz_0
          (P Q : M.point)
          (HP : 0 = to_x (to_xz P))
          (HQ : 0 = to_x (to_xz Q))
      : 0 = to_x (to_xz (Madd P Q)).
    Proof. t. Qed.

    Lemma scalarmult_to_x_to_xz_0
          (n : Z) (P : M.point)
          (H : 0 = to_x (to_xz P))
      : 0 = to_x (to_xz (scalarmult n P)).
    Proof.
      induction n using Z.peano_rect_strong.
      { cbn. t. }
      { (* Induction case from n to Z.succ n. *)
        unfold scalarmult_ref.
        rewrite Z.peano_rect_succ by omega.
        fold (scalarmult n P).
        apply add_to_x_to_xz_0; trivial. }
      { (* Induction case from n to Z.pred n. *)
        unfold scalarmult_ref.
        rewrite Z.peano_rect_pred by omega.
        fold (scalarmult n P).
        apply add_to_x_to_xz_0.
        { apply opp_to_x_to_xz_0; trivial. }
        { trivial. } }
    Qed.

    (* Combine the two cases together. *)

    Lemma montladder_correct
          (HFinv : Finv 0 = 0)
          (n : Z) (P : M.point)
          (scalarbits : Z) (point : F)
          (Hn : (0 <= n < 2^scalarbits)%Z)
          (Hscalarbits : (0 <= scalarbits)%Z)
          (Hpoint : point = to_x (to_xz P))
      : montladder scalarbits (Z.testbit n) point = to_x (to_xz (scalarmult n P)).
    Proof.
      destruct (dec (point = 0)) as [Hz|Hnz].
      { rewrite (montladder_correct_0 HFinv _ _ _ Hz Hn Hscalarbits).
        setoid_subst_rel Feq.
        apply scalarmult_to_x_to_xz_0.
        trivial. }
      { apply (montladder_correct_nz HFinv _ _ _ _ Hnz Hn Hscalarbits).
        trivial. }
    Qed.

  End MontgomeryCurve.
End M.


Require Export Functor.Core.
Require Import Common Categories.Hom Category.Morphisms Category.Duals Functor.Duals Functor.Product NaturalTransformation SetCategory.

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

Local Open Scope category_scope.

Section FullFaithful.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable C' : PreCategory.
  Variable D : PreCategory.
  Variable D' : PreCategory.
  Variable F : Functor C D.
  Variable F' : Functor C' D'.

  Definition InducedHomNaturalTransformation
  : NaturalTransformation (HomFunctor C) (HomFunctor D ⟨ F ⟨ 1 ⟩ , F ⟨ 1 ⟩ ⟩).
  Proof.
    refine (Build_NaturalTransformation
              (HomFunctor C)
              (HomFunctor D ⟨ F ⟨ 1 ⟩ , F ⟨ 1 ⟩ ⟩)
              (fun sd : (C^op * C) =>
                 MorphismOf F (s := _) (d := _))
              _
           ).
    abstract (
        repeat (intros [] || intro);
        simpl in *;
          repeat (apply path_forall; intro);
        unfold compose, HomFunctor_MorphismOf;
        simpl;
        rewrite !FCompositionOf;
        reflexivity
      ).
  Defined.

  (** We really want surjective/injective here, but we only have epi/mono.
      They're equivalent in the category of sets.  Are they equivalent in the
      category of [Type]s? *)
  Definition FunctorFull
    := forall x y : C, IsEpimorphism (InducedHomNaturalTransformation (x, y)).
  Definition FunctorFaithful
    := forall x y : C, IsMonomorphism (InducedHomNaturalTransformation (x, y)).

  Definition FunctorFullyFaithful
    := forall x y : C, IsIsomorphism (InducedHomNaturalTransformation (x, y)).

  Lemma FunctorFullyFaithful_split
  : FunctorFullyFaithful -> FunctorFull /\ FunctorFaithful.
  Proof.
    unfold FunctorFullyFaithful, FunctorFull, FunctorFaithful;
    intro; split; intros;
    typeclasses eauto.
  Qed.

(*
  (* Depends on injective + surjective -> isomorphism, and epi = surj, mono = inj *)
  Definition FunctorFullFaithful_and : FunctorFull /\ FunctorFaithful -> FunctorFullyFaithful.
    intro H; destruct H as [ e m ].
    unfold FunctorFullyFaithful, FunctorFull, FunctorFaithful in *.
    intros x y; specialize (e x y); specialize (m x y).
    unfold IsEpimorphism, IsMonomorphism in *; simpl in *.
    unfold IsIsomorphism; simpl.
    eexists;
      split.
    destruct C, D, F; simpl in *; clear C D F.
    *)
End FullFaithful.


From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Bool.Bool.
From Coq Require Import Reals.Reals. Import Rdefinitions. Import RIneq.
From Coq Require Import ZArith.Zdiv.
From Coq Require Import ZArith.Int.
From Coq Require Import ZArith.Znat.
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.
From Coq Require Import Lists.List.

Import ListNotations.

Require Import Ltac2.Ltac2.
Require Import Ltac2.Option.

From ATL Require Import ATL Tactics Common CommonTactics Div IdentParsing
     GatherScatter NatToString IntToString Convolution Im2col Blur CodeGen
     Normalize Reshape CheckSafe.

Open Scope string_scope.

Set Default Proof Mode "Classic".

Definition SENTINEL := "!!!".

Ltac Llibfunc name :=
  let _ := match goal with _ => intros;
                                try autounfold with examples end in
  let _ := match goal with
           | _ => check_safe
           | _ => idtac "Warning: not all accesses proven safe"
           end in

  let args'' := args_for_decl in
  let args' := eval simpl in args'' in
  let args := match args' with
                   | String _ ?s' => s'
                   | EmptyString => EmptyString
              end in
  let _ := match goal with _ => intros end in

  let _ := match goal with _ =>
                           normalize end in

  let prog := match goal with |- ?prog = _ => prog end in
  let progty := type of prog in
  let tystr := type_to_str progty in
  let funcname := name in

  let size := alloc_size prog in

  let tup := L prog constr:("output")
                    constr:(fun (acc : indty) => acc)
                    constr:(true)
                    constr:(2%nat) in
  let allocs := fst tup in
  let lower := snd tup in
  let frees := thd tup in

  let header := constr:([funcname++".h";
                        "#include <stdlib.h>";
                        "";
                        "void "++funcname++"("++args++","++scalar++"*output);"]) in

  let func := constr:((funcname++".c")::
                      "#include <stdlib.h>"::
                      ("#include @"++funcname++".h@")::
                      ""::
                      ("void "++funcname++"("++args++","++scalar++"*output)"++"{")::
                      (allocs++
                      lower++
                      frees++
                      ["}"])%list) in

  let ret' := constr:(app ("!!!"::header) ("!!!"::func)) in
  let ret := eval simpl in ret' in
      ret.

Goal forall (c : (list R)) (n m : Z),
    (0 < n)%Z ->
    (-m+1 < n)%Z ->
    consistent c (Z.to_nat n,tt) ->
    conv4 c n m = conv1 c n m.
Proof.
  let s := Llibfunc constr:("conv4") in idtac_list s.
Abort.

Goal forall (c : (list R)) (n m : Z),
    (0 < n)%Z ->
    (-m+1 < n)%Z ->
    consistent c (Z.to_nat n,tt) ->
    conv1 c n m = conv4 c n m.
Proof.
  let s := Llibfunc constr:("conv1") in idtac_list s.
Abort.

Goal forall n m (l : list (list R)),
    consistent l (n,(m,tt)) ->
    transpose (
        (GEN [ j < 1 ]
            GEN [ i < Z.of_nat n ]
            l _[i;j])
          <++>
          (GEN [ 1 <= j < Z.of_nat m ]
            (GEN [ i < 1 ]
                 l _[i;j])
            <++>
            (GEN [ 1 <= i < Z.of_nat n - 1]
                 l _[i;j])
            <++>
            (GEN [ Z.of_nat n - 1 <= i < Z.of_nat n ]
                 l _[i;j])
          )
        )
 = @nil _.
Proof.
  let s := Llibfunc constr:("concattest1") in idtac_list s.
Abort.

Goal forall n m (l : list (list R)),
    consistent l (n,(m,tt)) ->
    transpose (
        (GEN [ j < 1 ]
            GEN [ i < Z.of_nat n ]
            l _[i;j])
          <++>
          (GEN [ 1 <= j < Z.of_nat m ]
               GEN [ i < Z.of_nat n ]
            l _[i;j])
          )
 = @nil _.
Proof.
  let s := Llibfunc constr:("concattest0") in idtac_list s.
Abort.

Goal forall n m (v : list (list R)),
    0 < n ->
    0 < m ->
    consistent v (n,(m,tt)) ->
    transpose (
        (GEN [ j < 1 ]
           (GEN [ i < 1 ]
                 v _[i;j])
            <++>
            (GEN [ 1 <= i < Z.of_nat n ]
                 v _[i;j])
            )
          <++>
          (GEN [ 1 <= j < Z.of_nat m ]
               GEN [ i < Z.of_nat n ]
               v _[i;j]
          )
        )
 = @nil _.
Proof.
  let s := Llibfunc constr:("concattest2") in idtac_list s.
Abort.

Goal forall n m (l : list (list R)),
    consistent l (n,(m,tt)) ->
    transpose (
        GEN [ j < Z.of_nat m ]
            (GEN [ i < 1 ]
            l _[i;j])
            <++>
            (GEN [ 1 <= i < Z.of_nat n ]
            l _[i;j]))
 = @nil _.
Proof.
  let s := Llibfunc constr:("concattest3") in idtac_list s.
Abort.

Goal forall n m (l : (list R)),
    consistent l (n*m,tt) ->
    flatten (
        transpose
          (
            (GEN [ i < 1 ]
             (GEN [ j < Z.of_nat n ]
                  l _[j * Z.of_nat m + i]))
              <++>
            (GEN [ 1 <= i < Z.of_nat m ]
             (GEN [ j < Z.of_nat n ]
                 l _[j * Z.of_nat m + i]))
      ))

 = @nil _.
Proof.
  let s := Llibfunc constr:("concattest4") in idtac_list s.
Abort.

Goal forall n m (v : list (list R)),
    0 < n ->
    0 < m ->
    consistent v (n,(m,tt)) ->
flatten_trunc n
    (GEN [ i < Z.of_nat n // 64 ]
     transpose
       (flatten_trunc m
          (GEN [ xo < Z.of_nat m // 64 ]
                transpose
                (
                  (GEN [ i2 < 1 ]
                       (GEN [ i1 < 64 ]
                        (|[ xo * 64 + i1 <? Z.of_nat m ]|
                         (|[ i * 64 + i2 <? Z.of_nat n ]|
                          (v _[i * 64 + i2;xo * 64 + i1])))))
                    <++>
                  (GEN [ 1 <= i2 < 64 ]
                       (GEN [ i1 < 64 ]
                        (|[ xo * 64 + i1 <? Z.of_nat m ]|
                         (|[ i * 64 + i2 <? Z.of_nat n ]|
                          (v _[i * 64 + i2;xo * 64 + i1])))))

                )
    )))
 = @nil _.
Proof.
  let s := Llibfunc constr:("concattest5") in idtac_list s.
Abort.

Goal forall N M (v : list (list R)),
    0 < N ->
    0 < M ->
    consistent v (N,(M,tt)) ->
    blurimmediate v M N = blurtwostage N M v.
Proof.
  let s := Llibfunc constr:("blurim") in idtac_list s.
Abort.

Goal forall N M (v : list (list R)),
    0 < N ->
    0 < M ->
    consistent v (N,(M,tt)) ->
    blurtwostage N M v = blurimmediate v M N.
Proof.
  let s := Llibfunc constr:("blurtwo") in idtac_list s.
Abort.

Goal forall n m (l : list (list R)),
    0 < n ->
    0 < m ->
    consistent l (n,(m,tt)) ->
    blur_tiles_guarded l n m 64 64
    = @nil _.
Proof.
  let s := Llibfunc constr:("blurtiles") in idtac_list s.
Abort.

Goal forall n m (l : list (list R)),
    0 < n ->
    0 < m ->
    consistent l (n,(m,tt)) ->
    fusion_no_boundary n m l
    = @nil _.
Proof.
  let s := Llibfunc constr:("fusion_nb") in idtac_list s.
Abort.

Goal forall n m (l : list (list R)),
    0 < n ->
    0 < m ->
    consistent l (n,(m,tt)) ->
    tile_no_boundary 64 64 n m l
    = @nil _.
Proof.
  let s := Llibfunc constr:("tile_nb") in idtac_list s.
Abort.

Goal forall W R0 (x w : list R),
    consistent w (Z.to_nat R0, tt) ->
    consistent x (Z.to_nat R0, tt) ->
    (0 < W)%Z ->
    (Z.of_nat (length x) < W)%Z ->
    gather W x w = @nil _.
Proof.
  let s := Llibfunc constr:("gather") in idtac_list s.
Abort.

Goal forall W R0 (x w : list R),
    consistent w (Z.to_nat R0, tt) ->
    consistent x (Z.to_nat R0, tt) ->
    (0 < W)%Z ->
    (Z.of_nat (length x) < W)%Z ->
    scatter W x w = @nil _.
Proof.
  let s := Llibfunc constr:("scatter") in idtac_list s.
Abort.

Goal forall A B K W RR (w : list (list R)) (x : list R),
    (0 < K)%Z ->
    (0 < W)%Z ->
    (0 < RR)%Z ->
    consistent w (A,(B,tt))->
    consistent x (Z.to_nat K,tt) ->
    im2colminilifted K W RR w x = im2colmini K W RR w x.
Proof.
  let s := Llibfunc constr:("im2collifted") in idtac_list s.
Abort.

Goal forall A B K W RR (w : list (list R)) (x : list R),
    (0 < K)%Z ->
    (0 < W)%Z ->
    (0 < RR)%Z ->
    consistent w (A,(B,tt))->
    consistent x (Z.to_nat K,tt) ->
    im2colminilifted K W RR w x = im2colmini K W RR w x.
Proof.
  let s := Llibfunc constr:("im2col") in idtac_list s.
Abort.

Goal forall n m (v : list (list R)),
    2 < n ->
    2 < m ->
    consistent v (n,(m,tt)) ->
    blurimmediate_partition n m v = @nil _.
Proof.
  let s := Llibfunc constr:("blurpart") in idtac_list s.
Abort.

Goal forall n m (v : list (list R)),
    2 < n ->
    2 < m ->
    consistent v (n,(m,tt)) ->
    blurimmediate_isolate n m v = @nil _.
Proof.
  let s := Llibfunc constr:("blurisolate") in idtac_list s.
Abort.

Goal forall N M (v : list (list R)),
    2 < N ->
    2 < M ->
    consistent v (N,(M,tt)) ->
    blurtwostage_partition N M v = @nil _.
Proof.
  let s := Llibfunc constr:("blurtwopart") in idtac_list s.
Abort.


Require Import Coq.omega.Omega.

Require Import Bedrock.Examples.PreAutoSep.

(** Let's put the lemma prover through its paces. *)

Hint Extern 1 => elimtype False; omega : contradiction.

Theorem t0 : forall a b, a =*> b ===> a =*> b.
  sepLemma.
Qed.

Theorem t1 : forall a b c d, a =*> b * c =*> d ===> c =*> d * a =*> b.
  sepLemma.
Qed.

Theorem t2 : forall P : nat -> Prop, (Ex x, [| P x |]) ===> Ex x, [| P x |].
  sepLemma; eauto.
Qed.

Theorem t3 : forall ls : list nat, [| (length ls > 0)%nat |] ===> Ex x, Ex ls', [| ls = x :: ls' |].
  destruct ls; sepLemma.
Qed.

Theorem t4 : forall A (R : A -> A -> Prop),
  (Ex x, Ex y, Ex z, [| R x y /\ R y z |]) ===> (Ex y, ((Ex x, [| R x y |]) * (Ex z, [| R y z |]))).
  sepLemma.
  apply H.
  eassumption.
Qed.

(** Unification **)
Theorem t5 : forall p1 P2 V, exists p2, exists v,
  (p1 =*> P2 * P2 =*> V) ===> (p1 =*> p2 * p2 =*> v).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t6 : forall p1 P2 V, exists p2, exists v,
  (P2 =*> V * p1 =*> P2) ===> (p1 =*> p2 * p2 =*> v).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t7 : forall p1 P2 V, exists p2, exists v,
  (p1 =*> P2 * P2 =*> V) ===> (p2 =*> v * p1 =*> p2).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t8 : forall p1 P2 V, exists p2, exists v,
  (P2 =*> V * p1 =*> P2) ===> (p2 =*> v * p1 =*> p2).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t_err : forall a b c d, a =*> c * b =*> d ===> a =*> b * c =*> d.
  intros.
  progress sep_canceller ltac:(ILTacCommon.isConst) auto_ext ltac:(hints_ext_simplifier auto_ext).
  (progress sep_canceller ltac:(ILTacCommon.isConst) auto_ext ltac:(hints_ext_simplifier auto_ext); fail 3) || idtac.
Abort.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories.Limits Require Import Limit GenProd_GenSum GenProd_Eq_Limits.
From Categories Require Import Functor.Functor Const_Func Functor.Functor_Ops.
From Categories Require Import NatTrans.Main.
From Categories Require Import Ext_Cons.Comma.
From Categories.Basic_Cons Require Import Terminal Equalizer Limits.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Cat.Terminal.

(** We show that if C is a complete category and G : C –≻ D preserves limits,
then every comma category (Comma (Func_From_SingletonCat x) G) for (x : D) has
generalized products. *)
Section Commas_GenProd.
  Context
    {C D : Category}
    {CC : Complete C}
    {G : (C --> D)%functor}
    (GCont : Continuous CC G)
    (x : D).

  Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end : core.
  Local Hint Extern 1 => apply Comma_Hom_eq_simplify : core.
  Local Hint Extern 1 => progress cbn in * : core.
  Local Hint Extern 1 => rewrite From_Term_Cat : core.

  Local Obligation Tactic := basic_simpl; auto 10.

  Section fun_conv.
    Context {A : Type} (f : A → (Comma (Const_Func 1 x) G)).

    Definition fun_conv (y : A) : C := CMO_trg (f y).

  End fun_conv.

  Context {A : Type} (f : A → (Comma (Const_Func 1 x) G)).

  Definition GenProd_fun_conv : (Π (fun_conv f))%object :=
    LimitOf (Discr_Func (fun_conv f)).

  Program Definition f_Cone : Cone (G ∘ (Discr_Func (fun_conv f)))%functor :=
    {|
    cone_apex :=
      {|
        FO :=
          fun _ => x;
        FA := fun _ _ _ => id
      |};
    cone_edge :=
      {|
        Trans := fun c => CMO_hom (f c)
      |}
    |}.

  Definition Limit_G_fun_conv : Limit (G ∘ (Discr_Func (fun_conv f)))%functor :=
    is_Cone_Local_Right_KanExt_Local_Right_KanExt
      _
      _
      (GCont _ (Discr_Func (fun_conv f))) .

  Section Comma_GenProd_Cone.
    Local Unset Transparent Obligations.

    Program Definition Comma_GenProd_Cone : Cone (Discr_Func f) :=
      {|
      cone_apex :=
        {|
          FO :=
            fun x =>
              {|
                CMO_src := x;
                CMO_trg := GenProd_fun_conv;
                CMO_hom := Trans (LRKE_morph_ex Limit_G_fun_conv f_Cone) tt
              |};
          FA :=
            fun a b h =>
              {|
                CMH_left := h;
                CMH_right := id
              |}
        |};
      cone_edge :=
        {|
          Trans :=
            fun c =>
              {|
                CMH_left := tt;
                CMH_right := Trans GenProd_fun_conv c
              |}
        |}
      |}.

    Next Obligation.
    Proof.
      cbn_rewrite (f_equal
                     (fun w:
                            (f_Cone ∘ Functor_To_1_Cat (Discr_Cat A)
                                    --> G ∘ Discr_Func (fun_conv f))%nattrans
                      => Trans w c)
                     (cone_morph_com (LRKE_morph_ex Limit_G_fun_conv f_Cone))).
      rewrite From_Term_Cat.
      rewrite F_id.
      auto.
    Qed.

  End Comma_GenProd_Cone.

  Program Definition Cone_f_Cone_fun_conv_f (Cn : Cone (Discr_Func f)) :
    Cone (Discr_Func (fun_conv f)) :=
    {|
      cone_apex :=
        {|
          FO := fun _ => CMO_trg (Cn _o tt)%object;
          FA := fun a b h => id
        |};
      cone_edge :=
        {|
          Trans := fun c => CMH_right (Trans Cn c)
        |}
    |}.

  Section Cone_f_Cone_Morph_from_f_Cone.
    Context (Cn : Cone (Discr_Func f)).

    Local Obligation Tactic := idtac.

    Program Definition Cone_f_Cone_Morph_from_f_Cone  :
      LoKan_Cone_Morph f_Cone Limit_G_fun_conv :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  ((G _a
                      (Trans
                         (
                           LRKE_morph_ex
                             (GenProd_fun_conv)
                             (Cone_f_Cone_fun_conv_f Cn)
                         )
                         c
                      )
                   ) ∘ (CMO_hom (Cn _o tt)))%object%morphism
            |}
        |}.
    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.
    Next Obligation.
    Proof.
      symmetry.
      apply Cone_f_Cone_Morph_from_f_Cone_obligation_1.
    Qed.
    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality z.
      cbn in *.
      simpl_ids.
      rewrite assoc_sym.
      rewrite <- F_compose.
      rewrite assoc_sym.
      rewrite <- F_compose.
      repeat rewrite assoc.
      cbn_rewrite
        <-
        (f_equal
           (fun w :
                ((Cone_f_Cone_fun_conv_f Cn)
                   ∘ Functor_To_1_Cat (Discr_Cat A)
                   --> Discr_Func (fun_conv f))%nattrans
            => Trans w z)
           (cone_morph_com
              (LRKE_morph_ex (GenProd_fun_conv) (Cone_f_Cone_fun_conv_f Cn)))
        ).
      etransitivity; [|symmetry; apply (CMH_com (Trans Cn z))].
      cbn; auto.
    Qed.

  End Cone_f_Cone_Morph_from_f_Cone.

  Section Comma_GenProd_Cone_Morph_ex.
    Context (Cn : Cone (Discr_Func f)).

    Local Unset Transparent Obligations.

    Program Definition Comma_GenProd_Cone_Morph_ex :
      LoKan_Cone_Morph Cn Comma_GenProd_Cone :=
      {|
      cone_morph :=
        {|
          Trans :=
            fun c =>
              {|
                CMH_left := tt;
                CMH_right :=
                  match c as u return (CMO_trg (Cn _o u)%object --> _)%morphism
                  with
                    tt =>
                    Trans
                      (LRKE_morph_ex
                         (GenProd_fun_conv) (Cone_f_Cone_fun_conv_f Cn))
                      tt
                  end
              |}
        |}
      |}.
    Next Obligation.
    Proof.
      repeat match goal with [x : unit |- _] => destruct x end.
      simpl_ids.
      apply
        (f_equal
           (fun w : (f_Cone --> Limit_G_fun_conv)%nattrans => Trans w tt)
           (LRKE_morph_unique
              Limit_G_fun_conv
              f_Cone
              (Cone_f_Cone_Morph_from_f_Cone Cn)
              (LRKE_morph_ex Limit_G_fun_conv f_Cone)
           )
        ).
    Qed.

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality z.
      apply Comma_Hom_eq_simplify; cbn in *.
      match goal with [|- ?A = _] => destruct A; trivial end.
      simpl_ids.
      cbn_rewrite
        (f_equal
           (fun w : ((Cone_f_Cone_fun_conv_f Cn)
                     ∘ Functor_To_1_Cat (Discr_Cat A)
                     --> Discr_Func (fun_conv f))%nattrans
            => Trans w z)
           (cone_morph_com
              (LRKE_morph_ex (GenProd_fun_conv) (Cone_f_Cone_fun_conv_f Cn))));
        auto.
    Qed.

  End Comma_GenProd_Cone_Morph_ex.

  Program Definition Cone_Morph_to_Comma_GenProd_Cone_TO_Cone_Morph_to_GenProd_fun_conv
          (Cn : Cone (Discr_Func f))
          (h : LoKan_Cone_Morph Cn Comma_GenProd_Cone) :
    LoKan_Cone_Morph (Cone_f_Cone_fun_conv_f Cn) GenProd_fun_conv :=
    {|
    cone_morph :=
      {|
        Trans :=
          fun c =>
            match
              c as u
              return
              (
                (CMO_trg ((Cn _o)%object tt))
                  -->
                  (
                    (CC
                       (Discr_Cat A) _o)
                      (Discr_Func (fun_conv f)) _o)%object
                  u
              )%morphism
            with
            | tt => CMH_right (Trans h tt)
            end
      |}
    |}.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality z.
    cbn.
    cbn_rewrite (
        f_equal
          (fun w :
                 ((Cn ∘ Functor_To_1_Cat (Discr_Cat A))
                    -->
                    @Discr_Func (Comma (Const_Func 1 x) G) _ f)%nattrans
           => CMH_right (Trans w z)
          )
          (cone_morph_com h)
      ).
    auto.
  Qed.

  Program Definition Comma_GenProd : (Π f)%object :=
    {| LRKE := Comma_GenProd_Cone;
       LRKE_morph_ex := Comma_GenProd_Cone_Morph_ex |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality z.
    destruct z.
    apply Comma_Hom_eq_simplify.
    match goal with [|- ?A = ?B] => destruct A; destruct B; trivial end.
    change (CMH_right (Trans h tt)) with
    (Trans (Cone_Morph_to_Comma_GenProd_Cone_TO_Cone_Morph_to_GenProd_fun_conv
              Cn h) tt).
    change (CMH_right (Trans h' tt)) with
    (Trans (Cone_Morph_to_Comma_GenProd_Cone_TO_Cone_Morph_to_GenProd_fun_conv
              Cn h') tt).
    match goal with
      [|- Trans ?A tt = Trans ?B tt] =>
      assert (A = B) as Heq; [|rewrite Heq]; trivial
    end.
    apply (LRKE_morph_unique GenProd_fun_conv).
  Qed.

End Commas_GenProd.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path.
Require Import Eqdep Relations.
From fcsl
Require Import pred prelude ordtype pcm finmap unionmap heap.
From Toychain
Require Import SeqFacts Chains Types Parameters Forests Protocol Address.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Type NetState (T : Types) (P : ConsensusParams T) (F : Forest T P)
       (A : NetAddr) (Pr : ConsensusProtocol T P F A).
Import T P A Pr.
Definition StateMap := union_map [ordType of Address] State.
Definition initState' s : StateMap := foldr (fun a m => (a \\-> Init a) \+ m) Unit s.
Definition initState := initState' (enum [finType of Address]).

Axiom valid_initState' : forall s,  uniq s -> valid (initState' s).
Axiom dom_initState' : forall s, uniq s -> dom (initState' s) =i s.
End NetState.

Module States (T : Types) (P : ConsensusParams T) (F : Forest T P)
            (A : NetAddr) (Pr : ConsensusProtocol T P F A) <: NetState T P F A Pr.
Import T P A Pr.

Definition StateMap := union_map [ordType of Address] State.

Definition initState' s : StateMap := foldr (fun a m => (a \\-> Init a) \+ m) Unit s.

(* Master-lemma, proving a conjunction of two mutually-necessary facts *)
Lemma initStateValidDom s :
  uniq s -> dom (initState' s) =i s /\ valid (initState' s).
Proof.
elim: s => /=[|a s']; first by rewrite valid_unit dom0.
move => IH.
move/andP => [H_ni H_u].
move/IH: H_u => [H1 H2] {IH}.
split; last first.
- case: validUn; rewrite ?validPt ?H2//.
  move=>k. rewrite domPt inE. move=>/eqP Z. subst k.
  by rewrite H1; move/negP: H_ni.
- move=>z;
  rewrite (domUn (a \\-> Init a) (initState' s')).
  rewrite !inE !domPt !inE.
  rewrite H1.
  case validUn.
  * by move/negP => H_v; case: H_v; rewrite validPt.
  * by move/negP.
  * move => k.
    rewrite H1.
    rewrite domPt inE=>/eqP H_eq.
    rewrite -H_eq => H_in.
    by move/negP: H_ni.
  * move => Hv1 Hv2 H_d.
    by rewrite eq_sym.
Qed.

Lemma valid_initState' s : uniq s -> valid (initState' s).
Proof. by move => H_u; case: (initStateValidDom H_u). Qed.

Lemma dom_initState' s : uniq s -> dom (initState' s) =i s.
Proof. by move => H_u; case: (initStateValidDom H_u). Qed.

Definition initState := initState' (enum [finType of Address]).
End States.


(*

  Correct and complete implementation definition for pattern matching synthesis problem.

  (C) Dmitry Boulytchev, JetBrains Research, St. Petersburg State University, 2020.

*)

Require Import SyntaxDef.
Require Import Declarative.
Require Import Switch.

(* The definition of a correct and complete pattern matching implementation *)
Definition CCI (ps : Patterns) (s : S) : Prop :=
  forall (v : Value) (i : nat), <| v ; ps |> = i <-> v |- s ==> i.

(* Elimination of universal quantifier over the set of answers *)
Lemma answer_quantifier_elimination (ps : Patterns) (s : S) :
  (forall (v : Value), exists (i : nat),  <| v ; ps |> = i /\ v |- s ==> i) -> CCI ps s.
Proof.
  intro H.
  unfold CCI.
  intros v i.
  split; intro H'; specialize (H v); inversion_clear H; inversion_clear H0.
  * rewrite H' in H. subst x. auto.
  * apply (eval_deterministic v s i H' x) in H1. subst i. auto.
Qed.


From isla Require Import opsem.

Definition a18258 : isla_trace :=
  Barrier (RegVal_Base (Val_Enum ((Mk_enum_id 4%nat), Mk_enum_ctor 24%nat))) Mk_annot :t:
  Smt (DeclareConst 94%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 94%Z)) Mk_annot :t:
  Smt (DefineConst 95%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 94%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 95%Z)) Mk_annot :t:
  tnil
.


(* This file is part of the Linear Logic  formalization in Coq: https://github.com/meta-logic/coq-ll *)

(** ** Soundness
This file proves the soundness of the triadic (focused) system of linear logic *)

(* Add LoadPath "../" .  *)
Require Export Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export LL.SequentCalculiBasicTheory.

Set Implicit Arguments.

Module FFSoundness (DT : Eqset_dec_pol).
  Module Export Sys :=  SqBasic DT.

  Theorem Soundness : forall (B : list Lexp) n  (M : list Lexp) A ,
      LexpPos M ->
      n |-F- B ; M ; A  ->  |-- B ; M ++ (Arrow2LL A).
  Proof with solveF.
    intros B n M A MPos.
    generalize dependent B.
    generalize dependent M.
    generalize dependent A.
    induction n  using strongind;
      intros A M MPos B H1.
    + inversionF H1;subst ...
      eapply sig2_copy with (F:=  A3°);auto.

    (* INDUCTIVE CASES *)
    + inversionF H1.
      ++ (* tensor *)
        apply sig2_tensor with (N:=M0) (M:=N) (F:=F) (G:=G) ...
        MReplace (F :: N) ( N ++ (Arrow2LL (DW F) )) .
        apply H with n0 ...
        MReplace (G :: M0) ( M0 ++ (Arrow2LL (DW G) )) .
        apply H with m ...
      ++ (* oplus *)
        apply H in H2 ...
        simpl in *.
        eapply sig2_plus1 with (F:=F) (M:=M) ...
        rewrite union_comm in H2 ...
      ++ (* oplus2 *)
        apply H in H2 ...
        simpl in  *.
        eapply sig2_plus2 with (G:=G) (M:=M) ...
        rewrite union_comm in H2.
        eauto.
      ++ (* bang *)
        apply H in H2;auto.
        simpl. simpl in H2.
        eapply sig2_bang with (F:=F);auto.
      ++ (* Release *)
        apply H in H3;auto.
      ++ (* bottom *)
        apply H in H2;auto.
        simpl in *.
        eapply sig2_bot;eauto.
      ++ (* par *)
        apply H in H2;auto.
        simpl in *.
        eapply sig2_par ...
        MReplace  (F :: G :: M ++ M0) (M ++ F :: G :: M0) ...
      ++ (* with *)
        apply H in H2 ...
        apply H in H3 ...
        simpl in *.
        apply sig2_with with (F:=F) (G:=G) (M:=M ++ M0) ...
        MReplace ( F :: M ++ M0) ( M ++ F :: M0) ...
        MReplace (G :: M ++ M0) ( M ++ G :: M0) ...
      ++  (* ? *)
        apply H in H2 ...
        simpl in *.
        apply sig2_quest with (F:=F) (M := M ++ M0) ...
        rewrite union_comm in H2 ...
      ++ (* store *)
        apply H in H3 ...
        simpl in *.
        rewrite <- union_assoc in H3 ...
      ++ (* decide *)
        apply H in H4 ...
        simpl in *.
        rewrite app_nil_r.
        rewrite H3.
        MReplace (F :: L') ( L' ++ [F])  ...
      ++ (* decide *)
        apply H in H4 ...
        simpl in *.
        rewrite H3.
        eapply sig2_copy with (F:=F) ...
        rewrite H3 in H4 ...
        MReplace ( (F::M)++[]) (M ++ [F]) ...
      ++ (* exists *)
        apply H in H2;auto.
        simpl in *.
        rewrite union_comm in H2.
        rewrite union_comm ...
        eapply sig2_ex ...
        eauto.
      ++ (* forall *)
        simpl in *.
        eapply sig2_fx ...
        intro x.
        generalize (H2 x);intro.
        apply H in H0 ...
        simpl in *.
        MReplace (Subst FX x :: M ++ M0) ( M ++ Subst FX x :: M0) ...
  Qed.

End FFSoundness.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.CCC Basic_Cons.PullBack.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import PreSheaf.PreSheaf.

Section PSh_PullBack.
  Context (C : Category) {F G I : PreSheaf C}
          (f : (F --> I)%nattrans) (g : (G --> I)%nattrans).

  Local Hint Extern 1 =>
  match goal with
    [x : sig _ |- _ ] =>
    let H := fresh "H" in
    destruct x as [x H]
  end : core.

  Local Hint Extern 1 => match goal with
                          [|- context [(?F _a id)%morphism]] => rewrite (F_id F)
                        end : core.
  Local Hint Extern 1 =>
  match goal with
    [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end : core.

  Local Hint Extern 1 =>
  match goal with
    [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
    cbn_rewrite (equal_f (Trans_com f h))
  end : core.

  Local Hint Extern 1 => progress cbn in * : core.

  Local Obligation Tactic := basic_simpl; auto 10.

  (** The pointwise pullback presheaf. *)
  Program Definition PSh_PullBack_Func : PreSheaf C :=
    {|
      FO :=
        fun c =>
          {x : ((F _o c) * (G _o c))%object%type |
           Trans f c (fst x) = Trans g c (snd x)
          };
      FA :=
        fun c c' h x =>
          exist
            _
            ((F _a h (fst (proj1_sig x)))%morphism,
             (G _a h (snd (proj1_sig x)))%morphism)
            _
    |}.

  (** The morphism from the pullback to the domain object of the first
      morphism. *)
  Program Definition PSh_PullBack_morph_1 : (PSh_PullBack_Func --> F)%nattrans :=
    {|
      Trans := fun c x => fst (proj1_sig x)
    |}.

  (** The morphism from the pullback to the domain object of the second
      morphism. *)
  Program Definition PSh_PullBack_morph_2 : (PSh_PullBack_Func --> G)%nattrans :=
    {|
      Trans := fun c x => snd (proj1_sig x)
    |}.

  (** The morphism from the candidate pullback to the pullback. *)
  Program Definition PSh_PullBack_morph_ex
          (p' : (C ^op --> Type_Cat)%functor)
          (pm1 : (p' --> F)%nattrans)
          (pm2 : (p' --> G)%nattrans)
          (H : (f ∘ pm1)%nattrans = (g ∘ pm2)%nattrans)
    :
      (p' --> PSh_PullBack_Func)%nattrans
    :=
      {|
        Trans :=
          fun c x =>
            exist
              _
              (Trans pm1 c x, Trans pm2 c x)
              (f_equal (fun w : (p' --> I)%nattrans => Trans w c x) H)
      |}.

  (** The pointwise pullback presheaf is the pullback of presheaves. *)
  Program Definition PSh_PullBack : @PullBack (PShCat C) _ _ _ f g :=
    {|
      pullback := PSh_PullBack_Func;
      pullback_morph_1 := PSh_PullBack_morph_1;
      pullback_morph_2 := PSh_PullBack_morph_2;
      pullback_morph_ex := PSh_PullBack_morph_ex
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros p' pm1 pm2 H u u' H1 H2 H3 H4.
    rewrite <- H3 in H1; clear H3.
    rewrite <- H4 in H2; clear H4.
    apply NatTrans_eq_simplify.
    extensionality c.
    extensionality x.
    assert (H1' := f_equal (fun w : (p' --> F)%nattrans => Trans w c x) H1);
      clear H1.
    assert (H2' := f_equal (fun w : (p' --> G)%nattrans => Trans w c x) H2);
      clear H2.
    cbn in *.
    match goal with
      [|- ?A = ?B] => destruct A as [[? ?] ?]; destruct B as [[? ?] ?]
    end.
    apply sig_proof_irrelevance.
    cbn in *; subst; trivial.
  Qed.

End PSh_PullBack.

Instance PSh_Has_PullBacks (C : Category) : Has_PullBacks (PShCat C) :=
  @PSh_PullBack C.


Require Export BasicDefinitions.
Require Import PslBase.Bijection.

(** ** Formalisation of finite types using canonical structures and type classes *)

(** * Definition of finite Types *)

Class finTypeC  (type:eqType) : Type :=
  FinTypeC {
      enum: list type;
      enum_ok: forall x: type, count enum x = 1
    }.

Structure finType : Type :=
  FinType
    {
      type:> eqType;
      class: finTypeC type
    }.

Arguments FinType type {class}.
Existing Instance class | 0.

(* This is a hack to work-around a problem with a class of hacks *)
Hint Extern 5 (finTypeC (EqType ?x)) => unfold x : typeclass_instances.

Canonical Structure finType_CS (X : Type) {p : eq_dec X} {class : finTypeC (EqType X)} : finType := FinType (EqType X).

(** Print the base type of [finType] in the Canonical Structure. *)
Arguments finType_CS (X) {_ _}.

Definition elem (F: finType) := @enum (type F) (class F).
Hint Unfold elem.
Hint Unfold class.

Lemma elem_spec (X: finType) (x:X) : x el (elem X).
Proof.
  apply countIn.  pose proof (enum_ok x) as H. unfold elem. omega.
Qed.

Hint Resolve elem_spec.
Hint Resolve enum_ok.

Lemma allSub (X: finType) (A:list X) : A <<= elem X.
Proof.
  intros x _. apply elem_spec.
Qed.
Hint Resolve allSub.

(** A properties that hold on every element of (elem X) hold for every element of the finType X *)
Theorem Equivalence_property_all (X: finType) (p: X -> Prop) :
  (forall x, p x) <-> forall x, x el (elem X) -> p x.
Proof.
  split; auto.
Qed.

Theorem Equivalence_property_exists (X: finType) (p:X -> Prop):
  (exists x, p x) <-> exists x, x el (elem X) /\ p x.
Proof.
  split.
  - intros [x P]. eauto.
  - intros [x [E P]]. eauto.
Qed.

Instance finType_forall_dec (X: finType) (p: X -> Prop): (forall x, dec (p x)) -> dec (forall x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_all p).
  - auto.
Qed.

Instance finType_exists_dec (X:finType) (p: X -> Prop) : (forall x, dec (p x)) -> dec (exists x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_exists p).
  - auto.
Qed.

Definition finType_cc (X: finType) (p: X -> Prop) (D: forall x, dec (p x)) : (exists x, p x) -> {x | p x}.
Proof.
  intro H.
  assert(exists x, x el (elem X) /\ p x) as E by firstorder.
  pose proof (list_cc D E) as [x G].
  now exists x.
Defined.

Definition pickx (X: finType): X + (X -> False).
Proof.
  destruct X as [X [enum ok]]. induction enum.
  - right. intro x. discriminate (ok x).
  - tauto.
Defined.

(** * Properties of decidable Propositions *)

Lemma DM_notAll (X: finType) (p: X -> Prop) (D:forall x, dec (p x)): (~ (forall x, p x)) <-> exists x, ~ (p x).
Proof.
  decide (exists x,~ p x); firstorder.
Qed.

Lemma DM_exists (X: finType) (p: X -> Prop) (D: forall x, dec (p x)):
  (exists x, p x) <->  ~(forall x, ~ p x).
Proof.
  split.
  - firstorder.
  - decide (exists x, p x); firstorder.
Qed.

(* Index is an injective function *)

Fixpoint  getPosition {E: eqType} (A: list E) x := match A with
                                                   | nil => 0
                                                   | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end.

Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |.
Proof.
  induction A;cbn.
  -repeat destruct Dec;tauto.
  -repeat destruct Dec;intuition; congruence.
Qed.

Definition pos_def (X : eqType) (x : X) A n :=  match pos x A with None => n | Some n => n end.

Definition index {F: finType} (x:F) := getPosition (elem F) x.

Lemma index_nth {F : finType} (x:F) y: nth (index x) (elem F) y = x.
  unfold index, elem, enum.
  destruct F as [[X E] [A all_A]];cbn.
  pose proof (getPosition_correct x A) as H.
  destruct Dec. auto. apply notInZero in n. now setoid_rewrite all_A in n.
Qed.

Lemma injective_index (A: finType) (x1 x2 : A) : index x1 = index x2 -> x1 = x2.
Proof.
  destruct (elem A) eqn:E.
  - hnf. intros. assert (x1 el elem A) by eauto using elem_spec. rewrite E in H0. auto.
  - clear E. eapply (left_inv_inj (g := (fun y => nth y (elem A) e))).
    hnf. intros. now rewrite index_nth.
Qed.

Lemma index_leq (A:finType) (x:A): index x <= length (elem A).
Proof.
  unfold index.
  generalize (elem A) . intros l.
  induction l;cbn;[|decide _].
  all:omega.
Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

From Utils Require Import Base Booleans Eqb Default.

Section __.
  Context (A : Type)
    `{Eqb_ok A}.

  Lemma invert_none_some (x : A)
    : None = Some x <-> False.
  Proof.
    solve_invert_constr_eq_lemma.
  Qed.
  Hint Rewrite invert_none_some : utils.

  Lemma invert_some_none (x : A)
    : Some x = None <-> False.
  Proof.
    solve_invert_constr_eq_lemma.
  Qed.
  Hint Rewrite invert_some_none : utils.

  Lemma invert_some_some (x y : A)
    : Some x = Some y <-> x = y.
  Proof. solve_invert_constr_eq_lemma. Qed.
  Hint Rewrite invert_some_some : utils.

  #[export] Instance option_eqb : Eqb (option A) :=
    fun a b =>
      match a, b with
      | Some a, Some b => eqb a b
      | None, None => true
      | _, _ => false
      end.

  #[export] Instance option_eqb_ok : Eqb_ok option_eqb.
  Proof.
    unfold Eqb_ok, option_eqb, eqb.
    intros a b;
      destruct a;
      destruct b;
      basic_goal_prep;
      basic_utils_crush.
    pose proof (H0 a a0) as H'.
    unfold eqb in *.
    revert H'.
    case_match;
      basic_utils_crush.
  Qed.

  #[export] Instance option_default : WithDefault (option A) := None.

End __.

#[export] Hint Rewrite invert_none_some : utils.
#[export] Hint Rewrite invert_some_none : utils.
#[export] Hint Rewrite invert_some_some : utils.


Require Import MyTactics.
Require Import DCSyntax.

(* The syntactic subcategory of values is decidable. *)

Definition if_value {A} (t : term) (a1 a2 : A) : A :=
  match t with
  | Var _ | Lam _ | Empty | Conflict | Const _ => a1
  | _ => a2
  end.

Definition is_value (t : term) :=
  if_value t True False.

Global Hint Extern 1 (is_value _) => (simpl; tauto) : is_value obvious.

(* A term either is or is not a value. *)

Lemma value_or_nonvalue:
  forall t,
  is_value t \/ ~ is_value t.
Proof.
  destruct t; simpl; eauto.
Qed.

(* Simplification rules for [if_value]. *)

Lemma if_value_value:
  forall A v (a1 a2 : A),
  is_value v ->
  if_value v a1 a2 = a1.
Proof.
  destruct v; simpl; tauto.
Qed.

Lemma if_value_nonvalue:
  forall A t (a1 a2 : A),
  ~ is_value t ->
  if_value t a1 a2 = a2.
Proof.
  destruct t; simpl; tauto.
Qed.

(* The syntactic subcategory of values is preserved by renamings. *)

Lemma is_value_renaming:
  forall v xi,
  is_value v ->
  is_value v.[ren xi].
Proof.
  destruct v; simpl; eauto.
Qed.

Lemma is_nonvalue_renaming:
  forall v xi,
  ~ is_value v ->
  ~ is_value v.[ren xi].
Proof.
  destruct v; simpl; eauto.
Qed.

Global Hint Resolve is_value_renaming is_nonvalue_renaming : is_value obvious.

Ltac is_value :=
  eauto with is_value.

(* The tactic [not_a_value] can be used to prove that the current case
   is impossible, because we have a hypothesis of the form [~ is_value v],
   where [v] clearly is a value. *)

Ltac not_a_value :=
  solve [ false; is_value ].

Ltac if_value :=
  repeat first [ rewrite if_value_value by is_value |
                 rewrite if_value_nonvalue by is_value ].

(* The tactic [value_or_nonvalue t] creates two cases: either [t] is a value,
   or it isn't. *)

Ltac value_or_nonvalue t :=
  destruct (value_or_nonvalue t);
  if_value.

(* The tactic [value_or_app_or_let] creates three cases: either [t] is a value,
   or it is an application, or it is a [let] construct. *)

Ltac value_or_app_or_let t :=
  value_or_nonvalue t; [|
    destruct t as [ ? | ? | t1 t2 | t1 t2 ]; [ not_a_value | not_a_value | |]
      (* In principle, we should not fix the names [t1] and [t2] here,
         as it might cause name clashes. *)
  ].

(* The predicate [is_value_subst sigma] holds if every term in the
   codomain of the substitution [sigma] is a value. *)

Definition is_value_subst (sigma : var -> term) :=
  forall x, is_value (sigma x).

Lemma is_value_subst_ids:
  is_value_subst ids.
Proof.
  intros x. is_value.
Qed.

Lemma is_value_subst_cons:
  forall v sigma,
  is_value v ->
  is_value_subst sigma ->
  is_value_subst (v .: sigma).
Proof.
  intros. intros [|x]; is_value.
Qed.

Definition is_value_subst_up:
  forall sigma,
  is_value_subst sigma ->
  is_value_subst (up sigma).
Proof.
  intros sigma h. intros [|x]; asimpl.
  { simpl. eauto. }
  { is_value. }
Qed.

Definition is_value_subst_upn:
  forall sigma i,
  is_value_subst sigma ->
  is_value_subst (upn i sigma).
Proof.
  induction i; intros; asimpl.
  { eauto. }
  { rewrite <- fold_up_upn. eauto using is_value_subst_up. }
Qed.

Lemma is_value_subst_renaming:
  forall sigma i,
  is_value_subst sigma ->
  is_value_subst (sigma >> ren (+i)).
Proof.
  intros. intro x. asimpl. is_value.
Qed.

Global Hint Resolve is_value_subst_up is_value_subst_upn is_value_subst_renaming
  : is_value obvious.

Lemma values_are_preserved_by_value_substitutions:
  forall v sigma,
  is_value v ->
  is_value_subst sigma ->
  is_value v.[sigma].
Proof.
  destruct v; simpl; intros; eauto with is_value.
Qed.

Lemma nonvalues_are_preserved_by_substitutions:
  forall t sigma,
  ~ is_value t ->
  ~ is_value t.[sigma].
Proof.
  destruct t; simpl; tauto.
Qed.

Global Hint Resolve
  is_value_subst_ids
  is_value_subst_cons
  values_are_preserved_by_value_substitutions
  nonvalues_are_preserved_by_substitutions
: is_value obvious.

Lemma is_ren_is_value_subst:
  forall sigma,
  is_ren sigma ->
  is_value_subst sigma.
Proof.
  intros ? [ xi ? ]. subst. eauto with is_value.
Qed.

Global Hint Resolve is_ren_is_value_subst : is_value obvious.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype.
From mathcomp.ssreflect
Require Import tuple finfun finset.
Require Import pred pcm unionmap heap heaptac domain stmod stsep stlog stlogR.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition indx {I : finType} (x : I) := index x (enum I).

Prenex Implicits indx.

(***********************************)
(* Arrays indexed by a finite type *)
(***********************************)

Record array (I : finType) (T : Type) : Type := Array {orig :> ptr}.
Implicit Arguments Array [I T].

Definition array_for (I : finType) (T : Type) of phant (I -> T) := array I T.
Identity Coercion array_for_array : array_for >-> array.
Notation "{ 'array' aT }" := (array_for (Phant aT))
  (at level 0, format "{ 'array'  '[hv' aT ']' }") : type_scope.

Module Array.
Section Array.
Variable (I : finType) (T : Type).
Notation array := {array I -> T}.

Definition shape (a : array) (f : {ffun I -> T}) :=
  [Pred h | h = updi a (fgraph f) /\ valid h].

(* helper lemmas *)

Lemma enum_split k :
        enum I = take (indx k) (enum I) ++ k :: drop (indx k).+1 (enum I).
Proof.
rewrite -{2}(@nth_index I k k (enum I)) ?mem_enum //.
by rewrite -drop_nth ?index_mem ?mem_enum // cat_take_drop.
Qed.

Lemma updi_split (a : array) k (f : {ffun I -> T}) :
        updi a (fgraph f) = updi a (take (indx k) (fgraph f)) \+
                            a.+(indx k) :-> f k \+
                            updi (a.+(indx k).+1) (drop (indx k).+1 (fgraph f)).
Proof.
rewrite fgraph_codom /= codomE {1}(enum_split k) map_cat updi_cat /=.
rewrite map_take map_drop size_takel ?joinA ?ptrA ?addn1 //.
by rewrite size_map index_size.
Qed.

Lemma takeord k x (f : {ffun I -> T}) :
        take (indx k) (fgraph [ffun y => [eta f with k |-> x] y]) =
        take (indx k) (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in take (indx k) (enum I), f =1 f'}.
- by rewrite !fgraph_codom /= !codomE -2!map_take; move/eq_in_map: E.
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= =>H4.
move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->.
by rewrite andbF.
Qed.

Lemma dropord k x (f : {ffun I -> T}) :
        drop (indx k).+1 (fgraph [ffun y => [eta f with k |->x] y]) =
        drop (indx k).+1 (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in drop (indx k).+1 (enum I), f =1 f'}.
- by rewrite !fgraph_codom /= !codomE -2!map_drop; move/eq_in_map: E.
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= => H4.
move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->.
by rewrite !andbF.
Qed.

(* main methods *)

Program Definition new (x : T) : STsep (emp, [vfun y => shape y [ffun => x]]) :=
  Do (x <-- allocb x #|I|;
      ret (Array x)).
Next Obligation.
move=>i ->; step=>y; heval; rewrite unitR; vauto; congr updi.
rewrite fgraph_codom /= codomE cardE.
by elim: (enum I)=>[|t ts] //= ->; rewrite (ffunE _ _).
Qed.

Definition newf_loop a (f : {ffun I -> T}) : Type :=
  forall s : seq I, STsep (fun i => exists g s', [/\ i \In shape a g,
                                      s' ++ s = enum I &
                                      forall x, x \in s' -> g x = f x],
                           [vfun y => shape y f]).

Program Definition newf (f : {ffun I -> T}) :
  STsep (emp, [vfun y => shape y f]) :=
  Do (if [pick x in I] is Some v return _ then
        x <-- new (f v);
        let f := Fix (fun (loop : newf_loop x f) s =>
                   Do (if s is k::t return _ then
                          x .+ (indx k) ::= f k;;
                          loop t
                       else ret (Array x)))
        in f (enum I)
      else ret (Array null)).
Next Obligation.
move=>_ /= [g][s'][[->]]; case: s=>[|k t] /= _ H1 H2.
- rewrite cats0 in H1; step; vauto.
  by rewrite (_ : g = f) // -ffunP=>y; apply: H2; rewrite H1 mem_enum.
rewrite (updi_split x k); step; apply: val_do0=>//.
exists (finfun [eta g with k |-> f k]), (s' ++ [:: k]).
rewrite /shape (updi_split x k) takeord dropord (ffunE _ _) /= eq_refl -catA.
split=>// y; rewrite ffunE /= mem_cat inE /=.
by case: eqP=>[->|_] //; rewrite orbF; apply: H2.
Qed.
Next Obligation.
move=>_ ->; case: fintype.pickP=>[v|] H /=.
- apply: bnd_seq; apply: val_do0=>//= x m [->] _ _.
  by apply: val_do0=>//; exists [ffun => f v], nil.
step; do !split=>//.
suff L: #|I| = 0 by case: (fgraph f)=>/=; rewrite L; case.
by rewrite cardE; case: (enum I)=>[|x s] //; move: (H x).
Qed.

Definition loop_inv (a : array) : Type :=
  forall k, STsep (fun i => exists xs:seq T, [/\ i = updi (a .+ k) xs, valid i &
                              size xs + k = #|I|],
                   [vfun y : unit => emp]).

Program
Definition free (a : array) :
    STsep (fun i => exists f, i \In shape a f, [vfun y => emp]) :=
  Do (let: f := Fix (fun (f : loop_inv a) k =>
                  Do (if k == #|I| then ret tt
                      else
                        dealloc a.+k;;
                        f k.+1))
      in f 0).
Next Obligation.
move=>_ /= [[|v xs]][->] /= _; first by rewrite add0n=>/eqP ->; apply: val_ret.
case: eqP=>[->|_ H]; first by move/eqP; rewrite -{2}(add0n #|I|) eqn_add2r.
by step; apply: val_doR=>// V; exists xs; rewrite V ptrA addn1 -addSnnS unitL.
Qed.
Next Obligation.
move=>_ /= [f][->] _; apply: val_do0=>// V; exists (tval (fgraph f)).
by rewrite ptr0 V {3}fgraph_codom /= codomE size_map -cardE.
Qed.

Program Definition read (a : array) (k : I) :
   {f h}, STsep (fun i => i = h /\ i \In shape a f,
                 [vfun y m => m = h /\ y = (f k)]) :=
  Do (!a .+ (indx k)).
Next Obligation.
by apply: ghR=>x [f h][->][/= ->] _ _; rewrite /shape (updi_split a k); step.
Qed.

Program Definition write (a : array) (k : I) (x : T) :
  {f}, STsep (shape a f,
              [vfun _ => shape a [ffun z => [eta f with k |-> x] z]]) :=
  Do (a .+ (indx k) ::= x).
Next Obligation.
apply: ghR=>_ f [->] _ _; rewrite /shape !(updi_split a k).
by step; rewrite takeord dropord ffunE eq_refl.
Qed.

End Array.
End Array.


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

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Arith.
Require Import Ascii.
Declare ML Module "string_syntax_plugin".

(** *** Definition of strings *)

(** Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.

Delimit Scope string_scope with string.
Bind Scope string_scope with string.
Local Open Scope string_scope.

(** Equality is decidable *)

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
Proof.
 decide equality; apply ascii_dec.
Defined.

(** *** Concatenation of strings *)

Reserved Notation "x ++ y" (right associativity, at level 60).

Fixpoint append (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (s1' ++ s2)
  end
where "s1 ++ s2" := (append s1 s2) : string_scope.

(******************************)
(** Length                    *)
(******************************)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.

(******************************)
(** Nth character of a string *)
(******************************)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None
  | String c s' => match n with
                   | O => Some c
                   | S n' => get n' s'
                   end
  end.

(** Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
  forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
Proof.
intros s1; elim s1; simpl.
intros s2; case s2; simpl; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H as H1 H2.
rewrite H2; trivial.
rewrite H1; auto.
Qed.

(** The first elements of [s1 ++ s2] are the ones of [s1] *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (s1 ++ s2).
Proof.
intros s1; elim s1; simpl; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl; auto.
intros n0 H; apply Rec; auto.
apply lt_S_n; auto.
Qed.

(** The last elements of [s1 ++ s2] are the ones of [s2] *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (s1 ++ s2).
Proof.
intros s1; elim s1; simpl; auto.
intros s2 n; rewrite plus_comm; simpl; auto.
intros a s1' Rec s2 n; case n; simpl; auto.
generalize (Rec s2 0); simpl; auto. intros.
rewrite <- Plus.plus_Snm_nSm; auto.
Qed.

(** *** Substrings *)

(** [substring n m s] returns the substring of [s] that starts
    at position [n] and of length [m];
    if this does not make sense it returns [""] *)

Fixpoint substring (n m : nat) (s : string) : string :=
  match n, m, s with
  | 0, 0, _ => EmptyString
  | 0, S m', EmptyString => s
  | 0, S m', String c s' => String c (substring 0 m' s')
  | S n', _, EmptyString => s
  | S n', _, String c s' => substring n' m s'
  end.

(** The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
Proof.
intros s; elim s; simpl; auto.
intros n; case n; simpl; auto.
intros m; case m; simpl; auto.
intros a s' Rec; intros n; case n; simpl; auto.
intros m; case m; simpl; auto.
intros p H; inversion H.
intros m' p; case p; simpl; auto.
intros n0 H; apply Rec; simpl; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl; auto.
Qed.

(** The substring has at most [m] elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
Proof.
intros s; elim s; simpl; auto.
intros n; case n; simpl; auto.
intros m; case m; simpl; auto.
intros a s' Rec; intros n; case n; simpl; auto.
intros m; case m; simpl; auto.
intros m' p; case p; simpl; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl; auto.
apply Le.le_S_n; auto.
Qed.

(** *** Concatenating lists of strings *)

(** [concat sep sl] concatenates the list of strings [sl], inserting
    the separator string [sep] between each. *)

Fixpoint concat (sep : string) (ls : list string) :=
  match ls with
  | nil => EmptyString
  | cons x nil => x
  | cons x xs => x ++ sep ++ concat sep xs
  end.

(** *** Test functions *)

(** Test if [s1] is a prefix of [s2] *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.

(** If [s1] is a prefix of [s2], it is the [substring] of length
    [length s1] starting at position [O] of [s2] *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
Proof.
intros s1; elim s1; simpl; auto.
intros s2; case s2; simpl; split; auto.
intros a s1' Rec s2; case s2; simpl; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.

(** Test if, starting at position [n], [s1] occurs in [s2]; if
    so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) : option nat :=
  match s2, n with
  | EmptyString, 0 =>
      match s1 with
      | EmptyString => Some 0
      | String a s1' => None
      end
  | EmptyString, S n' => None
  | String b s2', 0 =>
      if prefix s1 s2 then Some 0
      else
        match index 0 s1 s2' with
        | Some n => Some (S n)
        | None => None
        end
   | String b s2', S n' =>
      match index n' s1 s2' with
      | Some n => Some (S n)
      | None => None
      end
  end.

(* Dirty trick to avoid locally that prefix reduces itself *)
Opaque prefix.

(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
 auto.
intros n; case n; simpl; auto.
intros m s1; case s1; simpl; auto.
intros H; injection H as <-; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H as <-; auto.
case H0; simpl; auto.
case m; simpl; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; auto.
intros; discriminate.
intros n'; case m; simpl; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [Some m],
    [s1] does not occur in [s2] before [m] *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
 auto.
intros n; case n; simpl; auto.
intros m s1; case s1; simpl; auto.
intros H; injection H as <-.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H as <-; auto.
intros p H2 H3; inversion H3.
case m; simpl; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl; auto.
intros H2 H3; red; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [None], [s1] does not occur in [s2]
    after [n] *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
 auto.
intros n; case n; simpl; auto.
intros m s1; case s1; simpl; auto.
case m; intros; red; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl; auto.
intros b s2' Rec n m s1.
case n; simpl; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl; auto with bool.
case s1; simpl; auto.
intros a s H H0 H1 H2; red; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s);
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.

(* Back to normal for prefix *)
Transparent prefix.

(** If we are searching for the [Empty] string and the answer is no
    this means that [n] is greater than the size of [s] *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None -> length s < n.
Proof.
intros n s; generalize n; clear n; elim s; simpl; auto.
intros n; case n; simpl; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.

(** Same as [index] but with no optional type, we return [0] when it
    does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.

(** *** Concrete syntax *)

(**
  The concrete syntax for strings in scope string_scope follows the
  Coq convention for strings: all ascii characters of code less than
  128 are literals to the exception of the character `double quote'
  which must be doubled.

  Strings that involve ascii characters of code >= 128 which are not
  part of a valid utf8 sequence of characters are not representable
  using the Coq string notation (use explicitly the String constructor
  with the ascii codes of the characters).
*)

Example HelloWorld := "	""Hello world!""
".


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	            Adjunction Example : CCC                		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Cartesian1.
Require Export CCC.
Require Export FunProd.

Set Implicit Arguments.
Unset Strict Implicit.

(* construire l'expo... a` partir d'un CCC *)

Section funprod_hasexpo.

Variable C : Category.
Variable H : HasBinProd C.

Definition HasExponent1 := forall a : C, RightAdj (Fun_prod H a).

Variable H1 : HasExponent1.

 Section funprod_expo.

 Variable a b : C.

 Let ua' := CoUnit (H1 a) b.

 Definition Expo1 := CoUA_ob ua'.

 Definition Eval1 := CoUA_mor ua'.

  Section lambda1_def.

  Variable c : C.

  Definition Lambda1_mor (f : H_obj_prod H c a --> b) := CoUA_diese ua' f.

  Lemma Lambda1_map_law : Map_law Lambda1_mor.
  Proof.
  unfold Map_law in |- *; intros f g H'.
  unfold Lambda1_mor in |- *.
  apply (Codiese_map ua' (x:=f) (y:=g)).
  trivial.
  Qed.

  Canonical Structure Lambda1 := Build_Map Lambda1_map_law.

  End lambda1_def.

 Lemma Prf_beta_rule1 : Beta_rule_law Eval1 Lambda1.
 Proof.
 unfold Beta_rule_law in |- *; intros c f.
 unfold Lambda1, Eval1 in |- *.
 apply (Prf_isCoUA_law1 ua' f).
 Qed.

 Lemma Prf_eta_rule1 : Eta_rule_law Eval1 Lambda1.
 Proof.
 unfold Eta_rule_law in |- *; intros c h; simpl in |- *.
 unfold Lambda1_mor in |- *.
 apply Sym.
 apply (Prf_isCoUA_law2 ua' (a':=c) (f:=Mor_prod H h (Id a) o Eval1) (g:=h)).
 unfold CoUA_eq in |- *.
 apply Refl.
 Qed.

 End funprod_expo.

 Definition HasExp1_to_HasExp : HasExponent H :=
   fun a b : C =>
   Build_Exponent (Prf_beta_rule1 (a:=a) (b:=b))
     (Prf_eta_rule1 (a:=a) (b:=b)).

End funprod_hasexpo.

Coercion HasExp1_to_HasExp : HasExponent1 >-> HasExponent.

Structure IsCCC1 (C : Category) : Type :=
  {CCC1_Car :> IsCartesian1 C; CCC1_exponent :> HasExponent1 CCC1_Car}.

Coercion CCC1_to_CCC (C : Category) (H : IsCCC1 C) :=
  Build_IsCCC (CCC_isCar:=H) H.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinv1rel8 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel8
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 inv1
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold rel8 in |- *; intros Inv0 Inv1 and1.
elim and1; intros t1 and2; elim and2; intros t2 and3; elim and3;
 intros t3 and4; elim and4; intros eq_l0 t4.
elim eq_l0; assumption.
Qed.


Require Import Braun.common.util Braun.common.le_util Braun.common.same_structure.
Require Import Braun.common.log Braun.common.big_oh Braun.common.pow.
Require Import Braun.monad.monad.
Require Import Program.
Require Import Omega.
Require Import Max.
Require Import Div2.
Require Import Relations_1.
Require Import Braun.rbtrees.rbtree.

Definition bst_search_time (n:nat) :=
  19 * n + 3.

Definition bst_search_result (A:Set)
  (A_cmp:A -> A -> Prop)
  (A_asym:forall x y, A_cmp x y -> ~ A_cmp y x)
  (A_trans:Transitive A A_cmp)
  (A_cmp_dec:
    forall (x y:A),
      { A_cmp x y } + { A_cmp y x })
  (A_eq_dec:
    forall (x y:A),
      { x = y } + { x <> y })
  (x:A) (ct:CTree A) (res:bool) (c:nat) :=
  forall (min_a max_a:A)
         (MIN:A_cmp min_a x)
         (MAX:A_cmp x max_a)
         (BST:IsBST A_cmp ct min_a max_a),
    (res = true -> IsMember x ct) /\
    (res = false -> ~ IsMember x ct) /\
    1 <= c <= bst_search_time (height ct).

Load "bst_search_gen.v".

Next Obligation.
Proof.
 unfold bst_search_result, bst_search_time.
 intros min_a max_a CMPax CMPxa BST.
 split.
 intros EQ. inversion EQ.
 simpl.
 split; try omega.
 intros _ IM.
 inversion IM.
Qed.

Next Obligation.
Proof.
 unfold bst_search_result, bst_search_time.
 intros min_a max_a CMPax CMPxa BST.
 split.
 intros _. eauto.
 split.
 intros EQ. congruence.
 simpl (height (CT_node A l c v r)).
 rewrite mult_succ_r.
 omega.
Qed.

Obligation Tactic := idtac.
Next Obligation.
Proof.
  unfold bst_search_result, bst_search_time.
  intros A A_cmp A_asym A_trans A_cmp_dec A_eq_dec x ct.
  intros l c v r EQ. subst ct.
  intros NEQ _ CMPxv _.
  intros res.
  intros _.
  intros xm EQ. simpl in EQ. subst xm.
  intros an REC.
  intros min_a max_a CMPax CMPxa BST.
  edestruct REC as [IMt [IMf AN]].
   apply CMPax.
   apply CMPxv.
   inversion BST. subst. auto.
  clear REC.

  split.
  intros EQ. apply IMt in EQ. eauto.
  split.
  intros EQ. apply IMf in EQ.
  intros IM. inversion IM; subst; auto.
  rename H0 into IMr.
  inversion BST.
  subst.
  rename H3 into BSTl.
  rename H6 into CMPav.
  rename H7 into CMPva.
  rename H8 into BSTr.

  edestruct IsMember_impl_bounds.
  apply A_trans.
  apply BSTr.
  apply IMr.
  rename H into CMPvx.
  clear H0.
  eapply A_asym.
  apply CMPvx.
  auto.

  simpl (height (CT_node A l c v r)).
  remember (height l) as L.
  remember (height r) as R.
  clear HeqR HeqL IMf IMt CMPxv NEQ BST r v c l CMPxa CMPax max_a min_a x A_eq_dec
    A_cmp_dec A_trans A_asym A_cmp A res.
  rewrite mult_succ_r.
  rewrite <- plus_assoc.
  replace (19 + 3) with 22; try omega.
  apply max_case_strong.
  intros LE. clear LE R. omega.
  intros LE. omega.
Qed.
Obligation Tactic := program_simpl.

Obligation Tactic := idtac.
Next Obligation.
Proof.
  unfold bst_search_result, bst_search_time.
  intros A A_cmp A_asym A_trans A_cmp_dec A_eq_dec x ct.
  intros l c v r EQ. subst ct.
  intros NEQ _ CMPvx _.
  intros res.
  intros _.
  intros xm EQ. simpl in EQ. subst xm.
  intros an REC.
  intros min_a max_a CMPax CMPxa BST.
  edestruct REC as [IMt [IMf AN]].
   apply CMPvx.
   apply CMPxa.
   inversion BST. subst. auto.
  clear REC.
  split.
  intros EQ. apply IMt in EQ. eauto.
  split.
  intros EQ. apply IMf in EQ.
  intros IM. inversion IM; subst; auto.
  rename H0 into IMl.
  inversion BST.
  subst.
  rename H3 into BSTl.
  rename H6 into CMPav.
  rename H7 into CMPva.
  rename H8 into BSTr.

  edestruct IsMember_impl_bounds.
  apply A_trans.
  apply BSTl.
  apply IMl.
  clear H.
  rename H0 into CMPxv.
  eapply A_asym.
  apply CMPvx.
  auto.

  simpl (height (CT_node A l c v r)).
  remember (height l) as L.
  remember (height r) as R.
  clear HeqR HeqL IMf IMt CMPvx NEQ BST r v c l CMPxa CMPax max_a min_a x A_eq_dec
    A_cmp_dec A_trans A_asym A_cmp A res.
  apply max_case_strong.
  intros LE. omega.
  intros LE. clear LE L. omega.
Qed.
Obligation Tactic := program_simpl.

Corollary rbbst_search_time_bound_black_height:
  forall A (ct:CTree A) n,
    IsRB ct n ->
    bst_search_time (height ct) <= 38 * n + 22.
Proof.
  intros A ct n IR.
  unfold bst_search_time.
  apply IsRB_impl_height_no_color in IR.
  omega.
Qed.

Corollary bst_search_time_theta:
  big_theta bst_search_time (fun n => n).
Proof.
  unfold bst_search_time.
  apply big_theta_mult_plus.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require map.Map.
Require list.Append.
Require list.Reverse.

(* Why3 assumption *)
Definition unit := unit.

Parameter head: forall {a:Type} {a_WT:WhyType a}, (list a) -> a.

Axiom head_cons : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), ((head (cons x l)) = x).

Parameter tail: forall {a:Type} {a_WT:WhyType a}, (list a) -> (list a).

Axiom tail_cons : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), ((tail (cons x l)) = l).

(* Why3 assumption *)
Definition disjoint {a:Type} {a_WT:WhyType a} (l1:(list a))
  (l2:(list a)): Prop := forall (x:a), ~ ((list.Mem.mem x l1) /\
  (list.Mem.mem x l2)).

(* Why3 assumption *)
Fixpoint no_repet {a:Type} {a_WT:WhyType a} (l:(list a)) {struct l}: Prop :=
  match l with
  | nil => True
  | (cons x r) => (~ (list.Mem.mem x r)) /\ (no_repet r)
  end.

Axiom loc : Type.
Parameter loc_WhyType : WhyType loc.
Existing Instance loc_WhyType.

Parameter null: loc.

(* Why3 assumption *)
Inductive list_seg : loc -> (@map.Map.map loc loc_WhyType loc loc_WhyType)
  -> (list loc) -> loc -> Prop :=
  | list_seg_nil : forall (p:loc) (next:(@map.Map.map loc loc_WhyType
      loc loc_WhyType)), (list_seg p next nil p)
  | list_seg_cons : forall (p:loc) (q:loc) (next:(@map.Map.map
      loc loc_WhyType loc loc_WhyType)) (l:(list loc)), ((~ (p = null)) /\
      (list_seg (map.Map.get next p) next l q)) -> (list_seg p next
      (cons p l) q).

Axiom list_seg_frame : forall (next1:(@map.Map.map loc loc_WhyType
  loc loc_WhyType)) (next2:(@map.Map.map loc loc_WhyType loc loc_WhyType))
  (p:loc) (q:loc) (v:loc) (pM:(list loc)), ((list_seg p next1 pM null) /\
  ((next2 = (map.Map.set next1 q v)) /\ ~ (list.Mem.mem q pM))) -> (list_seg
  p next2 pM null).

Axiom list_seg_functional : forall (next:(@map.Map.map loc loc_WhyType
  loc loc_WhyType)) (l1:(list loc)) (l2:(list loc)) (p:loc), ((list_seg p
  next l1 null) /\ (list_seg p next l2 null)) -> (l1 = l2).

Axiom list_seg_sublistl : forall (next:(@map.Map.map loc loc_WhyType
  loc loc_WhyType)) (l1:(list loc)) (l2:(list loc)) (p:loc) (q:loc),
  (list_seg p next (List.app l1 (cons q l2)) null) -> (list_seg q next
  (cons q l2) null).

(* Why3 goal *)
Theorem list_seg_no_repet : forall (next:(@map.Map.map loc loc_WhyType
  loc loc_WhyType)) (pM:(list loc)) (p:loc), (list_seg p next pM null) ->
  (no_repet pM).
(* Why3 intros next pM p h1. *)
Proof.
induction pM.
now simpl.
intros p h.
assert (a=p) by (inversion h; auto).
subst a.
split.
intro h1.
destruct (Append.mem_decomp p pM h1) as (l1 & l2 & h2).
subst pM.
change (cons p (app l1 (cons p l2))) with (app (cons p l1) (cons p l2)) in h.
assert (h2 := list_seg_sublistl _ _ _ _ _ h).
assert (h3 := list_seg_functional _ _ _ _ (conj h h2)).
assert (h4 := (f_equal Length.length h3)).
rewrite Append.Append_length in h4.
generalize (Length.Length_nonnegative l1).
change (Length.length (cons p l1)) with (1+Length.length l1)%Z in h4.
omega.
inversion h; subst; clear h.
apply IHpM with (p := Map.get next p).
tauto.
Qed.