Require Import Coq.PArith.BinPos Coq.PArith.Pnat.
Require Import Coq.Arith.Arith.
Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Common.Tactics.SplitInContext.
Require Import Fiat.Common.Notations.

Set Implicit Arguments.

Local Coercion is_true : bool >-> Sortclass.
Delimit Scope grammar_fixedpoint_scope with fixedpoint.
Local Open Scope grammar_fixedpoint_scope.

Inductive lattice_for T := top | constant (_ : T) | bottom.
Bind Scope grammar_fixedpoint_scope with lattice_for.
Scheme Equality for lattice_for.

Definition collapse_lattice_for {T} (l : lattice_for T) : option T
  := match l with
       | constant n => Some n
       | _ => None
     end.

Arguments bottom {_}.
Arguments top {_}.
Notation "'⊥'" := bottom : grammar_fixedpoint_scope.
Notation "'⊤'" := top : grammar_fixedpoint_scope.

Global Instance lattice_for_Reflexive {T} {beq : T -> T -> bool}
       {H : Reflexive beq}
  : Reflexive (lattice_for_beq beq).
Proof.
  intros [|?|]; simpl; reflexivity.
Qed.

Global Instance lattice_for_Symmetric {T} {beq : T -> T -> bool}
       {H : Symmetric beq}
  : Symmetric (lattice_for_beq beq).
Proof.
  intros [|?|] [|?|]; simpl; trivial; intro; symmetry; assumption.
Qed.

Global Instance lattice_for_Transitive {T} {beq : T -> T -> bool}
       {H : Transitive beq}
  : Transitive (lattice_for_beq beq).
Proof.
  intros [|?|] [|?|] [|?|]; simpl; trivial;
    try reflexivity;
    try congruence;
    intros; etransitivity; eassumption.
Qed.

Global Instance lattice_for_Equivalence {T} {beq : T -> T -> bool}
       {H : Equivalence beq}
  : Equivalence (lattice_for_beq beq).
Proof.
  split; exact _.
Qed.

Definition lattice_for_lt {T} (lt : T -> T -> bool) (x y : lattice_for T)
  := match x, y with
     | ⊤, ⊤ => false
     | constant x', constant y' => lt x' y'
     | ⊥, ⊥ => false
     | _, ⊤ => true
     | ⊤, _ => false
     | _, constant _ => true
     | constant _, _ => false
     end.

Global Instance lattice_for_lt_Proper {T} {beq lt : T -> T -> bool}
       {H : Proper (beq ==> beq ==> eq) lt}
  : Proper (lattice_for_beq beq ==> lattice_for_beq beq ==> eq) (lattice_for_lt lt).
Proof.
  intros [|a|] [|b|] H0 [|a'|] [|b'|] H1; simpl in *;
    trivial; try congruence.
  apply H; assumption.
Qed.

Definition lattice_for_lub {T} (lub : T -> T -> lattice_for T) (x y : lattice_for T)
  := match x, y with
     | ⊤, ⊤ => ⊤
     | constant x', constant y' => lub x' y'
     | ⊥, ⊥ => ⊥
     | ⊤, _
     | _, ⊤
       => ⊤
     | ⊥, v
     | v, ⊥
       => v
     end.

Section lub_correct.
  Context {T} (beq : T -> T -> bool) (lt : T -> T -> bool) (lub : T -> T -> lattice_for T).

  Local Notation "x <= y" := (orb (lattice_for_beq beq x y) (lattice_for_lt lt x y)).

  Context (lub_correct_l : forall x y, constant x <= lub x y)
          (lub_correct_r : forall x y, constant y <= lub x y)
          (beq_Reflexive : Reflexive beq).

  Lemma lattice_for_lub_correct_l x y
    : x <= lattice_for_lub lub x y.
  Proof.
    clear lub_correct_r.
    destruct x as [|x|], y as [|y|]; try reflexivity.
    { exact (lub_correct_l x y). }
    { simpl.
      rewrite (reflexivity x : is_true (beq x x)).
      reflexivity. }
  Qed.

  Lemma lattice_for_lub_correct_r x y
    : y <= lattice_for_lub lub x y.
  Proof.
    clear lub_correct_l.
    destruct x as [|x|], y as [|y|]; try reflexivity.
    { exact (lub_correct_r x y). }
    { simpl.
      rewrite (reflexivity y : is_true (beq y y)).
      reflexivity. }
  Qed.

  Global Instance lattice_for_lub_Proper
         {lub_Proper : Proper (beq ==> beq ==> lattice_for_beq beq) lub}
    : Proper (lattice_for_beq beq ==> lattice_for_beq beq ==> lattice_for_beq beq) (lattice_for_lub lub).
  Proof.
    intros [|a|] [|b|] H [|a'|] [|b'|] H'; simpl in *;
      trivial; try congruence.
    apply lub_Proper; assumption.
  Qed.
End lub_correct.

Definition lattice_for_gt_well_founded {T} {lt : T -> T -> bool}
           (gt_wf : well_founded (Basics.flip lt))
  : well_founded (Basics.flip (lattice_for_lt lt)).
Proof.
  do 3 (constructor;
        repeat match goal with
               | [ v : T, H : well_founded _ |- _ ] => specialize (H v); induction H
               | [ x : lattice_for _ |- _ ] => destruct x
               | _ => progress simpl in *
               | _ => progress unfold Basics.flip in *
               | [ H : is_true false |- _ ] => exfalso; clear -H; abstract congruence
               | _ => intro
               | _ => solve [ eauto with nocore ]
               end).
Defined.

Global Instance lattice_for_lt_Transitive {T} {lt : T -> T -> bool} {_ : Transitive lt}
  : Transitive (lattice_for_lt lt).
Proof.
  intros [|?|] [|?|] [|?|]; simpl; trivial; try congruence; [].
  intros.
  etransitivity; eassumption.
Qed.

Class grammar_fixedpoint_lattice_data prestate :=
  { state :> _ := lattice_for prestate;
    prestate_lt : prestate -> prestate -> bool;
    state_lt : state -> state -> bool
    := lattice_for_lt prestate_lt;
    prestate_beq : prestate -> prestate -> bool;
    state_beq : state -> state -> bool
    := lattice_for_beq prestate_beq;
    prestate_le s1 s2 := (prestate_beq s1 s2 || prestate_lt s1 s2)%bool;
    state_le s1 s2 := (state_beq s1 s2 || state_lt s1 s2)%bool;
    prestate_beq_Equivalence : Equivalence prestate_beq;
    state_beq_Equivalence : Equivalence state_beq
    := lattice_for_Equivalence;
    preleast_upper_bound : prestate -> prestate -> state;
    least_upper_bound : state -> state -> state
    := lattice_for_lub preleast_upper_bound;
    preleast_upper_bound_correct_l
    : forall a b, state_le (constant a) (preleast_upper_bound a b);
    preleast_upper_bound_correct_r
    : forall a b, state_le (constant b) (preleast_upper_bound a b);
    least_upper_bound_correct_l
    : forall a b, state_le a (least_upper_bound a b)
    := lattice_for_lub_correct_l prestate_beq prestate_lt preleast_upper_bound preleast_upper_bound_correct_l _;
    least_upper_bound_correct_r
    : forall a b, state_le b (least_upper_bound a b)
    := lattice_for_lub_correct_r prestate_beq prestate_lt preleast_upper_bound preleast_upper_bound_correct_r _;
    prestate_gt_wf : well_founded (Basics.flip prestate_lt);
    state_gt_wf : well_founded (Basics.flip state_lt)
    := lattice_for_gt_well_founded prestate_gt_wf;
    preleast_upper_bound_Proper : Proper (prestate_beq ==> prestate_beq ==> state_beq) preleast_upper_bound;
    least_upper_bound_Proper : Proper (state_beq ==> state_beq ==> state_beq) least_upper_bound
    := @lattice_for_lub_Proper _ _ _ _;
    prestate_lt_Proper : Proper (prestate_beq ==> prestate_beq ==> eq) prestate_lt;
    state_lt_Proper : Proper (state_beq ==> state_beq ==> eq) state_lt
    := lattice_for_lt_Proper;
    prestate_lt_Transitive : Transitive prestate_lt;
    state_lt_Transitive : Transitive state_lt
    := lattice_for_lt_Transitive }.

Record grammar_fixedpoint_data :=
  { prestate : Type;
    lattice_data :> grammar_fixedpoint_lattice_data prestate;
    step_constraints : (default_nonterminal_carrierT -> state) -> (default_nonterminal_carrierT -> state -> state);
    step_constraints_ext : Proper (pointwise_relation _ state_beq ==> eq ==> state_beq ==> state_beq) step_constraints }.

Record grammar_fixedpoint_lattice_data_relation
       {xT yT} (x : grammar_fixedpoint_lattice_data xT) (y : grammar_fixedpoint_lattice_data yT) :=
  { state_relation :> @state _ x -> @state _ y -> Prop;
    top_state_related : state_relation ⊤ ⊤;
    state_relation_Proper : Proper (state_beq ==> state_beq ==> iff) state_relation }.

Global Existing Instance lattice_data.
Global Existing Instance step_constraints_ext.
Global Existing Instance state_lt_Transitive.
Global Existing Instance state_beq_Equivalence.
Global Existing Instance prestate_beq_Equivalence.
Global Existing Instance state_lt_Proper.
Global Existing Instance prestate_lt_Proper.
Global Existing Instance least_upper_bound_Proper.
Global Existing Instance preleast_upper_bound_Proper.
Global Existing Instance state_relation_Proper.

Global Arguments state_lt_Transitive {_ _} [_ _ _] _ _.
Global Arguments state_le _ _ !_ !_ / .
Global Arguments state {_ _}, {_} _.

Infix "<=" := (@state_le _ _) : grammar_fixedpoint_scope.
Infix "<" := (@state_lt _ _) : grammar_fixedpoint_scope.
Infix "⊔" := (@least_upper_bound _ _) : grammar_fixedpoint_scope.
Infix "=b" := (@state_beq _ _) : grammar_fixedpoint_scope.

Definition nonterminal_to_positive (nt : default_nonterminal_carrierT) : positive
  := Pos.of_nat (S nt).
Definition positive_to_nonterminal (nt : positive) : default_nonterminal_carrierT
  := pred (Pos.to_nat nt).
Lemma positive_to_nonterminal_to_positive nt : nonterminal_to_positive (positive_to_nonterminal nt) = nt.
Proof.
  unfold nonterminal_to_positive, positive_to_nonterminal.
  erewrite <- S_pred by apply Pos2Nat.is_pos.
  rewrite Pos2Nat.id.
  reflexivity.
