(**  * Bridge between Hydra-battle's and Gaia's [T1]  (Experimental)

This library introduces tools for making  definitions and lemmas from
 # Hydra battles's ordinals#  compatible with
 #Gaia's ssete9 library#.
 *)

(* begin snippet Requirements:: no-out  *)
From mathcomp Require Import all_ssreflect zify.
From Coq Require Import Logic.Eqdep_dec.
From hydras Require Import DecPreOrder ON_Generic  T1 E0.
From gaia Require Export ssete9.
(* end snippet Requirements *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
The name [T1] denotes Gaia's data type. We use [T1.T1] or [hT1] for Hydra battles ordinal terms.
*)

(* begin snippet hT1gT1 *)
#[global] Notation hT1 := T1.T1.
#[global] Notation T1 := ssete9.CantorOrdinal.T1.
(* end snippet hT1gT1 *)

(** We rename Hydra battle's total order on [hT1] *)

(* begin snippet MoreNotations:: no-out *)

(** Restrictions to terms in normal form *)

#[global] Notation LT := (restrict T1nf T1lt).
#[global] Notation LE := (restrict T1nf T1le).

(* end snippet MoreNotations *)

(** Translation functions *)

(* begin snippet h2gG2hDef *)
Fixpoint h2g (a : hT1) : T1 :=
  if a is T1.cons a n b then cons (h2g a) n (h2g b) else zero.

Fixpoint g2h (a : T1) : hT1 :=
  if a is cons a n b then T1.cons (g2h a) n (g2h b) else T1.zero.
(* end snippet h2gG2hDef *)

(* begin snippet h2gG2hRw:: no-out *)
Lemma h2g_g2hK : cancel g2h h2g.
Proof. elim => // => a1 IH1 n t2 IH2 /=; by rewrite IH1 IH2. Qed.
(* end snippet h2gG2hRw *)

(* begin snippet g2hH2gRw:: no-out *)
Lemma g2h_h2gK : cancel h2g g2h.
(* ... *)
(* end snippet g2hH2gRw *)
Proof.
   elim => // => a1 IH1 n t2 IH2 /=; by rewrite IH1 IH2.
Qed.

(* begin snippet g2hEqIff:: no-out *)
Lemma g2h_eqE (a b: T1): g2h a = g2h b <-> a = b.
(* end snippet g2hEqIff *)
Proof.
    split; [| by move => ->].
    rewrite -(h2g_g2hK a) -(h2g_g2hK b) !g2h_h2gK => -> //.
Qed.

(* begin snippet h2gEqIff:: no-out *)
Lemma h2g_eqE (a b :hT1): h2g a = h2g b <-> a = b.
(* end snippet h2gEqIff *)
Proof.
  split; [| by move => ->].
  rewrite  -(g2h_h2gK a) -(g2h_h2gK b) !h2g_g2hK  => ->  //.
Qed.

Lemma g2h_diffE (a b : T1) : g2h a <> g2h b <-> a <> b.
Proof.
  split => H Heq; [subst; by apply: H | by apply  H , g2h_eqE].
Qed.

Lemma h2g_diffE (a b : hT1) : h2g a <> h2g b <-> a <> b.
Proof.
  split => H Heq; [subst; by apply: H | by apply  H, h2g_eqE].
Qed.

(** Pretty printing *)
(* begin snippet T1ppDef *)
Definition T1pp (a:T1) : ppT1 := pp (g2h a).
(* end snippet T1ppDef *)

(** * refinement of constants, functions, etc. *)

(* begin snippet refineDefs *)

Definition refines0 (x:hT1)(y:T1) :=  y = h2g x.

Definition refines1 (f:hT1 -> hT1) (f': T1 -> T1) :=
  forall x: hT1, f' (h2g x) = h2g (f x).

Definition refines2 (f:hT1 -> hT1 -> hT1) (f': T1 -> T1 -> T1 ) :=
  forall x y : hT1, f' (h2g x) (h2g y) = h2g (f x y).

Definition refinesPred (hP: hT1 -> Prop) (gP: T1 -> Prop) :=
  forall x : hT1, hP x <-> gP (h2g x).

Definition refinesRel (hR: hT1 -> hT1 -> Prop)
  (gR: T1 -> T1 -> Prop) :=
  forall x y : hT1, hR x y <-> gR (h2g x) (h2g y).

(* end snippet refineDefs *)

(* begin snippet refines1R:: no-out *)
Lemma refines1_R f f' :
  refines1 f f' <-> forall y: T1, f (g2h y) = g2h (f' y).
(* end snippet refines1R *)
Proof.
  split => [Href y | H x].
  - by rewrite -{2}(h2g_g2hK y) Href g2h_h2gK.
  - by rewrite -{2}(g2h_h2gK x) ?H ?h2g_g2hK.
Qed.

(* begin snippet refines2R:: no-out *)
Lemma refines2_R f f' :
  refines2 f f' <-> forall y z: T1, f (g2h y) (g2h z) = g2h (f' y z).
(* end snippet refines2R *)
Proof.
  split => [Href y z | H x y].
  by rewrite -{2}(h2g_g2hK y) -{2}(h2g_g2hK z) ?Href ?g2h_h2gK.
  by rewrite -{2}(g2h_h2gK x)  -{2}(g2h_h2gK y) H h2g_g2hK.
Qed.

(** ** Refinements of usual constants *)

(* begin snippet constantRefs:: no-out *)

Lemma zero_ref : refines0 T1.zero zero.
Proof. done. Qed.

Lemma one_ref : refines0 T1.one one.
Proof. done. Qed.

Lemma Finite_ref (n:nat) : refines0 (T1.T1nat n) (\F n).
Proof. by case: n. Qed.

Lemma omega_ref : refines0 T1.T1omega T1omega.
Proof. done. Qed.
(* end snippet constantRefs *)

(** ** unary functions and predicates  *)

(* begin snippet unaryRefs:: no-out *)
Lemma succ_ref: refines1 T1.succ T1succ.
(*| .. coq:: none |*)
Proof.
  elim => [// |//  x] => //;  by case: x => // ? ? ? ? ? ? /= -> .
Qed.
(*||*)
Lemma phi0_ref x: refines0 (T1.phi0 x) (phi0 (h2g x)). (* .no-out *)
(*| .. coq:: none |*)
Proof. done. Qed.
(* end snippet unaryRefs *)

Lemma g2h_phi0 a : g2h (phi0 a) = T1.phi0 (g2h a).
Proof. by rewrite /phi0. Qed.

Lemma ap_ref : refinesPred Epsilon0.T1.ap T1ap.
Proof.
  move => a; split => Hap; first by case: Hap.
  move: Hap; case: a => //= a n b /andP [Hn Hz].
  move/eqP: Hn Hz =>->; move/eqP; by case: b.
Qed.

(** ** Equality and comparison *)

Lemma T1eq_refl (a: T1) : T1eq a a.
Proof. by apply /T1eqP. Qed.

Lemma T1eqE a b: T1eq a b -> g2h a = g2h b.
Proof. by move => /T1eqP ->. Qed.

Lemma T1eq_h2g (a b : hT1) : T1eq (h2g a) (h2g b) -> a = b.
Proof.  move => /T1eqE; by rewrite !g2h_h2gK. Qed.

(* begin snippet compareRef:: no-out *)
Lemma compare_ref (x y: hT1) :
  match T1.compare_T1 x y with
  | Datatypes.Lt => T1lt (h2g x) (h2g y)
  | Datatypes.Eq => h2g x = h2g y
  | Datatypes.Gt => T1lt (h2g y) (h2g x)
  end.
(* end snippet compareRef *)
Proof.
  move: y; elim: x => [|x1 IHx1 n x2 IHx2]; case => //= y1 n0 y2.
  case H: (Epsilon0.T1.compare_T1 x1 y1).
  - move: (IHx1 y1); rewrite H => {}IHx1.
    case H0: (PeanoNat.Nat.compare n n0).
    + have ->: (n = n0) by apply: Compare_dec.nat_compare_eq.
      case H1: (Epsilon0.T1.compare_T1 x2 y2).
      * rewrite IHx1; congr cons.
        move: (IHx2 y2); rewrite H1 => {}IHx2.
        case (h2g x1 < h2g y1); [trivial|]; by [].
        rewrite IHx1 eqxx /= eqxx ltnn.
        move: (IHx2 y2); rewrite H1 => {}IHx2; by rewrite T1ltnn.
        rewrite -IHx1 T1ltnn eqxx  ltnn  eqxx.
        move: (IHx2 y2);  by rewrite H1.
    + rewrite IHx1 T1ltnn eqxx.
      have {}H0 : (n < n0)%coq_nat by
        apply: Compare_dec.nat_compare_Lt_lt.
      by move/ltP: H0 =>->.
    + rewrite IHx1 T1ltnn eqxx.
      apply Compare_dec.nat_compare_Gt_gt in H0.
      by move/ltP: H0 => ->.
  all:  move: (IHx1 y1); by rewrite H => ->.
Qed.

(* begin snippet decideHLtRw:: no-out *)
Lemma decide_hltE (a b : hT1):
  bool_decide (T1.lt a b) = (h2g a < h2g b).
(* end snippet decideHLtRw *)
Proof.
  rewrite /Epsilon0.T1.lt; generalize (compare_ref a b);
    rewrite /Comparable.compare /=.
  destruct (decide (Epsilon0.T1.compare_T1 a b = Datatypes.Lt)).
  - have bd := e ; apply (bool_decide_eq_true _) in bd.
    by rewrite bd e.
  - have bd := n; apply (bool_decide_eq_false _) in bd.
    rewrite bd.
    destruct (Epsilon0.T1.compare_T1 a b) => //.
    * by move => ->; rewrite T1ltnn.
    * move => Hlt; symmetry;  apply/negP => Hlt'.
      have H1 : (h2g b < h2g b) by apply T1lt_trans with (h2g a).
      move: H1; by rewrite T1ltnn.
Qed.

(* begin snippet ltRef:: no-out *)
Lemma lt_ref : refinesRel T1.lt T1lt.
(* end snippet ltRef *)
Proof.
  move=> a b; split.
  - rewrite /Epsilon0.T1.lt /Comparable.compare; move => Hab.
    generalize (compare_ref a b); now rewrite Hab.
  - move => Hab; rewrite /T1.lt.
    case_eq (Epsilon0.T1.compare_T1 a b) => [Heq |//| Hgt].
    +  generalize (compare_ref a b); rewrite Heq.
       move => H0; move: Hab; rewrite H0; by rewrite T1ltnn.
    +  generalize (compare_ref a b); rewrite Hgt.
       move =>  H1; have H2: (h2g a < h2g a).
       * eapply T1lt_trans; eauto.
       *  move :H2; by rewrite T1ltnn.
Qed.

(* begin snippet leRef:: no-out *)
Lemma le_ref : refinesRel T1.le T1le.
(* end snippet leRef *)
Proof.
  move=> a b; split.
  - rewrite /T1le /Comparable.compare => Hab;  elim: Hab.
    + move => y Hy; have H: (h2g a < h2g y) by apply lt_ref.
      * by rewrite H orbT.
      * by rewrite eq_refl.
  - rewrite T1le_eqVlt; move => /orP; destruct 1; last first.
    + left; by rewrite lt_ref.
    +  move: H => /eqP; by rewrite h2g_eqE => ->; right.
Qed.

(** ** Ordinal addition *)

(* begin snippet plusRef:: no-out *)
Lemma plus_ref : refines2 T1.T1add T1add.
(* end snippet plusRef *)
Proof.
  move => x; elim: x => [|x1 IHx1 n x2 IHx2]; case => //= y1 n0 y2.
  case Hx1y1: (Epsilon0.T1.compare_T1 x1 y1); move: (compare_ref x1 y1);
    rewrite Hx1y1 => H.
  - rewrite /Comparable.compare H T1ltnn /=.
    by rewrite Hx1y1 -H /=.
  - by rewrite /Comparable.compare H Hx1y1.
  - replace (h2g x1 < h2g y1) with false; last first.
    + by apply T1lt_anti in H.
    + rewrite /Comparable.compare H /= Hx1y1.
      change (cons (h2g y1) n0 (h2g y2))
        with (h2g (T1.cons y1 n0 y2));
        by rewrite IHx2.
Qed.

(** ** Ordinal multiplication *)

Section Proof_of_mult_ref.

  Lemma T1mul_a0E (c : T1) : c * zero = zero.
  Proof. done. Qed.

  Lemma T1mul_cons_cons_E n b n' b' :
    cons zero n b * cons zero n' b' =
      cons zero (n * n' + n + n') b'.
  Proof. done.  Qed.

  Lemma T1mulE4 a n b n' b' :
    a != zero -> (cons a n b) * (cons zero n' b') =
                   cons a (n * n' + n + n') b.
  Proof.
    move => /T1eqP; cbn =>  Ha'.
    have Heq: T1eq a zero = false by  case: a Ha' => // /=.
    by rewrite Heq.
  Qed.

  Lemma multE4 a n b n' b' :
    a <> Epsilon0.T1.zero ->
    Epsilon0.T1.T1mul (T1.cons a n b)
      (T1.cons Epsilon0.T1.zero n' b') =
      T1.cons a (n * n' + n + n') b.
  Proof.
    cbn; case: a => [// | a n0 ? _ ]; congr T1.cons; nia.
  Qed.

  Lemma T1mulE5 a n b a' n' b' :
    a' != zero ->
    (cons a n b) * (cons a' n' b') =
      cons (a + a') n' (T1mul (cons a n b) b').
  Proof.
    move => H /=;  cbn;  have Ha' : T1eq a' zero = false
              by ( move: a' H; case => //).
    case (T1eq a zero); cbn; by rewrite Ha'.
  Qed.

  Lemma multE5 a n b a' n' b' :
    a' <>  T1.zero ->
    Epsilon0.T1.T1mul (T1.cons a n b)  (T1.cons a' n' b') =
      T1.cons (T1.T1add a  a') n' (T1.T1mul (T1.cons a n b) b').
  Proof.
    move => Ha'; cbn; case: a; move: Ha'; case: a' => //.
  Qed.

  Lemma h2g_cons a n b : h2g (T1.cons a n b)= cons (h2g a) n (h2g b).
  Proof. done. Qed.

  Lemma g2h_cons a n b : g2h (cons a n b) = T1.cons (g2h a) n (g2h b).
  Proof. done. Qed.

  Lemma h2g_zero  : h2g T1.zero = zero.
  Proof. done. Qed.

  Lemma g2h_zero : g2h zero = T1.zero.
    Proof. done. Qed.

  Lemma mult_ref0 : refines2 T1.T1mul T1mul.
  Proof.
    move => x y;  move: x; induction y.
    -  move => x; simpl h2g; rewrite T1mul_a0E; case x => //; by case.
    -  case.
       + simpl h2g => // /=.
       + move => a n0 b.
         destruct (Epsilon0.T1.T1_eq_dec  a Epsilon0.T1.zero).
         *  subst;
              destruct (Epsilon0.T1.T1_eq_dec y1 Epsilon0.T1.zero).
            -- subst y1; simpl h2g;
                 rewrite T1mul_cons_cons_E; congr cons; nia.
            -- repeat rewrite !h2g_cons !h2g_zero.
               rewrite T1mulE5.
               ++ rewrite multE5 => //.
                  ** simpl h2g; simpl T1add; congr cons.
                     destruct
                       (Epsilon0.T1.T1_eq_dec y2 Epsilon0.T1.zero).
                     { subst; by cbn. }
                     { change (cons zero n0 (h2g b)) with
                         (h2g (T1.cons Epsilon0.T1.zero n0 b));
                         now rewrite IHy2.
                     }
               ++  destruct y1; [now destruct n1| now compute].
         * destruct (Epsilon0.T1.T1_eq_dec y1 Epsilon0.T1.zero).
           --   subst; rewrite !h2g_cons !h2g_zero;
                  rewrite T1mulE4.
                ++ by rewrite multE4.
                ++ by case :a n1 .
           --   rewrite !h2g_cons.
                ++ rewrite T1mulE5.
                   ** rewrite  multE5 => //.
                      simpl h2g; rewrite plus_ref; congr cons.
                      change (cons (h2g a) n0 (h2g b))
                        with (h2g (T1.cons a n0 b));
                        now rewrite IHy2.
                   **  case: y1 n2 IHy1 => //.
  Qed.

End Proof_of_mult_ref.

(* begin snippet multRef:: no-out *)
Lemma mult_ref : refines2 T1.T1mul T1mul.
(* end snippet multRef *)
Proof mult_ref0.
(* begin snippet multA:: no-out *)

Lemma g2h_multE (a b : T1) : g2h (a * b) = T1.T1mul (g2h a) (g2h b).
Proof. apply symmetry, refines2_R,  mult_ref. Qed.

(* end snippet multA *)

Lemma g2h_plusE (a b: T1) : g2h (a + b) = T1.T1add (g2h a) (g2h b).
Proof. apply symmetry, refines2_R, plus_ref. Qed.

(** * Ordinal terms in normal form *)

(* begin snippet nfRef:: no-out *)

Lemma nf_ref (a: hT1)  : T1.nf_b a = T1nf (h2g a).
(* end snippet nfRef *)
Proof.
  elim: a => //.
  - move => a IHa n b IHb; rewrite T1.nf_b_cons_eq; simpl T1nf.
    by rewrite IHa IHb [phi0 (h2g a)]/(h2g (T1.phi0 a))
         andbA decide_hltE.
Qed.

Lemma LT_ref : refinesRel  T1.LT  LT.
Proof.
  split.
  - destruct 1 as [H [H0 H1]]; split.
    +  by rewrite  -nf_ref.
    + by apply lt_ref.
    + by rewrite -nf_ref.
  -  case => H H0 H1; repeat  split;
             red; rewrite ?nf_ref ?lt_ref => // ;
                                               by apply lt_ref.
Qed.

Lemma LE_ref : refinesRel T1.LE LE.
Proof.
  split.
  - case => a b; split.
    + rewrite -nf_ref => //.
    + case: b => c _; case :c => [y0 Hy0 |].
      apply T1ltW.
      * rewrite - decide_hltE => //.
        red;  rewrite bool_decide_eq_true => //.
      *  apply T1lenn.
    +  case b => _ ?; rewrite - nf_ref => //.
  - case; rewrite /T1.LE; repeat split => //.
   +  move: p p1; rewrite -nf_ref => //.
   +  move: p0; rewrite T1le_eqVlt => /orP.
      case => /eqP Heq; subst.
      * move: Heq; rewrite h2g_eqE => ?; subst; right.
      * left; move: Heq; rewrite -decide_hltE => // Heq.
           move: Heq => /eqP; rewrite bool_decide_eq_true => //.
   + move: p1 ; rewrite -nf_ref => //.
Qed.

(** Limits, successors, etc *)

(* begin snippet limitbRef:: no-out *)
Lemma T1limit_ref (a:Epsilon0.T1.T1) : T1.T1limit a = T1limit (h2g a).
(* end snippet limitbRef *)
Proof.
  elim: a => /= //.
  move => a IHa n b IHb; cbn; rewrite IHb.
  move: IHa; case:a => //.
  move => a n0 b0 IH;  cbn; move: IHb; case: b => //.
Qed.

(* begin snippet isSuccRef:: no-out *)
Lemma T1is_succ_ref (a:Epsilon0.T1.T1): T1.T1is_succ a = T1is_succ (h2g a).
(* end snippet isSuccRef *)
Proof.
  elim: a => /= //.
  move => a IHa n b /= -> ; case: a IHa => //.
Qed.

(* rewriting lemmas *)

(* begin snippet rewritingRules:: no-out *)
Lemma hnf_g2h a : T1.nf (g2h a) = T1nf a.
Proof.  by rewrite /T1.nf (nf_ref (g2h a)) h2g_g2hK. Qed.

Lemma g2h_succ a : g2h (T1succ a) = T1.succ (g2h a).
Proof. by rewrite -(h2g_g2hK a) succ_ref !g2h_h2gK. Qed.

Lemma hlt_iff a b: T1.lt a b <-> h2g a < h2g b.
Proof. by rewrite lt_ref. Qed.

(* end snippet rewritingRules *)

(* begin snippet T1ltIff:: no-out *)
Lemma T1lt_iff a b: T1nf a -> T1nf b ->
                          a < b <->  g2h a t1<  g2h b.
(* end snippet T1ltIff *)
Proof.
  move => Ha Hb; split.
  - rewrite -(h2g_g2hK a) -(h2g_g2hK b);  repeat split.
    1, 3:  by rewrite g2h_h2gK hnf_g2h.
    + by rewrite !h2g_g2hK hlt_iff.
  -  destruct 1 as [H0 [H1 H2]].
     by rewrite -(h2g_g2hK a) -(h2g_g2hK b) -hlt_iff.
Qed.

(* begin snippet T1leIff:: no-out *)
Lemma T1le_iff (a b: T1):
  a <= b <->  T1.le (g2h a) (g2h b).
(* end snippet T1leIff *)
Proof.
  split.
  -  rewrite T1le_eqVlt => /orP; case.
     move =>  /eqP Heq; subst; right.
     move => Hlt; left; by rewrite hlt_iff !h2g_g2hK.
  -  rewrite le_ref; by rewrite !h2g_g2hK.
Qed.

(** *  Well formed ordinals as a data type  *)
#[global] Notation hE0 := E0.E0.
#[global] Notation hcnf := E0.cnf.
#[global] Notation hE0lt := E0.E0lt.
#[global] Notation hE0le := E0.E0le.
#[global] Notation hE0zero := E0.E0zero.
#[global] Notation hE0omega := E0.E0omega.
#[global] Notation hE0phi0 := E0.E0phi0.
#[global] Notation hE0fin := E0.E0fin.
#[global] Notation hE0limit := E0.E0limit.
#[global] Notation hE0is_succ := E0.E0is_succ.

(* begin snippet E0Def:: no-out *)
Record E0 := mkE0 { cnf : T1 ; _ : T1nf cnf == true}.
Coercion cnf: E0 >-> T1.
(* end snippet E0Def *)

Canonical e0Sub := [subType for cnf].

Check fun (x:E0) => val x.

Remark omeganf : T1nf T1omega == true.
  by reflexivity. Qed.

Check (Sub T1omega).

Check (Sub T1omega omeganf : e0Sub).

Check (Sub T1omega omeganf : E0).

Definition E0eqb (a b: E0):= cnf a == cnf b.

Lemma gE0_eq_intro a b : cnf a = cnf b -> a = b.
Proof.
  destruct a, b; cbn.
  move => H; subst => //; congr mkE0; apply eq_proofs_unicity_on;
                      decide equality.
Qed.

(* begin snippet E0EqMixin:: no-out  *)
Definition E0_eq_mixin :  Equality.mixin_of E0.
(* end snippet E0EqMixin *)
Proof.
  exists E0eqb; move  => [x Hx] [y Hy] => /=.
  case E: (T1eq x y); cbn; rewrite E.
  - left; apply: gE0_eq_intro; by apply /eqP.
  - right => H; injection H => /eqP; by rewrite /eq_op /= E.
Defined.

(* begin snippet E0Eqtype *)
Definition E0_eqtype :=  Equality.Pack E0_eq_mixin.
Canonical Structure E0_eqtype.
(* end snippet E0Eqtype *)

(* begin snippet E0Defb:: no-out *)

Definition ppE0 (a: E0) := T1pp (cnf a).

Definition E0lt (a b: E0) := cnf a < cnf b.
Definition E0le  (a b: E0) := cnf a <= cnf b.

#[global, program] Definition E0zero: E0 := @mkE0 zero _.

#[global, program]
 Definition E0succ (a: E0): E0 :=  @mkE0 (T1succ (cnf a)) _.
Next Obligation.
  rewrite nf_succ => //; case: a => ? i //=; by apply /eqP.
Defined.

#[global, program]
 Definition E0pred (a:E0) : E0:=  @mkE0 (T1pred (cnf a)) _.
Next Obligation.
  case: a => ? ?; rewrite nf_pred  => //= ; by apply /eqP.
Defined.

Fixpoint E0fin (n:nat) : E0 :=
  if n is p.+1 then E0succ (E0fin p) else E0zero.

#[program] Definition E0omega: E0 := @mkE0 T1omega _.

#[program]  Definition E0phi0 (a: E0) : E0 := @mkE0 (phi0 (cnf a)) _.
(* end snippet E0Defb *)
Next Obligation.
  case : a => ? ?; apply /eqP => //=.
  rewrite Bool.andb_true_r; by apply /eqP.
Defined.

(* begin snippet E0plusMultDef:: no-out *)
#[program] Definition E0plus (a beta: E0) : E0 :=
  @mkE0 (T1add (cnf a) (cnf beta)) _.
Next Obligation.
  rewrite nf_add => //.
  case :a; cbn => t Ht; apply /eqP => //.
  case :beta; cbn => t Ht; apply /eqP => //.
Defined.

#[program] Definition E0mul (a beta: E0) : E0 :=
  @mkE0 (T1mul (cnf a) (cnf beta)) _.
  (* ... *)
  (* end snippet E0plusMultDef *)
Next Obligation.
  rewrite nf_mul => //.
  case :a; cbn => t Ht; apply /eqP => //.
  case :beta; cbn => t Ht; apply /eqP => //.
Defined.

Lemma E0fin_cnf (n:nat) : cnf (E0fin n) = \F n.
Proof. elim: n => // n /= ->; by rewrite T1succ_nat. Qed.

(* begin snippet gE0h2gG2h:: no-out *)
#[program] Definition E0_h2g (a: hE0): E0:= @mkE0 (h2g (E0.cnf a)) _.
Next Obligation.
  rewrite -nf_ref; case: a => /= cnf cnf_ok; by rewrite cnf_ok.
Defined.

#[program] Definition E0_g2h (a: E0): hE0 := @E0.mkord (g2h (cnf a)) _.
Next Obligation.
  case: a  => /= cnf0 /eqP; by rewrite hnf_g2h.
Defined.

(* end snippet gE0h2gG2h *)

Definition E0limit a := hE0limit (E0_g2h a).

Definition E0is_succ a := hE0is_succ (E0_g2h a).

Lemma E0_h2g_nf (a:hE0) : T1nf (cnf (E0_h2g a)).
Proof.
  case: a => /= cnf Hnf; by rewrite -nf_ref.
Qed.

Lemma gE0lt_iff a beta : E0lt a beta <-> E0_g2h a o< E0_g2h beta.
Proof.
  split.
    - rewrite /E0lt;  destruct a, beta.
     rewrite /Lt /T1.LT => /=; repeat split.
      + rewrite /T1.nf nf_ref h2g_g2hK; by apply /eqP.
      + by rewrite hlt_iff !h2g_g2hK.
      + rewrite /T1.nf nf_ref h2g_g2hK;  by apply /eqP.
    - rewrite /E0lt; destruct a, beta.
      rewrite /Lt /T1.LT; destruct 1 as [H [H0 H1]].
      move: H0 ; by rewrite hlt_iff !h2g_g2hK.
Qed.

Lemma gE0le_iff a beta : E0le a beta <-> E0_g2h a o<= E0_g2h beta.
Proof.
  split.
  - rewrite /E0le;  destruct a, beta.
    rewrite /hE0le /T1.LE => /=; repeat split.
    rewrite T1le_eqVlt => Hle.
    have Hor : (cnf0 =cnf1 \/ cnf0 < cnf1).
    { apply Bool.orb_prop in Hle;  destruct Hle as [? | ?].
      left;  apply /eqP => //.
      right => //.
    }
    destruct Hor as [? | Hneq].
    * subst; replace i0 with i.
      -- right.
      -- apply eq_proofs_unicity_on;  decide equality.
    * left; apply gE0lt_iff; rewrite /E0lt => //.
  - rewrite /E0le; destruct a, beta; cbn => Hle.
    destruct (le_lt_eq_dec Hle) as [l | e].
    + move: l; rewrite /hE0lt ; cbn;  rewrite -T1lt_iff.
     * by apply T1ltW.
     * by apply /eqP.
     * by apply /eqP.
    + injection e; rewrite g2h_eqE =>  Heq; subst; apply T1lenn.
Qed.

Lemma E0_h2g_g2hK : cancel E0_g2h E0_h2g.
Proof.
  case => a Ha /=; rewrite /E0_g2h /E0_h2g.
  apply  gE0_eq_intro=> /=;  by rewrite h2g_g2hK.
Qed.

Lemma E0_g2h_h2gK : cancel E0_h2g E0_g2h.
Proof.
  case => a Ha /=. rewrite /E0_g2h /E0_h2g; f_equal.
  apply  E0_eq_intro=> /=;  by rewrite g2h_h2gK.
Qed.

Lemma g2h_E0succ a : E0_g2h (E0succ a)= E0.E0succ (E0_g2h a).
Proof.
  rewrite /E0succ; apply E0_eq_intro => /=; by rewrite g2h_succ.
Qed.

Lemma  E0is_succ_succ a : E0is_succ  (E0succ a).
Proof.
 rewrite /E0is_succ g2h_E0succ; apply Succ_Succb.
Qed.

(* To do : clean up ! *)

Lemma E0is_succE a: E0is_succ a -> {beta: E0 | a = E0succ beta}.
Proof.
 rewrite /E0is_succ => H.
 case (Succb_Succ _ H) => beta Hbeta; exists (E0_h2g beta).
 rewrite -(E0_h2g_g2hK a) Hbeta.
 have H0:= g2h_E0succ (E0_h2g beta).
 move: H0; rewrite E0_g2h_h2gK.
 move => H0;  rewrite -H0.
by rewrite E0_h2g_g2hK.
Qed.

Lemma E0_eqE (x y: E0) : x = y <-> (E0_g2h x = E0_g2h y).
  split.
   move => Heq; by subst.
   move => H; by rewrite -(E0_h2g_g2hK x) -(E0_h2g_g2hK y) H.
Qed.

Lemma E0_diffE (x y: E0) : x <> y <-> (E0_g2h x <> E0_g2h y).
Proof.
 split => Hdiff Heq.
  - apply: Hdiff; by apply /E0_eqE.
  - subst; by apply: Hdiff.
Qed.

(* clean up!  *)

Lemma E0pred_succK x : E0pred (E0succ x) = x.
Proof.
  apply E0_eqE; rewrite /E0pred.
  apply E0_eq_intro => //=.
  rewrite pred_succ => //.
  case: x => c Hc //=.  by apply /eqP.
Qed.

Lemma g2h_E0zero : E0_g2h E0zero = E0.E0zero.
Proof.  rewrite /E0zero; by apply E0_eq_intro. Qed.

Lemma E0g2h_Fin i: E0_g2h (E0fin i) = E0.E0fin i.
Proof.  apply E0_eq_intro => /=; rewrite E0fin_cnf; by case: i. Qed.

Lemma E0g2h_phi0 a : E0_g2h (E0phi0 a) = E0.E0phi0 (E0_g2h a).
Proof.  apply E0_eq_intro => //. Qed.

Lemma E0g2h_mulE (a b: E0): E0_g2h (E0mul a b) = E0.E0mul (E0_g2h a) (E0_g2h b).
Proof.
  destruct a, b; apply E0_eq_intro => /=;  by rewrite g2h_multE.
Qed.

Lemma E0g2h_plusE (a b: E0): E0_g2h (E0plus a b)= E0.E0add (E0_g2h a) (E0_g2h b).
Proof.
  case: a ; case: b => a ? b ?;  apply E0_eq_intro => /=;
         by rewrite g2h_plusE.
Qed.

Lemma E0g2h_omegaE : E0_g2h E0omega = hE0omega.
 Proof.  by  apply E0_eq_intro => /=.  Qed.

From Coq Require Import Relations Basics
     Wellfounded.Inverse_Image Wellfounded.Inclusion.

(** TODO: simplify this proof !!! *)

(* begin snippet gE0LtWf:: no-out *)
Lemma gE0lt_wf : well_founded E0lt.
Proof.
  move => ?; apply Acc_incl with (fun x y =>  hE0lt (E0_g2h x) (E0_g2h y)).
  (* ... *)
  (* end snippet gE0LtWf *)
  - move => a b ; rewrite /E0lt => Hab.
    case: a Hab => cnf0 i0 Hb.
    case: b Hb => cnf1 i1 /= Hlt ; rewrite /E0.E0lt => /=.
    move: Hlt i0 i1; rewrite -(h2g_g2hK cnf0).
    rewrite -(h2g_g2hK cnf1)  -decide_hltE;  repeat split.
    + move: i0 i1; rewrite -!nf_ref => i0 i1; rewrite g2h_h2gK => //.
      red. move: i0 => /eqP. by [].
    + red in Hlt; move: Hlt;  rewrite bool_decide_eq_true  => //.
      by rewrite !g2h_h2gK.
    + move: i1; rewrite -!nf_ref  g2h_h2gK /eqP => i1  //.
      by move: i1 => /eqP.
  -  apply Acc_inverse_image, E0lt_wf.
Qed.

Lemma L1' (a: T1) : T1omega * (a * T1omega) = T1omega * a * T1omega.
Proof. by  rewrite mulA. Qed.

(** Sequences and limits *)

Definition g2h_seq (s: nat-> T1) n := g2h (s n).
Definition h2g_seq (s: nat -> hT1) n := h2g (s n).

Definition gstrict_lub (s : nat -> T1) (lambda : T1) :=
  (forall i : nat, LT (s i) lambda) /\
    (forall a : T1, (forall i : nat, LE (s i) a) -> LE lambda  a).

Lemma strict_lub_ref (s:nat-> hT1) (lambda: hT1) :
  strict_lub s lambda <-> gstrict_lub (h2g_seq s) (h2g lambda).
Proof.
  rewrite /gstrict_lub; split.
  -  case => Ha Hb;  split.
     + move => i; rewrite -!LT_ref => //.
     + move => a Ha1; rewrite -(h2g_g2hK a) -LE_ref.
       apply Hb => i; destruct (Ha1 i) as [H H0 H1]; split.
       * move: H; rewrite -hnf_g2h /h2g_seq g2h_h2gK => //.
       * split.
         --  move: H0; rewrite T1le_iff /h2g_seq g2h_h2gK  => //.
         --  by rewrite hnf_g2h.
  -   destruct 1 as [H H0]; split.
      + move => i; move:  (H i); rewrite LT_ref =>//.
      +  move => a Ha; rewrite LE_ref;  apply H0.
         move => i; rewrite -LE_ref; apply Ha.
Qed.

(* begin snippet SearchDemoa *)
Search ( _ * ?beta = ?beta)%ca.
(* end snippet SearchDemoa *)

(* begin snippet SearchDemob *)
Search ( _ * ?beta = ?beta)%t1.
(* end snippet SearchDemob *)

(* begin snippet T1compareDef *)
#[global] Instance  T1compare : Compare T1:=
  fun a beta => compare (g2h a) (g2h beta).

Compute compare (\F 6 + T1omega) T1omega.
(* end snippet T1compareDef *)

(* begin snippet T1compareG2h:: no-out *)
Lemma compare_g2h (a beta : T1):
  compare (g2h a) (g2h beta) = compare a beta .
 Proof.  by []. Qed.

 Lemma compare_h2g (a beta: hT1) :
   compare (h2g a) (h2g beta) =compare a beta .
Proof.
  rewrite -(g2h_h2gK a)  -(g2h_h2gK beta).
   by rewrite compare_g2h !g2h_h2gK.
Qed.
(* end snippet T1compareG2h *)

(** * Make E0 an ordinal notation *)

(* begin snippet T1compareCorrect:: no-out *)
Lemma T1compare_correct (a b:  T1):
  CompSpec eq T1lt a b (compare a b).
(* end snippet T1compareCorrect *)
Proof.
  rewrite /compare /T1compare.
  case  (T1.compare_correct (g2h a) (g2h b)).
  rewrite g2h_eqE => H; subst;  by constructor.
  all:  constructor; move:H; by rewrite  lt_ref !h2g_g2hK .
Qed.

(* begin snippet E0compare:: no-out *)
#[global] Instance E0compare: Compare E0 :=
  fun (alpha beta: E0) => T1compare (cnf alpha) (cnf beta).

Lemma E0compare_correct (alpha beta : E0) :
  CompSpec eq E0lt alpha beta (compare alpha beta).
(* ... *)
(* end snippet E0compare *)
Proof.
  destruct alpha, beta; rewrite /compare;
    case  (T1compare_correct cnf0 cnf1) => Hcomp.
  { subst; replace i0 with i.
    + rewrite /E0compare; cbn.
      replace (compare (g2h cnf1) (g2h cnf1)) with Datatypes.Eq => //.
      * by constructor.
      * by rewrite compare_refl.
    + apply eq_proofs_unicity_on;
       by  destruct y, (T1nf cnf1) => //; [left | right] => //.
  } {
    rewrite /E0compare; cbn.
    replace (compare (g2h cnf0) (g2h cnf1)) with Datatypes.Lt.
    + constructor; rewrite /E0lt => //.
    + move: Hcomp;  rewrite /compare T1lt_iff.
      case ; rewrite -compare_lt_iff => _ [Hcomp _].
      symmetry; by rewrite compare_lt_iff.
      1, 2: by apply /eqP.
  }
  rewrite /E0compare; cbn.
  replace (compare (g2h cnf0) (g2h cnf1)) with Datatypes.Gt.
  + constructor; rewrite /E0lt => //.
  +  move: Hcomp; rewrite /compare T1lt_iff.
     case ; rewrite -compare_gt_iff => // _ [Hcomp _] //.
     all: by apply /eqP.
Qed.

(* begin snippet E0Sto:: no-out *)
#[global] Instance E0_sto : StrictOrder E0lt.
(* end snippet E0Sto *)
Proof.
  split.
  - move => x. case :x => x Hx.  rewrite /complement /E0lt=> /=.
    by rewrite T1ltnn.
  -  rewrite /Transitive; case => x Hx; case => y Hy; case => z Hz.
     by rewrite /E0lt; cbn; apply T1lt_trans.
Qed.

(* begin snippet compEpsilon0:: no-out *)
#[global] Instance E0_comp : Comparable E0lt compare.
Proof. split; [apply  E0_sto | apply E0compare_correct]. Qed.
(* end snippet compEpsilon0 *)

(* begin snippet ExampleComp *)
Compute compare (E0phi0 (E0fin 2)) (E0mul (E0succ E0omega) E0omega).
(* end snippet ExampleComp *)

(* begin snippet gEpsilon0:: no-out *)
#[global] Instance Epsilon0 : ON E0lt compare.
Proof. split; [apply: E0_comp | apply: gE0lt_wf]. Qed.
(* end snippet gEpsilon0:: no-out *)

(* begin snippet LocateExample *)
Locate T1omega.
(* end snippet LocateExample *)

(** * Abstract properties of arithmetic functions (with SSreflect inequalities)
 *)

(* begin snippet MonoDef *)
Definition strict_mono (f: nat -> nat) :=
  forall n p, (n
 (f n < f p)%N.

Definition dominates_from (n : nat) (g f : nat -> nat) :=
  forall p : nat, (n <= p)%N -> (f p < g p)%N.

Definition dominates g f := exists n : nat, dominates_from n g f .

Definition dominates_strong g f  := {n : nat | dominates_from n g f}.

Definition fun_le  f g := forall n:nat, (f n <=  g n)%N.

(* end snippet MonoDef *)


(** * This follows the axiomatic treatment of reals
    in the Coq standard library. *)

Require Export Notations.
Require Export ComprehensionNotation.

(* TODO replace these with the 5 axioms in Points.v *)

(** ** Axioms *)

Axiom Ob : Set.

Axiom BOT : Ob.
Axiom TOP : Ob.
Axiom I : Ob.
Axiom K : Ob.
Axiom F : Ob.
Axiom B : Ob.
Axiom C : Ob.
Axiom W : Ob.
Axiom S : Ob.
Axiom R : Ob.
Axiom J : Ob.
Axiom AP : Ob -> Ob -> Ob.
Axiom LESS : Ob -> Ob -> Prop.
Axiom NLESS : Ob -> Ob -> Prop.
Axiom Join : forall {s : Type}, (s -> Ob) -> Ob.

Notation "x * y" := (AP x y) : Ob_scope.

Open Scope Ob_scope.
Delimit Scope Ob_scope with Ob.
Bind Scope Ob_scope with Ob.

Notation "x 'o' y" := (B * x * y) : Ob_scope.
Notation "x || y" := (J * x * y) : Ob_scope.
Notation "x (+) y" := (R * x * y) : Ob_scope.
Notation "x [= y" := (LESS x y) : Ob_scope.
Notation "x [!= y" := (NLESS x y) : Ob_scope.

Axiom I_beta : forall x, I*x = x.
Axiom K_beta : forall x y, K*x*y = x.
Axiom F_beta : forall x y, F*x*y = y.
Axiom B_beta : forall x y z, B*x*y*z = x*(y*z).
Axiom C_beta : forall x y z, C*x*y*z = x*z*y.
Axiom W_beta : forall x y, W*x*y = x*y*y.
Axiom S_beta : forall x y z, S*x*y*z = x*z*(y*z).
Axiom J_beta : forall x y z, (x||y)*z = x*z || y*z.
Axiom R_beta : forall x y z, (x(+)y)*z = x*z (+) y*z.
Axiom R_idem : forall x, x(+)x = x.
Axiom R_sym : forall x y, x(+)y = y(+)x.
Axiom R_sym_sym : forall w x y z, (w(+)x) (+) (y(+)z) = (y(+)x) (+) (w(+)z).
Axiom Join_beta : forall (s : Type) x y, Join x * y = Join (x i * y for i : s).

Hint Rewrite
  I_beta K_beta F_beta B_beta C_beta
  W_beta S_beta J_beta R_beta R_idem Join_beta
  : beta.

Tactic Notation "beta_reduce" := autorewrite with beta.
Tactic Notation "beta_reduce" "in" hyp(H) := autorewrite with beta in H.

(** To avoid nontermination in [beta_reduce],
    we provide a mechanism to "freeze" terms during reduction. *)
Tactic Notation "freeze" reference(c) "in" tactic(tac) :=
  let v := fresh "v" in
  let H := fresh "Hv" in
  assert (exists v, c=v) as H;
  [ exists c; reflexivity
  | destruct H as [v H]; rewrite H; tac; destruct H].

Axiom LESS_TOP : forall x, x [= TOP.
Axiom LESS_BOT : forall x, BOT [= x.
Axiom J_left : forall x y, x [= x||y.
Axiom J_right : forall x y, y [= x||y.
Axiom J_lub : forall x y z, x [= z -> y [= z -> x||y [= z.
Axiom R_subconvex : forall x y z, x [= z -> y [= z -> x(+)y [= z.
Axiom R_supconvex : forall x y z, z [= x -> z [= x -> z [= x(+)y.
Axiom LESS_refl : forall x, x [= x.
Axiom LESS_antisym : forall x y, x [= y -> y [= x -> x = y.
Axiom LESS_trans : forall x y z, x [= y -> y [= z -> x [= z.
Axiom LESS_AP_left : forall x x' y, x [= x' -> x*y [= x'*y.
Axiom LESS_AP_right : forall x y y', y [= y' -> x*y [= x*y'.
Axiom NLESS_def : forall x y, x [!= y <-> exists f, f * x = TOP /\ f * y = BOT.
(*
Axiom NLESS_def : forall x y, x [!= y <-> (x [= y -> TOP [= BOT).
*)

Hint Resolve LESS_TOP.
Hint Resolve LESS_BOT.
Hint Resolve J_left.
Hint Resolve J_right.
Hint Resolve J_lub.
Hint Resolve LESS_refl.
Hint Resolve LESS_antisym.
Hint Resolve LESS_AP_left.
Hint Resolve LESS_AP_right.

Ltac monotonicity := repeat (apply LESS_AP_left || apply LESS_AP_right).

Definition is_upper_bound {s : Type} (e : s -> Ob) (x : Ob) : Prop :=
  forall i, e i [= x.

Definition is_lub {s : Type} (e : s -> Ob) (x : Ob) : Prop :=
  is_upper_bound e x /\ forall y, is_upper_bound e y -> x [= y.

Axiom Join_lub : forall {s : Type} (e : s -> Ob), is_lub e (Join e).

Lemma Join_ub : forall {s : Type} (e : s -> Ob) i, e i [= Join e.
Proof.
  intros s e i; apply Join_lub.
Qed.

Lemma Join_ub_eq : forall {s : Type} (e : s -> Ob) i x, x = e i -> x [= Join e.
Proof.
  intros s e i x Heq; rewrite Heq; apply Join_lub.
Qed.

Lemma Join_empty : forall e : Empty_set -> Ob, Join e = BOT.
Proof.
  intros e.
  apply LESS_antisym.
    apply Join_lub; unfold is_upper_bound; intro i; elim i.
  auto.
Qed.

Lemma Join_single : forall (x : Ob) (s : Type), s -> Join (x for _ : s) = x.
Proof.
  intros x s y.
  apply LESS_antisym;
  apply Join_lub with (e := fun _ : s => x);
  unfold is_upper_bound;
  auto.
Qed.

Lemma J_sym : forall x y, x||y = y||x.
Proof.
  intros x y.
  apply LESS_antisym; auto.
Qed.

Lemma less_eq_join : forall x y, x [= y <-> x || y = y.
Proof.
  intros x y; split; intro H.
  apply LESS_antisym; auto.
  rewrite <- H; auto.
Qed.

(** ** Global properties *)

Axiom consistency : ~ TOP [= BOT.

Theorem completeness : forall {s : Type} (e : s -> Ob), exists x, is_lub e x.
Proof.
  intros s e.
  exists (Join e).
  apply Join_lub.
Qed.

Axiom extensionality : forall f g, (forall x, f * x = g * x) -> f = g.

Lemma less_extensionality : forall f g, (forall x, f * x [= g * x) -> f [= g.
Proof.
  intros f g H.
  apply less_eq_join.
  apply extensionality; intro x.
  rewrite J_beta; auto.
Qed.

Tactic Notation "eta_expand" :=
  let x := fresh in
  match goal with
  | [|- _ = _] => apply extensionality; intro x
  | [|- _ [= _] => apply less_extensionality; intro x
  end.

Tactic Notation "eta_expand" "as" ident(x) :=
  match goal with
  | [|- _ = _] => apply extensionality; intro x
  | [|- _ [= _] => apply less_extensionality; intro x
  end.

Tactic Notation "eta_expand" "in" hyp(H) :=
  eapply LESS_AP_left in H; beta_reduce in H.

Ltac beta_eta :=
  compute; (
  beta_reduce; auto
  || eta_expand; beta_reduce; auto
  || eta_expand; eta_expand; beta_reduce; auto
  || eta_expand; eta_expand; eta_expand; beta_reduce; auto).

Lemma B_assoc : forall f g h, (f o g) o h = f o (g o h).
Proof.
  intros f g h; beta_eta.
Qed.

Lemma TOP_beta : forall x, TOP*x = TOP.
Proof.
  intro x.
  apply LESS_antisym.
  apply LESS_TOP.
  apply LESS_trans with (K*TOP*x).
  beta_eta.
  apply LESS_AP_left; auto.
Qed.

Lemma BOT_beta : forall x, BOT*x = BOT.
Proof.
  intro x.
  apply LESS_antisym.
  apply LESS_trans with (K*BOT*x).
  apply LESS_AP_left; auto.
  beta_eta.
  apply LESS_BOT.
Qed.

Lemma TOP_J_left : forall x, TOP||x = TOP.
Proof.
  intro x.
  rewrite J_sym.
  apply less_eq_join; auto.
Qed.

Lemma TOP_J_right : forall x, x||TOP = TOP.
Proof.
  intro x.
  rewrite J_sym.
  apply TOP_J_left.
Qed.

Lemma BOT_J_left : forall x, BOT||x = x.
Proof.
  intro x.
  apply less_eq_join; auto.
Qed.

Lemma BOT_J_right : forall x, x||BOT = x.
Proof.
  intro x.
  rewrite J_sym.
  apply BOT_J_left.
Qed.

Hint Rewrite TOP_beta BOT_beta TOP_J_left TOP_J_right BOT_J_left BOT_J_right
  : beta.

Lemma J_K_F : J = K || F.
Proof.
  beta_eta.
Qed.

Lemma J_Join : J = Join (if b then K else F for b : bool).
Proof.
  rewrite J_K_F.
  apply LESS_antisym.
    apply J_lub.
      apply Join_ub with (e := (if i then K else F for i : bool)) (i := true).
    apply Join_ub with (e := (if i then K else F for i : bool)) (i := false).
  apply Join_lub; unfold is_upper_bound.
  intro b; case b; auto.
Qed.

(** ** Definability and accessibility *)

(* FIXME should [definable] and [code_conv] be [Set] or [Prop]? *)

Inductive definable : Ob -> Set :=
  | S_definable : definable S
  | K_definable : definable K
  | R_definable : definable R
  | J_definable : definable J
  | AP_definable x y : definable x -> definable y -> definable (x*y).

Hint Constructors definable.

Axiom accessibility :
  forall x : Ob, x = Join (y for y : Ob if definable y).

(** This is specialized to SKJ, TODO update for SKRJ *)
Inductive code_conv : Ob -> Set :=
  | conv_TOP : code_conv TOP
  | conv_AP_TOP x : code_conv (x * TOP) -> code_conv x.

Hint Constructors code_conv.

Axiom LESS_conv :
  forall x y, (forall f, definable f -> code_conv (f*x) -> code_conv (f*y)) -> x [= y.

Notation "x <--> y" := ((x -> y) * (y -> x))%type
  (at level 95, no associativity) : type_scope.

Lemma eq_conv :
  forall x y, (forall f, definable f -> code_conv (f*x) <--> code_conv (f*y)) -> x = y.
Proof.
  intros x y H.
  apply LESS_antisym; apply LESS_conv; intros f Hdef; firstorder.
Qed.


(*|
####################################################
Coq: Rewriting with ``forall`` in hypothesis or goal
####################################################

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

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

I have proved 'correctness' of the reverse function on polymorphic
``Lists`` in Coq. The following proof works just fine, but I have a
few questions about how the ``rewrite`` tactic works.

Here's the code:
|*)

Require Export Coq.Lists.List.
Import ListNotations.

Fixpoint rev {T : Type} (l : list T) : list T :=
  match l with
  | nil    => nil
  | h :: t => rev t ++ [h]
  end.

(* Prove rev_acc equal to above naive implementation. *)
Fixpoint rev_acc {T : Type} (l acc : list T) : list T :=
  match l with
  | nil => acc
  | h :: t => rev_acc t (h::acc)
  end.

Theorem app_assoc : forall  (T : Type) (l1 l2 l3 : list T),
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
Admitted.

Theorem rev_acc_correct : forall (T : Type) (l k : list T),
    rev l ++ k = rev_acc l k.
Proof.
  intros T l. induction l as [ | h l' IHl' ].
  - reflexivity.
  - simpl. intro k.
    (* Why is "intro k" required for "rewrite -> app_assoc" but
       "rewrite -> IHl'" works regardless of "intro k". generalize
       (rev l'), [h], k. *)
    rewrite -> app_assoc. simpl.
    rewrite -> IHl'. reflexivity.

(*|
In the inductive step of the proof for ``rev_acc_correct`` if I skip
``intro k``, then rewriting with ``app_assoc`` complains that it
cannot find a matching subterm.
|*)

    Undo 5. (* .none *)
    Fail rewrite -> app_assoc. (* .fails .unfold .messages *)

(*|
Here, I presume that the ``?`` before the placeholder names denote
that the terms are constrained, in this case to be of type ``List T``
for some type ``T``; and since ``rev l'`` and ``[h]`` in the goal are
instances of ``List T``, one would expect a match in the goal.

On the other hand, rewriting with inductive hypothesis (``rewrite ->
IHl'``) instead of ``app_assoc`` goes through without needing an
``intro k`` before.

I find this behaviour of ``rewrite`` a bit confusing and the Coq
manual doesn't provide any details. I don't want to have to read
through the implementation but I need a good operational understanding
of what the rewrite tactic does, especially with regards to how term
matching works. Any answers/references in this direction are highly
appreciated.
|*)

(*|
Answer
******

The complication with this rewrite is that there's a *binder* (the
``forall k``), which can complicate things. If you just want things to
work, use ``setoid_rewrite`` instead of ``rewrite`` and it will
rewrite under binders.

- ``rewrite IHl'`` looks like it happens under a binder, but the
  pattern being re-written doesn't actually involve the bound
  variable, so the binder isn't actually important. Here's what I
  mean: the goal is

  .. code-block:: coq

      forall k : list T, (rev l' ++ [h]) ++ k = rev_acc l' (h :: k)

  which is the same thing as (that is, equal to):

  .. code-block:: coq

      (fun l : list T => forall k : list T,
           l ++ k = rev_acc l' (h :: k)) (rev l' ++ [h])

  which I got using ``pattern (rev l' ++ [h])`` in Ltac. Now it's
  clear that you can just rewrite the part being applied to and ignore
  the binder. When you do ``rewrite IHl'`` Coq easily figures out that
  ``IHl`` should be specialized to ``[h]`` and the rewrite proceeds.

- ``rewrite app_assoc``, on the other hand, needs to be specialized to
  three lists, specifically ``rev l'``, ``[h]``, and ``k``. It can't
  be specialized in the current context because the variable ``k`` is
  only bound underneath the ``forall``. This is why the pattern ``(?x
  ++ ?y) ++ ?z`` doesn't appear in the goal.

So what do you actually do? You can of course introduce ``k`` so there
is no binder, but there's a simpler and more general technique: Coq
has generalized rewriting that can rewrite under binders, which you
can use by instead calling ``setoid_rewrite`` (see `Rewriting under
binders
<https://coq.inria.fr/refman/addendum/generalized-rewriting.html#extensions>`__
in the Coq reference manual). The manual tells you you need to declare
morphisms, but the relevant ones have all been implemented for you in
this case for ``forall``, so ``setoid_rewrite app_assoc`` will just
work.

Note that while you can always introduce a ``forall`` to get rid of
the binder, ``setoid_rewrite`` can be really handy when your goal is
an ``exists``. Rather than using ``eexists`` you can just rewrite
under the binder.
|*)


(** * Push-Button Synthesis of Bernstein-Yang Inversion: Reification Cache *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.derive.Derive.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.ZUtil.Pow.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.Freeze.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Crypto.Arithmetic.BYInv.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Local Open Scope Z_scope.

Require Import Crypto.Arithmetic.UniformWeight.
Require Import Lists.List.

Import
  Language.Wf.Compilers
  Language.Compilers
  Language.API.Compilers.
Import Compilers.API.

Import Associational Positional.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Module Export WordByWordMontgomeryInversion.
  Import WordByWordMontgomery.WordByWordMontgomery.

  Definition msat bitwidth n m := Partition.partition (uweight bitwidth) n m. (* m in saturated representation *)

  Derive reified_divstep_gen
         SuchThat (is_reification_of reified_divstep_gen divstep)
         As reified_divstep_gen_correct.
  Proof. Time cache_reify (). Time Qed.
#[global]
  Hint Extern 1 (_ = _) => apply_cached_reification divstep (proj1 reified_divstep_gen_correct) : reify_cache_gen.
#[global]
  Hint Immediate (proj2 reified_divstep_gen_correct) : wf_gen_cache.
#[global]
  Hint Rewrite (proj1 reified_divstep_gen_correct) : interp_gen_cache.
  Local Opaque reified_divstep_gen. (* needed for making [autorewrite] not take a very long time *)

  Derive reified_msat_gen
         SuchThat (is_reification_of reified_msat_gen msat)
         As reified_msat_gen_correct.
  Proof.
    Time cache_reify ().
    Time Qed.
#[global]
  Hint Extern 1 (_ = _) => apply_cached_reification msat (proj1 reified_msat_gen_correct) : reify_cache_gen.
#[global]
  Hint Immediate (proj2 reified_msat_gen_correct) : wf_gen_cache.
#[global]
  Hint Rewrite (proj1 reified_msat_gen_correct) : interp_gen_cache.
  Local Opaque reified_msat_gen. (* needed for making [autorewrite] not take a very long time *)

  Derive reified_eval_twos_complement_gen
         SuchThat (is_reification_of reified_eval_twos_complement_gen eval_twos_complement)
         As reified_eval_twos_complement_gen_correct.
  Proof. Time cache_reify (). Time Qed.
#[global]
  Hint Extern 1 (_ = _) => apply_cached_reification eval_twos_complement (proj1 reified_eval_twos_complement_gen_correct) : reify_cache_gen.
#[global]
  Hint Immediate (proj2 reified_eval_twos_complement_gen_correct) : wf_gen_cache.
#[global]
  Hint Rewrite (proj1 reified_eval_twos_complement_gen_correct) : interp_gen_cache.
  Local Opaque reified_eval_twos_complement_gen. (* needed for making [autorewrite] not take a very long time *)
End WordByWordMontgomeryInversion.


From solutions Require Export sem_typed sem_operators.

(** * Compatibility lemmas *)
(** We prove that the logical relations, i.e., the semantic typing judgment,
that we have defined is compatible with typing rules. That is, the logical
relations is a congruence with respect to the typing rules.

These compatibility lemmas are what one gets when the syntactic typing judgment
is replaced semantic typing judgment in syntactic typing rules. For instance
([sem_typed_pair]):

<<
   Γ ⊢ e1 : τ1        Γ ⊢ e2 : τ2
  --------------------------------
       Γ ⊢ (e1, e2) : τ1 × τ2
>>

becomes:

<<
  (Γ ⊨ e1 : A1) -∗ (Γ ⊨ e2 : A2) -∗ Γ ⊨ (e1, e2) : A1 * A2
>>
*)

Section compatibility.
  Context `{!heapG Σ}.
  Implicit Types A B : sem_ty Σ.
  Implicit Types C : sem_ty Σ → sem_ty Σ.

  (** * Compatibility rules for expression typing *)
  (** * Variables *)
  Lemma Var_sem_typed Γ (x : string) A : Γ !! x = Some A → ⊢ Γ ⊨ x : A.
  Proof.
    iIntros (HΓx vs) "!> #HΓ /=".
    iDestruct (env_sem_typed_lookup with "HΓ") as (v ->) "HA"; first done.
    by iApply wp_value.
  Qed.

  Lemma Val_sem_typed Γ v A : ⊨ᵥ v : A -∗ Γ ⊨ v : A.
  Proof.
    iIntros "#Hv" (vs) "!> #HΓ /=".
    iApply wp_value. iApply "Hv".
  Qed.

  (** * Products and sums *)
  Lemma Pair_sem_typed Γ e1 e2 A1 A2 :
    Γ ⊨ e1 : A1 -∗ Γ ⊨ e2 : A2 -∗ Γ ⊨ (e1,e2) : A1 * A2.
  Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w2) "#HA2".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (w1) "#HA1".
    wp_pures. iExists w1, w2. auto.
  Qed.
  Lemma Fst_sem_typed Γ e A1 A2 : Γ ⊨ e : A1 * A2 -∗ Γ ⊨ Fst e : A1.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w).
    iDestruct 1 as (w1 w2 ->) "[??]". by wp_pures.
  Qed.
  Lemma Snd_sem_typed Γ e A1 A2 : Γ ⊨ e : A1 * A2 -∗ Γ ⊨ Snd e : A2.
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w).
    iDestruct 1 as (w1 w2 ->) "[??]". by wp_pures.
  Qed.

  Lemma InjL_sem_typed Γ e A1 A2 : Γ ⊨ e : A1 -∗ Γ ⊨ InjL e : A1 + A2.
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HA".
    wp_pures. iLeft. iExists w. auto.
  Qed.
  Lemma InjR_sem_typed Γ e A1 A2 : Γ ⊨ e : A2 -∗ Γ ⊨ InjR e : A1 + A2.
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HA".
    wp_pures. iRight. iExists w. auto.
  Qed.
  Lemma Case_sem_typed Γ e e1 e2 A1 A2 B :
    Γ ⊨ e : A1 + A2 -∗ Γ ⊨ e1 : (A1 → B) -∗ Γ ⊨ e2 : (A2 → B) -∗
    Γ ⊨ Case e e1 e2 : B.
  (* SOLUTION *) Proof.
    iIntros "#H #H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#[HA|HA]".
    - iDestruct "HA" as (w1 ->) "HA". wp_pures.
      wp_apply (wp_wand with "(H1 [//])"); iIntros (v) "#HAB". by iApply "HAB".
    - iDestruct "HA" as (w2 ->) "HA". wp_pures.
      wp_apply (wp_wand with "(H2 [//])"); iIntros (v) "#HAB". by iApply "HAB".
  Qed.

  (** * Functions *)
  Lemma Rec_sem_typed Γ f x e A1 A2 :
    binder_insert f (A1 → A2)%sem_ty (binder_insert x A1 Γ) ⊨ e : A2 -∗
    Γ ⊨ (rec: f x := e) : (A1 → A2).
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=". wp_pures. iModIntro. iLöb as "IH".
    iIntros "!>" (v) "#HA1". wp_pures. set (r := RecV f x _).
    rewrite -subst_map_binder_insert_2. iApply "H".
    iApply (env_sem_typed_insert with "IH"). by iApply env_sem_typed_insert.
  Qed.

  Lemma App_sem_typed Γ e1 e2 A1 A2 :
    Γ ⊨ e1 : (A1 → A2) -∗ Γ ⊨ e2 : A1 -∗ Γ ⊨ e1 e2 : A2.
  Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w) "#HA1".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (v) "#HA". by iApply "HA".
  Qed.

  (** * Polymorphic functions and existentials *)
  Lemma TLam_sem_typed Γ e C : (∀ A, Γ ⊨ e : C A) -∗ Γ ⊨ (Λ: e) : ∀ A, C A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=". wp_pures.
    iIntros "!> !>" (A) "/=". wp_pures. by iApply ("H" $! A).
  Qed.
  Lemma TApp_sem_typed Γ e C A : (Γ ⊨ e : ∀ A, C A) -∗ Γ ⊨ e <_> : C A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HB". by iApply ("HB" $! A).
  Qed.

  Lemma Pack_sem_typed Γ e C A : Γ ⊨ e : C A -∗ Γ ⊨ (pack: e) : ∃ A, C A.
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HB".
    wp_lam. by iExists A.
  Qed.
  Lemma Unpack_sem_typed Γ x e1 e2 C B :
    (Γ ⊨ e1 : ∃ A, C A) -∗ (∀ A, binder_insert x (C A) Γ ⊨ e2 : B) -∗
    Γ ⊨ (unpack: x := e1 in e2) : B.
  (* SOLUTION *) Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (v); iDestruct 1 as (A) "#HC".
    rewrite /exist_unpack; wp_pures. rewrite -subst_map_binder_insert.
    wp_apply (wp_wand with "(H2 [])").
    { by iApply env_sem_typed_insert. }
    auto.
  Qed.

  (** ** Heap operations *)
  Lemma Alloc_sem_typed Γ e A : Γ ⊨ e : A -∗ Γ ⊨ ref e : ref A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_bind (subst_map _ e). iApply (wp_wand with "(H [//])"); iIntros (w) "HA".
    iApply wp_fupd. wp_alloc l as "Hl".
    iMod (inv_alloc (tyN .@ l) _ (∃ v, l ↦ v ∗ A v)%I with "[Hl HA]") as "#?".
    { iExists w. iFrame. }
    iModIntro. iExists l; auto.
  Qed.
  Lemma Load_sem_typed Γ e A : Γ ⊨ e : ref A -∗ Γ ⊨ ! e : A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_bind (subst_map _ e). iApply (wp_wand with "(H [//])"); iIntros (w).
    iDestruct 1 as (l ->) "#?".
    iInv (tyN.@l) as (v) "[>Hl HA]". wp_load. eauto 10.
  Qed.
  Lemma Store_sem_typed Γ e1 e2 A :
    Γ ⊨ e1 : ref A -∗ Γ ⊨ e2 : A -∗ Γ ⊨ (e1 <- e2) : ().
  (* SOLUTION *) Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w2) "#HA".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (w1); iDestruct 1 as (l ->) "#?".
    iInv (tyN.@l) as (v) "[>Hl _]". wp_store. eauto 10.
  Qed.
  Lemma FAA_sem_typed Γ e1 e2 :
    Γ ⊨ e1 : ref sem_ty_int -∗ Γ ⊨ e2 : sem_ty_int -∗ Γ ⊨ FAA e1 e2 : sem_ty_int.
  (* SOLUTION *) Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w2); iDestruct 1 as (n) "->".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (w1); iDestruct 1 as (l ->) "#?".
    iInv (tyN.@l) as (v) "[>Hl Hv]"; iDestruct "Hv" as (n') "> ->".
    wp_faa. iModIntro. eauto 10.
  Qed.
  Lemma CmpXchg_sem_typed Γ A e1 e2 e3 :
    SemTyUnboxed A →
    Γ ⊨ e1 : ref A -∗ Γ ⊨ e2 : A -∗ Γ ⊨ e3 : A -∗
    Γ ⊨ CmpXchg e1 e2 e3 : A * sem_ty_bool.
  (* SOLUTION *) Proof.
    intros. iIntros "#H1 #H2 #H3" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H3 [//])"); iIntros (w3) "HA3".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w2) "HA2".
    iDestruct (sem_ty_unboxed with "HA2") as %?.
    wp_apply (wp_wand with "(H1 [//])"); iIntros (w1); iDestruct 1 as (l ->) "#?".
    iInv (tyN.@l) as (v) "[>Hl #Hv]". wp_cmpxchg as ?|?; iModIntro;
      (iSplitL; [by eauto 12 with iFrame | iExists _, _; eauto]).
  Qed.

  (** ** Recursive types *)
  (** Hint: A crucial ingredient for these proofs is the lemma [sem_ty_unfold]. *)
  Lemma Fold_sem_typed Γ e C `{!NonExpansive C} :
    Γ ⊨ e : C (μ A, C A)%sem_ty -∗ Γ ⊨ (fold: e) : μ A, C A.
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!# #HΓ /=". wp_pures.
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HC".
    rewrite /rec_fold. wp_lam. iModIntro. by iApply sem_ty_unfold.
  Qed.
  Lemma Unfold_sem_typed Γ e C `{!NonExpansive C} :
    Γ ⊨ e : (μ A, C A) -∗ Γ ⊨ (unfold: e) : C (μ A, C A)%sem_ty.
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!# #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HC".
    rewrite sem_ty_unfold. rewrite /rec_unfold. by wp_lam.
  Qed.

  (** ** Operators *)
  Lemma UnOp_sem_typed Γ e op A B :
    SemTyUnOp op A B → Γ ⊨ e : A -∗ Γ ⊨ UnOp op e : B.
  Proof.
    intros ?. iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (v) "#HA".
    iDestruct (sem_ty_un_op with "HA") as (w ?) "#HB". by wp_unop.
  Qed.
  Lemma BinOp_sem_typed Γ e1 e2 op A1 A2 B :
    SemTyBinOp op A1 A2 B → Γ ⊨ e1 : A1 -∗ Γ ⊨ e2 : A2 -∗ Γ ⊨ BinOp op e1 e2 : B.
  (* SOLUTION *) Proof.
    intros. iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (v2) "#HA2".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (v1) "#HA1".
    iDestruct (sem_ty_bin_op with "HA1 HA2") as (w ?) "#HB". by wp_binop.
  Qed.

  Lemma If_sem_typed Γ e e1 e2 B :
    Γ ⊨ e : sem_ty_bool -∗ Γ ⊨ e1 : B -∗ Γ ⊨ e2 : B -∗
    Γ ⊨ (if: e then e1 else e2) : B.
  (* SOLUTION *) Proof.
    iIntros "#H #H1 #H2" (vs) "!> #HΓ /=".
    iSpecialize ("H1" with "HΓ"). iSpecialize ("H2" with "HΓ").
    wp_apply (wp_wand with "(H [//])"); iIntros (w). iDestruct 1 as ([]) "->"; by wp_if.
  Qed.

  (** ** Fork *)
  Lemma Fork_sem_typed Γ e : Γ ⊨ e : () -∗ Γ ⊨ Fork e : ().
  (* SOLUTION *) Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply wp_fork; last done. by iApply (wp_wand with "(H [//])").
  Qed.

  (** * Compatibility rules for value typing *)
  (** ** Base types *)
  Lemma UnitV_sem_typed : ⊢ ⊨ᵥ #() : ().
  Proof. by iPureIntro. Qed.
  Lemma BoolV_sem_typed (b : bool) : ⊢ ⊨ᵥ #b : sem_ty_bool.
  Proof. by iExists b. Qed.
  Lemma IntV_sem_typed (n : Z) : ⊢ ⊨ᵥ #n : sem_ty_int.
  (* SOLUTION *) Proof.
    by iExists n.
  Qed.

  (** ** Products and sums *)
  Lemma PairV_sem_typed v1 v2 τ1 τ2 :
    ⊨ᵥ v1 : τ1 -∗ ⊨ᵥ v2 : τ2 -∗
    ⊨ᵥ PairV v1 v2 : (τ1 * τ2).
  Proof. iIntros "#H1 #H2". iExists v1, v2. auto. Qed.
  Lemma InjLV_sem_typed v τ1 τ2 :
    ⊨ᵥ v : τ1 -∗
    ⊨ᵥ InjLV v : (τ1 + τ2).
  Proof. iIntros "H". iLeft. auto. Qed.
  Lemma InjRV_sem_typed v τ1 τ2 :
    ⊨ᵥ v : τ2 -∗
    ⊨ᵥ InjRV v : (τ1 + τ2).
  Proof. iIntros "H". iRight. auto. Qed.

  (** ** Functions *)
  Lemma RecV_sem_typed f x e A B :
    binder_insert f (A → B)%sem_ty (binder_insert x A ∅) ⊨ e : B -∗
    ⊨ᵥ RecV f x e : (A → B).
  Proof.
    iIntros "#H". iLöb as "IH".
    iIntros "!>" (v) "#HA1". wp_pures. set (r := RecV f x _).
    rewrite -subst_map_binder_insert_2_empty. iApply "H".
    iApply (env_sem_typed_insert with "IH").
    iApply (env_sem_typed_insert with "[$]"). iApply env_sem_typed_empty.
  Qed.

  Lemma TLamV_sem_typed e C : (∀ A, ∅ ⊨ e : C A) -∗ ⊨ᵥ (Λ: e) : ∀ A, C A.
  Proof.
    iIntros "#H !>" (A) "/=". wp_pures.
    rewrite -{2}(subst_map_empty e). iApply ("H" $! A).
    by iApply env_sem_typed_empty.
  Qed.
End compatibility.


Require Export Helpers.

(**

* Operator Definitions

- UnaryOperator : For unary operations
- BinaryArithOperator : For Binary Arithmetic Only
- BinaryCompOperator : For comparison of two values

*)

Inductive UnaryOperator : Type :=
  | unot : UnaryOperator.

Inductive BinaryArithOperator : Type :=
  | badd : BinaryArithOperator
  | bsub : BinaryArithOperator
  | bmult : BinaryArithOperator
  | bdiv : BinaryArithOperator
  | bmod : BinaryArithOperator
.

(**
  - | band : BinaryArithOperator
  - | bor : BinaryArithOperator
  - | bxor : BinaryArithOperator
  For later
*)

Inductive BinaryCompOperator : Type :=
  | beq : BinaryCompOperator
  | blt : BinaryCompOperator
  | bgt : BinaryCompOperator.

Inductive PrimType : Type :=
  | Int | Char | Bool.

Inductive Prim : Type :=
  | boolean : nat -> Prim
  | char : nat -> Prim
  | int : nat -> Prim.

(**

* Signature for Functionality module on primitives

*)

Module Type PrimitiveType.
  Parameter t : Type.   (** ADT for primitives which is Prim *)
  Parameter t_type : Type. (** ADT for primitive types *)
  Parameter cast : t_type -> t -> t.
  Parameter comp : t -> t -> nat.
  Parameter toNat : t -> nat.
  Parameter fromNat : t_type -> nat -> t.
  Parameter getType : t -> t_type.
(**
  - Axiom castToSame : forall x ty, ty = (getType x) -> (cast ty x) = x.
  - Axiom castType : forall x ty, getType (cast ty x) = ty.
  Not a priority, since Primitives are in separate modules, there execution can be updated anytime
  without breaking whole system
*)
End PrimitiveType.

(**

* PType an implementation module

*)

Module PType <: PrimitiveType.
(**
  Declares parameter ADTs for Primitive and PrimitiveType
*)
  Definition t := Prim.
  Definition t_type := PrimType.

(**

** Operations

  - toNat : Prim to nat conversion
  - fromNat : nat and input type to Prim of input type
  - getType : return type of current Prim
  - comp : compares two prims
  - cast : cast given prim to prim of input type

*)

  Fixpoint toNat (x:t) : nat :=
    match x with
    | boolean n => n
    | char n => n
    | int n => n
    end.

  Inductive toNatRel : t -> nat -> Prop :=
    | boolToNatRel : forall n:nat, toNatRel (boolean n) n
    | charToNatRel : forall n:nat, toNatRel (char n) n
    | intToNatRel : forall n:nat, toNatRel (int n) n.

  Theorem toNatRelEq : forall (x:t) (n:nat), toNat x = n <-> toNatRel x n.
  Proof.
    destruct x; split; intro; simpl in H; subst; try econstructor; try (inversion H; simpl; reflexivity).
  Qed.

  Fixpoint fromNat (ty:t_type) (n:nat) : t :=
    match ty with
    | Bool => boolean n
    | Char => char n
    | Int => int n
    end.

  Inductive fromNatRel : t_type -> nat -> t -> Prop :=
    | boolFromNatRel : forall n:nat, fromNatRel Bool n (boolean n)
    | charFromNatRel : forall n:nat, fromNatRel Char n (char n)
    | intFromNatRel : forall n:nat, fromNatRel Int n (int n).

  Theorem fromNatRelEq : forall (ty:t_type) (x:t) (n:nat), fromNat ty n = x <-> fromNatRel ty n x.
  Proof.
    destruct ty; split; intro; simpl in H; subst; try econstructor; try inversion H; simpl; reflexivity.
  Qed.

  Fixpoint getType (x:t) : t_type :=
    match x with
    | boolean x => Bool
    | char x => Char
    | int x => Int
    end.

  Inductive getTypeRel : t -> t_type -> Prop :=
    | boolGetTypeRel: forall n:nat, getTypeRel (boolean n) Bool
    | charGetTypeRel: forall n:nat, getTypeRel (char n) Char
    | intGetTypeRel: forall n:nat, getTypeRel (int n) Int.

  Theorem getTypeRelEq : forall (x:t) (ty:t_type), getType x = ty <-> getTypeRel x ty.
  Proof.
    destruct x; split; intro; simpl in H; subst; try econstructor; inversion H; simpl; reflexivity.
  Qed.

  Definition cast (ty:t_type) (x:t) : t :=
    fromNat ty (toNat x).

  Inductive castRel : t_type -> t -> t -> Prop:=
    | castRelConstructor : forall (x1 x2:t) (ty:t_type) (n:nat), toNatRel x1 n -> fromNatRel ty n x2 -> castRel ty x1 x2.

  Theorem castRelEq : forall (ty:t_type) (x1 x2:t), cast ty x1 = x2 <-> castRel ty x1 x2.
  Proof.
    intros; split; intro.
    unfold cast in H.
      remember (toNat x1) as n.
      econstructor. eapply toNatRelEq. symmetry. eapply Heqn.
      apply fromNatRelEq. assumption.
    inversion H. unfold cast. apply toNatRelEq in H0. subst. apply fromNatRelEq.
    assumption.
  Qed.

  Definition comp (x1 x2:t) : nat :=
    (toNat x1) - (toNat x2).

End PType.


(* Copyright © 1998-2008
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing Qpos $\mathbb{Q}^{+}$ #Q<SUP>+</SUP># *)

Require Export Coq.QArith.QArith.
Require Import Coq.QArith.Qpower.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.algebra.COrdFields2.
Require Import Coq.Logic.Eqdep_dec.
Require Import CoRN.tactics.CornTac.
Require Import Coq.QArith.Qround.
Require Import Coq.QArith.Qabs.
Require Import CoRN.stdlib_omissions.Q.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Local Open Scope Q_scope.

(**
* [Qpos]
*)

Definition Qpos: Set := sig (Qlt 0).

Program Definition QposMake (num den: positive): Qpos := num # den.
Next Obligation. auto with *. Qed.

Notation "a # b" := (QposMake a b) (at level 55, no associativity) : Qpos_scope.

Bind Scope Qpos_scope with Qpos.
Delimit Scope Qpos_scope with Qpos.

Program Definition integral_Qpos (p: positive): Qpos := (p:Q).

Coercion integral_Qpos: positive >-> Qpos.

(** There is an injection from [Qpos] to [Q] that we make into a
coercion. *)

Definition QposAsQ: Qpos -> Q := @proj1_sig _ _.

Coercion QposAsQ : Qpos >-> Q.

(** Basic properties about [Qpos] *)
Definition Qpos_prf : forall a:Qpos, 0 < a := @proj2_sig _ _.

#[global]
Hint Immediate Qpos_prf.

Lemma Qpos_nonzero : forall x:Qpos, (x:Q)[#]0.
Proof.
 intros ?.
 apply: pos_ap_zero.
 apply Qpos_prf.
Qed.

Lemma Qpos_nonzero' (q: Qpos): ~ q == 0.
  (* simpler variant that actually shows up as proof obligations *)
Proof. apply Qpos_nonzero. Qed.

#[global]
Hint Immediate Qpos_nonzero'.

Lemma Qpos_nonneg : forall a:Qpos, 0 <= a.
Proof. intros [??]. auto with *. Qed.

#[global]
Hint Immediate Qpos_nonneg.

Lemma Qopp_Qpos_neg (x: Qpos): -x < 0.
Proof. apply Qopp_Qlt_0_r. auto. Qed.

#[global]
Hint Immediate Qopp_Qpos_neg.

(** Any positive rational number can be transformed into a [Qpos]. *)
Definition mkQpos: forall (a:Q) (p:0 < a), Qpos := @exist Q (Qlt 0).

(* begin hide *)
Arguments mkQpos [a].
(* end hide *)
Lemma QposAsmkQpos : forall (a:Q) (p:0<a), (QposAsQ (mkQpos p))=a.
Proof.
 intros [[|an|an] ad] p.
   discriminate.
  reflexivity.
 discriminate.
Qed.
(* begin hide *)
Arguments QposAsmkQpos [a].
(* end hide *)

Lemma positive_Z (z: Z): Z.lt 0 z -> sig (fun p: positive => Zpos p = z).
 destruct z; intros.
   intros.
   elim (Z.lt_irrefl _ H).
  exists p.
  reflexivity.
 exfalso.
 apply (Zlt_asym _ _ H).
 auto with *.
Defined.

(* todo: move this Qlt_uniq stuff elsewhere *)
Require Coq.Logic.Eqdep_dec.

Definition comparison_eq_dec (a b: comparison): { a = b } + { a <> b}.
 destruct a, b; try (left; reflexivity); try (right; discriminate).
Defined.

Lemma Zlt_uniq (a b: Z) (p q: (a < b)%Z): p = q.
Proof.
 unfold Z.lt in *. destruct p. intros.
 apply (Eqdep_dec.K_dec_set comparison_eq_dec).
 reflexivity.
Qed.

Lemma Qlt_uniq (a b: Q) (p q: a < b): p = q.
Proof. intros. apply Zlt_uniq. Qed.

Program Definition Qpos_as_positive_ratio (q: Qpos):
  sig (fun ps: positive * positive => q = QposMake (fst ps) (snd ps)) :=
  (positive_Z (Qnum q) _, Qden q).

Next Obligation.
 destruct q as [[??] ?]. unfold Qlt in *. simpl in *. auto with *.
Qed.

Next Obligation.
 destruct q as [[??] ?]. simpl.
 destruct positive_Z. simpl.
 subst. unfold QposMake.
 f_equal. apply Qlt_uniq.
Qed.

Lemma Qpos_positive_numerator_rect (P: Qpos -> Type):
  (forall (a b: positive), P (a # b)%Qpos) -> forall q, P q.
Proof.
 intros H q.
 destruct (Qpos_as_positive_ratio q).
 subst.
 apply H.
Defined.

Lemma QposAsQposMake : forall a b, (QposAsQ (QposMake a b)) = (Zpos a)#b.
Proof.
 trivial.
Qed.

(* begin hide *)
#[global]
Hint Rewrite QposAsmkQpos QposAsQposMake : QposElim.
(* end hide *)

(**
*** Equality
*)
Definition QposEq (a b:Qpos) := Qeq a b.
#[global]
Instance Qpos_default : @DefaultRelation Qpos QposEq | 2 := {}.

Add Relation Qpos QposEq
 reflexivity proved by (fun (x:Qpos) => Qeq_refl x)
 symmetry proved by (fun (x y:Qpos) => Qeq_sym x y)
 transitivity proved by (fun (x y z:Qpos) => Qeq_trans x y z) as QposSetoid.

Definition QposAp (a b:Qpos) := Qap a b.

Definition Qpos_PI (a b: Qpos): (a: Q) = b -> a = b.
Proof.
 destruct a, b.
 simpl. intros. subst.
 f_equal. apply Qlt_uniq.
Qed.

(**
*** Addition
*)
Program Definition Qpos_plus (x y:Qpos) : Qpos := Qplus x y.

Next Obligation.
 apply: plus_resp_pos; apply Qpos_prf.
Qed.

Infix "+" := Qpos_plus : Qpos_scope.
(* begin hide *)
Add Morphism Qpos_plus : Qpos_plus_wd.
Proof.
 intros x1 x2 Hx y1 y2 Hy.
 unfold QposEq in *.
 unfold Qpos_plus.
 simpl.
 apply Qplus_comp; assumption.
Qed.
(* end hide *)
Lemma Q_Qpos_plus : forall (x y:Qpos), ((x + y)%Qpos:Q)=(x:Q)+(y:Q).
Proof.
 trivial.
Qed.
(* begin hide *)
#[global]
Hint Rewrite Q_Qpos_plus : QposElim.
(* end hide *)

(**
*** One
*)
Program Definition Qpos_one : Qpos := 1.
Next Obligation. auto with qarith. Qed.
Notation "1" := Qpos_one : Qpos_scope.

Lemma Q_Qpos_one : (1%Qpos:Q)=(1:Q).
Proof. trivial. Qed.
(* begin hide *)
#[global]
Hint Rewrite Q_Qpos_one : QposElim.
(* end hide *)

(**
*** Multiplication
*)

Program Definition Qpos_mult (x y:Qpos) : Qpos := Qmult x y.

Infix "*" := Qpos_mult : Qpos_scope.
(* begin hide *)
Add Morphism Qpos_mult : Qpos_mult_wd.
Proof.
 intros x1 x2 Hx y1 y2 Hy.
 unfold QposEq in *.
 unfold Qpos_mult.
 simpl.
 apply Qmult_comp; assumption.
Qed.
(* end hide *)
Lemma Q_Qpos_mult : forall (x y:Qpos), ((x * y)%Qpos:Q)=(x:Q)*(y:Q).
Proof.
 trivial.
Qed.
(* begin hide *)
#[global]
Hint Rewrite Q_Qpos_mult : QposElim.
(* end hide *)
(**
*** Inverse
*)

Program Definition Qpos_inv (x:Qpos): Qpos := / x.

Next Obligation.
 apply Qinv_lt_0_compat.
 destruct x.
 assumption.
Qed.

(* begin hide *)
Add Morphism Qpos_inv : Qpos_inv_wd.
Proof.
 intros [x P] [y Q] E.
 unfold QposEq in *.
 simpl in *.
 rewrite E.
 reflexivity.
Qed.
(* end hide *)
Lemma Q_Qpos_inv : forall (x:Qpos), Qpos_inv x = / x :> Q.
Proof.
 trivial.
Qed.
#[global]
Hint Rewrite Q_Qpos_inv : QposElim.

Notation "a / b" := (Qpos_mult a (Qpos_inv b)) : Qpos_scope.

(**
*** Tactics
These tactics solve Ring and Field equations over [Qpos] by converting
them to problems over [Q].
*)
Ltac QposRing :=
 unfold canonical_names.equiv, QposEq;
 autorewrite with QposElim;
 ring.

Ltac QposField :=
 unfold canonical_names.equiv, QposEq;
 autorewrite with QposElim;
 field.

(** This is a standard way of decomposing a rational b that is greater than
a into a plus a positive value c. *)
Lemma Qpos_lt_plus : forall (a b:Q),
 a< b ->
 {c:Qpos | b==(a+c)}.
Proof.
 intros.
 assert (0<b-a).
  apply: shift_zero_less_minus.
  assumption.
 exists (mkQpos H0).
 QposRing.
Defined.
(* begin hide *)
Arguments Qpos_lt_plus [a b].
(* end hide *)
(**
*** Power
*)
Lemma Qpos_power_pos : forall (x:Qpos) z, 0 < x^z.
Proof.
 intros x z.
 destruct (Qle_lt_or_eq _ _ (Qpower_pos x z (Qlt_le_weak _ _ (Qpos_prf x))));[assumption|].
 destruct z.
   discriminate H.
  elim (Qpower_not_0_positive x p).
   apply Qpos_nonzero.
  symmetry; assumption.
 elim (Qpower_not_0_positive (/x) p).
  change (~(Qpos_inv x) == 0).
  apply Qpos_nonzero.
 change ((/x)^p==0).
 rewrite -> Qinv_power.
 symmetry; assumption.
Qed.

Definition Qpos_power (x:Qpos) (z:Z) : Qpos.
Proof.
 apply mkQpos with (x^z).
 apply Qpos_power_pos.
Defined.

Infix "^" := Qpos_power : Qpos_scope.
(* begin hide *)
#[global]
Instance Qpos_power_wd: Proper (QposEq ==> @eq Z ==> QposEq) Qpos_power.
Proof.
 intros x1 x2 Hx y1 y2 Hy.
 unfold QposEq in *.
 unfold Qpos_power.
 autorewrite with QposElim.
 simpl.
 now rewrite Hx, Hy.
Qed.
(* end hide *)
Lemma Q_Qpos_power : forall (x:Qpos) z, ((x^z)%Qpos:Q)==(x:Q)^z.
Proof.
 intros.
 unfold Qpos_power.
 autorewrite with QposElim.
 reflexivity.
Qed.
#[global]
Hint Rewrite Q_Qpos_power : QposElim.

(**
*** Summing lists
*)
Definition QposSum (l:list Qpos) : Q := fold_right
(fun (x:Qpos) (y:Q) => x+y) ([0]:Q) l.

Lemma QposSumNonNeg : forall l, 0 <= QposSum l.
Proof.
 induction l.
  apply: leEq_reflexive.
 simpl.
 apply: plus_resp_nonneg.
  apply: less_leEq.
  apply Qpos_prf.
 assumption.
Qed.

(** A version of [Qred] for [Qpos]. *)
Lemma QposRed_prf : forall (a:Q), (0 < a) -> (0 < Qred a).
Proof.
 intros a Ha.
 rewrite -> Qred_correct.
 assumption.
Qed.

Definition QposRed (a:Qpos) : Qpos := mkQpos (QposRed_prf a (Qpos_prf a)).

#[global]
Instance QposRed_complete: Proper (QposEq ==> eq) QposRed.
Proof.
 intros p q H.
 unfold QposRed.
 generalize (QposRed_prf p (Qpos_prf p)).
 generalize (QposRed_prf q (Qpos_prf q)).
 rewrite (Qred_complete p q H).
 unfold Qlt, Z.lt.
 intros A B.
 assert (X:forall x y : comparison, x = y \/ x <> y).
  decide equality.
 rewrite (eq_proofs_unicity X A B).
 reflexivity.
Qed.

Lemma QposRed_correct : forall p, QposRed p == p.
Proof.
 unfold QposRed.
 intros p.
 simpl.
 apply Qred_correct.
Qed.

(* For a Qpos we know its ceiling is positive: *)

Definition QposCeiling (q: Qpos): positive :=
  match Qceiling q with
  | Zpos p => p
  | _ => 1%positive (* impossible *)
  end.

Lemma QposCeiling_Qceiling (q: Qpos): (QposCeiling q: Z) = Qceiling q.
Proof with auto with *.
 unfold QposCeiling.
 pose proof Qle_ceiling q.
 destruct (Qceiling q); try reflexivity; exfalso; destruct q; simpl in *.
  apply (Qlt_not_le 0 x q)...
 apply (Qlt_irrefl 0).
 apply Qlt_le_trans with x...
 apply Qle_trans with (Zneg p)...
Qed.

(* This function is only defined for non zero elements, so in case of 0, we yield a dummy *)
Definition QabsQpos (x : Q) : Qpos :=
  match x with
  | 0 # _ => (1%Qpos)
  | (Zpos an) # ad => (an # ad)%Qpos
  | (Zneg an) # ad => (an # ad)%Qpos
  end.

Lemma QabsQpos_correct x : ~x == 0 -> QabsQpos x == Qabs x.
Proof with auto with qarith.
 intros E. destruct x as [n d]. simpl.
 destruct n...
 destruct E...
Qed.

Lemma QabsQpos_Qpos (x : Qpos) : QposEq (QabsQpos x) x.
Proof with auto with qarith.
 unfold QposEq.
 rewrite QabsQpos_correct...
 apply Qabs_pos...
Qed.


(* Here we model IO as a partial function between input and output
   states: [IO a ~ (io_state -> io_state * a)], actually
   implemented as [io_state -> io_state -> a -> Prop].

   Partiality is caused by the presence of a general (monadic)
   fixpoint combinator ([mfix]).
 *)

From Coq Require Import
     List ZArith String
     RelationClasses
     extraction.ExtrOcamlIntConv.
Import ListNotations.

From Coq.extraction Require Import
     ExtrOcamlIntConv.

From ExtLib Require Import
     Data.Monads.OptionMonad
     Structures.Monads.

From advent.lib Require Import
     io utils.

(* First, some general definitions about state [S -> (S * A)].
   We then specialize [S] to a simple model of IO state. *)

(* [state_rel]: state [S -> (S * A)] as a relation. *)
Definition state_rel (S : Type) (A : Type) : Type :=
  S -> S -> A -> Prop.

(* [state_rel] is a monad. *)
Instance Monad_state_rel (S : Type) : Monad (state_rel S) := {
  ret _ x := fun s1 s2 x' => s2 = s1 /\ x' = x;
  bind _ _ m k := fun s1 s3 y =>
    exists x s2, m s1 s2 x /\ k x s2 s3 y
}.

(* Errors are modelled by the empty relation. *)
Instance MonadError_state_rel (S : Type) : MonadError (state_rel S) := {
  error _ _ := fun _ _ _ => False
}.

(* Relations are preordered by implication. *)
Definition incl_rel {S A : Type} (r1 r2 : state_rel S A) :=
  forall s1 s2 a, r1 s1 s2 a -> r2 s1 s2 a.

(* Logical equivalence. *)
Definition eq_rel {S A : Type} (r1 r2 : state_rel S A) :=
  incl_rel r1 r2 /\ incl_rel r2 r1.

Instance Transitive_incl_rel {S A} : Transitive (@incl_rel S A).
Proof. firstorder. Qed.

Instance Transitive_eq_rel {S A} : Transitive (@eq_rel S A).
Proof. firstorder. Qed.

(* For [mfix], we will be manipulating relations with an extra
   parameter: [A -> S -> S -> B -> Prop]. *)
Definition incl_rel1 {S A B : Type}
           (r1 r2 : A -> state_rel S B) :=
  forall x, incl_rel (r1 x) (r2 x).

(* Reflexivity of [incl_rel1]. *)
Lemma incl_rel1_refl {S A B : Type} (r : A -> state_rel S B) :
  incl_rel1 r r.
Proof.
  intros x z1 z2 y; auto.
Qed.

(* Least fixed point of the "relation transformer", [gf] (or
   "generating function"; note how it maps relations to relations).
   [gf] is assumed to be monotonic (see below).
   Definition inspired by [paco] (https://github.com/snu-sf/paco). *)
Inductive lfp_rel1 {S A B : Type}
          (gf : (A -> state_rel S B) -> (A -> state_rel S B))
          (a : A) (s1 s2 : S) (b : B) : Prop :=
| LFP
    (P : A -> state_rel S B)
    (P_ind : incl_rel1 P (lfp_rel1 gf))
    (P_holds : gf P a s1 s2 b).

(* [monotonic_rel1 gf : Prop] : the relation transformer [gf]
   is monotonic. *)
Definition monotonic_rel1 {S U V A B : Type}
           (gf : (U -> state_rel S V) -> (A -> state_rel S B)) :=
  forall r1 r2,
    incl_rel1 r1 r2 ->
    incl_rel1 (gf r1) (gf r2).

(* [lfp_rel1 gf] is included in [gf (lfp_rel1 gf)]... *)
Lemma lfp_rel_unfold {S A B : Type}
      (gf : (A -> state_rel S B) -> (A -> state_rel S B))
      (mon_gf : monotonic_rel1 gf) :
  incl_rel1 (lfp_rel1 gf) (gf (lfp_rel1 gf)).
Proof.
  intros x z1 z2 y [P P_ind P_holds].
  eapply mon_gf.
  apply P_ind.
  apply P_holds.
Qed.

(* ... and conversely. Therefore, [lfp_rel1] does define a fixed
   point... *)
Lemma lfp_rel_fold {S A B : Type}
      (gf : (A -> state_rel S B) -> (A -> state_rel S B)) :
  incl_rel1 (gf (lfp_rel1 gf)) (lfp_rel1 gf).
Proof.
  intros x z1 z2 y Hgf.
  apply LFP with (P := lfp_rel1 gf).
  apply incl_rel1_refl.
  auto.
Qed.

(* ... and it is in fact the smallest: every other fixed point [fp]
   contains [lfp_rel1 gf]. *)
Lemma really_lfp {S A B : Type}
      (gf : (A -> state_rel S B) -> (A -> state_rel S B))
      (mon_gf : monotonic_rel1 gf)
      (fp : A -> state_rel S B)
      (H_fp : incl_rel1 (gf fp) fp) :
  incl_rel1 (lfp_rel1 gf) fp.
Proof.
  intros x z1 z2 y.
  induction 1 as [x z1 z2 y P P_ind IH P_holds].
  apply H_fp.
  apply mon_gf with (r1 := P); auto.
Qed.

(* Fixed-point semantics for [mfix]. *)
Instance MonadFix_state_rel (S : Type) : MonadFix (state_rel S) := {
  mfix _ _ := lfp_rel1
}.

(* Utilities to prove monotonicity. *)

Lemma monotonic_refl (S U V W A : Type)
      (m : state_rel S A) :
  monotonic_rel1 (fun (_ : U -> _ V) (_ : W) => m).
Proof.
  unfold monotonic_rel1, incl_rel1, incl_rel; auto.
Qed.

Lemma monotonic_id (S U V W : Type)
      (g : W -> U) :
  monotonic_rel1 (fun (f : U -> state_rel S V) (w : W) => f (g w)).
Proof.
  unfold monotonic_rel1, incl_rel1; auto.
Qed.

Lemma monotonic_ret (S U V W A : Type)
      (g : W -> A) :
  monotonic_rel1 (fun (f : U -> state_rel S V) (w : W) => ret (g w)).
Proof.
  unfold monotonic_rel1, incl_rel1, incl_rel; auto.
Qed.

Lemma monotonic_bind (S U V W A B : Type)
      (m : (U -> state_rel S V) -> W -> state_rel S A)
      (k : (U -> state_rel S V) -> W -> A -> state_rel S B)
      (mon_m : monotonic_rel1 m)
      (mon_k : forall a, monotonic_rel1 (fun f w => k f w a)) :
  monotonic_rel1 (fun f w => pbind (m f w) (k f w)).
Proof.
  intros r1 r2 Hr12 w s1 s3 b [a [s2 [Hm Hk]]].
  exists a, s2.
  firstorder.
  specialize (mon_k a).
  unfold monotonic_rel1 in mon_k.
  eapply mon_k; eauto.
Qed.

(* Modelling [IO]. *)

(* We represent IO state as a sequence of inputs and a sequence
   of outputs. For problems like AoC that should be quite enough.
   The input and output types are parameters: we trust the
   parsing/printing done by [read]/[print], there is still quite
   some space left to play with verification.
 *)
Record io_state (I O : Type) := Mk_io_state {
  input : list I;
  output : list O;
}.

Arguments Mk_io_state {I O} _ _.
Arguments input {I O} _.
Arguments output {I O} _.

(* Construct an initial state from an initial input sequence. *)
Definition initial {I O : Type} (i : list I) : io_state I O :=
  Mk_io_state i [].

(* Update the state on a [read]. *)
Definition drop_input {I O : Type} (r : io_state I O) : io_state I O :=
  let '(Mk_io_state i o) := r in
  Mk_io_state (tl i) o.

(* Update the state on a [print]. *)
Definition push_output {I O : Type}
           (z : O) (r : io_state I O) : io_state I O :=
  let '(Mk_io_state i o) := r in
  Mk_io_state i (o ++ [z]).

(* [state_rel] specialized with [io_state]. *)
Definition io_rel (I O : Type) : Type -> Type :=
  state_rel (io_state I O).

(* Toplevel specification, we model an [IO unit] program
   as a relation between inputs and outputs. *)
Definition rel_spec (I O : Type) :
  io_rel I O unit -> list I -> list O -> Prop :=
  fun x i o =>
    exists s,
      x (initial i) s tt /\
      output s = o.

(* Model [read] in [io_rel]. *)
Instance MonadI_io_rel (I O : Type) : MonadI I (io_rel I O) := {
  read := fun s1 s2 x' =>
    (exists z,
      input s1 = z :: input s2 /\
      s2 = drop_input s1 /\
      x' = Some z) \/
    (input s1 = [] /\ s2 = s1 /\ x' = None);
}.

(* Model [print] in [io_rel]. *)
Instance MonadO_io_rel (I O : Type) : MonadO O (io_rel I O) := {
  print z := fun s1 s2 x' =>
    s2 = push_output z s1 /\
    x' = tt
}.

(* Specification of [fold_read]. *)
Lemma fold_read_rel {I O A : Type} (f : A -> I -> A) (a0 : A) :
  eq_rel (fold_read f a0)
         (fun (s1 s2 : io_state I O) (a1 : A) =>
            a1 = fold_left f (input s1) a0 /\
            s2 = Mk_io_state [] (output s1)).
Proof.
  split.
  - intros s1 s2 xs.
    unfold fold_read, FoldRead_MonadFix.
    match goal with
    | [ |- mfix ?body _ _ _ _ -> _ ] =>
      assert (mon_body : monotonic_rel1 body)
    end.
    { apply monotonic_bind.
      - apply monotonic_refl.
      - intros [i|].
        { apply monotonic_id. }
        { apply monotonic_ret. }
    }
    match goal with
    | [ |- mfix ?body _ _ _ _ -> _ ] =>
      assert (H : forall acc s1 s2 a1,
                 lfp_rel1 body acc s1 s2 a1 ->
                 a1 = fold_left f (input s1) acc /\
                 s2 = Mk_io_state [] (output s1)); [|auto]
    end.
    { revert mon_body; clear; intros mon_body acc [is1 os1].
      revert acc. induction is1 as [| i1 is1]; intros acc s2 xs Hloop.
      - apply lfp_rel_unfold in Hloop; auto.
        destruct Hloop as [ox [s1' [Hread Hloop]]].
        destruct Hread as [[i1 [Hi1]] | [Hi [Hs1' Hox]]].
        + discriminate Hi1.
        + subst ox.
          destruct Hloop; subst; auto.
      - apply lfp_rel_unfold in Hloop; auto.
        destruct Hloop as [ox [s1' [Hread Hloop]]].
        destruct Hread as [[i1' [Hi1 [Hs1' Hox]]] | [Hs1' Hox]].
        + subst ox s1'.
          simpl in Hi1; inversion Hi1; subst.
          apply IHis1 in Hloop.
          destruct Hloop as [Hxs Hs2]. subst.
          auto.
        + discriminate.
    }
  - intros s1 s2 a1 [Ha1 Hs2].
    unfold fold_read, FoldRead_MonadFix.
    match goal with
    | [ |- mfix ?body _ _ _ _ ] =>
      assert (H : forall acc s1 s2 a1,
                 a1 = fold_left f (input s1) acc ->
                 s2 = Mk_io_state [] (output s1) ->
                 lfp_rel1 body acc s1 s2 a1); [| apply H; auto]
    end.
    { clear.
      intros acc s1. revert acc.
      remember (input s1) as is1 eqn:Hs1.
      generalize dependent s1.
      induction is1 as [|i1 is1 IH];
        intros s1 Hs1 acc s2 xs His1 Hs2;
        apply lfp_rel_fold.
      + exists None, s2.
        split.
        * right; destruct s1, s2; simpl in *; subst; auto.
        * simpl; auto.
      + exists (Some i1), (Mk_io_state is1 (output s1)).
        split.
        * left. exists i1. simpl.
          destruct s1; simpl in *; subst; auto.
        * apply IH; auto.
    }
Qed.

(* Specification of [read_all]: it consumes all the input and
   returns it in a list. *)
Lemma read_all_rel {I O : Type} :
  eq_rel read_all
         (fun (s1 s2 : io_state I O) xs =>
            xs = input s1 /\
            s2 = Mk_io_state [] (output s1)).
Proof.
  split; intros s1 s2 a1.
  - intros [is1' [s1' [H1' [? ?]]]]; subst.
    apply fold_read_rel in H1'.
    rewrite fold_left_cons in H1'.
    destruct H1'; subst.
    unfold rev'; rewrite <- rev_alt, rev_involutive.
    auto.
  - intros [? ?]; subst.
    exists (rev (input s1)). eexists.
    split.
    + apply fold_read_rel.
      split.
      * rewrite fold_left_cons; auto.
      * reflexivity.
    + unfold rev'; rewrite <- rev_alt, rev_involutive.
      simpl; auto.
Qed.


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 A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 B2 /\ (wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ A1 A2 P /\ (col_ A1 B1 B2 /\ (col_ A2 B1 B2 /\ (col_ A1 C1 C2 /\ col_ A2 C1 C2))))))))))))) -> col_ C2 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition handle_id_sysreg_trap_spec (rec: Pointer) (esr: Z64) (adt: RData) : option RData :=
    match esr with
    | VZ64 esr =>
      rely is_int64 esr;
      rely (peq (base rec) buffer_loc);
      when gidx == (buffer (priv adt)) @ (offset rec);
      let gn := (gs (share adt)) @ gidx in
      rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
      rely (ref_accessible gn CPU_ID);
      let idreg := Z.land esr ESR_EL2_SYSREG_MASK in
      rely is_int idreg;
      if __ESR_EL2_SYSREG_IS_WRITE esr then None
      else
        let mask := (if idreg =? ESR_EL2_SYSREG_ID_AA64ISAR1_EL1
                      then HANDLE_ID_SYSREG_MASK else 0) in
        let rt := __ESR_EL2_SYSREG_ISS_RT esr in
        rely is_int rt; rely is_int64 (ID_AA64PFR0_EL1 (id_regs (priv adt)));
        let val := Z.land (ID_AA64PFR0_EL1 (id_regs (priv adt))) (U64MAX - mask) in
        let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))}} in
        Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
    end.

End Spec.


(** * Metamodel **)
Require Import core.Model.
Require Import core.Metamodel.
Require Import core.EqDec.

Class Sum (SumType: Type) (SubTypeName: Type):=
  {
    denoteSubType: SubTypeName -> Set;
    toSubType: forall (t: SubTypeName), SumType -> option (denoteSubType t);
    toSumType: forall (t: SubTypeName), (denoteSubType t) -> SumType;

  }.

Class ModelingMetamodel `(mm : Metamodel) :=
{
    ModelClass: Type;
    ModelReference: Type;
    elements: Sum ModelElement ModelClass;
    links: Sum ModelLink ModelReference;

    (* Denotation *)
    denoteModelClass: ModelClass -> Set := denoteSubType;
    denoteModelReference: ModelReference -> Set := denoteSubType;

    (* Downcasting *)
    toModelClass: forall (t:ModelClass), ModelElement -> option (denoteModelClass t) := toSubType;
    toModelReference: forall (t:ModelReference), ModelLink -> option (denoteModelReference t) := toSubType;

    (* Upcasting *)
    toModelElement: forall (t: ModelClass), (denoteModelClass t) -> ModelElement := toSumType;
    toModelLink: forall (t: ModelReference), (denoteModelReference t) -> ModelLink := toSumType;

}.

Definition hasType {mm: Metamodel} {mmm: ModelingMetamodel mm} (t: ModelClass) (e: ModelElement) : bool :=
  match (toModelClass t e) with
  | Some e' => true
  | _ => false
  end.