Qed.
Lemma nonterminal_to_positive_to_nonterminal nt : positive_to_nonterminal (nonterminal_to_positive nt) = nt.
Proof.
  unfold nonterminal_to_positive, positive_to_nonterminal.
  rewrite Nat2Pos.id_max; simpl.
  reflexivity.
Qed.

Global Instance lattice_for_rect_Proper {A}
  : Proper (eq ==> forall_relation (fun _ => eq) ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl))
           (@lattice_for_rect A (fun _ => Prop)) | 3.
Proof.
  unfold forall_relation; intros ??? ?? H' ??? [|?|] H''; subst; simpl in *; trivial.
  rewrite H'; assumption.
Qed.

Global Instance lattice_for_rect_Proper_85 {A}
  : Proper (eq ==> forall_relation (fun _ => eq) ==> eq ==> eq ==> Basics.flip Basics.impl)
           (@lattice_for_rect A (fun _ => Prop)) | 3.
Proof.
  unfold forall_relation; intros ??? ?? H' ??? [|?|] ?? H''; subst; simpl in *; trivial.
  rewrite H'; assumption.
Qed.

Lemma lattice_for_rect_pull {A B C} f t c b v
  : f (@lattice_for_rect A (fun _ => B) t c b v)
    = @lattice_for_rect A (fun _ => C) (f t) (fun x => f (c x)) (f b) v.
Proof. destruct v; reflexivity. Qed.

Global Instance state_relation_Proper_impl
       {xT yT x y} (R : @grammar_fixedpoint_lattice_data_relation xT yT x y)
  : Proper (state_beq ==> state_beq ==> Basics.impl) R | 2.
Proof.
  pose proof (state_relation_Proper R) as H.
  unfold Proper, respectful in *; split_iff; eauto.
Qed.
Global Instance state_relation_Proper_flip_impl
       {xT yT x y} (R : @grammar_fixedpoint_lattice_data_relation xT yT x y)
  : Proper (state_beq ==> state_beq ==> Basics.flip Basics.impl) R | 2.
Proof.
  pose proof (state_relation_Proper R) as H.
  unfold Proper, respectful in *; split_iff; eauto.
Qed.


Require Import Coq.Strings.String.
Require Import Fiat.Parsers.Reflective.Syntax.
Require Import Fiat.Parsers.Reflective.Syntactify.
Require Import Fiat.Common.NatFacts.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.List.Operations.
Set Implicit Arguments.

Local Open Scope list_scope.

Definition interp_SimpleTypeCode_step
           (interp_SimpleTypeCode : SimpleTypeCode -> Type)
           (t : SimpleTypeCode)
  : Type
  := match t with
     | cnat => nat
     | cbool => bool
     | cascii => Ascii.ascii
     | cstring => string
     | critem_ascii => Reflective.ritem Ascii.ascii
     | crchar_expr_ascii => Reflective.RCharExpr Ascii.ascii
     | clist T => list (interp_SimpleTypeCode T)
     | cprod A B => interp_SimpleTypeCode A * interp_SimpleTypeCode B
     end%type.

Fixpoint interp_SimpleTypeCode (t : SimpleTypeCode)
  := interp_SimpleTypeCode_step (@interp_SimpleTypeCode) t.

Fixpoint interp_TypeCode (t : TypeCode) : Type
  := match t with
     | csimple T => interp_SimpleTypeCode T
     | carrow A B => interp_TypeCode A -> interp_TypeCode B
     end%type.

Fixpoint apply_args_for {T}
         (f : interp_TypeCode T)
         (argsv : args_for interp_TypeCode T)
  : interp_TypeCode (range_of T)
  := match argsv in args_for _ T return interp_TypeCode T -> interp_TypeCode (range_of T) with
     | an_arg A B arg args => fun f => @apply_args_for _ (f arg) args
     | noargs T => fun f => f
     end f.

Section step.
  Context (interp_RLiteralTerm : forall {T}, RLiteralTerm T -> interp_TypeCode T).
  Context (interp_Term_gen : forall {T} (t : Term interp_TypeCode T), interp_TypeCode T).

  Definition interp_Term_gen_step {T} (t : Term interp_TypeCode T) : interp_TypeCode T
    := match t in (Term _ T') return interp_TypeCode T' with
       | RVar T v => v
       | RLambda A B f => fun x => @interp_Term_gen _ (f x)
       | RApp A B f x => @interp_Term_gen _ f (@interp_Term_gen _ x)
       | RLiteralApp c t args => apply_args_for (interp_RLiteralTerm t)
                                                (map_args_for (@interp_Term_gen) args)
       end.
End step.

Fixpoint interp_Term_gen (interp_RLiteralTerm : forall T, RLiteralTerm T -> interp_TypeCode T)
         {T} (t : Term interp_TypeCode T) : interp_TypeCode T
  := @interp_Term_gen_step interp_RLiteralTerm (@interp_Term_gen interp_RLiteralTerm) T t.

Definition interp_RLiteralTerm {T} (t : RLiteralTerm T) : interp_TypeCode T
  := match t with
     | RLC t'
       => match t' in (RLiteralConstructor T') return interp_TypeCode T' with
          | Rpair _ _ => @pair _ _
          | RS => S
          | RO => O
          | Rnil _ => @nil _
          | Rcons _ => @cons _
          | Rbool v
          | Rrchar_expr_ascii v
          | Rstring v
          | Rritem_ascii v
            => v
          end
     | RLNC t'
       => match t' in (RLiteralNonConstructor T') return interp_TypeCode T' with
          | Rfst _ _ => @fst _ _
          | Rsnd _ _ => @snd _ _
          | Rnth' A => nth'
          | Rnth A => @List.nth _
          | Rmap A B => @List.map _ _
          | Rfold_left A B => @List.fold_left _ _
          | Rorb => orb
          | Randb => andb
          | Randbr => andbr
          | Rorbr => orbr
          | Rminusr => minusr
          | Rpred => pred
          | Rplus => plus
          | Rleb => Compare_dec.leb
          | Rbeq_nat => EqNat.beq_nat
          | Rstring_beq => Equality.string_beq
          | Rlength _ => @List.length _
          | Rbool_rect_nodep _ => @bool_rect_nodep _
          | Rlist_rect_nodep _ _ => @list_rect_nodep _ _
          | Rlist_caset_nodep _ _ => @list_caset_nodep _ _
          | Rritem_rect_nodep _ => @Reflective.ritem_rect_nodep _ _
          | Rcombine _ _ => @List.combine _ _
          | Rfirst_index_default _ => @first_index_default _
          | Rrev _ => @List.rev _
          | Rup_to => up_to
          | Rmax => max
          | Rinterp_RCharExpr_ascii => Reflective.interp_RCharExpr
          end
     end.

Definition interp_Term : forall {T} (t : Term interp_TypeCode T), interp_TypeCode T
  := @interp_Term_gen (@interp_RLiteralTerm).

(* Section equality.
  Context {M : Type -> Type}.

  Definition args_for_values_code {T} (a0 : @args_for_values M T)
    : @args_for_values M T -> Prop
    := match a0 in @args_for_values _ T return @args_for_values _ T -> Prop with
       | an_argv A B a0 as0
         => fun a1
            => a0 = ahdv a1 /\ as0 = atlv a1
       | noargsv _
         => fun a1 => noargsv = a1
       end.

  Global Instance args_for_values_code_refl {T} : RelationClasses.Reflexive (@args_for_values_code T).
  Proof.
    intro a; destruct a; simpl; repeat split.
  Qed.

  Lemma args_for_values_encode {T} (a0 a1 : @args_for_values M T)
    : a0 = a1 -> args_for_values_code a0 a1.
  Proof.
    intro; subst; reflexivity.
  Qed.
End equality.
 *)

Ltac fold_interp_Term :=
  change (@interp_Term_gen (@interp_RLiteralTerm)) with (@interp_Term) in *;
  fold @interp_TypeCode in *.

Ltac simpl_interp_Term :=
  unfold interp_Term; simpl @interp_Term_gen;
  fold_interp_Term.

Ltac simpl_interp_Term_in_all :=
  unfold interp_Term in *; simpl @interp_Term_gen in *;
  fold_interp_Term.

Lemma interp_Term_syntactify_list {T : SimpleTypeCode}
      (ls : list (Term interp_TypeCode T))
: List.map interp_Term ls = interp_Term (Syntactify.syntactify_list ls).
Proof.
  unfold interp_Term; induction ls; simpl; [ reflexivity | ].
  rewrite <- IHls; reflexivity.
Qed.

Lemma interp_Term_syntactify_nat
      (v : nat)
: v = interp_Term (Syntactify.syntactify_nat _ v).
Proof.
  unfold interp_Term.
  induction v as [|v IHv]; [ reflexivity | simpl ].
  rewrite <- IHv; reflexivity.
Qed.

Lemma interp_Term_syntactify_rproductions
      ls
: ls = interp_Term (Syntactify.syntactify_rproductions _ ls).
Proof.
  repeat match goal with
         | [ |- ?x = ?x ] => reflexivity
         | _ => progress unfold Syntactify.syntactify_rproductions, syntactify_prod, syntactify_string
         | _ => progress simpl
         | _ => progress simpl_interp_Term
         | _ => rewrite <- interp_Term_syntactify_list, List.map_map
         | [ |- ?x = List.map _ ?x ]
           => etransitivity; [ symmetry; apply List.map_id | ]
         | [ |- List.map _ ?x = List.map _ ?x ]
           => apply List.map_ext; intro
         | [ |- _ = _ :> prod _ _ ]
           => apply injective_projections
         end.
Qed.


(* -------------------------------------------------------------------- *)
(* ------- *) Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals realseq realsum distr.
(* ------- *) Require Import notations inhabited pwhile psemantic passn.

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

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.
Local Open Scope syn_scope.
Local Open Scope sem_scope.
Local Open Scope mem_scope.

(* -------------------------------------------------------------------- *)
Definition range {A : choiceType} (P : pred A) (mu : Distr A) :=
  forall m, m \in dinsupp mu -> P m.

Section Range.
Context {A B : choiceType}.

Lemma range_dnull (P : pred A) : range P dnull.
Proof. by move=> x /dinsuppP; rewrite dnullE. Qed.

Lemma range_dunit (P: pred A) m : P m -> range P (dunit m).
Proof. by move=> Pm m' /in_dunit ->. Qed.

Lemma range_dlet (PA : pred A) (PB : pred B) mu f :
    range PA mu -> (forall m, PA m -> range PB (f m))
  -> range PB (\dlet_(m <- mu) f m).
Proof. by move=> hA hB y /dinsupp_dlet[x] /hA /hB /(_ y). Qed.

Lemma dinsupp_dlim (mu : nat -> Distr A) x:
  x \in dinsupp (\dlim_(n) mu n) ->
    exists k, x \in dinsupp (mu k).
Proof.
move/dinsuppP; rewrite dlimE; apply: contrapR.
move/asboolPn/forallp_asboolPn => eq; rewrite (@eq_nlim _ (fun _ => 0)).
  by move=> n; apply/dinsuppPn/negP/eq.
  by rewrite nlimC.
Qed.

Lemma range_dlim P (mu : nat -> Distr A):
  (forall n, range P (mu n)) -> range P (dlim mu).
Proof. by move=> h m /dinsupp_dlim[k] /h. Qed.

Lemma range_weaken (P1 P2 : pred A) mu:
  (forall x, P1 x -> P2 x) ->
  range P1 mu -> range P2 mu.
Proof. by move=> imp_P h m /h /imp_P. Qed.

Lemma range_pswap (P : pred (A * B)) (mu : Distr (A * B)) :
  range P mu -> range (pswap P) (dswap mu).
Proof.
move=> h [m1 m2] m_in_mu; have := h (m2, m1); apply.
by apply/dinsuppP; rewrite -dswapK; apply/dinsuppP/dinsupp_swap.
Qed.

Lemma pr_range (mu : Distr A) (E : pred A) :
  \P_[mu] (~ E)%A = 0 <-> range E mu.
Proof.
  split.
  + by move=> /pr_eq0 h x; apply/contraLR => /h /dinsuppPn.
  rewrite /range -(pr_pred0 mu)=> Hin;apply eq_in_pr=> x /Hin.
  by rewrite /mem /= /in_mem /= => ->.   (* TODO: simplify this *)
Qed.
End Range.

(* -------------------------------------------------------------------- *)
Section Phl.
Context {X : eqType} {mem : memType X}.

Notation assn := (pred mem).
Notation cmd  := (@cmd_ X mem).

Definition phl (P : assn) (c : cmd) (Q : assn) :=
  forall m, P m -> range Q (ssem_ c m).

Arguments phl P%A c%S Q%A.

Definition forall_in {T : ihbType} (mu : mem -> Distr T) (P : T -> assn) : assn :=
  `[< fun m => forall t,  t \in dinsupp (mu m) -> P t m >]%A.

Notation "`[ 'forall' x 'in' mu => Q ]" :=
  (@forall_in _ mu%A (fun x => Q)): assn.

Notation "`[ 'forall' x 'in' mu | m => Q ]" :=
  (@forall_in _ mu%A (fun x m => Q)): assn.

(* -------------------------------------------------------------------- *)
(* Core rules                                                           *)
(* -------------------------------------------------------------------- *)
Lemma phl_eq (P Q : assn) (c c' : cmd):
     (forall m, P m -> ssem_ c m = ssem_ c' m)
  -> phl P c Q
  -> phl P c' Q.
Proof. by move=> Hc Hw m Pm;rewrite -Hc //;apply Hw. Qed.

Instance phl_m : Proper (eq ==> @eqcmd _ mem ==> eq ==> iff) phl.
Proof. by move=> ??-> ??? ??->;split;apply phl_eq. Qed.

Lemma phl_conseq (P2 Q2 P1 Q1 : assn) (c : cmd):
 (forall m, P1 m -> P2 m) ->
 (forall m, Q2 m -> Q1 m) ->
 phl P2 c Q2 -> phl P1 c Q1.
Proof. by move=> HP HQ H2 m /HP /H2 Hr m' /Hr /HQ. Qed.

Lemma phl_F (c : cmd) P: phl pred0 c P.
Proof. by []. Qed.

Lemma phl_T (c : cmd) P: phl P c predT.
Proof. by []. Qed.

Lemma phl_skip (P : assn) : phl P skip P.
Proof. by move=> ??;rewrite ssemE;apply range_dunit. Qed.

Lemma phl_abort (P Q : assn) : phl P abort Q.
Proof. by move=> ??;rewrite ssemE;apply range_dnull. Qed.

Lemma phl_assign {T : ihbType} x (e:expr_ X mem T) (Q : assn):
   phl [pred m | Q m.[x <- `[{e}]%A m]] (x <<- e) Q.
Proof. by move=> m /=;rewrite !semE;apply range_dunit. Qed.

Lemma phl_random {T : ihbType} x (d:expr_ X mem (Distr T)) (Q : assn):
   phl `[forall v in `[{d}] | m => Q m.[x <- v]] (x <$- d) Q.
Proof.
move=> m /asboolP /= h; rewrite !semE.
apply (@range_dlet _ _ [pred v | Q m.[x<- v]]) => v /=.
  by apply h. by apply range_dunit.
Qed.

Lemma phl_seq (R Pr Po : assn) (c1 c2:cmd):
  phl Pr c1 R -> phl R c2 Po -> phl Pr (c1;;c2) Po.
Proof.
by move=> H1 H2 m /H1 Hm; rewrite ssemE; apply/(range_dlet Hm H2).
Qed.

Lemma phl_if (Pr Po : assn) (e:expr_ X mem bool) (c1 c2:cmd):
  phl (Pr /\ `[{e}])   c1 Po ->
  phl (Pr /\ `[{~~e}]) c2 Po ->
  phl Pr (If e then c1 else c2)%S Po.
Proof.
by move=> H1 H2 m Hm; rewrite ssemE; case: ifPn => He;
  [apply H1 | apply H2] => /=; rewrite Hm.
Qed.

Lemma phl_while (I : assn) (e:expr_ X mem bool) (c:cmd):
  phl (I /\ `[{e}]) c I ->
  phl I (While e Do c) (I /\ `[{~~e}]).
Proof.
move=> Hc m Hm; rewrite ssemE; apply/range_dlim=> n.
elim: n m Hm => [|n Hn] m Hm /=.
+ by rewrite ssemE; apply range_dnull.
apply (@phl_if I)=> //; last by apply phl_skip.
by apply (phl_seq Hc)=> ??; apply Hn.
Qed.

(* -------------------------------------------------------------------- *)
Lemma phl_ll (P Q : assn) (c:cmd) m:
  phl P c Q -> P m -> \P_[ssem_ c m] predT = 1 -> \P_[ssem_ c m] Q = 1.
Proof.
 by move=> Hphl /Hphl HP <-; rewrite !pr_exp;apply/eq_exp => x /HP ->.
Qed.
End Phl.

(* -------------------------------------------------------------------- *)
Definition eqon (X : pred { t : ihbType & vars t } ) (m : cmem) :=
  nosimpl (fun m' : cmem => forall x, x \in X -> m.[tagged x] = m'.[tagged x]).

Definition separated X (P : pred dmem) :=
  forall (mu1 mu2 : dmem),
      (forall m : cmem, \P_[mu1] [pred m' | `[<eqon (predC X) m m'>] ] =
                        \P_[mu2] [pred m' | `[<eqon (predC X) m m'>] ])
    -> mu1 \in P -> mu2 \in P.

(* -------------------------------------------------------------------- *)
Fixpoint mod (c : cmd) : pred { t : ihbType & vars t } :=
  match c with
  | abort    => pred0
  | skip     => pred0
  | x <<- _  => [pred y | `[<y = Tagged _ x>]]
  | x <$- _  => [pred y | `[<y = Tagged _ x>]]
  | c1 ;; c2 => [predU mod c1 & mod c2]

  | If _ then c1 else c2 => [predU mod c1 & mod c2]
  | While _ Do c         => mod c
  end.

(* -------------------------------------------------------------------- *)
Fixpoint eaccess {t} (e : expr t) : pred { t : ihbType & vars t } :=
  match e with
  | var_ _ x => [pred y | `[<y = Tagged _ x>]]
  | _ => pred0
  end.

(* -------------------------------------------------------------------- *)
Global Instance eqon_R X : Equivalence (eqon X).
Proof.
constructor=> //; first by move=> c1 c2 eq x /eq ->.
by move=> c1 c2 c3 eq1 eq2 x xX; rewrite eq1 ?eq2.
Qed.

(* -------------------------------------------------------------------- *)
Lemma mod_spec c m:
   phl [pred m' | m == m'] c
       [pred m' | `[<eqon (predC (mod c)) m m'>] ].
Proof. elim: c m.
+ by move=> m; apply phl_abort.
+ move=> m; pose P := [pred m' | m == m'].
  apply (phl_conseq (P2 := P) (Q2 := P))=> //; last exact/phl_skip.
  by move=> m' /eqP ->; apply/asboolT.
+ move=> t x e m; set Q := (Q in phl _ _ Q).
  pose R := [pred m' | Q m'.[x <- `[{e}] m']].
  apply (phl_conseq (P2 := R) (Q2 := Q))=> //; last exact/phl_assign.
  move=> m' /eqP <-; apply/asboolP=> -[u y] /asboolP /=.
  move/eq_vars=> neq; rewrite mget_neq //.
  by case: eqP neq; intuition.
+ move=> t x d m; set Q := (Q in phl _ _ Q).
  pose R := forall_in `[{d}] (fun v m => Q m.[x <- v]).
  apply (phl_conseq (P2 := R) (Q2 := Q)) => //; last exact/phl_random.
  move=> m' /= /eqP <-; apply/asboolP => z.
  move=> zQ; apply/asboolP => -[u y] /asboolP /eq_vars /= neq.
  by rewrite mget_neq //; case: eqP neq; intuition.
+ move=> e c1 ih1 c2 ih2 m; apply phl_if.
  * pose P := [pred m' | m == m'].
    pose Q := [pred m' | `[<eqon (predC (mod c1)) m m'>]].
    apply (phl_conseq (P2 := P) (Q2 := Q)); last exact/ih1.
    - by move=> m' /= /andP [/eqP <-].
    move=> m' /asboolP eq_m_m'; apply/asboolP=> z.
    by case/norP => [cz1 cz2]; rewrite eq_m_m'.
  * pose P := [pred m' | m == m'].
    pose Q := [pred m' | `[<eqon (predC (mod c2)) m m'>]].
    apply (phl_conseq (P2 := P) (Q2 := Q)); last exact/ih2.
    - by move=> m' /= /andP [/eqP <-].
    move=> m' /asboolP eq_m_m'; apply/asboolP=> z.
    by case/norP => [cz1 cz2]; rewrite eq_m_m'.
+ move=> e c ihc m.
  pose P := ([pred m' | `[< eqon (~ mod c)%A m m' >]])%A.
  pose Q := ([pred m' | `[< eqon (~ mod c)%A m m' >]] /\ `[{~~ e}])%A.
  apply (phl_conseq (P2 := P) (Q2 := Q)).
  + by move=> m' /eqP <-; apply /asboolP.
  + by move=> m' /andP [].
  apply/phl_while=> m1 /andP[] /asboolP Hm1 _.
  apply: (@range_weaken _ [pred m' | `[< eqon (~ mod c)%A m1 m' >]]).
  + move=> x /asboolP eq_m1_x; apply/asboolP=> z Hz.
    by rewrite Hm1 // eq_m1_x.
  by apply (ihc m1)=> //=.
+ move=> c1 ih1 c2 ih2 m; eapply phl_seq; first by apply (ih1 m).
  move=> m1 /asboolP Hm1.
  apply: (@range_weaken _ [pred m' | `[< eqon (~ mod c2)%A m1 m' >]]).
  + move=> x /asboolP Hx; apply/asboolP=> z /=.
    by case/norP => [/= zc1 zc2]; rewrite Hm1 // Hx.
  by apply (ih2 m1) => /=.
Qed.

(* -------------------------------------------------------------------- *)
Lemma modll c mu m : lossless predT c ->
  \P_[mu]         [pred m' | `[<eqon (predC (mod c)) m m'>] ] =
  \P_[dssem c mu] [pred m' | `[<eqon (predC (mod c)) m m'>] ].
Proof.
move=> ll; rewrite pr_dlet pr_exp; apply/eq_exp => m' _.
apply/esym; rewrite !inE; case/boolP: (X in (_ X)%:R) => /= /asboolP h.
+ pose P := [pred m' | `[< eqon (~ mod c)%A m m' >]]; suff: phl P c P.
  - by move=> Hr; rewrite (phl_ll Hr) ?ll //; apply/asboolP.
  move=> m''; rewrite !inE => /asboolP eqm''.
  apply: (range_weaken (P1 := [pred m' | `[< eqon (~ mod c)%A m'' m' >]])).
  + by move=> m3 /asboolP eqm3; apply/asboolP; rewrite eqm''.
  by apply/mod_spec; rewrite inE.
+ rewrite (eq_in_pr (B := pred0)) ?pr_pred0 // => m''.
  move/mod_spec=> /(_ _ (eqxx _)) => /asboolP eq_m'_m''.
  by apply/asboolPn => eq_m_m''; apply/h; rewrite eq_m'_m''.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                               lemma_free.v                               *)
(****************************************************************************)

Section lemma_free.

Require Export gc.

Lemma gcfree_nowhite :
 forall s t : state,
 (forall n : node, mk s n <> white) ->
 gc_free s t -> forall n : node, mk t n <> white.

intros s t H_white gcfree; elim gcfree; clear gcfree.
intros ctls ctlt H_grey heap m mksm; absurd (mk s m = white); auto.
Qed.

Lemma gcfree_nogrey :
 forall s t : state,
 (forall n : node, mk s n <> grey) ->
 gc_free s t -> forall n : node, mk t n <> grey.

intros s t H_grey gcfree; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm H; elim H; clear H.
intros mark mktm n; elim (eq_dec_node n m).
intro neqm; rewrite neqm; intro mktn; absurd (mk t m = free); auto.
rewrite mktn; discriminate.
intro ndifm; rewrite <- (mark n ndifm); auto.
Qed.

Lemma updatecolor_blacks_blackt :
 forall s t : state,
 (forall n : node, mk s n <> grey) ->
 forall m : node,
 mk s m = white ->
 update_color (mk s) (mk t) free m ->
 forall n : node, mk s n = black -> mk t n = black.

intros s t H_col m mksm mark n mksn; elim mark; clear mark.
intros mark mktm; rewrite <- (mark n); auto.
apply (noteqmar_noteqnod (mk s) n m); rewrite mksn; rewrite mksm;
 discriminate.
Qed.

Lemma gcfree_blacks_blackt :
 forall s t : state,
 gc_free s t -> forall n : node, mk s n = black -> mk t n = black.

intros s t gcfree n mksn; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm mark;
 apply (updatecolor_blacks_blackt s t) with (m := m);
 auto.
Qed.

Lemma gcfree_notblacks_notblackt :
 forall s t : state,
 gc_free s t -> forall n : node, mk s n <> black -> mk t n <> black.

intros s t gcfree n mksn; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm upd_col; elim upd_col; clear upd_col.
intros mark mktm; elim (eq_dec_node n m).
intro neqm; rewrite neqm; rewrite mktm; discriminate.
intro ndifm; rewrite <- (mark n ndifm); assumption.
Qed.

Lemma gcfree_accest_access :
 forall s t : state,
 gc_free s t ->
 forall n : node, accessible node (hp t) rt n -> accessible node (hp s) rt n.

intros s t gcfree n acces_t_n; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm mark; rewrite <- heap; assumption.
Qed.

Lemma gcfree_notaccess_notaccest :
 forall (s t : state) (n : node),
 ~ accessible node (hp s) rt n ->
 gc_free s t -> ~ accessible node (hp t) rt n.

intros s t n notacces_n_s gcfree; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm upd_col; rewrite heap; assumption.
Qed.

Lemma gcfree_notgreys_notgreyt :
 forall s t : state,
 gc_free s t -> forall n : node, mk s n <> grey -> mk t n <> grey.

intros s t gcfree n mksn; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm mark; elim mark; clear mark.
intros mark mktm; elim (eq_dec_node n m).
intro neqm; rewrite neqm; rewrite mktm; discriminate.
intro ndifm; rewrite <- (mark n ndifm); assumption.
Qed.

Lemma gcfree_greys_greyt :
 forall s t : state,
 gc_free s t -> forall n : node, mk s n = grey -> mk t n = grey.

intros s t gcfree n mksn; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm mark; absurd (mk s n = grey); auto.
Qed.

End lemma_free.

Hint Resolve gcfree_blacks_blackt.
Hint Resolve gcfree_notaccess_notaccest.
Hint Resolve gcfree_notgreys_notgreyt.
Hint Resolve gcfree_nowhite.
Hint Resolve gcfree_nogrey.


From Undecidability.L Require Import Tactics.LTactics Functions.Encoding Prelim.LoopSum Functions.LoopSum Functions.UnboundIteration.
Require Import Nat.
From Undecidability.L.Datatypes Require Import LTerm LProd.
From Undecidability.L.Datatypes Require Import Lists.

(* ** Extracted size of terms *)

(* Instance term_size' : computable size'. *)
(* Proof. *)
(*   extract. *)
(* Abort. (*possible, but the run time of this implementation is not good enough. *) *)

Lemma size'_surj : surjective size'.
Proof.
  intros n. induction n.
  -exists (var 0). cbn. lia.
  -destruct IHn as [x <-].
   exists (lam x). cbn. easy.
Qed.

Import Util.L_facts.
Definition sizeTR' '(stack,res) : (list term * nat) + nat :=
  match stack with
    [] => inr res
  | s::stack =>
    match s with
      var n => inl (stack,S (n + res))
    | app s t => inl (s::t::stack,S res)
    | lam s => inl (s::stack,S res)
    end
  end.

Fixpoint sizeTR'_fuel (s:term) : nat :=
  match s with
    var _ => 1
  | app s t => 1 + (sizeTR'_fuel s + sizeTR'_fuel t)
  | lam s => 1 + sizeTR'_fuel s
  end.

Lemma sizeTR'_correct stack res s k:
  loopSum (sizeTR'_fuel s + k) sizeTR' (s::stack,res)
  = loopSum k sizeTR' (stack,size s + res).
Proof.
  induction s in res,stack,k |- *.
  all:cbn.
  -reflexivity.
  -rewrite <- !Nat.add_assoc. cbn.
   rewrite IHs1, IHs2. easy.
  -rewrite IHs. easy.
Qed.

Lemma sizeTR_correct s:
  loopSum (sizeTR'_fuel s + 1) sizeTR' ([s],0) = Some (size s).
Proof.
  rewrite sizeTR'_correct. cbn. easy.
Qed.

#[global]
Instance termT_sizeTR' : computableTime' sizeTR'
                                           (fun x _ => (let '(stack,res) := x in
                                                    match stack with
                                                      var n ::_ =>  n*11
                                                    | _ => 0
                                                    end + 35,tt)).
Proof.
 extract. solverec. unfold LNat.c__add1, LNat.add_time, LNat.c__add. nia.
Qed.

Lemma sizeTR'_fuel_leq_size s : sizeTR'_fuel s <= size s.
Proof.
  induction s;cbn [size sizeTR'_fuel];try Lia.lia.
Qed.

Global
Instance termT_size : computableTime' size (fun s _ => (108 * size s + 50,tt)).
Proof.
  eexists.
  eapply computesTime_timeLeq.

  2:{ unshelve (eapply uiter_total_instanceTime with (1 := sizeTR_correct) (preprocessT:=(fun _ _ => (5,tt)))).
      extract. solverec.
  }
  split. 2:exact Logic.I.
  cbn [fst].
  erewrite uiterTime_bound_recRel with (iterT := fun _ '(stack,res) => ((sumn (map size stack)) * 108
                                                                   + 35 + 9))
                                       (P:= fun n x => True).
  { cbn [length map sumn]. Lia.lia. }
  {intros n [stack res] H. cbn.
   destruct stack as [|[[]| |]].
   2-5:split;[easy|].
   all:cbn [length map sumn sizeTR'_fuel size];try Lia.lia.
  }
  all:easy.
Qed.


Require Export maps.
Require Export ZArith.
Require Export List.

Open Scope list_scope.

Definition loc : Set := Z.
Inductive val : Set :=
 | Closure (body : exp) (context : env)
 | Num : nat -> val
 | Addr : loc -> val
 | Pair : val -> val -> val
 (* Primitive functions *)
 | Inc | Dec | Plus | Plus1 (x:nat)
 | Eq | Eq1 (a:val)
 | Nil | Cons | Cons1 (a:val) | Car | Cdr
with exp : Set :=
 | App (f x : exp)
 | Lit (v : val)
 | Var (ix : nat)
 | Lam (body : exp)
 | Closed (e : exp)
 | If (c t e : exp)
 | Seq (a b : exp)
 | Ref (e : exp) | Dealloc (v : exp)
 | Deref (e : exp) | Assign (v : exp) (e : exp)
with env : Set := Env : list val -> env.

Coercion App : exp >-> Funclass.
Coercion Lit : val >-> exp.

Definition Let := (Lam (Lam ((Var 0) (Var 1)))).
Definition strict_worker : exp := (Var 1)
  ((Closed (Lam (Lam (((Var 1) (Var 1)) (Var 0))))) (Var 0)).
Definition strict_fix : exp :=
  Closed (Lam ((Lam ((Var 0) (Var 0))) (Lam strict_worker))).

Local Ltac eq_assums := pose eq_nat_dec;pose Z_eq_dec;
   pose list_eq_dec;decide equality.
Fixpoint val_eq_dec (x y:val) : {x=y}+{x<>y}
with exp_eq_dec (x y:exp) : {x=y}+{x<>y}
with env_eq_dec (x y:env) : {x=y}+{x<>y}.
eq_assums. eq_assums. eq_assums.
Defined.

Inductive control : Set := Val (v : val)
                         | Exp (e : exp) (env : env).

Inductive cont : Set :=
    Top
  | AppFun (e' : exp) (scope : env) (k : cont) (* app fun [] e' *)
  | AppArg (v' : val) (k : cont)               (* app arg v' [] *)
  | RefVal (k : cont)                          (* ref [] *)
  | SeqCtx (e : exp) (scope : env) (k : cont)  (* [] ; e *)
  | DerefTgt (k : cont)                        (* ! [] *)
  | AssignTgt (e : exp) (scope : env) (k : cont) (* [] := e *)
  | AssignVal (l : loc) (k : cont)               (* l := [] *)
  | DeallocCtx (k : cont)                      (* dealloc [] *)
  | IfCond (t e : exp) (scope : env) (k : cont).

Inductive cfg : Set :=
  Cfg {code:control
      ;heap:Map loc val
      ;mark:loc
      ;ctx:cont}.

Fixpoint get (ix : nat) {A} (l : list A) : option A :=
  match ix, l with
    | _, nil => None
    | O, cons v _ => Some v
    | S ix', cons _ l' => get ix' l'
  end.
Definition getEnv (ix : nat) (p : env) :=
  match p with
    | Env l => get ix l
  end.
Definition extend (x : val) (p : env) : env :=
  match p with
    | Env l => Env (x :: l)
  end.

Definition apply (f : val) (v : val) : option control :=
  match f with
    | Closure e p' => Some (Exp e (extend v p'))
    | Inc => match v with
      | Num n => Some (Val (Num (S n)))
      | _ => None
      end
    | Dec => match v with
      | Num n => Some (Val (Num (pred n)))
      | _ => None
      end
    | Plus => match v with
      | Num n => Some (Val (Plus1 n))
      | _ => None
      end
    | Plus1 x => match v with
      | Num n => Some (Val (Num (x+n)))
      | _ => None
      end
    | Eq => Some (Val (Eq1 v))
    | Eq1 x => Some (if val_eq_dec x v then Val (Num 0)
                                       else Val Nil)
    | Cons => Some (Val (Cons1 v))
    | Cons1 a => Some (Val (Pair a v))
    | Car =>
      match v with
        | Pair a _ => Some (Val a)
        | _ => None
      end
    | Cdr =>
      match v with
        | Pair _ b => Some (Val b)
        | _ => None
      end
    | Pair _ _ => None
    | Nil => None
    | Num _ => None
    | Addr _ => None
  end.

Definition isNil v :=
  match v with
    | Nil => true
    | _ => false
  end.

Inductive lam_step : cfg -> cfg -> Prop :=
  | enter_function : forall e0 e1 p s m k,
      lam_step (Cfg (Exp (App e0 e1) p) s m k)
               (Cfg (Exp e0 p)          s m (AppFun e1 p k))
  | enter_argrgument : forall v s e p m k,
      lam_step (Cfg (Val v)   s m (AppFun e p k))
               (Cfg (Exp e p) s m (AppArg v k))
  | eval_call : forall v s f k m r, apply f v = Some r ->
       lam_step (Cfg (Val v) s m (AppArg f k))
                (Cfg r       s m k)
  | eval_lit : forall v p s m k,
      lam_step (Cfg (Exp (Lit v) p) s m k)
               (Cfg (Val v)         s m k)
  | eval_lam : forall e p s m k,
      lam_step (Cfg (Exp (Lam e) p)     s m k)
               (Cfg (Val (Closure e p)) s m k)
  | eval_var : forall i p v s m k, get i p = Some v ->
      lam_step (Cfg (Exp (Var i) (Env p)) s m k)
               (Cfg (Val v)               s m k)
  | enter_seq : forall e e' p s m k,
      lam_step (Cfg (Exp (Seq e e') p) s m k)
               (Cfg (Exp e p)          s m (SeqCtx e' p k))
  | eval_seq : forall v e p s m k,
      lam_step (Cfg (Val v)   s m (SeqCtx e p k))
               (Cfg (Exp e p) s m k)
  | enter_if : forall c t e p s m k,
      lam_step (Cfg (Exp (If c t e) p) s m k)
               (Cfg (Exp c p)          s m (IfCond t e p k))
  | eval_if_nil : forall v s t e p m k, isNil v = true ->
      lam_step (Cfg (Val v)   s m (IfCond t e p k))
               (Cfg (Exp e p) s m k)
  | eval_if_nonnil : forall v s t e p m k, isNil v = false ->
      lam_step (Cfg (Val v)   s m (IfCond t e p k))
               (Cfg (Exp t p) s m k)
  | enter_ref : forall e p s m k,
      lam_step (Cfg (Exp (Ref e) p) s m k)
               (Cfg (Exp e p)       s m (RefVal k))
  | eval_ref : forall v s m k,
      lam_step (Cfg (Val v)         s            m   (RefVal k))
               (Cfg (Val (Addr m)) (m|->v :* s) (m+1) k)%Z
  | enter_dealloc : forall e p s m k,
      lam_step (Cfg (Exp (Dealloc e) p) s m k)
               (Cfg (Exp e p)           s m (DeallocCtx k))
  | eval_dealloc : forall l s x s' m k, s ~= l|->x :* s' ->
      lam_step (Cfg (Val (Addr l)) s  m (DeallocCtx k))
               (Cfg (Val Nil)      s' m k)
  | enter_deref : forall e p s m k,
      lam_step (Cfg (Exp (Deref e) p) s m k)
               (Cfg (Exp e p)         s m (DerefTgt k))
  | eval_deref : forall l v s s' m k, s ~= l|->v :* s' ->
      lam_step (Cfg (Val (Addr l)) s m (DerefTgt k))
               (Cfg (Val v)        s m k)
  | enter_assign_target : forall t e p s m k,
      lam_step (Cfg (Exp (Assign t e) p) s m k)
               (Cfg (Exp t p)            s m (AssignTgt e p k))
  | enter_assign_val : forall l p e' s m k,
      lam_step (Cfg (Val (Addr l)) s m (AssignTgt e' p k))
               (Cfg (Exp e' p)     s m (AssignVal l k))
  | eval_assign : forall l v s w s' m k, s ~= l|->w :* s' ->
      lam_step (Cfg (Val v) s             m(AssignVal l k))
               (Cfg (Val v) (l|->v :* s') m k)
  | close_exp : forall e v s m k,
      lam_step (Cfg (Exp (Closed e) v)        s m k)
               (Cfg (Exp  e        (Env nil)) s m k).


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_low_nil_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  subtype T1 t_nil = false.
Proof.
  intros.

  remember (subtype T1 t_bot) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import Rels.
Require Import Classical.
Require Import Epsilon.
Require Import Utf8.

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

Section noetherian.

Variable A : Type.
Variable leA : relation A.

Definition noetherian :=
  forall c : nat -> A, ~ (forall i, leA (c (S i)) (c i)).

Definition not_acc_inv (x : {n | ~ Acc leA n})
  : {n | leA n (proj1_sig x) /\ ~ Acc leA n}.
Proof.
destruct x as [x Hx].
apply constructive_indefinite_description.
apply not_all_not_ex.
intros H.
assert (Habs : Acc leA x).
{ apply Acc_intro. intros y Hy.
  specialize H with y. tauto. }
easy.
Defined.

Lemma not_acc_inv_leA (x : {n | ~ Acc leA n}) :
  let a := not_acc_inv x in
    leA (proj1_sig a) (proj1_sig x).
Proof.
destruct x as [x Hx].
simpl.
unfold not_acc_inv.
assert (Htmp :=
        proj2_sig (
          (constructive_indefinite_description
           _
           (not_all_not_ex A (λ n : A, leA n x ∧ ¬Acc leA n)
              (λ H : ∀ n : A, ¬(leA n x ∧ ¬Acc leA n),
               False_ind False
                 (Hx
                    (Acc_intro x
                       (λ (y : A) (Hy : leA y x),
                        NNPP (Acc leA y)
                          (λ H0 : ¬Acc leA y,
                           False_ind False (H y (conj Hy H0))))))))))).
now simpl in Htmp.
Qed.

Definition not_acc_chain (x : {n | ~ Acc leA n})
  : nat -> {k | ~ Acc leA k}.
Proof.
destruct x as [x Hx].
intros n. induction n as [| n IHn].
- now exists x.
- idtac.
  exists (proj1_sig (not_acc_inv IHn)).
  assert (Htmp := proj2_sig (not_acc_inv IHn)).
  now simpl in Htmp.
Defined.

Lemma not_acc_chain_0 (x : {n | ~ Acc leA n}) :
  let c := not_acc_chain x in
    c 0 = x.
Proof. now destruct x as [x Hx]. Qed.

Lemma not_acc_chain_S (x : {n | ~ Acc leA n}) k :
  let c := not_acc_chain x in
    proj1_sig (c (S k)) =
      proj1_sig (not_acc_inv (c k)).
Proof. now destruct x as [x Hx]. Qed.

Lemma not_acc_chain_chain (x : {n | ~ Acc leA n}) :
  let c := not_acc_chain x in
    forall i, leA (proj1_sig (c (S i))) (proj1_sig (c i)).
Proof.
intros c i. unfold c. rewrite not_acc_chain_S.
generalize (not_acc_chain x i).
intros a.
now apply not_acc_inv_leA.
Qed.

(* <- is provable classically *)
Theorem wf_noetherian :
  well_founded leA <-> noetherian.
Proof.
split.
- intros Hwf.
  pose (P := fun x:A =>
               forall c,
                 ~ (c 0 = x /\ forall i, leA (c (S i)) (c i))).
  cut (forall x:A, P x).
  { unfold P. intros H c. specialize H with (c 0) c.
    now firstorder. }
  apply well_founded_ind with (R:=leA); auto.
  intros x Hx. unfold P.
  intros c [? Hc]; subst x.
  specialize Hx with (c 1).
  assert (H1 : P (c 1)) by firstorder.
  clear Hx.
  unfold P in H1.
  specialize H1 with (fun i => c (S i)).
  simpl in H1.
  now intuition.
- idtac. intros Hnoe.
  destruct (classic (well_founded leA)) as [? | Hnwf]; auto.
  unfold well_founded in Hnwf.
  apply not_all_ex_not in Hnwf.
  destruct Hnwf as [x Hx].
  assert (e : {x | ~ Acc leA x}) by (exists x; auto).
  pose (c := fun i => proj1_sig (not_acc_chain e i)).
  assert (Hc : forall i, leA (c (S i)) (c i))
    by (apply not_acc_chain_chain).
  now apply Hnoe in Hc.
Qed.

End noetherian.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B P Q T R X : Universe, ((wd_ A B /\ (wd_ B R /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ B P /\ (wd_ A P /\ (col_ A B T /\ (col_ A B X /\ (col_ A B R /\ (col_ R X P /\ (col_ T X B /\ (col_ B R Q /\ col_ Q T P)))))))))))) -> col_ B A Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import NArith.
Require Import List.
Require Import AssocList.
Require Import Bool.

Section MappingDB.
Variable kernel_object : Type.

Section Def.

  Definition mapping_db : Type := assoc_list (assoc_list kernel_object).

  Definition has_mapping (pd:N) (sel:N) (ko:kernel_object) : mapping_db -> Prop :=
    contains pd (In (sel,ko)).

  Definition in_mapping_db (pd:N) (sel:N) : mapping_db -> Prop :=
    contains pd (in_domain sel).

End Def.

Section Create.

  Definition create_mapping (pd:N) (sel:N) (ko:kernel_object) :
    mapping_db -> mapping_db :=
    al_insert_merge pd (al_insert sel ko) (al_insert sel ko al_empty).

  Theorem create_has_mapping :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object),
      has_mapping pd sel ko (create_mapping pd sel ko db).
  Proof.
    Hint Resolve insert_In In_contains.
    intros db pd sel ko. unfold has_mapping. unfold create_mapping.
    apply insert_merge_contains; simpl; eauto.
  Qed.

  Lemma ineq_2_dec :
    forall (a a' b b':N), (a <> a' \/ b <> b') -> (a <> a' \/ (a = a' /\ b <> b')).
  Proof.
    intros a a' b b' H. destruct (N.eq_dec a a'); tauto.
  Qed.

  Theorem create_preserve_other :
    forall (db:mapping_db) (pd pd':N) (sel sel':N) (ko ko':kernel_object),
      (pd' <> pd \/ sel' <> sel) -> al_invariant db ->
      (has_mapping pd sel ko db
       <-> has_mapping pd sel ko (create_mapping pd' sel' ko' db)).
  Proof.
    Hint Resolve <- insert_preserve_other insert_merge_preserve_other.
    Hint Resolve -> insert_preserve_other insert_merge_preserve_other.
    Hint Resolve insert_In In_contains In_in_domain al_invariant_in_eq.
    intros db pd pd' sel sel' ko ko' ineq inv_db. apply ineq_2_dec in ineq.
    unfold has_mapping. unfold create_mapping. destruct ineq as [H|[? H]].
    - split;
      destruct 1 as [pd_mappings [in_db in_pd]];
      eapply insert_merge_preserve_other in in_db; eauto.
    - subst. split.
      + destruct 1 as [pd_mappings [in_db in_pd]]. apply insert_merge_contains.
        * intros. exfalso. eauto.
        * intros. replace v with pd_mappings by eauto. eauto.
      + destruct 1 as [pd_mappings [in_created in_pd]].
        apply In_insert_merge_inv in in_created as [[? ?] | [? [? ?]]];
          subst;
          try (apply insert_preserve_other in in_pd);
          eauto.
  Qed.

End Create.

Section Delete.

  Definition delete_mapping (pd:N) (sel:N) : mapping_db -> mapping_db :=
    al_update pd (al_remove sel).

  Theorem delete_deletes_mapping :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object),
      (forall k x, In (k,x) db -> al_invariant x) ->
      al_invariant db -> ~has_mapping pd sel ko (delete_mapping pd sel db).
  Proof.
    Hint Unfold not.
    Hint Resolve remove_not_in In_in_domain.
    intros db pd sel ko inv inv_l. unfold delete_mapping. unfold has_mapping.
    destruct 1 as [pdv [pd_in sel_in]].
    apply In_update_inv in pd_in as [x [in_db rm_eq]];
      try (eapply remove_not_in with (l := x));
      subst; eauto.
  Qed.

  Theorem delete_preserve_other :
    forall (db:mapping_db) (pd pd':N) (sel sel':N) (ko:kernel_object),
      al_invariant db ->
      (forall k x, In (k,x) db -> al_invariant x) ->
      (pd' <> pd \/ sel <> sel') ->
      (has_mapping pd sel ko db <-> has_mapping pd sel ko (delete_mapping pd' sel' db)).
  Proof.
    Hint Resolve -> update_preserve_other remove_preserve_other.
    Hint Resolve <- update_preserve_other remove_preserve_other.
    Hint Resolve update_updates.
    intros db pd pd' sel sel' ko inv_db inv_all ineq. apply ineq_2_dec in ineq.
    unfold has_mapping. unfold contains. unfold delete_mapping.
    destruct ineq as [H|[pd_eq sel_ineq]].
    - split; destruct 1; intuition eauto.
    - subst. split; destruct 1 as [pdm [in_db in_pdm]].
      + eauto.
      + apply In_update_inv in in_db as [? [? ?]]; subst; eauto.
  Qed.

End Delete.

Section DeleteAll.

  Definition delete_all_except
             (f:kernel_object -> bool)
             (exceptions:assoc_list (list N))
             : mapping_db -> mapping_db :=
    al_map
      (fun pd pdm =>
         match al_assoc pd exceptions with
           | None     => al_filter (fun _ x => negb (f x)) pdm
           | Some exc => al_filter
                           (fun sel x => negb (andb
                                                 (f x)
                                                 (negb (existsb (N.eqb sel) exc))))
                           pdm
         end).

  Theorem delete_all_except_deletes :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object) (f:kernel_object -> bool)
           (exceptions:assoc_list (list N)),
      has_mapping pd sel ko (delete_all_except f exceptions db) ->
      f ko = false \/ contains pd (In sel) exceptions.
  Proof.
    Hint Resolve assoc_In.
    intros db pd sel ko f exceptions. unfold has_mapping.
    unfold delete_all_except. unfold contains. destruct 1 as [pdm [in_map in_pdm]].
    apply In_map_iff in in_map as [pdm' [pdm_pdm' pdm'_in_db]].
    destruct (al_assoc pd exceptions) eqn:A;
      subst pdm; apply filter_predicate_true in in_pdm;
      apply negb_true_iff in in_pdm.
    - apply andb_false_iff in in_pdm. destruct in_pdm as [H|H].
      + tauto.
      + apply negb_false_iff in H. apply existsb_exists in H as [sel' [in_l E]].
        apply Neqb_ok in E. subst. eauto.
    - eauto.
  Qed.

  Theorem delete_all_except_preseve_other :
  forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object) (f:kernel_object -> bool)
         (exceptions:assoc_list (list N)),
    f ko = false ->
    (has_mapping pd sel ko db <->
     has_mapping pd sel ko (delete_all_except f exceptions db)).
  Proof.
    intros db pd sel ko f exceptions ffalse. unfold delete_all_except.
    split.
    - unfold has_mapping. unfold contains.
      destruct 1 as [pdm [in_db in_pdm]]. destruct (al_assoc pd exceptions) eqn:A;
        eexists; (split;
          [ apply In_map_iff; rewrite A; eauto
          | apply al_filter_In; rewrite negb_true_iff; rewrite ffalse; simpl; auto
          ]).
    - unfold has_mapping. unfold contains. destruct 1 as [pdm [in_map in_pdm]].
      apply In_map_iff in in_map. destruct in_map as [pdm' [pdm_pdm' in_db]].
      destruct (al_assoc pd exceptions);
        subst pdm; apply al_filter_In in in_pdm; destruct in_pdm; eauto.
  Qed.

End DeleteAll.

End MappingDB.


Require Import Reals Psatz Omega.
Local Open Scope R_scope.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import pival_dist pival ival ival_dist.
Require Import stdpp.tactics.

Definition singleton {X} (I: ivdist X) : pidist X.
Proof.
  unshelve (econstructor).
  { refine {| choices := λ I', ivd_ival I = I' |}.
    abstract (eexists; eauto). }
  - abstract (intros I' <-; apply val_sum1).
Defined.

Definition In_pidist {X} (I: ivdist X) (Is: pidist X) : Prop :=
  ∃ I', eq_ival I I' ∧ In I' Is.

Lemma In_pidist_le_singleton {X} (I: ivdist X) Is:
  In_pidist I Is ↔ le_pidist (singleton I) Is.
Proof.
  split.
  - rewrite /In_pidist/singleton//=. intros Hin I' <-. eauto.
  - rewrite /In_pidist/singleton/le_pidist/le_pival//=.
    intros Hle. apply Hle.
    rewrite /In. done.
Qed.

Global Instance singleton_proper X : Proper (@eq_ivd X ==> @eq_pidist X) singleton.
Proof.
  intros Is1 Is2 Heq.
  rewrite /eq_pidist/eq_pival; split.
  - intros ? <-.
    exists Is2. split; first done.
    done.
  - intros ? <-.
    exists Is1. split; first by (symmetry).
    done.
Qed.

Transparent pidist_ret.
Lemma singleton_mret {X} (x: X) : eq_pidist (singleton (mret x)) (mret x).
Proof.
  rewrite //=/singleton/base.mret//=/pidist_ret//=/base.mret//=.
  split.
  - intros I <-. subst.
    eexists; split; last first.
    { eexists. }
    rewrite //=.
    unshelve (eexists); first by eauto.
    unshelve (eexists); first by eauto.
    repeat split => //=.
  - intros I ->. subst.
    eexists; split; last first.
    { eexists. }
    rewrite //=.
    unshelve (eexists); first by eauto.
    unshelve (eexists); first by eauto.
    repeat split => //=.
Qed.

Lemma singleton_bind {X Y} (I: ivdist X) (f: X → ivdist Y) :
  eq_pidist (singleton (mbind f I)) (x ← singleton I; singleton (f x)).
Proof.
  split.
  - intros ? <-; subst.
    edestruct (pival_mbind_in (singleton I) (λ x, singleton (f x))
                              I (λ i, f (ind I i)))
      as (Ib&pf&Heq&Hin); eauto.
    * done.
    * intros. done.
  - intros I' Hin.
    apply pival_mbind_in_inv in Hin as (Ix&h&Hhgt0&Hin&Hin'&?).
    eexists; split; last first;
    rewrite /In/singleton//= in Hin. subst.
    etransitivity; first by (symmetry; eauto).

    eapply eq_ival_nondep_option_suffice.
    unshelve (eexists).
    {
      intros (i&ih).
      destruct (Rgt_dec (val I i) 0) as [Hgt|Hngt].
      * assert (h i = f (ind I i)) as Heq.
        {
          feed pose proof (Hin' i); eauto.
        }
        apply Some.
        exists i. rewrite -Heq. exact ih.
      * exact None.
    }
    unshelve (eexists).
    {
      intros (i&ifx).
      destruct (Rgt_dec (val I i) 0) as [Hgt|Hngt].
      * assert (h i = f (ind I i)) as Heq.
        {
          feed pose proof (Hin' i); eauto.
        }
        apply Some.
        exists i. rewrite Heq. exact ifx.
      * exact None.
    }
    repeat split => //=.
    * intros (i&ifx) => //=.
      intros Hgt. destruct Rgt_dec => //=; last first.
      { specialize (val_nonneg (f (ind I i)) ifx). nra. }
      match goal with
      | [ |- context [ eq_rect_r _ _ ?Hpf ] ] => destruct Hpf => //=
      end.
    * intros (i&ih) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { intros. specialize (val_nonneg (h i) ih). nra. }
      intros Hgt1 => ->.
      f_equal. f_equal.
      rewrite rew_opp_l. done.
    * intros (i&ifx) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { specialize (val_nonneg (f (ind I i)) ifx). intros. nra. }
      intros Hgt1 => ->.
      f_equal. f_equal.
      rewrite rew_opp_r. done.
    * intros (i&ih) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { intros. specialize (val_nonneg (h i) ih). nra. }
      intros Hgt1 ?. rewrite //=.
      destruct (Hin' i Hgt1) => //=.
    * intros (i&ih) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { intros. specialize (val_nonneg (h i) ih). nra. }
      intros Hgt1 ?. rewrite //=.
      destruct (Hin' i Hgt1) => //=.
Qed.

Lemma singleton_plus {X} p Hpf (I1 I2: ivdist X) :
  eq_pidist (singleton (ivdplus p Hpf I1 I2)) (pidist_plus p Hpf (singleton I1) (singleton I2)).
Proof.
  split.
  - intros ? <-.
    eexists; split; eauto.
    { rewrite //=/pidist_plus//=/pplus_aux/In//=.
      do 2 eexists; split_and!; eauto;
      rewrite /pscale_aux;  eexists; split; eauto; done.
    }
  - intros ? (?&?&Hin1&Hin2&->).
    eexists; split; eauto.
    rewrite /singleton//=/In.
    f_equal.
    * rewrite /pscale/pscale_aux//= in Hin1.
      firstorder.
    * rewrite /pscale/pscale_aux//= in Hin2.
      firstorder.
Qed.


(** * Adámek's theorem

The main result is Adámek's theorem for constructing terminal coalgebras of
omega-continuous functors which is used to construct coinductive types.

Written by: Kobe Wullaert, 2022
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.MoreFoundations.Propositions.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.FunctorCoalgebras.

Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Cochains.

Local Open Scope cat.

Section lim_terminal_coalgebra.

Context {C : category} (TerminalC : Terminal C).
Context {F : functor C C} (HF : is_omega_cont F).

Let Fcochain : cochain C := termCochain TerminalC F.

Variable (CC : LimCone Fcochain).

Let L : C := lim CC.
Let FFcochain : cochain C := mapcochain F Fcochain.
Let Fa : cone FFcochain (F L) := mapcone F _ (limCone CC).

Let FHC' : isLimCone FFcochain (F L) Fa :=
      HF Fcochain L (limCone CC) (isLimCone_LimCone CC).
Let FHC : LimCone FFcochain := make_LimCone _ _ _ FHC'.

Local Definition shiftCone : cone FFcochain L.
Proof.
use make_cone.
- intro n; apply (coneOut (limCone CC) (S n)).
- intros m n e ; destruct e.
  refine (_ @ coneOutCommutes (limCone CC) _ (S n) (idpath _)).
  apply maponpaths.
  simpl.
  rewrite ! idpath_transportf.
  rewrite ! id_left.
  apply idpath.
Defined.

Local Lemma unshiftCone_forms_cone {x : C} ( cc : cone FFcochain x)
  :  forms_cone Fcochain (λ n : vertex conat_graph,
     nat_rect (λ n0 : nat, C ⟦ x, dob Fcochain n0 ⟧) (TerminalArrow TerminalC x)
              (λ (n0 : nat) (_ : C ⟦ x, dob Fcochain n0 ⟧), coneOut cc n0) n).
Proof.
  intros m n e ; destruct e ; destruct n as [|n].
  - apply TerminalArrowUnique.
  - simpl.
    rewrite idpath_transportf ; rewrite id_left.
    rewrite (! coneOutCommutes cc _ n  (idpath _)).
    apply maponpaths.
    simpl.
    rewrite idpath_transportf, id_left.
    apply idpath.
Qed.

Local Definition unshiftCone (x : C) (cc : cone FFcochain x) : cone Fcochain x.
Proof.
use make_cone.
- intro n.
  induction n as [|n].
  + apply TerminalArrow.
  + apply (coneOut cc _).
- apply unshiftCone_forms_cone.
Defined.

Local Definition shiftIsLimCone : isLimCone FFcochain L shiftCone.
Proof.
intros x cc; simpl.
use tpair.
+ use tpair.
  * apply limArrow, (unshiftCone _ cc).
  * abstract (intro n; apply (limArrowCommutes CC x (unshiftCone x cc) (S n))).
+ abstract (intros p; apply subtypePath;
             [ intro f; apply impred; intro; apply homset_property
             | apply limArrowUnique; intro n;
               destruct n as [|n]; [ apply TerminalArrowUnique | apply (pr2 p) ]]).
Defined.

Local Definition shiftLimCone : LimCone FFcochain :=
  make_LimCone FFcochain L shiftCone shiftIsLimCone.

Definition lim_algebra_mor : C⟦L,F L⟧ := limArrow FHC L shiftCone.

Local Definition is_z_iso_lim_algebra_mor : is_z_isomorphism lim_algebra_mor :=
  isLim_is_z_iso _ FHC _ _ shiftIsLimCone.

Let α : z_iso L (F L) := make_z_iso' _ is_z_iso_lim_algebra_mor.
Let α_inv : z_iso (F L) L := z_iso_inv_from_z_iso α.
Let α_alg : coalgebra_ob F := tpair (λ X : C, C ⟦ X , F X⟧) L α.

Lemma unfold_inv_from_z_iso_α :
  inv_from_z_iso α = limArrow shiftLimCone _ (limCone FHC).
Proof.
apply idpath.
Qed.

(** Given a coalgebra:
<<
          a
      A ------> F A
>>
 we now define a coalgebra morphism ad:
<<
        a
    A ------>  F A
    |          |
    | ad       |
    |          |
    V   α      V
    L ------>  F L
>>

*)
Section coalgebra_mor.

Variable (Aa : coalgebra_ob F).

Local Notation A := (coalg_carrier _ Aa).
Local Notation a := (coalg_map _ Aa).

Local Definition cone_over_coalg (n : nat) : C ⟦ A, iter_functor F n TerminalC⟧.
Proof.
induction n as [|n Fn]; simpl.
- apply TerminalArrow.
- apply (a · #F Fn).
Defined.

(* a_n : F^n 0 -> A *)
Local Notation an := cone_over_coalg.

Lemma isConeOverCoalg {u v : nat} (e : S v = u) : an u · dmor Fcochain e = an v.
Proof.
  destruct e.
  induction v as [| n IHn].
  - apply TerminalArrowUnique.
  - simpl ; rewrite assoc' ; apply cancel_precomposition.
    etrans.
    2: { apply maponpaths ; exact IHn. }
    rewrite functor_comp.
    simpl.
    do 2 rewrite functor_comp.
    apply maponpaths.
    unfold dmor.
    cbn.
    rewrite ! id_left.
    apply idpath.
Qed.

(* ad = a† = a dagger *)
Local Definition ad : C⟦A,L⟧.
Proof.
apply limArrow.
use make_cone.
- apply cone_over_coalg.
- red ; intro ; intros ; apply isConeOverCoalg.
Defined.

Lemma ad_is_coalgebra_mor (n : nat) :  a · # F ad · inv_from_z_iso α · limOut CC n = an n.
Proof.
  destruct n as [|n].
  - now apply TerminalArrowUnique.
  - rewrite unfold_inv_from_z_iso_α.
    eapply pathscomp0.
    {
      rewrite assoc'.
      apply maponpaths.
      apply (limArrowCommutes shiftLimCone).
    }
    simpl; rewrite assoc', <- functor_comp.
    apply cancel_precomposition, maponpaths, (limArrowCommutes CC).
Qed.

Local Definition ad_mor : coalgebra_mor F Aa α_alg.
Proof.
  exists ad.
  abstract (apply pathsinv0, z_iso_inv_to_right, pathsinv0, limArrowUnique; simpl; intro n ; apply ad_is_coalgebra_mor).
Defined.

End coalgebra_mor.

Lemma limCoAlgIsTerminal_subproof (Aa : CoAlg_category F)
        (Fa' : coalgebra_mor F Aa α_alg) : Fa' = ad_mor Aa.
Proof.
  use total2_paths_f.
  2: { apply homset_property. }

  apply limArrowUnique ; intro n.
  destruct Fa' as [f hf]; simpl.
  unfold is_coalgebra_mor in hf; simpl in hf.
  induction n as [|n IHn]; simpl.
  - apply TerminalArrowUnique.
  - rewrite <- IHn, functor_comp, assoc.
    etrans.
    2: { apply cancel_postcomposition ; apply (! hf). }
    rewrite assoc'.
    apply maponpaths.
    apply (z_iso_inv_to_left _ _ _ α).
    apply (limArrowCommutes shiftLimCone).
Qed.

Lemma limCoAlgIsTerminal : isTerminal (CoAlg_category F) α_alg.
Proof.
  apply make_isTerminal; intros Aa.
  exists (ad_mor Aa).
  apply limCoAlgIsTerminal_subproof.
Defined.

Definition limCoAlgTerminal : Terminal (CoAlg_category F) :=
  make_Terminal _ limCoAlgIsTerminal.

End lim_terminal_coalgebra.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_R1.
Require Export XR_Rplus.

Local Open Scope R_scope.

Fixpoint INR (n:nat) : R :=
  match n with
  | O => R0
  | S O => R1
  | S n => INR n + R1
  end.
Arguments INR n%nat.
Arguments INR _ : simpl nomatch.


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.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func_Prop.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Adjunction.Adjunction Adjunction.Duality Adjunction.Adj_Facts.
From Categories Require Import KanExt.Global.

(** In this module we establish the dualit of kan extensions.
That is, the left kan extension along p is just the right kan extension along
pᵒᵖ and vice versa.
 *)
Section GlobalDuality.
  Context {C C' : Category} (p : (C –≻ C')%functor) (D : Category).

  (** We establish this duality though hom functor definition of adjunction. *)

  Local Obligation Tactic := idtac.

  Section Left_to_Right.
    Context (lke : Left_KanExt p D).

    (** The natural Isomorphism underlying the right kan extension which is to
        be shown.
        Hom_{Func_Cat Cᵒᵖ Dᵒᵖ}(– ∘ p, –) ≃ Hom_{Func_Cat C'ᵒᵖ Dᵒᵖ}(–, lkeᵒᵖ)
    *)
    Local Definition KanExt_Left_to_Right_NIso :=
      (
        (
          (
            ((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C' D))
               ∘_h (NatTrans_id_Iso
                      (Prod_Functor
                         (Functor_id ((Func_Cat C' D) ^op) ^op) (lke^op)))
            )
              ∘ (Hom_Adjunct_Duality (Adj_to_Hom_Adj (left_kan_ext_adj lke)))
          )
            ∘ (((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C D))⁻¹)
                 ∘_h (NatTrans_id_Iso
                        (Prod_Functor
                           (Left_Functor_Extender p D)
                           (Functor_id (Func_Cat C D) ^op))))
        )
          ∘_h (NatTrans_id_Iso
                 (Prod_Functor
                    ((inverse_morphism (Func_Cat_Op_Iso C' D))^op)
                    (inverse_morphism (Func_Cat_Op_Iso C D))
                 )
              )
      )%natiso
    .

    (** If we give the trans formations (e.g., function given in the first
        obligation) explicitly "Program" generates obligations for
        equalities that are definitional! *)

    Program Definition KanExt_Left_to_Right :
      Right_KanExt  (p^op) (D^op) :=
      {|
        right_kan_ext :=
          ((Op_Func_Cat_to_Func_Cat_Op C' D) ∘
          (lke^op ∘ (Func_Cat_Op_to_Op_Func_Cat C D)))%functor;
        right_kan_ext_adj :=
          Hom_Adj_to_Adj
            {|
              iso_morphism :=
                {|
                  Trans := _
                |};
              inverse_morphism :=
                {|
                  Trans := _
                |}
            |}
      |}.

    Next Obligation.
    Proof.
      exact (fun c => Trans (iso_morphism KanExt_Left_to_Right_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (iso_morphism KanExt_Left_to_Right_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      rewrite NatTrans_hor_comp_Op.
      repeat rewrite <- NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Left_to_Right_obligation_2.
    Qed.

    Next Obligation.
    Proof.
      exact (fun c => Trans (inverse_morphism KanExt_Left_to_Right_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (inverse_morphism KanExt_Left_to_Right_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      rewrite NatTrans_hor_comp_Op.
      repeat rewrite <- NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Left_to_Right_obligation_5.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   ((KanExt_Left_to_Right_NIso ⁻¹)
                      ∘ KanExt_Left_to_Right_NIso)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (left_inverse KanExt_Left_to_Right_NIso); trivial.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   (KanExt_Left_to_Right_NIso
                      ∘ KanExt_Left_to_Right_NIso⁻¹)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (right_inverse KanExt_Left_to_Right_NIso); trivial.
    Qed.

  End Left_to_Right.

  Section Right_to_Left.
    Context (rke : Right_KanExt p D).

    (** The natural Isomorphism underlying the right kan extension which is
        to be shown.

        Hom_{Func_Cat C'ᵒᵖ Dᵒᵖ}(rke, –) ≃ Hom_{Func_Cat Cᵒᵖ Dᵒᵖ}(–, – ∘ p)
     *)
    Local Definition KanExt_Right_to_Left_NIso :=
      (
        (
          (
            (
              (Hom_Func_Cat_Iso (Func_Cat_Op_Iso C D))
                ∘_h (
                  NatTrans_id_Iso
                    (Prod_Functor
                       (Functor_id ((Func_Cat C D) ^op) ^op)
                       ((Left_Functor_Extender p D)^op)
                ))
            )
              ∘ (Hom_Adjunct_Duality (Adj_to_Hom_Adj (right_kan_ext_adj rke)))
          )
            ∘ (
              ((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C' D))⁻¹)
                ∘_h (NatTrans_id_Iso
                       (Prod_Functor rke (Functor_id (Func_Cat C' D) ^op))))
        )
          ∘_h
          (NatTrans_id_Iso
             (Prod_Functor
                ((inverse_morphism (Func_Cat_Op_Iso C D))^op)
                (inverse_morphism (Func_Cat_Op_Iso C' D))
             )
          )
      )%natiso
    .

    Program Definition KanExt_Right_to_Left :
      Left_KanExt  (p^op) (D^op) :=
      {|
        left_kan_ext :=
          (
            (Op_Func_Cat_to_Func_Cat_Op C' D)
              ∘ (rke^op ∘ (Func_Cat_Op_to_Op_Func_Cat C D))
          )%functor;
        left_kan_ext_adj :=
          Hom_Adj_to_Adj
            {|
              iso_morphism :=
                {|
                  Trans := _
                |};
              inverse_morphism :=
                {|
                  Trans := _
                |}
            |}
      |}.

    Next Obligation.
    Proof.
      exact (fun c => Trans (iso_morphism KanExt_Right_to_Left_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (iso_morphism KanExt_Right_to_Left_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      repeat rewrite NatTrans_hor_comp_Op.
      repeat rewrite NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Right_to_Left_obligation_2.
    Qed.

    Next Obligation.
    Proof.
      exact (fun c => Trans (inverse_morphism KanExt_Right_to_Left_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (inverse_morphism KanExt_Right_to_Left_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      repeat rewrite NatTrans_hor_comp_Op.
      repeat rewrite NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Right_to_Left_obligation_5.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   ((KanExt_Right_to_Left_NIso ⁻¹)
                      ∘ KanExt_Right_to_Left_NIso)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (left_inverse KanExt_Right_to_Left_NIso); trivial.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   (KanExt_Right_to_Left_NIso
                      ∘ KanExt_Right_to_Left_NIso⁻¹)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (right_inverse KanExt_Right_to_Left_NIso); trivial.
    Qed.

  End Right_to_Left.

End GlobalDuality.


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.Notations.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Shift.
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.ZArith.ZArith.
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.Util.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 ?ii] => pattern (while t b l ii) end.
      eapply (while.by_invariant_fuel
                (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)))).
      { split.
        (* invariant holds in the beginning *)
        { cbn; split; [lia|split;[reflexivity|t]]. }
        { (* fuel <= measure *) cbn. rewrite Z.succ_pred. reflexivity. } }
      { 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.
        { split. (* 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]]]). } }
        { (* measure decreases *)
          cbv [Let_In]; break_match; cbn; rewrite Z.succ_pred; apply Znat.Z2Nat.inj_lt; lia. } }
        { (* if loop exited, invariant implies postcondition *)
          break_match; break_match_hyps; setoid_subst_rel Feq; fsatz. } }
    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_fuel
                (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 *) ).
      { split; cbn.
        { (* invariant holds in the beginning *)
          rewrite ?Z.succ_pred, ?Z.lt_pow_2_shiftr, <-?Z.one_succ by tauto.
          repeat split; [lia|t..]. }
        { (* sufficient fuel *) rewrite Z.succ_pred. reflexivity. } }
      { 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.
        split.
        { (* 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. }
        { (* measure decreases *)
          cbv [Let_In]; break_match; cbn; rewrite Z.succ_pred; apply Znat.Z2Nat.inj_lt; lia. }
        { (* 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. } }
    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 lia.
        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 lia.
        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.


Set Printing Universes.

Module unidecls.
  Universes a b.
End unidecls.

Universe a.

Constraint a < unidecls.a.

Print Universes.

(** These are different universes *)
Check Type@{a}.
Check Type@{unidecls.a}.

Check Type@{unidecls.b}.

Fail Check Type@{unidecls.c}.

Fail Check Type@{i}.
Universe foo.
Module Foo.
  (** Already declared globaly: but universe names are scoped at the module level  *)
  Universe foo.
  Universe bar.

  Check Type@{Foo.foo}.
  Definition bar := 0.
End Foo.

(** Already declared in the module *)
Universe bar.

(** Accessible outside the module: universe declarations are global *)
Check Type@{bar}.
Check Type@{Foo.bar}.

Check Type@{Foo.foo}.
(** The same *)
Check Type@{foo}.
Check Type@{Top.foo}.

Universe secfoo.
Section Foo'.
  Fail Universe secfoo.
  Universe secfoo2.
  Check Type@{Foo'.secfoo2}.
  Constraint secfoo2 < a.
End Foo'.

Check Type@{secfoo2}.
Fail Check Type@{Foo'.secfoo2}.
Fail Check eq_refl : Type@{secfoo2} = Type@{a}.

(** Below, u and v are global, fixed universes *)
Module Type Arg.
  Universe u.
  Parameter T: Type@{u}.
End Arg.

Module Fn(A : Arg).
  Universes v.

  Check Type@{A.u}.
  Constraint A.u < v.

  Definition foo : Type@{v} := nat.
  Definition bar : Type@{A.u} := nat.

  Fail Definition foo(A : Type@{v}) : Type@{A.u} := A.
End Fn.

Module ArgImpl : Arg.
  Definition T := nat.
End ArgImpl.

Module ArgImpl2 : Arg.
  Definition T := bool.
End ArgImpl2.

(** Two applications of the functor result in the exact same universes *)
Module FnApp := Fn(ArgImpl).

Check Type@{FnApp.v}.
Check FnApp.foo.
Check FnApp.bar.

Check (eq_refl : Type@{ArgImpl.u} = Type@{ArgImpl2.u}).

Module FnApp2 := Fn(ArgImpl).
Check Type@{FnApp2.v}.
Check FnApp2.foo.
Check FnApp2.bar.

Import ArgImpl2.
(** Now u refers to ArgImpl.u and ArgImpl2.u *)
Check FnApp2.bar.

(** It can be shadowed *)
Universe u.

(** This refers to the qualified name *)
Check FnApp2.bar.

Constraint u = ArgImpl.u.
Print Universes.

Set Universe Polymorphism.

Section PS.
  Universe poly.

  Definition id (A : Type@{poly}) (a : A) : A := a.
End PS.
(** The universe is polymorphic and discharged, does not persist *)
Fail Check Type@{poly}.

Print Universes.
Check id nat.
Check id@{Set}.