From Coq Require Export ZArith.
From stdpp Require Import gmap lexico.

Set Implicit Arguments.

#[global] Open Scope Z_scope.

Declare Custom Entry alu.

Module Syntax.

Inductive op := Add | Mul | Div | Mod | Eql | Inp.  (* Inp ignores register 2 *)
Inductive reg := x | y | z | w | imm (_ : Z).
Coercion imm : Z >-> reg.
Record instr := Mk_instr
  { iop : op
  ; ir1 : reg
  ; ir2 : reg
  }.

Notation "'input' a1 .. an" := (cons a1 .. (cons an nil) ..)
  (at level 200, a1 custom alu, an custom alu, only parsing).

Notation "'add' r1 r2" := (Mk_instr Add r1%Z r2%Z)
  (in custom alu at level 1, r1 constr at level 0, r2 constr at level 0).
Notation "'mul' r1 r2" := (Mk_instr Mul r1%Z r2%Z)
  (in custom alu at level 1, r1 constr at level 0, r2 constr at level 0).
Notation "'div' r1 r2" := (Mk_instr Div r1%Z r2%Z)
  (in custom alu at level 1, r1 constr at level 0, r2 constr at level 0).
Notation "'mod' r1 r2" := (Mk_instr Mod r1%Z r2%Z)
  (in custom alu at level 1, r1 constr at level 0, r2 constr at level 0).
Notation "'eql' r1 r2" := (Mk_instr Eql r1%Z r2%Z)
  (in custom alu at level 1, r1 constr at level 0, r2 constr at level 0).
Notation "'inp' r" := (Mk_instr Inp r x)
  (in custom alu at level 1, r constr at level 0).

Notation "`` x" := x
  (at level 10, x custom alu, only parsing).

Definition example := input
inp w
mul x 0
add x z
mod x 26
div z 1
add x 11
eql x w
eql x 0
mul y 0
add y 25
mul y x
add y 1
mul z y
mul y 0
add y w
add y -8
mul y x
add z y
.

Definition ocons {A} (x : A) (xs : option (list A)) : option (list A) :=
  option_map (cons x) xs.

Fixpoint recognize (xs : list instr) : option (list (Z * Z * Z)) :=
  match xs with
  |    `` inp w
    :: `` mul x 0
    :: `` add x z
    :: `` mod x 26
    :: `` div z (imm A)
    :: `` add x (imm B)
    :: `` eql x w
    :: `` eql x 0
    :: `` mul y 0
    :: `` add y 25
    :: `` mul y x
    :: `` add y 1
    :: `` mul z y
    :: `` mul y 0
    :: `` add y w
    :: `` add y (imm C)
    :: `` mul y x
    :: `` add z y
    :: xs => option_map (cons (A,B,C)) (recognize xs)
  | nil => Some nil
  | _ => None
  end.

End Syntax.

Definition step '((div_z, add_x, add_y) : Z * Z * Z) (rw : Z) (rz : Z) : option Z :=
  if (rz <? 0) || (div_z =? 0) then None else Some
  ( let rx := (rz mod 26) + add_x in
    let rz := Z.quot rz div_z in
    if rx =? rw then rz else rz * 26 + rw + add_y).

(* Recursion and memoization *)

Definition endo (X : Type) : Type := (X -> X).

Class Monad M : Type :=
  { ret : forall {A}, A -> M A
  ; bind : forall {A B}, M A -> (A -> M B) -> M B
  }.

Declare Scope monad_scope.
#[global] Open Scope monad_scope.

Notation "'let*' x ':=' u 'in' v" := (bind u (fun x => v)) (at level 200) : monad_scope.

Fixpoint traverse {M} `{Monad M} {A B} (f : A -> M B) (xs : list A) : M (list B) :=
  match xs with
  | [] => ret []
  | x :: xs =>
    let* y := f x in
    let* ys := traverse f xs in
    ret (y :: ys)
  end.

Record identity (A : Type) : Type := Mk_identity { run_identity : A }.

Instance Monad_identity : Monad identity :=
  {| ret _ x := Mk_identity x
  ;  bind _ _ u k := k (run_identity u)
  |}.

Fixpoint naive_fix (fuel : nat) {A R} (r0 : R) (gf : endo (A -> identity R)) : A -> R :=
  fun x =>
    run_identity (gf (fun x => Mk_identity match fuel with
        | O => r0
        | S fuel => naive_fix fuel r0 gf x
        end) x).

Record state (S A : Type) : Type := Mk_state { run_state : S -> S * A }.

Instance Monad_state {S} : Monad (state S) :=
  {| ret _ x := Mk_state (fun s => (s, x))
  ;  bind _ _ u k := Mk_state (fun s =>
       let '(s, x) := run_state u s in
       run_state (k x) s) |}.

Definition memom (A R : Type) `{Countable A} : Type -> Type := state (gmap A R).

Fixpoint _memo_fix (fuel : nat) {A B R} `{Countable A}
  (r0 : R) (gf : endo (A -> B -> state (gmap A R) R)) : A -> B -> state (gmap A R) R :=
  fun x b => Mk_state (fun s =>
    match lookup x s with
    | Some y => (s, y)
    | None =>
      let __memo_fix x b := match fuel with O => ret r0 | S fuel => _memo_fix fuel r0 gf x b end in
      let '(s, y) := run_state (gf __memo_fix x b) s in
      (insert x y s, y)
    end).

Definition memo_fix (fuel : nat) {A B R} `{Countable A}
  (r0 : R) (gf : endo (A -> B -> state (gmap A R) R)) : A -> B -> R :=
  fun x b => snd (run_state (_memo_fix fuel r0 gf x b) empty).

Fixpoint find' {A B} (xs : list A) (f : A -> option B) : option B :=
  match xs with
  | nil => None
  | x :: xs =>
    match f x with
    | None => find' xs f
    | Some y => Some y
    end
  end.

Fixpoint findM {M} `{Monad M} {A B} (xs : list A) (f : A -> M (option B)) : M (option B) :=
  match xs with
  | nil => ret None
  | x :: xs =>
    let* o := f x in
    match o with
    | None => findM xs f
    | Some y => ret (Some y)
    end
  end.

Notation "'let?' x ':=' xs 'in' f" := (find' xs (fun x => f))
  (at level 200, x pattern).

Notation "'let?*' x ':=' xs 'in' f" := (findM xs (fun x => f))
  (at level 200, x pattern).

(* [log_lt n b k = true] if [k / b^n = 0] *)
Fixpoint log_lt (n : nat) (b k : Z) : bool :=
  (k =? 0) ||
  match n with
  | O => false
  | S n => log_lt n b (k / b)
  end.

Definition _search {M} `{Monad M} (digits : list Z)
  : endo (Z * N -> list (Z -> Z -> option Z) -> M (option (list Z))) := fun _search '(rz, n) ts =>
  match ts with
  | nil => if rz =? 0 then ret (Some nil) else ret None
  | t :: ts =>
    let?* d := digits in
    match t d rz with
    | None => ret None
    | Some rz =>
      if log_lt (13 - N.to_nat n) 26 rz then
        let* r := _search (rz, N.succ n) ts in
        ret (option_map (cons d) r)
      else
        ret None
    end
  end.

Definition decimal (xs : list Z) : Z :=
  fold_left (fun acc d => acc * 10 + d) xs 0.

Definition search (digits : list Z) (ts : list (Z -> Z -> option Z)) : option Z :=
  let r := memo_fix (length ts) None (_search digits) (0,0%N) ts in
  option_map decimal r.

Export Syntax.

Definition solve (i : list instr) : option Z :=
  match recognize i with
  | None => None
  | Some ts => search (9::8::7::6::5::4::3::2::1::nil) (map step ts)
  end.

Definition solve2 (i : list instr) : option Z :=
  match recognize i with
  | None => None
  | Some ts => search (1::2::3::4::5::6::7::8::9::nil) (map step ts)
  end.

Definition solve12 i := (solve i, solve2 i).

(* Compute solve example. *)

Fixpoint compile (xs : list (Z * Z * Z)) : list instr :=
  match xs with
  | nil => nil
  | (A,B,C) :: xs =>
       `` inp w
    :: `` mul x 0
    :: `` add x z
    :: `` mod x 26
    :: `` div z (imm A)
    :: `` add x (imm B)
    :: `` eql x w
    :: `` eql x 0
    :: `` mul y 0
    :: `` add y 25
    :: `` mul y x
    :: `` add y 1
    :: `` mul z y
    :: `` mul y 0
    :: `` add y w
    :: `` add y (imm C)
    :: `` mul y x
    :: `` add z y
    :: compile xs
  end.

Ltac destructall :=
  repeat lazymatch goal with
  | [ |- context [match ?u with _ => _ end]] => destruct u; try discriminate
  end.

Lemma compile_recognize xs ys : Some ys = recognize xs -> xs = compile ys.
Proof.
  revert xs ys; fix SELF 1; intros [ | x xs] ys; cbn [recognize]; destructall.
  { injection 1; intros ->; reflexivity. }
  specialize (SELF xs).
  destruct (recognize xs) as [ zs | ]; [ | discriminate].
  specialize (SELF zs eq_refl).
  cbn [option_map]; injection 1; intros ->.
  cbn.
  rewrite SELF. reflexivity.
Qed.

Lemma recognize_compile xs : Some xs = recognize (compile xs).
Proof.
  induction xs as [ | x xs IH ]; [ reflexivity | destruct x as [[A B] C] ]; cbn.
  rewrite <- IH; reflexivity.
Qed.

Set Primitive Projections.
Record regs := Mk_regs
  { get_w : Z
  ; get_x : Z
  ; get_y : Z
  ; get_z : Z
  }.

Definition get_reg (r : reg) : regs -> Z :=
  match r with
  | imm v => fun _ => v
  | w => get_w
  | x => get_x
  | y => get_y
  | z => get_z
  end.

Definition set_reg (r : reg) (v : Z) (rr : regs) : option regs :=
  let '(Mk_regs rw rx ry rz) := rr in
  match r with
  | imm _ => None
  | w => Some (Mk_regs v rx ry rz)
  | x => Some (Mk_regs rw v ry rz)
  | y => Some (Mk_regs rw rx v rz)
  | z => Some (Mk_regs rw rx ry v)
  end.

Arguments set_reg r /.

Definition alu_div (x y : Z) : option Z :=
  if y =? 0 then None else Some (Z.quot x y).

Definition alu_mod (x y : Z) : option Z :=
  if (x <? 0) || (y <=? 0) then None else Some (Z.modulo x y).

Definition alu_eql (x y : Z) : Z :=
  if x =? y then 1 else 0.

Definition alu (t : instr) (is : list Z) (rr : regs) : option (list Z * regs) :=
  let no_input := option_map (fun x => (is, x)) in
  let evalop (o : Z -> Z -> option Z) :=
    let r1 := ir1 t in let r2 := ir2 t in
    mbind (fun v => set_reg r1 v rr) (o (get_reg r1 rr) (get_reg r2 rr)) in
  let tevalop (o : Z -> Z -> Z) := evalop (fun x y => Some (o x y)) in
  match iop t with
  | Add => no_input (tevalop Z.add)
  | Mul => no_input (tevalop Z.mul)
  | Div => no_input (evalop alu_div)
  | Mod => no_input (evalop alu_mod)
  | Eql => no_input (tevalop alu_eql)
  | Inp =>
    match is with
    | nil => None
    | v :: is => option_map (fun x => (is, x)) (set_reg (ir1 t) v rr)
    end
  end.

Fixpoint alus (ts : list instr) (is : list Z) (rr : regs) : option Z :=
  match ts with
  | nil => Some (get_z rr)
  | t :: ts =>
    match alu t is rr with
    | None => None
    | Some (is, rr) => alus ts is rr
    end
  end.

Fixpoint steps (ts : list (Z * Z * Z)) (is : list Z) (rz : Z) : option Z :=
  match ts, is with
  | nil, _ => Some rz
  | t :: ts, i :: is =>
    match step t i rz with
    | None => None
    | Some rz => steps ts is rz
    end
  | _ :: _, nil => None
  end.

Lemma alus_unfold t ts is rr
  : alus (t :: ts) is rr
  = match alu t is rr with
    | None => None
    | Some (is, rr) => alus ts is rr
    end.
Proof. reflexivity. Qed.

Lemma steps_correct ts is rr : steps ts is (get_z rr) = alus (compile ts) is rr.
Proof.
  revert is rr; induction ts as [| t ts IH]; cbn; [ reflexivity | intros is rr ].
  destruct is as [| i is], t as [[A B] C]; [ reflexivity | ].
  do 4 (rewrite alus_unfold; cbn - [alus]).
  rewrite Z.mul_0_r, Z.add_0_l.
  unfold alu_mod. destruct (get_z _ <? 0); [ reflexivity | ].
  cbn - [alus].
  do 1 (rewrite alus_unfold; cbn - [alus]).
  unfold alu_div. destruct (A =? 0); [ reflexivity | ]. cbn - [alus].
  do 13 (rewrite alus_unfold; cbn - [alus]).
  rewrite !Z.mul_0_r, !Z.add_0_l.
  unfold alu_eql. destruct (_ =? _); cbn.
  { rewrite !Z.mul_0_r, Z.add_0_l, Z.add_0_r, Z.mul_1_r. apply (IH _ (Mk_regs _ _ _ _)). }
  { rewrite !Z.mul_1_r, Z.add_assoc. apply (IH _ (Mk_regs _ _ _ _)). }
Qed.

Fixpoint evals (ts : list (Z -> Z -> option Z)) (ws : list Z) (rz : Z) : option Z :=
  match ts, ws with
  | t :: ts, rw :: ws =>
    match t rw rz with
    | Some rz => evals ts ws rz
    | None => None
    end
  | _ :: _, nil => None
  | nil, _ => Some rz
  end.

Lemma evals_steps ts ws rz : evals (map step ts) ws rz = steps ts ws rz.
Proof.
  revert ws rz; induction ts as [|t ts IH]; intros; cbn; [ reflexivity | ].
  destruct ws as [|rw ws]; [ reflexivity | ].
  destruct step; auto.
Qed.

Definition smallest {A} (r : relation A) (f : A -> Prop) (x : A) : Prop :=
  f x /\ (forall y, f y -> r x y).

Definition smallest_lexico {A} `{Lexico A} := smallest (lexico (A := A)).
Definition greatest_lexico {A} `{Lexico A} := smallest (fun x y : A => lexico y x).

Definition is_digit (x : Z) : Prop := elem_of x (1::2::3::4::5::6::7::8::9::nil).

Theorem solve_correct i ans : solve i = Some ans <->
  exists i0 res,
    i = compile i0 /\
    ans = decimal res /\ Forall is_digit res /\
    greatest_lexico (fun res' => steps i0 res' 0 = Some 0) res.
Proof.
Abort.

Theorem solve2_correct i ans : solve i = Some ans <->
  exists i0 res,
    i = compile i0 /\
    ans = decimal res /\ Forall is_digit res /\
    smallest_lexico (fun res' => steps i0 res' 0 = Some 0) res.
Proof.
Abort.


From iris.heap_lang Require Import proofmode notation.
From iris.heap_lang.lib Require Import par.
Local Definition N := nroot .@ "example".

(* PART 3: Basic concurrency *)
Definition coin_flip : val := λ: <>,
  let: "l" := ref #0 in
  (("l" <- #0) ||| ("l" <- #1));;
  !"l".

Lemma test2_spec `{heapG Σ, spawnG Σ} :
  {{{ True }}} coin_flip #() {{{ n, RET #n; ⌜ n = 0 ∨ n = 1 ⌝ }}}.
Proof.
  iIntros (Φ) "_ Post". wp_let. wp_alloc l as "Hl". wp_let.
  iMod (inv_alloc N _
    (∃ x : Z, l ↦ #x ∧ ⌜ x = 0 ∨ x = 1 ⌝)%I with "[Hl]") as "#?".
  { eauto 10. }
  wp_apply (wp_par (λ _, True)%I (λ _, True)%I).
  - iInv N as (n) ">[Hl _]" "Hclose".
    wp_store. iMod ("Hclose" with "[Hl]"); eauto 10.
  - iInv N as (n) ">[Hl _]" "Hclose".
    wp_store. iMod ("Hclose" with "[Hl]"); eauto 10.
  - iIntros (v1 v2) "_ !> /=". wp_seq.
    iInv N as (n) ">[Hl %]" "Hclose".
    wp_load. iMod ("Hclose" with "[Hl]") as "_"; first eauto 10.
    iApply "Post"; auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable num_1_ : Universe.
Variable num_0_ : Universe.

Variable initial_model_1 : (dom_ num_0_ /\ (dom_ num_1_ /\ p_ num_0_ num_0_ num_0_ num_0_)).
Variable q_e_d_2 : (p_ num_1_ num_1_ num_1_ num_1_ -> goal_).
Variable p4_3 : (forall X Y Z : Universe, (p_ X Y Z num_0_ -> p_ X Y Z num_1_)).
Variable p3_4 : (forall X Y : Universe, (p_ X Y num_0_ num_1_ -> p_ X Y num_1_ num_0_)).
Variable p2_5 : (forall X : Universe, (p_ X num_0_ num_1_ num_1_ -> p_ X num_1_ num_0_ num_0_)).
Variable p1_6 : (p_ num_0_ num_1_ num_1_ num_1_ -> p_ num_1_ num_0_ num_0_ num_0_).

Theorem hdn001_7 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Raxiom.
Require Import ZArith.

Module Rrealize : Raxiom.CReals.
  Definition R : Type.
  Admitted. (* TODO *)

  Definition R0 : R.
  Admitted. (* TODO *)

  Definition R1 : R.
  Admitted. (* TODO *)

  Definition Radd : R -> R -> R.
  Admitted. (* TODO *)

  Definition Rmul (x y : R) : R.
  Admitted. (* TODO *)

  Definition Ropp (x : R) : R.
  Admitted. (* TODO *)

  Definition Rsub (x y : R) := Radd x (Ropp y).

  Definition Rlt (x y : R) : Type.
  Admitted. (* TODO *)

  Definition Rgt (r1 r2 : R) := Rlt r2 r1.
  Definition Rdiscr (r1 r2 : R) := sum (Rlt r1 r2) (Rlt r2 r1).
  Definition Req (r1 r2 : R) := Rdiscr r1 r2 -> False.
  Definition Rle (r1 r2 : R) := sumor (Rlt r1 r2) (Req r1 r2).
  Definition Rge (r1 r2 : R) := Rle r2 r1.

  Definition Rinv (x : R) (_ : Rdiscr x R0) := x. (* TODO *)

  Definition Rdiv (x y : R) (p : Rdiscr y R0) := Rmul x (Rinv y p).

  Lemma Rlt_trans : forall x y z, Rlt x y -> Rlt y z -> Rlt x z.
  Admitted. (* TODO *)

  Lemma Rlt_asym : forall x y : R, Rlt x y -> Rlt y x -> False.
  Admitted. (* TODO *)

  Lemma Req_lt_compat_l : forall x1 x2 y : R, Req x1 x2 -> Rlt x1 y -> Rlt x2 y.
  Admitted. (* TODO *)

  Lemma Req_lt_compat_r : forall x1 x2 y : R, Req x1 x2 -> Rlt y x1 -> Rlt y x2.
  Admitted. (* TODO *)

  Lemma Radd_lt_compat_l : forall x y1 y2 : R, Rlt y1 y2 -> Rlt (Radd x y1) (Radd x y2).
  Admitted. (* TODO *)

  Lemma Radd_eq_compat_l : forall x y1 y2, Req y1 y2 -> Req (Radd x y1) (Radd x y2).
  Admitted. (* TODO *)

  Lemma Rmul_lt_compat_l : forall x y1 y2 : R, Rlt R0 x -> Rlt y1 y2 -> Rlt (Rmul x y1) (Rmul x y2).
  Admitted. (* TODO *)

  Lemma Rmul_eq_compat_l : forall x y1 y2, Req y1 y2 -> Req (Rmul x y1) (Rmul x y2).
  Admitted. (* TODO *)

  Lemma Rinv_0_lt_compat : forall (x : R) (pr : Rlt R0 x) (pr' : Rdiscr x R0), Rlt R0 (Rinv x pr').
  Admitted. (* TODO *)

  Lemma Radd_comm : forall a b, Req (Radd a b) (Radd b a).
  Admitted. (* TODO *)

  Lemma Radd_assoc : forall x y z, Req (Radd (Radd x y) z) (Radd x (Radd y z)).
  Admitted. (* TODO *)

  Lemma Radd_opp_r : forall x, Req (Radd x (Ropp x)) R0.
  Admitted. (* TODO *)

  Lemma Radd_0_l : forall x, Req (Radd R0 x) x.
  Admitted. (* TODO *)

  Lemma Rmul_add_distr_l a b c : Req (Rmul a (Radd b c)) (Radd (Rmul a b) (Rmul a c)).
  Admitted. (* TODO *)

  Lemma Rmul_comm : forall a b, Req (Rmul a b) (Rmul b a).
  Admitted. (* TODO *)

  Lemma Rmul_assoc : forall x y z, Req (Rmul (Rmul x y) z) (Rmul x (Rmul y z)).
  Admitted. (* TODO *)

  Lemma Rmul_1_l : forall x, Req (Rmul R1 x) x.
  Admitted. (* TODO *)

  Lemma Rinv_l : forall (x : R) (pr : Rdiscr x R0), Req (Rmul (Rinv x pr) x) R1.
  Admitted. (* TODO *)

  Lemma Rlt_0_1 : Rlt R0 R1.
  Admitted. (* TODO *)

  Fixpoint IPR (p : positive) : R :=
    match p with
      | xI p => Radd (Rmul (Radd R1 R1) (IPR p)) R1
      | xO p => Rmul (Radd R1 R1) (IPR p)
      | xH => R1
    end.

  Definition IZR (z : BinInt.Z) : R :=
    match z with
      | Z0 => R0
      | Zpos p => IPR p
      | Zneg p => Ropp (IPR p)
    end.

  Definition Rdist x y d : Type := prod (Rlt (Rsub x y) d) (Rlt (Ropp d) (Rsub x y)).

  Definition Rup : R -> Z.
  Admitted. (* TODO *)

  Lemma Rup_spec : forall r : R, Rdist r (IZR (Rup r)) R1.
  Admitted. (* TODO *)

  Definition Rseq_Cauchy (Un : nat -> R) : Type := forall eps, Rlt R0 eps ->
    {N : nat & forall p q, (N <= p)%nat -> (N <= q)%nat -> Rdist (Un p) (Un q) eps}.

  Definition Rseq_cv (Un : nat -> R) (l : R) : Type := forall eps, Rlt R0 eps ->
    {N : nat & forall n, (N <= n)%nat -> Rdist (Un n) l eps}.

  Lemma Rcomplete : forall Un, Rseq_Cauchy Un -> {l : R & Rseq_cv Un l}.
  Admitted. (* TODO *)

End Rrealize.


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

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

Print Assumptions carry.


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  - definition of relative comonad
  - relative comonads are functors
  - definition of morphisms of comonads, identity, composition

*)

Require Import Theory.Category.
Require Import Theory.Functor.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＲＥＬＡＴＩＶＥ  ＣＯＭＯＮＡＤ  ＤＥＦＩＮＩＴＩＯＮ
  ----------------------------------------------------------------------------*)
(** * Relative comonad **)

(** ** Definition **)

Structure RelativeComonad `(F : Functor 𝒞 𝒟) : Type := mkRelativeComonad
{ T              :>  𝒞 → 𝒟
; counit         :   ∀ {X}, T X ⇒ F X
; cobind         :   ∀ {X Y}, [ T X ⇒ F Y ⟶ T X ⇒ T Y ]
; cobind_counit  :   ∀ {X}, cobind counit ≈ id[ T X ]
; counit_cobind  :   ∀ {X Y} {f : T X ⇒ F Y}, counit ∘ cobind(f) ≈ f
; cobind_cobind  :   ∀ {X Y Z} {f : T X ⇒ F Y} {g : T Y ⇒ F Z}, cobind(g) ∘ cobind(f) ≈ cobind(g ∘ cobind(f)) }.

Arguments mkRelativeComonad  {_ _ _ _ _ _} _ _ _.
Arguments counit             {_ _ _} _ {_}.
Arguments cobind             {_ _ _} _ {_ _}.
Arguments cobind_counit      {_ _ _} _ {_}.
Arguments counit_cobind      {_ _ _} _ {_ _ _}.
Arguments cobind_cobind      {_ _ _} _ {_ _ _ _ _}.

Notation "'counit[' X ]"     := (counit _ (X := X)) (only parsing).
Notation "T '⋅counit'"       := (counit T) (at level 0, only parsing).
Notation "T '⋅counit[' X ]"  := (counit T (X := X)) (at level 0, only parsing).
Notation "T '⋅cobind'"       := (cobind T) (at level 0, only parsing).

Notation "'RelativeComonad.make' ⦃ 'T' ≔ T ; 'counit' ≔ counit ; 'cobind' ≔ cobind ⦄" :=
  (@mkRelativeComonad _ _ _ T counit cobind _ _ _) (only parsing).

(*------------------------------------------------------------------------------
  -- ＦＵＮＣＴＯＲＩＡＬＩＴＹ
  ----------------------------------------------------------------------------*)
(** ** Functoriality of relative comonads **)

(* begin hide *)
Section Functoriality.
(* end hide *)

  Context `{F : Functor 𝒞 𝒟} (T : RelativeComonad F).

  Program Definition lift {A B} : [ A ⇒ B ⟶ T A ⇒ T B ] :=
    λ f ↦ T⋅cobind (F⋅f ∘ T⋅counit).
  Next Obligation.
    intros f g eq_fg. now rewrite eq_fg.
  Qed.

  Lemma lift_id : ∀ A, id[ T A ] ≈ lift id[ A ].
  Proof.
    intros A; simpl; unfold lift.
    rewrite <- identity, left_id, cobind_counit.
    reflexivity.
  Qed.

  Lemma lift_compose : ∀ A B C (f : A ⇒ B) (g : B ⇒ C), lift (g ∘ f) ≈ (lift g) ∘ (lift f).
  Proof.
    intros A B C g f; simpl; unfold lift.
    rewrite cobind_cobind,
            compose_assoc,
            counit_cobind,
            <- compose_assoc,
            <- map_compose.
    reflexivity.
  Qed.

  Definition Lift : Functor 𝒞 𝒟 := mkFunctor lift_id lift_compose.

(* begin hide *)
End Functoriality.
(* end hide *)

(*------------------------------------------------------------------------------
  -- ＭＯＲＰＨＩＳＭ
  ----------------------------------------------------------------------------*)
(** ** Morphism of relative comonads **)

Structure Morphism `{F : Functor 𝒞 𝒟} (T S : RelativeComonad F) : Type := mkMorphism
{ τ           :>  ∀ C, T C ⇒ S C
; τ_counit    :   ∀ {C}, T⋅counit[ C ] ≈ S⋅counit[ C ] ∘ τ(C)
; τ_commutes  :   ∀ {C D} {f : S C ⇒ F D}, τ(D) ∘ T⋅cobind (f ∘ τ(C)) ≈ S⋅cobind f ∘ τ(C) }.

Arguments mkMorphism  {_ _ _ _ _ _} _ _.
Arguments τ           {_ _ _ _ _ _} _.
Arguments τ_counit    {_ _ _ _ _} _ {_}.
Arguments τ_commutes  {_ _ _ _ _} _ {_ _ _}.

Notation "'RelativeComonad.make' ⦃ 'τ' ≔ τ ⦄" := (@mkMorphism _ _ _ _ _ τ _ _) (only parsing).

Module Morphism.

  (* -- Ｉｄｅｎｔｉｔｙ  /  Ｃｏｍｐｏｓｉｔｉｏｎ                      -- *)
  Section id_composition.

    Context `{F : Functor 𝒞 𝒟}.

    Implicit Types (T S U : RelativeComonad F).

    Program Definition Hom T S : Setoid :=
      Setoid.make ⦃ Carrier ≔ Morphism T S ; Equiv ≔ λ f g ∙ ∀ x, f x ≈ g x ⦄.
    Next Obligation.
      constructor.
      - intros f x; reflexivity.
      - intros f g eq_fg x. symmetry. apply eq_fg.
      - intros f g h eq_fg eq_gh; etransitivity; eauto.
    Qed.

    Local Infix "⇒" := Hom.

    Program Definition id {S} : S ⇒ S :=
      RelativeComonad.make ⦃ τ ≔ λ C ∙ id[ S C ] ⦄.
    Next Obligation.
      now rewrite right_id.
    Qed.
    Next Obligation.
      rewrite left_id; now do 2 rewrite right_id.
    Qed.

    Program Definition compose {S T U} : [ T ⇒ U ⟶ S ⇒ T ⟶ S ⇒ U ] :=
      λ g f ↦₂ RelativeComonad.make ⦃ τ ≔ λ C ∙ g(C) ∘ f(C) ⦄.
    Next Obligation.
      rewrite <- compose_assoc; now do 2 rewrite <- τ_counit.
    Qed.
    Next Obligation.
      setoid_rewrite <- compose_assoc at 2.
      rewrite <- τ_commutes. rewrite compose_assoc.
      setoid_rewrite <- compose_assoc at 2. rewrite τ_commutes.
      rewrite <- compose_assoc. reflexivity.
    Qed.
    Next Obligation.
      intros f₁ f₂ eq_f₁f₂ g₁ g₂ eq_g₁g₂ x. simpl.
      apply Π₂.cong; [ apply eq_f₁f₂ | apply eq_g₁g₂ ].
    Qed.

  End id_composition.

End Morphism.


(*|
=============================================================
 6.822 Formal Reasoning About Programs, Spring 2021 - Pset 9
=============================================================
|*)

Require Export Frap.

Module Type S.
  Inductive nat_op :=
  | Plus
  | Minus
  | Times.

  Inductive exp :=
  | Const (n : nat)
  | Var (x : string)
  | Read (e1 : exp)
  | NatOp (b: nat_op) (e1 e2 : exp).

  Inductive bool_op :=
  | Equal
  | Less.

  Inductive bexp :=
  | BoolOp (b: bool_op) (e1 e2 : exp).

  Definition heap := fmap nat nat.
  Definition valuation := fmap var nat.

  Inductive io := In (v : nat) | Out (v : nat).
  Definition trace := list io.

  Definition assertion := trace -> heap -> valuation -> Prop.

  Inductive cmd :=
  | Skip
  | Assign (x : var) (e : exp)
  | Write (e1 e2 : exp)
  | Seq (c1 c2 : cmd)
  | If_ (be : bexp) (then_ else_ : cmd)
  | While_ (inv : assertion) (be : bexp) (body : cmd)
  | Input (x : var)
  | Output (e : exp).

  (* BEGIN NOTATION MAGIC *)
  Coercion Const : nat >-> exp.
  Coercion Var : string >-> exp.
  Declare Scope cmd_scope.
  Notation "*[ e ]" := (Read e) : cmd_scope.
  Notation "a + b" := (NatOp Plus a b) : cmd_scope.
  Notation "a - b" := (NatOp Minus a b) : cmd_scope.
  Notation "a * b" := (NatOp Times a b) : cmd_scope.
  Notation "a = b" := (BoolOp Equal a b) : cmd_scope.
  Notation "a < b" := (BoolOp Less a b) : cmd_scope.
  Definition set (dst src : exp) : cmd :=
    match dst with
    | Read dst' => Write dst' src
    | Var dst' => Assign dst' src
    | _ => Assign "Bad LHS" 0
    end.
  Infix "<-" := set (no associativity, at level 70) : cmd_scope.
  Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
  Notation "'when' b 'then' then_ 'else' else_ 'done'" :=
    (If_ b then_ else_) (at level 75, b at level 0) : cmd_scope.
  Notation "'when' b 'then' then_ 'done'" :=
    (If_ b then_ Skip) (at level 75, b at level 0) : cmd_scope.
  Notation "{{ I }}  'while' b 'loop' body 'done'" := (While_ I%nat%type b body) (at level 75) : cmd_scope.
  Notation "x '<--' 'input'" := (Input x) (at level 75) : cmd_scope.
  Notation "'output' e" := (Output e) (at level 75) : cmd_scope.
  Delimit Scope cmd_scope with cmd.
  (* END NOTATION MAGIC *)

  Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

  Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
    match e with
    | Const n => n
    | Var x => v $! x
    | Read e1 => h $! eval e1 h v
    | NatOp b e1 e2 =>
      let e1 := eval e1 h v in
      let e2 := eval e2 h v in
      match b with
      | Plus => e1 + e2
      | Minus => e1 - e2
      | Times => e1 * e2
      end
    end.

  Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
    match b with
    | BoolOp b e1 e2 =>
      let e1 := eval e1 h v in
      let e2 := eval e2 h v in
      match b with
      | Equal => if eval e1 h v ==n eval e2 h v then true else false
      | Less => if eval e2 h v <=? eval e1 h v then false else true
      end
    end.

  Inductive exec : trace -> heap -> valuation -> cmd ->
                   trace -> heap -> valuation -> Prop :=
  | ExSkip : forall tr h v,
      exec tr h v Skip tr h v
  | ExAssign : forall tr h v x e,
      exec tr h v (Assign x e) tr h (v $+ (x, eval e h v))
  | ExWrite : forall tr h v e1 e2,
      exec tr h v (Write e1 e2) tr (h $+ (eval e1 h v, eval e2 h v)) v
  | ExSeq : forall tr1 h1 v1 c1 tr2 h2 v2 c2 tr3 h3 v3,
      exec tr1 h1 v1 c1 tr2 h2 v2 ->
      exec tr2 h2 v2 c2 tr3 h3 v3 ->
      exec tr1 h1 v1 (Seq c1 c2) tr3 h3 v3
  | ExIfTrue : forall tr1 h1 v1 b c1 c2 tr2 h2 v2,
      beval b h1 v1 = true ->
      exec tr1 h1 v1 c1 tr2 h2 v2 ->
      exec tr1 h1 v1 (If_ b c1 c2) tr2 h2 v2
  | ExIfFalse : forall tr1 h1 v1 b c1 c2 tr2 h2 v2,
      beval b h1 v1 = false ->
      exec tr1 h1 v1 c2 tr2 h2 v2 ->
      exec tr1 h1 v1 (If_ b c1 c2) tr2 h2 v2
  | ExWhileFalse : forall I tr h v b c,
      beval b h v = false ->
      exec tr h v (While_ I b c) tr h v
  | ExWhileTrue : forall I tr1 h1 v1 b c tr2 h2 v2 tr3 h3 v3,
      beval b h1 v1 = true ->
      exec tr1 h1 v1 c tr2 h2 v2 ->
      exec tr2 h2 v2 (While_ I b c) tr3 h3 v3 ->
      exec tr1 h1 v1 (While_ I b c) tr3 h3 v3
  | ExInput : forall tr h v x inp,
      exec tr h v (Input x) (In inp :: tr) h (v $+ (x, inp))
  | ExOutput : forall tr h v e,
      exec tr h v (Output e) (Out (eval e h v) :: tr) h v.

  Reserved Notation "<{ P }> c <{ Q }>"
           (at level 90, c at next level,
            format "'[hv' <{  P  }> '/'  c  '/' <{  Q  }> ']'").

  Notation "'fun/inv' tr h v => e" :=
    (fun (tr : trace) (h : heap) (v : valuation) => e%nat%type)
      (at level 90, tr ident, h ident, v ident).

  Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
  | HtSkip : forall P, <{ P }> Skip <{ P }>
  | HtAssign : forall P x e,
      <{ P }>
      Assign x e
      <{ fun/inv tr h v => exists v', P tr h v' /\ v = v' $+ (x, eval e h v') }>
  | HtWrite : forall P (e1 e2 : exp),
      <{ P }>
      Write e1 e2
      <{ fun/inv tr h v =>
           exists h', P tr h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v) }>
  | HtSeq : forall (P Q R : assertion) c1 c2,
      <{ P }> c1 <{ Q }> -> <{ Q }> c2 <{ R }> -> <{ P }> c1;; c2 <{ R }>
  | HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
      <{ fun/inv tr h v => P tr h v /\ beval b h v = true }> c1 <{ Q1 }> ->
      <{ fun/inv tr h v => P tr h v /\ beval b h v = false }> c2 <{ Q2 }> ->
      <{ P }> (when b then c1 else c2 done) <{ fun/inv tr h v => Q1 tr h v \/ Q2 tr h v }>
  | HtWhile : forall (I P : assertion) b c,
      (forall tr h v, P tr h v -> I tr h v) ->
      <{ fun/inv tr h v => I tr h v /\ beval b h v = true }> c <{ I }> ->
      <{ P }>
      {{ I }} while b loop c done
      <{ fun/inv tr h v => I tr h v /\ beval b h v = false }>
  | HtInput : forall (P : assertion) x,
      <{ P }>
      x <-- input
      <{ fun/inv tr h v =>
           exists tr' v' inp, P tr' h v' /\ tr = In inp :: tr' /\ v = v' $+ (x, inp) }>
  | HtOutput : forall (P : assertion) e,
      <{ P }>
      output e
      <{ fun/inv tr h v => exists tr', P tr' h v /\ tr = Out (eval e h v) :: tr' }>
  | HtConsequence : forall (P Q P' Q' : assertion) c,
      <{ P }> c <{ Q }> ->
      (forall tr h v, P' tr h v -> P tr h v) ->
      (forall tr h v, Q tr h v -> Q' tr h v) ->
      <{ P' }> c <{ Q' }>
  where "<{ P }> c <{ Q }>" := (hoare_triple P c%cmd Q).

  Example max3 :=
    ("x" <-- input;;
     "y" <-- input;;
     "z" <-- input;;
     when "x" < "y" then
       when "y" < "z" then
         output "z"
       else
         output "y"
       done
     else
       when "x" < "z" then
         output "z"
       else
         output "x"
       done
     done)%cmd.

  Definition max3_spec (tr: trace): Prop :=
    exists x y z,
      tr = [Out (max x (max y z)); In z; In y; In x].

  (*[10%]*) Axiom max3_ok:
    <{ fun/inv tr _ _ => tr = [] }>
    max3
    <{ fun/inv tr' _ _ => max3_spec tr' }>.

  Example fibonacci n inv :=
    ("cnt" <- 0;;
     "x" <- 0;;
     output "x";;
     "y" <- 1;;
     output "y";;
     {{ inv }}
     while "cnt" < n loop
       "tmp" <- "y";;
       "y" <- "x" + "y";;
       "x" <- "tmp";;
       "cnt" <- "cnt" + 1;;
       output "y"
     done)%cmd.

  Inductive fibonacci_spec : trace -> Prop :=
  | FibInit: fibonacci_spec [Out 1; Out 0]
  | FibRec: forall x y tr,
      fibonacci_spec (Out y :: Out x :: tr) ->
      fibonacci_spec (Out (x + y) :: Out y :: Out x :: tr).

  Parameter fibonacci_invariant : forall (n: nat), assertion.

  (*[20%]*) Axiom fibonacci_ok : forall (n: nat),
    <{ fun/inv tr _ _ => tr = [] }>
    fibonacci n (fibonacci_invariant n)
    <{ fun/inv tr' _ _ => fibonacci_spec tr' }>.

  Example fact inv :=
    ("cnt" <- 0;;
     "x" <- 1;;
     output "x";;
     {{ inv }}
     while "cnt" < "n" loop
       "cnt" <- 1 + "cnt";;
       "x" <- "x" * "cnt";;
       output "x"
     done)%cmd.

  Inductive fact_spec : nat -> trace -> Prop :=
  | FactInit: fact_spec 0 [Out 1]
  | FactRec: forall x n tr,
      fact_spec n (Out x :: tr) ->
      fact_spec (S n) (Out (x * S n) :: Out x :: tr).

  Parameter fact_invariant : forall (n: nat), assertion.

  (*[20%]*) Axiom fact_ok : forall (n: nat),
    <{ fun/inv tr _ v => tr = [] /\ v $! "n" = n }>
    fact (fact_invariant n)
    <{ fun/inv tr' _ _ => fact_spec n tr' }>.

  Example mailbox inv :=
    ("done" <- 0;;
     {{ inv }}
     while "done" = 0 loop
       "address" <-- input;;
       when "address" = 0 then
         "done" <- 1
       else
         "val" <-- input;;
         output *["address"];;
         *["address"] <- "val"
       done
     done)%cmd.

  Inductive mailbox_spec : forall (h: heap) (tr: trace), Prop :=
  | MBNil: mailbox_spec $0 []
  | MBPut: forall h address val ret tr,
      address <> 0 ->
      ret = h $! address ->
      mailbox_spec h tr ->
      mailbox_spec (h $+ (address, val)) (Out ret :: In val :: In address :: tr).

  Inductive mailbox_done (h: heap) : trace -> Prop :=
  | MBDone: forall tr,
      mailbox_spec h tr ->
      mailbox_done h (In 0 :: tr).

  Parameter mailbox_invariant : assertion.

  (*[20%]*) Axiom mailbox_ok:
    <{ fun/inv tr h _ => tr = [] /\ h = $0 }>
    mailbox mailbox_invariant
    <{ fun/inv tr' h' _ => mailbox_done h' tr' }>.

  Example search inv :=
    ("needle" <-- input;;
     {{ inv }}
     while 0 < "length" loop
       "length" <- "length" - 1;;
       when *["ptr" + "length"] = "needle" then
         output "length" done
     done)%cmd.

  Inductive search_spec (needle: nat) : forall (offset: nat) (haystack: list nat), trace -> Prop :=
  | SearchNil: forall offset,
      search_spec needle offset [] [In needle]
  | SearchConsYes: forall n offset haystack tr,
      0 < offset ->
      n = needle ->
      search_spec needle offset haystack tr ->
      search_spec needle (offset - 1) (n :: haystack) (Out (offset - 1) :: tr)
  | SearchConsNo: forall n offset haystack tr,
      0 < offset ->
      n <> needle ->
      search_spec needle offset haystack tr ->
      search_spec needle (offset - 1) (n :: haystack) tr.

  Inductive search_done haystack tr : Prop :=
  | SearchDone: forall needle offset,
      offset = 0 ->
      search_spec needle offset haystack tr ->
      search_done haystack tr.

  Inductive array_at (h: heap) : nat -> list nat -> Prop :=
  | ArrayEmpty : forall ptr, array_at h ptr []
  | ArrayCons : forall ptr hd tl,
      h $! ptr = hd ->
      array_at h (S ptr) tl ->
      array_at h ptr (hd :: tl).

  Parameter search_invariant : forall (ptr: nat) (data: list nat), assertion.

  (*[30%]*) Axiom search_ok : forall ptr data,
    <{ fun/inv tr h v =>
         tr = [] /\
         v $! "ptr" = ptr /\
         v $! "length" = Datatypes.length data /\
         array_at h ptr data }>
    search (search_invariant ptr data)
    <{ fun/inv tr' h' _ =>
         array_at h' ptr data /\
         search_done data tr' }>.
End S.


From Coq Require Import Bool Arith Arith.Peano_dec Arith.Compare_dec List.

Import ListNotations.

Notation "a =_? b" := (eq_nat_dec a b) (at level 20).
Notation "a <>_? b" := (negb (a =_? b)) (at level 20).
Notation "a <_? b" := (lt_dec a b) (at level 20).
Notation "a <=_? b" := (le_dec a b) (at level 20).
Notation "a >_? b" := (gt_dec a b) (at level 20).
Notation "a >=_? b" := (ge_dec a b) (at level 20).

Notation "a <>? b" := (negb (Nat.eqb a b)) (at level 70).
Notation "a =? b" := (Nat.eqb a b) (at level 70).
Notation "a <=? b" := (leb a b) (at level 70).

(*
  Programming bools
  &&  ||  =?  <>?  <=?
  ----
  andb_prop
  orb_prop
  beq_nat_true_iff  beq_nat_false_iff
  leb_iff
  negb_true_iff  negb_false_iff
*)

Lemma eq_nat_dec_eq:
  forall (A: Type) n (s1 s2: A),
    (if eq_nat_dec n n then s1 else s2) =
    s1.
Proof.
  intros.
  destruct (eq_nat_dec n n).
  reflexivity.

  exfalso. apply n0. reflexivity.
Qed.

Lemma eq_nat_dec_neq:
  forall (A: Type) n n' (s1 s2: A),
    (not (n = n'))
    -> (if eq_nat_dec n n' then s1 else s2) =
       s2.
Proof.
  intros.

  destruct (eq_nat_dec n n').
  exfalso. apply H in e. assumption.

  reflexivity.
Qed.

Lemma fold_left_and_false:
  forall (A: Type) ls (f: A -> bool),
    fold_left (fun b l => b && f l) ls false = false.
Proof.
  intros.
  induction ls.
  simpl.
  reflexivity.
  simpl.
  assumption.
Qed.

Lemma fold_left_and:
  forall (A: Type) ls (l: A) f,
    (fold_left (fun b l => b && f l) ls true = true
     /\ In l ls)
    -> f l = true.
Proof.
  intros.
  destruct H.
  generalize dependent l.
  generalize dependent f.
  induction ls.

  intros. unfold In in H0. contradiction.

  intros.
  apply in_inv in H0.
  destruct H0.

  subst a.
  simpl in H.
  destruct (f l).
  reflexivity.
  simpl in H.
  rewrite fold_left_and_false in H.
  assumption.

  apply IHls.
  simpl in H.
  destruct (f a).
  assumption.
  rewrite fold_left_and_false in H.
  inversion H.
  assumption.
Qed.

Theorem call:
  forall {A B : Type} {f g: A -> B} (x: A),
    f = g -> f x = g x.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
 x = y -> f x = f y.
Proof.
intros A B f x y eq. rewrite eq. reflexivity.
Qed.

Theorem f2_equal : forall (A B C: Type) (f: A -> B -> C) (x1 x2: A)(y1 y2: B),
 (x1 = x2 /\ y1 = y2) -> f x1 y1 = f x2 y2.
Proof.
intros A B C f x1 x2 y1 y2 eq. destruct eq as [eq1 eq2]. rewrite eq1. rewrite eq2. reflexivity.
Qed.

Theorem f3_equal : forall (A B C D: Type) (f: A -> B -> C -> D)
 (x1 x2: A)(y1 y2: B)(z1 z2: C),
 (x1 = x2 /\ y1 = y2 /\ z1 = z2) -> f x1 y1 z1 = f x2 y2 z2.
Proof.
intros A B C D f x1 x2 y1 y2 z1 z2 eq.
destruct eq as [eq1 [eq2 eq3]].
rewrite eq1.
rewrite eq2.
rewrite eq3.
reflexivity.
Qed.

Definition nat_dec (n: nat): {n' | n = S n'} + {n = 0}.
  destruct n; eauto.
Defined.

Definition option_dec {A}(n: option A): {n' | n = Some n'} + {n = None}.
  destruct n; eauto.
Defined.

(* ------------------------------------------------------- *)
(* General tactics. *)

Tactic Notation "open_conjs" :=
  repeat(match goal with
           | [ H : _ /\ _ |- _ ] => destruct H
         end).

Tactic Notation "split_all" :=
  repeat(match goal with
           | [ |- _ /\ _ ] => split
         end).

Ltac specex H :=
  repeat match type of H with
           | forall x : ?T, _ =>
             match type of T with
               | Prop =>
                 fail 1
               | _ =>
                 let x := fresh "x" in
                   evar (x : T);
                   let x' := eval unfold x in x in
                     clear x; specialize (H x')
             end
         end.

Ltac depremise H :=
  match type of H with
    | forall x : ?T, _ =>
      let x := fresh "x" in
      assert (x: T);
      [ clear H | specialize (H x); clear x ]
  end.

Ltac specex_deprem H :=
  specex H; depremise H.

Ltac subv x :=
  match goal with
    | H: x = _ |- _ => rewrite H; simpl
    | H: _ = x |- _ => rewrite <- H; simpl
    | _ => try unfold x; simpl
  end.

Ltac subv_in x H' :=
  match goal with
    | H: x = _ |- _ => rewrite H in H'; simpl in H'
    | H: _ = x |- _ => rewrite <- H in H'; simpl in H'
    | _ => try unfold x in H'; simpl in H'
  end.

Tactic Notation "rewrite_clear" ident(H) ident(H') :=
  rewrite H in H'; clear H.

Tactic Notation "r_rewrite_clear" ident(H) ident(H') :=
  rewrite <- H in H'; clear H.

Tactic Notation "bool_to_prop" :=
  try match goal with
    | [ |- negb _ = true ] =>  try apply negb_true_iff
    | [ |- negb _ = false ] =>  try apply negb_false_iff
  end;
  (apply andb_prop ||
   apply orb_prop ||
   apply Nat.eqb_eq ||
   apply Nat.eqb_neq ||
   apply leb_iff).

Tactic Notation "bool_to_prop_in" ident(H) :=
  try match goal with
    | [ H: negb _ = true |- _ ] =>  try apply negb_true_iff in H
    | [ H: negb _ = false |- _ ] =>  try apply negb_false_iff in H
  end;
  (apply andb_prop in H ||
   apply orb_prop in H ||
   apply Nat.eqb_eq in H ||
   apply Nat.eqb_neq in H ||
   apply leb_iff in H).

(* ------------------------------------------------------- *)
(* list set lemmas *)

Lemma nil_cons_end:
  forall (T: Type)(l: list T)(e: T),
    not((l++[e]) = nil).
Proof.
  intros.
  intro.
  destruct l.

    rewrite app_nil_l in H.
    assert (A := @nil_cons T e nil).
    symmetry in H.
    apply A in H.
    assumption.

    rewrite <- app_comm_cons in H.
    assert (A := @nil_cons T t (l ++ [e])).
    symmetry in H.
    apply A in H.
    assumption.
Qed.

Lemma list_end : forall (T: Type)(l: list T),
 l = nil \/ exists l' e, l = l' ++ [e].
Proof.
  intros.
  destruct l.

    left. reflexivity.

    right.
    assert (A1 := @nil_cons T t l).
    apply not_eq_sym in A1.

    assert (A2 := @exists_last T (t :: l) A1).
    destruct A2. destruct s.
    exists x. exists x0.
    assumption.
Qed.

Lemma cons_to_app:
  forall {T: Type}(ls: list T)(e: T),
    e :: ls = [e] ++ ls.
Proof.
  intros.
  assert (A := app_nil_l ls).
  rewrite <- A at 1.
  rewrite app_comm_cons.
  reflexivity.
Qed.

Lemma filter_filter:
  forall A (f g: A->bool) l,
    filter f (filter g l) = filter (fun x => (andb (f x) (g x))) l.
Proof.
  intros.
  induction l.
  reflexivity.

  unfold filter at 2 3.
  (* unfold compose. *)
  destruct (g a); simpl; destruct (f a);

  simpl;
  try apply f_equal;
  unfold filter in IHl at 2 3;
  rewrite IHl;
  reflexivity.
Qed.

Lemma nodup_filter:
  forall A (l: list A) f,
  NoDup l -> NoDup (filter f l).
Proof.
  intros.
  induction l.

  simpl. constructor.

  simpl.
  inversion H.
  subst.
  destruct (f a).
  depremise IHl. assumption.
  constructor.
  intro. apply filter_In in H0. destruct H0. contradiction.
  assumption.

  apply IHl. assumption.
Qed.


Require Import Bedrock.Platform.Cito.SyntaxExpr.
Require Import Bedrock.StringSet.
Import StringSet.

Set Implicit Arguments.

Fixpoint free_vars expr:=
  match expr with
    |Var s => singleton s
    |Const w => empty
    |Binop op a b => union (free_vars a) (free_vars b)
    |TestE te a b => union (free_vars a) (free_vars b)
  end.


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

(** Initial Author : Evgeny Makarov, INRIA, 2007 *)

Require Export Equalities Orders NumPrelude GenericMinMax.

(** Axiomatization of a domain with zero, successor, predecessor,
    and a bi-directional induction principle. We require [P (S n) = n]
    but not the other way around, since this domain is meant
    to be either N or Z. In fact it can be a few other things,
    for instance [Z/nZ] (See file [NZDomain] for a study of that).
*)

Module Type ZeroSuccPred (Import T:Typ).
 Parameter Inline(20) zero : t.
 Parameter Inline(50) succ : t -> t.
 Parameter Inline pred : t -> t.
End ZeroSuccPred.

Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T).
 Notation "0" := zero.
 Notation S := succ.
 Notation P := pred.
End ZeroSuccPredNotation.

Module Type ZeroSuccPred' (T:Typ) :=
 ZeroSuccPred T <+ ZeroSuccPredNotation T.

Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E).
 Declare Instance succ_wd : Proper (eq ==> eq) S.
 Declare Instance pred_wd : Proper (eq ==> eq) P.
 Axiom pred_succ : forall n, P (S n) == n.
 Axiom bi_induction :
  forall A : t -> Prop, Proper (eq==>iff) A ->
    A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n.
End IsNZDomain.

(** Axiomatization of some more constants

    Simply denoting "1" for (S 0) and so on works ok when implementing
    by nat, but leaves some (N.succ N0) when implementing by N.
*)

Module Type OneTwo (Import T:Typ).
 Parameter Inline(20) one two : t.
End OneTwo.

Module Type OneTwoNotation (T:Typ)(Import NZ:OneTwo T).
 Notation "1" := one.
 Notation "2" := two.
End OneTwoNotation.

Module Type OneTwo' (T:Typ) := OneTwo T <+ OneTwoNotation T.

Module Type IsOneTwo (E:Eq')(Z:ZeroSuccPred' E)(O:OneTwo' E).
 Import E Z O.
 Axiom one_succ : 1 == S 0.
 Axiom two_succ : 2 == S 1.
End IsOneTwo.

Module Type NZDomainSig :=
 EqualityType <+ ZeroSuccPred <+ IsNZDomain <+ OneTwo <+ IsOneTwo.
Module Type NZDomainSig' :=
 EqualityType' <+ ZeroSuccPred' <+ IsNZDomain <+ OneTwo' <+ IsOneTwo.

(** Axiomatization of basic operations : [+] [-] [*] *)

Module Type AddSubMul (Import T:Typ).
 Parameters Inline add sub mul : t -> t -> t.
End AddSubMul.

Module Type AddSubMulNotation (T:Typ)(Import NZ:AddSubMul T).
 Notation "x + y" := (add x y).
 Notation "x - y" := (sub x y).
 Notation "x * y" := (mul x y).
End AddSubMulNotation.

Module Type AddSubMul' (T:Typ) := AddSubMul T <+ AddSubMulNotation T.

Module Type IsAddSubMul (Import E:NZDomainSig')(Import NZ:AddSubMul' E).
 Declare Instance add_wd : Proper (eq ==> eq ==> eq) add.
 Declare Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
 Declare Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
 Axiom add_0_l : forall n, 0 + n == n.
 Axiom add_succ_l : forall n m, (S n) + m == S (n + m).
 Axiom sub_0_r : forall n, n - 0 == n.
 Axiom sub_succ_r : forall n m, n - (S m) == P (n - m).
 Axiom mul_0_l : forall n, 0 * n == 0.
 Axiom mul_succ_l : forall n m, S n * m == n * m + m.
End IsAddSubMul.

Module Type NZBasicFunsSig := NZDomainSig <+ AddSubMul <+ IsAddSubMul.
Module Type NZBasicFunsSig' := NZDomainSig' <+ AddSubMul' <+IsAddSubMul.

(** Old name for the same interface: *)

Module Type NZAxiomsSig := NZBasicFunsSig.
Module Type NZAxiomsSig' := NZBasicFunsSig'.

(** Axiomatization of order *)

Module Type NZOrd := NZDomainSig <+ HasLt <+ HasLe.
Module Type NZOrd' := NZDomainSig' <+ HasLt <+ HasLe <+
                      LtNotation <+ LeNotation <+ LtLeNotation.

Module Type IsNZOrd (Import NZ : NZOrd').
 Declare Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
 Axiom lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
 Axiom lt_irrefl : forall n, ~ (n < n).
 Axiom lt_succ_r : forall n m, n < S m <-> n <= m.
End IsNZOrd.

(** NB: the compatibility of [le] can be proved later from [lt_wd]
    and [lt_eq_cases] *)

Module Type NZOrdSig := NZOrd <+ IsNZOrd.
Module Type NZOrdSig' := NZOrd' <+ IsNZOrd.

(** Everything together : *)

Module Type NZOrdAxiomsSig <: NZBasicFunsSig <: NZOrdSig
 := NZOrdSig <+ AddSubMul <+ IsAddSubMul <+ HasMinMax.
Module Type NZOrdAxiomsSig' <: NZOrdAxiomsSig
 := NZOrdSig' <+ AddSubMul' <+ IsAddSubMul <+ HasMinMax.

(** Same, plus a comparison function. *)

Module Type NZDecOrdSig := NZOrdSig <+ HasCompare.
Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare.

Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare.
Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare.

(** A square function *)

Module Type NZSquare (Import NZ : NZBasicFunsSig').
 Parameter Inline square : t -> t.
 Axiom square_spec : forall n, square n == n * n.
End NZSquare.


Require Export XR_Rminus_diag_uniq.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 = R0 -> r1 = r2.
Proof.
  intros x y heq.
  symmetry.
  apply Rminus_diag_uniq.
  exact heq.
Qed.


Require Import
  HoTT.Types.Bool
  HoTT.Types.Forall
  HoTT.Classes.theory.ua_homomorphism.

Import algebra_notations ne_list.notations.

(** The following section defines product algebra [ProdAlgebra].
    Section [bin_prod_algebra] specialises the definition to
    binary product algebra. *)

Section prod_algebra.
  Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ).

  Definition carriers_prod_algebra : Carriers σ
    := λ (s : Sort σ), ∀ (i:I), A i s.

  Fixpoint op_prod_algebra (w : SymbolType σ)
      : (∀ i, Operation (A i) w) →
        Operation carriers_prod_algebra w :=
    match w return (∀ i, Operation (A i) w) →
                    Operation carriers_prod_algebra w
    with
    | [:_:] => idmap
    | _ ::: g => λ f p, op_prod_algebra g (λ i, f i (p i))
    end.

  Definition ops_prod_algebra (u : Symbol σ)
    : Operation carriers_prod_algebra (σ u)
    := op_prod_algebra (σ u) (λ (i:I), u.#(A i)).

  Definition ProdAlgebra : Algebra σ
    := BuildAlgebra carriers_prod_algebra ops_prod_algebra.

  Global Instance trunc_prod_algebra {n : trunc_index}
    `{!∀ i, IsTruncAlgebra n (A i)}
    : IsTruncAlgebra n ProdAlgebra.
  Proof.
    intro s. exact _.
  Qed.
End prod_algebra.

(** The next section defines the product projection homomorphisms. *)

Section hom_proj_prod_algebra.
  Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ).

  Definition def_proj_prod_algebra (i:I) (s : Sort σ) (c : ProdAlgebra I A s)
    : A i s
    := c i.

  Lemma oppreserving_proj_prod_algebra {w : SymbolType σ}
    (i : I) (v : ∀ i : I, Operation (A i) w) (α : Operation (A i) w)
    (P : v i = α)
    : OpPreserving (def_proj_prod_algebra i)
        (op_prod_algebra I A w v) α.
  Proof.
    induction w.
    - exact P.
    - intro p. apply (IHw (λ i, v i (p i)) (α (p i))). f_ap.
  Defined.

  Global Instance is_homomorphism_proj_prod_algebra (i:I)
    : IsHomomorphism (def_proj_prod_algebra i).
  Proof.
    intro u.
    by apply oppreserving_proj_prod_algebra.
  Defined.

  Definition hom_proj_prod_algebra (i : I)
    : Homomorphism (ProdAlgebra I A) (A i)
    := BuildHomomorphism (def_proj_prod_algebra i).

End hom_proj_prod_algebra.

(** The product algebra univarsal mapping property [ump_prod_algebra]. *)

Section ump_prod_algebra.
  Context
    `{Funext}
    {σ : Signature}
    (I : Type)
    (A : I → Algebra σ)
    (C : Algebra σ).

  Definition hom_prod_algebra_mapout
    (f : Homomorphism C (ProdAlgebra I A)) (i:I)
    : Homomorphism C (A i)
    := hom_compose (hom_proj_prod_algebra I A i) f.

  Definition def_prod_algebra_mapin (f : ∀ (i:I) s, C s → A i s)
    : ∀ (s : Sort σ) , C s → ProdAlgebra I A s
    := λ (s : Sort σ) (x : C s) (i : I), f i s x.

  Lemma oppreserving_prod_algebra_mapin {w : SymbolType σ}
    (f : ∀ (i:I) s, C s → A i s)
    (α : ∀ (i:I), Operation (A i) w) (β : Operation C w)
    (P : ∀ (i:I), OpPreserving (f i) β (α i))
    : OpPreserving (def_prod_algebra_mapin f) β
        (op_prod_algebra I A w (λ i, α i)).
  Proof.
    induction w.
    - funext i. apply P.
    - intro x. apply IHw. intro i. apply P.
  Defined.

  Global Instance is_homomorphism_prod_algebra_mapin
    (f : ∀ (i:I), Homomorphism C (A i))
    : IsHomomorphism (def_prod_algebra_mapin f).
  Proof.
    intro u.
    apply oppreserving_prod_algebra_mapin.
    intro i.
    apply f.
  Defined.

  Definition hom_prod_algebra_mapin (f : ∀ i, Homomorphism C (A i))
    : Homomorphism C (ProdAlgebra I A)
    := BuildHomomorphism (def_prod_algebra_mapin f).

  (** Given a family of homomorphisms [h : ∀ (i:I), Homomorphism C (A i)]
      there is a unique homomorphism [f : Homomorphism C (ProdAlgebra I A)]
      such that [h i = hom_compose (pr i) f], where

      <<
        pr i = hom_proj_prod_algebra I A i
      >>

      is the ith projection homomorphism. *)

 Lemma ump_prod_algebra `{!∀ i, IsHSetAlgebra (A i)}
   : (∀ (i:I), Homomorphism C (A i)) <~> Homomorphism C (ProdAlgebra I A).
  Proof.
    apply (equiv_adjointify hom_prod_algebra_mapin hom_prod_algebra_mapout).
    - intro f. by apply path_hset_homomorphism.
    - intro f. funext i. by apply path_hset_homomorphism.
  Defined.
End ump_prod_algebra.

(** Binary product algebra. *)

Section bin_prod_algebra.
  Context `{Funext} {σ : Signature} (A B : Algebra σ).

  Definition bin_prod_algebras (b:Bool) : Algebra σ
    := if b then B else A.

  Global Instance trunc_bin_prod_algebras {n : trunc_index}
    `{!IsTruncAlgebra n A} `{!IsTruncAlgebra n B}
    : ∀ (b:Bool), IsTruncAlgebra n (bin_prod_algebras b).
  Proof.
    intros []; exact _.
  Qed.

  Definition BinProdAlgebra : Algebra σ :=
    ProdAlgebra Bool bin_prod_algebras.

  Definition fst_prod_algebra : Homomorphism BinProdAlgebra A
    := hom_proj_prod_algebra Bool bin_prod_algebras false.

  Definition snd_prod_algebra : Homomorphism BinProdAlgebra B
    := hom_proj_prod_algebra Bool bin_prod_algebras true.
End bin_prod_algebra.

Module prod_algebra_notations.
  Global Notation "A × B" := (BinProdAlgebra A B) : Algebra_scope.
End prod_algebra_notations.

Import prod_algebra_notations.

(** Specialisation of the product algebra univarsal mapping property
    to binary product. *)

Section ump_bin_prod_algebra.
  Context
    `{Funext}
    {σ : Signature}
    (A B C : Algebra σ)
    `{!IsHSetAlgebra A} `{!IsHSetAlgebra B}.

 Lemma ump_bin_prod_algebra
   : Homomorphism C A * Homomorphism C B <~> Homomorphism C (A × B).
  Proof.
    set (k := λ (b:Bool), Homomorphism C (bin_prod_algebras A B b)).
    exact (equiv_compose
            (ump_prod_algebra Bool (bin_prod_algebras A B) C)
            (equiv_bool_forall_prod k)^-1).
  Defined.
End ump_bin_prod_algebra.


(*|
##################################################################
How to define an inductive type and a definition at the same time?
##################################################################

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

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

I want to have the following definitions:
|*)

Require Import String. (* .none *)
Fail Inductive a : Set :=
| basic : string -> a
| complex : string -> list t -> a. (* .fails *)

Fail Definition t := string * a * a. (* .fails *)

(*|
As you can see, when defining ``a``, ``t`` is used and when defining
``t``, ``a`` is used. My question is how can I define these two at the
same time?
|*)

(*|
Answer
******

You can define them mutually with the ``Inductive`` command.
|*)

Inductive a : Set :=
| basic : string -> a
| complex : string -> list t -> a
with t : Set :=
| t_intro : string * a * a -> t.

(*|
Or you can substitute using the definition of ``t``, and define ``t``
afterwards.
|*)

Reset a. (* .none *)
Inductive a : Set :=
| basic : string -> a
| complex : string -> list (string * a * a) -> a.

Definition t : Set := (string * a * a)%type.

Definition complex' : string -> list t -> a := complex.


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

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1, and Inria Futurs (Logical)
*)

Require Import Arith.
Require Import ArithRing.
Require Import Compare_dec.
Require Import Omega.
Require Import Max.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

(* Now in Coq.Init.Nat
Fixpoint power (base exp:nat){struct exp}:nat :=
  match exp with 0 => 1
               | S exp' => base * (power base exp')
  end.
Notation "n ^ p" := (power n p):nat_scope.
*)
Notation power := Nat.pow (only parsing).

Lemma power_of_1 : forall p, power 1 p = 1.
 induction p; simpl.
 auto.
 rewrite IHp;auto.
Qed.

Goal forall a b, 0 < power (S a) b.
 induction b.
 simpl;auto.
 simpl.
 auto with arith.
Save power_positive.

Lemma pred_of_power : forall b e, pred (power (S b) (S e)) =
                                  (power (S b) e)*b  +
                                  pred (power (S b) e).
 simpl.
 intros;generalize ((S b) ^e).
 destruct n.
 simpl.
 rewrite mult_0_r.
 simpl;auto.
 rewrite (mult_comm b (S n)).
simpl.
ring.
Qed.

(* some tools *)

(* this kind of argument must replace a lot of steps in proofs.
   must define the same for cpnf and ordinals *)

Lemma get_predecessor : forall (n:nat), 0 < n -> {p:nat | n = S p}.
 intro n; case n.
 intro ; absurd (0<0); auto with arith.
 intro n0; exists n0;auto.
Qed.

Ltac pred_exhib H name :=
  match type of H
       with O < ?n =>
         case (get_predecessor  H); intro name; intro
  end.

(* about euclidean division *)

Lemma Euc1 : forall b q  q' r r', 0 < b ->
                                  q*b + r = q'*b + r' ->
                                  r < b -> r' < b -> q = q'.
intros; case (lt_eq_lt_dec q q').
destruct 1.
assert (S q <= q').
auto with arith.
assert ((S q)*b + r <= q' *b + r).
apply plus_le_compat_r.
apply mult_le_compat_r.
auto.
simpl in H4.
rewrite <- plus_assoc in H4.
rewrite H0 in H4.
omega.
auto.
intro.
assert (S q' <= q).
auto with arith.
assert ((S q')*b + r <= q *b + r).
apply plus_le_compat_r.
apply mult_le_compat_r.
auto.
simpl in H4.
rewrite <- plus_assoc in H4.
rewrite H0 in H4.
omega.
Qed.

Lemma Euc2 : forall b q  q' r r', 0 < b ->
               q*b+r = q'*b+r' -> r < b -> r' < b -> r =r'.
 intros.
 rewrite (Euc1  q q' H H0 H1 H2) in H0.
 omega.
Qed.

Lemma max_le_regR : forall n p q, p <= q -> max p n <= max q n.
  intros; case (max_dec p n).
 intro e;rewrite e.
 apply le_trans with q.
 auto.
  apply le_max_l.
 intro e;rewrite e.
 apply le_max_r.
Qed.

Lemma max_le_regL :  forall n p q, p <= q -> max n p <= max n q.
  intros; rewrite (max_comm n p);rewrite (max_comm n q).
  apply max_le_regR.
  auto.
Qed.

Lemma lt_lt_Sn : forall a b c, a < b -> b < S c -> a < c.
 eauto with arith.
Qed.


(** * Introduction. Vladimir Voevodsky . Feb. 2010 - Sep. 2011

This is the first in the group of files which contain the (current state of) the mathematical library for theproof assistant Coq based on the Univalent Foundations. It contains some new notations for constructions defined in Coq.Init library as well as the definition of dependent sum as a record.

*)

(** Preambule. *)

Unset Automatic Introduction.  (** This line has to be removed for the file to compile with Coq8.2 *)

(** Universe structure *)

Notation UUU := Set .

(** Empty type.  The empty type is introduced in Coq.Init.Datatypes by the line:

[ Inductive Empty_set : Set := . ]

*)

Notation empty := Empty_set.

(** Identity Types. Idenity types are introduced in Coq.Init.Datatypes by the lines :

[ Inductive identity ( A : Type ) ( a : A ) : A -> Type := identity_refl : identity _ a a .
Hint Resolve identity_refl : core . ]

*)

Notation paths := identity .
Notation idpath := identity_refl .

(** Coproducts .

The coproduct of two types is introduced in Coq.Init.Datatypes by the lines:

[ Inductive sum (A B:Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B. ]
*)

Notation coprod := sum .

Notation ii1fun := inl .
Notation ii2fun := inr .

Notation ii1 := inl .
Notation ii2 := inr .
Implicit Arguments ii1 [ A B ] .
Implicit Arguments ii2 [ A B ] .

(** Dpendent sums.

One can not use a new record each time one needs it because the general theorems about this construction would not apply to new instances of "Record" due to the "generativity" of inductive definitions in Coq. One could use "Inductive" instead of "Record" here but using "Record" which is equivalent to "Structure" allows us later to use the mechanism of canonical structures with total2. *)

Record total2 { T: Type } ( P: T -> Type ) := tpair : forall t : T , forall tp : P t , total2 P .

Definition pr1 { T: Type } { P : T -> Type } ( tp : total2 P ) : T := match tp with tpair t p => t end .
Definition pr2 { T: Type } { P : T -> Type } ( tp : total2 P ) : P ( pr1 tp ) := match tp as a return P ( pr1 a ) with tpair t p => p end .

(*

(** The phantom type family ( following George Gonthier ) *)

Inductive Phant ( T : Type ) := phant : Phant T .

*)

(** The following command checks wheather the patch which modifies the universe level assignement for inductive types have been installed. With the patch it returns [ paths 0 0 : UUU ] . Without the patch it returns [ paths 0 0 : Prop ]. *)

Check (paths O O) .

(* End of the file uuu.v *)


(****************************************************************************************

 Construction of algebras

 In the 'Formal Theory of Monads' by Street, the core definition is when a 2-category
 has the construction of algebras, which says that the inclusion of that 2-category
 into the monads has a right adjoint.

 We take a slightly different approach: instead, we define this notion using limits.
 More specifically, we look at Eilenberg-Moore objects. In this file, we show that these
 two notions are indeed equivalent.

 Contents
 1. Definition of having the construction of algebras
 2. Having the construction of algebras is equivalent to having Eilenberg-Moore objects

 ****************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion.

Local Open Scope cat.

(**
 1. Definition of having the construction of algebras
 *)
Definition has_construction_of_algs
           (B : bicat)
  : UU
  := right_universal_arrow (mnd_incl B).

(**
 2. Having the construction of algebras is equivalent to having Eilenberg-Moore objects
 *)
Section ConstructionOfAlgsToEM.
  Context {B : bicat}
          (HB : has_construction_of_algs B).

  Definition has_construction_of_algs_cone
             (m : mnd B)
    : em_cone m
    := pr1 HB m ,, pr12 HB m.

  Definition has_construction_of_algs_to_em_mnd_cell_data
             {x : B}
             {m : mnd B}
             (f : x --> pr1 HB m)
    : mnd_cell_data
        (# (mnd_incl B) f · (pr12 HB) m)
        (em_hom_functor m (has_construction_of_algs_cone m) x f)
    := id2 _.

  Definition has_construction_of_algs_to_em_is_mnd_cell
             {x : B}
             {m : mnd B}
             (f : x --> pr1 HB m)
    : is_mnd_cell (has_construction_of_algs_to_em_mnd_cell_data f).
  Proof.
    unfold is_mnd_cell ; cbn.
    unfold has_construction_of_algs_to_em_mnd_cell_data.
    rewrite id2_rwhisker, lwhisker_id2.
    rewrite id2_left, id2_right.
    rewrite !vassocl.
    do 2 apply maponpaths.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocr.
    rewrite runitor_rwhisker.
    rewrite !vassocl.
    rewrite linvunitor_assoc.
    apply idpath.
  Qed.

  Definition has_construction_of_algs_to_em_mnd_cell
             {x : B}
             {m : mnd B}
             (f : x --> pr1 HB m)
    : # (mnd_incl B) f · pr12 HB m
      ==>
      em_hom_functor m (has_construction_of_algs_cone m) x f.
  Proof.
    use make_mnd_cell.
    - exact (has_construction_of_algs_to_em_mnd_cell_data f).
    - exact (has_construction_of_algs_to_em_is_mnd_cell f).
  Defined.

  Definition has_construction_of_algs_to_em_is_nat_trans
             (x : B)
             (m : mnd B)
    : is_nat_trans
        (right_universal_arrow_functor (mnd_incl B) x m (pr12 HB))
        (em_hom_functor m (pr1 HB m,, (pr12 HB) m) x)
        has_construction_of_algs_to_em_mnd_cell.
  Proof.
    intros f₁ f₂ α.
    use eq_mnd_cell ; cbn.
    exact (id2_right _ @ !(id2_left _)).
  Qed.

  Definition has_construction_of_algs_to_em_nat_trans
             (x : B)
             (m : mnd B)
    : right_universal_arrow_functor (mnd_incl B) x m (pr12 HB)
      ⟹
      em_hom_functor m (pr1 HB m,, (pr12 HB) m) x.
  Proof.
    use make_nat_trans.
    - exact has_construction_of_algs_to_em_mnd_cell.
    - exact (has_construction_of_algs_to_em_is_nat_trans x m).
  Defined.

  Definition has_construction_of_algs_to_em
    : bicat_has_em B.
  Proof.
    intro m.
    simple refine (_ ,, _).
    - exact (has_construction_of_algs_cone m).
    - apply is_universal_has_em_ump.
      intros x.
      use (nat_iso_adj_equivalence_of_cats _ _ (pr22 HB x m)).
      + exact (has_construction_of_algs_to_em_nat_trans x m).
      + intro f.
        use is_inv2cell_to_is_z_iso.
        use is_invertible_mnd_2cell.
        cbn ; unfold has_construction_of_algs_to_em_mnd_cell_data.
        is_iso.
  Defined.
End ConstructionOfAlgsToEM.

Section EMToConstructionOfAlgs.
  Context {B : bicat}
          (HB : bicat_has_em B).

  Definition em_to_has_construction_of_algs_nat_mnd_cell_data
             {m : mnd B}
             {x : B}
             (f : x --> pr1 (HB m))
    : mnd_cell_data
        (em_hom_functor m (pr1 (HB m)) x f)
        (right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)) f)
    := id2 _.

  Definition em_to_has_construction_of_algs_nat_is_mnd_cell
             {m : mnd B}
             {x : B}
             (f : x --> pr1 (HB m))
    : is_mnd_cell (em_to_has_construction_of_algs_nat_mnd_cell_data f).
  Proof.
    unfold is_mnd_cell.
    unfold em_to_has_construction_of_algs_nat_mnd_cell_data.
    etrans.
    {
      apply maponpaths.
      apply lwhisker_id2.
    }
    refine (id2_right _ @ _).
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply id2_rwhisker.
    }
    refine (id2_left _ @ _).
    refine (!_).
    do 2 refine (vassocl _ _ _ @ _).
    cbn.
    do 3 refine (_ @ vassocr _ _ _).
    do 2 apply maponpaths.
    refine (!_).
    refine (vassocr _ _ _ @ _).
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply rwhisker_vcomp.
      }
      refine (vassocr _ _ _ @ _).
      apply maponpaths_2.
      apply runitor_rwhisker.
    }
    refine (vassocl _ _ _ @ _).
    apply maponpaths.
    refine (!_).
    apply linvunitor_assoc.
  Qed.

  Definition em_to_has_construction_of_algs_nat_mnd_cell
             {m : mnd B}
             {x : B}
             (f : x --> pr1 (HB m))
    : em_hom_functor m (pr1 (HB m)) x f
      ==>
      right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)) f.
  Proof.
    use make_mnd_cell.
    - exact (em_to_has_construction_of_algs_nat_mnd_cell_data f).
    - exact (em_to_has_construction_of_algs_nat_is_mnd_cell f).
  Defined.

  Definition em_to_has_construction_of_algs_is_nat_trans
             (m : mnd B)
             (x : B)
    : is_nat_trans
        (em_hom_functor m (pr1 (HB m)) x)
        (right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)))
        em_to_has_construction_of_algs_nat_mnd_cell.
  Proof.
    intros f₁ f₂ α.
    use eq_mnd_cell.
    exact (id2_right _ @ !(id2_left _)).
  Qed.

  Definition em_to_has_construction_of_algs_nat_trans
             (m : mnd B)
             (x : B)
    : em_hom_functor m (pr1 (HB m)) x
      ⟹
      right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)).
  Proof.
    use make_nat_trans.
    - exact em_to_has_construction_of_algs_nat_mnd_cell.
    - exact (em_to_has_construction_of_algs_is_nat_trans m x).
  Defined.

  Definition em_to_has_construction_of_algs
    : has_construction_of_algs B.
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact (λ m, pr1 (HB m)).
    - exact (λ m, pr21 (HB m)).
    - intros x m.
      use (nat_iso_adj_equivalence_of_cats
             _ _
             (has_em_ump_is_universal m (pr2 (HB m)) x)).
      + exact (em_to_has_construction_of_algs_nat_trans m x).
      + intro f.
        use is_inv2cell_to_is_z_iso.
        use is_invertible_mnd_2cell.
        cbn ; unfold em_to_has_construction_of_algs_nat_mnd_cell_data.
        is_iso.
  Defined.
End EMToConstructionOfAlgs.

Definition has_construction_of_algs_weq_has_em_inv₁
           {B : bicat}
           (HB₁ : is_univalent_2_1 B)
           (HB₂ : has_construction_of_algs B)
  : em_to_has_construction_of_algs (has_construction_of_algs_to_em HB₂) = HB₂.
Proof.
  refine (maponpaths (λ z, _ ,, _ ,, z) _).
  use funextsec ; intro x.
  use funextsec ; intro m.
  enough (isaprop
            (adj_equivalence_of_cats
               (right_universal_arrow_functor (mnd_incl B) x m (pr12 HB₂))))
    as X.
  {
    apply X.
  }
  use isofhlevelweqf.
  - exact (@left_adjoint_equivalence
             bicat_of_univ_cats
             (univ_hom HB₁ x (pr1 HB₂ m))
             (univ_hom (is_univalent_2_1_mnd _ HB₁) (mnd_incl B x) m)
             (right_universal_arrow_functor (mnd_incl B) x m (pr12 HB₂))).
    - exact (@adj_equiv_is_equiv_cat
               (univ_hom _ _ _)
               _
               _).
    - apply isaprop_left_adjoint_equivalence.
      exact univalent_cat_is_univalent_2_1.
Qed.

Definition has_construction_of_algs_weq_has_em_inv₂
           {B : bicat}
           (HB₁ : is_univalent_2_1 B)
           (HB₂ : bicat_has_em B)
  : has_construction_of_algs_to_em (em_to_has_construction_of_algs HB₂) = HB₂.
Proof.
  use funextsec ; intro m.
  refine (maponpaths (λ z, _ ,, z) _).
  apply isaprop_has_em_ump.
  exact HB₁.
Qed.

Definition has_construction_of_algs_weq_has_em
           (B : bicat)
           (HB : is_univalent_2_1 B)
  : has_construction_of_algs B ≃ bicat_has_em B.
Proof.
  use make_weq.
  - exact has_construction_of_algs_to_em.
  - use isweq_iso.
    + exact em_to_has_construction_of_algs.
    + apply has_construction_of_algs_weq_has_em_inv₁.
      exact HB.
    + apply has_construction_of_algs_weq_has_em_inv₂.
      exact HB.
Defined.


(** * Functor category [D → C] (also [Cᴰ] and [[D, C]]) *)
Require Import Category.Strict Functor.Core NaturalTransformation.Core Functor.Paths.
(** These must come last, so that [identity], [compose], etc., refer to natural transformations. *)
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Identity NaturalTransformation.Composition.Laws NaturalTransformation.Paths.

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

(** ** Definition of [C → D] *)
Section functor_category.
  Context `{Funext}.

  Variables C D : PreCategory.

  (** There is a category Fun(C, D) of functors from [C] to [D]. *)
  Definition functor_category : PreCategory
    := @Build_PreCategory (Functor C D)
                          (@NaturalTransformation C D)
                          (@identity C D)
                          (@compose C D)
                          (@associativity _ C D)
                          (@left_identity _ C D)
                          (@right_identity _ C D)
                          _.
End functor_category.

Local Notation "C -> D" := (functor_category C D) : category_scope.

(** ** [C → D] is a strict category if [D] is *)
Lemma isstrict_functor_category `{Funext} C `{IsStrictCategory D}
: IsStrictCategory (C -> D).
Proof.
  typeclasses eauto.
Defined.

Module Export FunctorCategoryCoreNotations.
  (*Notation "C ^ D" := (functor_category D C) : category_scope.
  Notation "[ C , D ]" := (functor_category C D) : category_scope.*)
  Notation "C -> D" := (functor_category C D) : category_scope.
End FunctorCategoryCoreNotations.


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.Ascii.
Require Import
        Bedrock.Word
        Coq.Strings.Ascii
        Coq.Strings.String.

Section String.
  (* this has an exact idential structure to _FixList_ *)
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnit monoid bool}.

  Fixpoint format_string (xs : string) (ce : CacheFormat) : B * CacheFormat :=
    match xs with
    | EmptyString => (mempty, ce)
    | String x xs' => let (b1, env1) := format_ascii x ce in
                      let (b2, env2) := format_string xs' env1 in
                          (mappend b1 b2, env2)
    end.

  Fixpoint decode_string (s : nat) (b : B) (cd : CacheDecode) : string * B * CacheDecode :=
    match s with
    | O => (EmptyString, b, cd)
    | S s' => let (x1, e1) := decode_ascii b cd in
              let (x, b1) := x1 in
              let (x2, e2) := decode_string s' b1 e1 in
              let (xs, b2) := x2 in
              (String x xs, b2, e2)
    end.

  Local Opaque format_ascii.
  Theorem String_decode_correct :
    forall sz,
      format_decode_correct
        monoid
        (fun ls => length ls = sz)
        format_string (decode_string sz).
  Proof.
    unfold format_decode_correct.
    intros sz env env' xenv xenv' l l' bin' ext ext' Eeq Ppred Penc Pdec.
    generalize dependent sz. generalize dependent env. generalize dependent env'.
    generalize dependent xenv. generalize dependent xenv'. generalize dependent bin'.
    generalize dependent l'. generalize dependent ext'. induction l.
    { intros.
      inversion Penc; subst; clear Penc.
      rewrite mempty_left in Pdec. simpl in *.
      inversion Pdec. subst. intuition eauto. }
    { intros.
      destruct sz. inversion Ppred.
      simpl in *.
      destruct (format_ascii a env) eqn: ?.
      destruct (format_string l c) eqn: ?.
      inversion Penc; subst; clear Penc.
      inversion Ppred; subst; clear Ppred.
      rewrite <- mappend_assoc in Pdec.
      destruct (decode_ascii (mappend b (mappend b0 ext)) env') as [[? ?] ?] eqn: ?.
      destruct (Ascii_decode_correct _ _ _ _ _ _ _ _ _ Eeq I Heqp Heqp1) as [? [? ?]]. subst.
      destruct (decode_string (length l) (mappend b0 ext) c0) as [[? ?] ?] eqn: ?.
      specialize (IHl _ _ _ _ _ _ _ H Heqp0 _ eq_refl Heqp2).
      inversion Pdec; subst; clear Pdec.
      intuition eauto. subst. eauto. }
  Qed.
End String.


Require Import Rpos.
Require Import RL.hmr.term.
Require Import RL.hmr.hseq.
Require Import RL.hmr.hmr.

Require Import CMorphisms.
Require Import Lra.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.
(** * Definition of prederivations *)

Inductive preHMR : hypersequent -> Type :=
| prehmrr_leaf : forall G, preHMR G
| prehmrr_INIT : preHMR (nil :: nil)
| prehmrr_W : forall G T, preHMR G -> preHMR (T :: G)
| prehmrr_C : forall G T, preHMR (T :: T :: G) -> preHMR (T :: G)
| prehmrr_S : forall G T1 T2, preHMR ((T1 ++ T2) :: G) -> preHMR (T1 :: T2 :: G)
| prehmrr_T : forall G T r, preHMR (seq_mul r T :: G) -> preHMR (T :: G)
| prehmrr_ID : forall G T n r s, sum_vec r = sum_vec s -> preHMR (T :: G) -> preHMR ((vec s (HMR_covar n) ++ vec r (HMR_var n) ++ T) :: G)
| prehmrr_Z : forall G T r, preHMR (T :: G) -> preHMR ((vec r HMR_zero ++ T) :: G)

| prehmrr_plus : forall G T A B r, preHMR ((vec r A ++ vec r B ++ T) :: G) -> preHMR ((vec r (A +S B) ++ T) :: G)
| prehmrr_mul : forall G T A r0 r, preHMR ((vec (mul_vec r0 r) A ++ T) :: G) -> preHMR ((vec r (r0 *S A) ++ T) :: G)
| prehmrr_max : forall G T A B r, preHMR ((vec r B ++ T) :: (vec r A ++ T) :: G) -> preHMR ((vec r (A \/S B) ++ T) :: G)
| prehmrr_min : forall G T A B r, preHMR ((vec r A ++ T) :: G) -> preHMR ((vec r B ++ T) :: G) -> preHMR ((vec r (A /\S B) ++ T) :: G)
| prehmrr_one : forall G T r s, sum_vec s <= sum_vec r -> preHMR (T :: G) -> preHMR ((vec s HMR_coone ++ vec r HMR_one ++ T) :: G)
| prehmrr_diamond : forall T r s, sum_vec s <= sum_vec r -> preHMR ((vec s HMR_coone ++ vec r HMR_one ++ T) :: nil) -> preHMR ((vec s HMR_coone ++ vec r HMR_one ++ seq_diamond T) :: nil)
| prehmrr_ex_seq : forall G T1 T2, Permutation_Type T1 T2 -> preHMR (T1 :: G) -> preHMR (T2 :: G)
| prehmrr_ex_hseq : forall G H, Permutation_Type G H -> preHMR G -> preHMR H.

Fixpoint leaves {G} (pi : preHMR G) :=
  match pi with
| prehmrr_leaf G => G :: nil
| prehmrr_INIT => nil
| prehmrr_W G T pi => leaves pi
| prehmrr_C _ _ pi => leaves pi
| prehmrr_S _ _ _ pi => leaves pi
| prehmrr_T _ _ _ pi => leaves pi
| prehmrr_ID _ _ _ _ _ _ pi => leaves pi
| prehmrr_Z _ _ _ pi => leaves pi
| prehmrr_plus _ _ _ _ _ pi => leaves pi
| prehmrr_mul  _ _ _ _ _ pi => leaves pi
| prehmrr_max  _ _ _ _ _ pi => leaves pi
| prehmrr_min  _ _ _ _ _ pi1 pi2 => leaves pi1 ++ leaves pi2
| prehmrr_one  _ _ _ _ _ pi => leaves pi
| prehmrr_diamond  _ _ _ _ pi => leaves pi
| prehmrr_ex_seq  _ _ _ _ pi => leaves pi
| prehmrr_ex_hseq _ _ _ pi => leaves pi
  end.

Lemma finish_preproof : forall G (pi : preHMR G),
    Forall_inf HMR_T (leaves pi) ->
    HMR_T G.
Proof.
  intros G pi; induction pi; intros Hall.
  - inversion Hall; assumption.
  - apply hmrr_INIT.
  - apply hmrr_W; apply IHpi; apply Hall.
  - apply hmrr_C; apply IHpi; apply Hall.
  - apply hmrr_S; apply IHpi; apply Hall.
  - apply hmrr_T with r; try reflexivity; apply IHpi; apply Hall.
  - apply hmrr_ID; try assumption; apply IHpi; apply Hall.
  - apply hmrr_Z; apply IHpi; apply Hall.
  - apply hmrr_plus; apply IHpi; apply Hall.
  - apply hmrr_mul; apply IHpi; apply Hall.
  - apply hmrr_max; apply IHpi; apply Hall.
  - simpl in Hall.
    apply hmrr_min; [apply IHpi1; eapply Forall_inf_app_l | apply IHpi2; eapply Forall_inf_app_r]; try eassumption.
  - apply hmrr_one; try assumption; apply IHpi; apply Hall.
  - apply hmrr_diamond; try assumption; apply IHpi; apply Hall.
  - eapply hmrr_ex_seq; [ | apply IHpi; apply Hall]; try assumption.
  - eapply hmrr_ex_hseq; [ | apply IHpi; apply Hall ] ; try assumption.
Defined.

Lemma HMR_to_preHMR : forall G,
    HMR_T G ->
    preHMR G.
Proof.
  intros G pi.
  induction pi.
  - apply prehmrr_INIT.
  - now apply prehmrr_W.
  - now apply prehmrr_C.
  - now apply prehmrr_S.
  - inversion f.
  - now apply prehmrr_T with r.
  - now apply prehmrr_ID.
  - now apply prehmrr_Z.
  - now apply prehmrr_plus.
  - now apply prehmrr_mul.
  - now apply prehmrr_max.
  - now apply prehmrr_min.
  - now apply prehmrr_one.
  - now apply prehmrr_diamond.
  - now apply prehmrr_ex_seq with T1.
  - now apply prehmrr_ex_hseq with G.
  - inversion f.
Defined.

Lemma HMR_to_preHMR_no_leaf :
  forall G (pi : HMR_T G),
    leaves (HMR_to_preHMR G pi) = nil.
Proof.
  intros G pi.
  induction pi; simpl; try rewrite IHpi; try rewrite IHpi1; try rewrite IHpi2; try reflexivity; try inversion f.
Qed.


(*
 - The projection pseudofunctor of the total prebicategory of a displayed prebicategory to its base
From 'UniMath/Bicategories/PseudoFunctors/Examples/Projection.v'
*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.

Require Import Integers.Prebicategories.DispPrebicat.
Require Import Integers.Prebicategories.Invertible_2cells.
Require Import Integers.Prebicategories.PseudoFunctor.
Import PseudoFunctor.Notations.

Local Open Scope cat.
Local Open Scope mor_disp_scope.
Local Open Scope bicategory_scope.

Section Projection.
  Context {C : prebicat}.
  Variable (D : disp_prebicat C).

  Definition pr1_pseudofunctor_data : pseudofunctor_data (total_prebicat D) C.
  Proof.
    use make_pseudofunctor_data.
    - exact (λ a, pr1 a).
    - exact (λ _ _ f, pr1 f).
    - exact (λ _ _ _ _ θ, pr1 θ).
    - exact (λ a, (id2 (identity (pr1 a)))).
    - exact (λ _ _ _ f g, id2 (pr1 f · pr1 g)).
  Defined.

  Definition pr1_pseudofunctor_laws : pseudofunctor_laws pr1_pseudofunctor_data.
  Proof.
    repeat split.
    - intros a b c f g h θ. cbn.
      refine (_ @ _).
      + apply id2_left.
      + apply (!id2_right _).
    - intros a b c f g h θ. cbn.
      refine (_ @ _).
      + apply id2_left.
      + apply (!id2_right _).
    - intros a b f. cbn.
      refine (!(_ @ _ @ _)).
      + apply maponpaths_2.
        apply maponpaths_2.
        apply id2_rwhisker.
      + apply maponpaths_2.
        apply id2_left.
      + apply id2_left.
    - intros a b f. cbn.
      refine (!(_ @ _ @ _)).
      + apply maponpaths_2.
        apply maponpaths_2.
        apply lwhisker_id2.
      + apply maponpaths_2.
        apply id2_left.
      + apply id2_left.
    - intros a b c d f g h. cbn.
      refine (_ @ _ @ _ @!(_ @ _ @ _)).
      + apply maponpaths_2.
        apply maponpaths_2.
        apply lwhisker_id2.
      + apply maponpaths_2.
        apply id2_left.
      + apply id2_left.
      + apply maponpaths_2.
        apply maponpaths.
        apply id2_rwhisker.
      + apply id2_right.
      + apply id2_right.
  Qed.

  Definition pr1_pseudofunctor : pseudofunctor (total_prebicat D) C.
  Proof.
    use make_pseudofunctor.
    - exact pr1_pseudofunctor_data.
    - exact pr1_pseudofunctor_laws.
    - split.
      + intro a. cbn.
        is_iso.
      + intros a b c f g. cbn.
        is_iso.
  Defined.
End Projection.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.PrimeFieldTheorems Crypto.Algebra.Field.
Require Import Crypto.Util.Decidable.

Require Import Circom.BabyJubjub.
(* Require Import Circom.Tuple. *)
(* Require Import Crypto.Util.Decidable Crypto.Util.Notations. *)
(* Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac. *)

Module Type CIRCOM.
  Parameter q: positive.
  Parameter k: Z.
  Axiom prime_q: prime q.
  Axiom two_lt_q: 2 < q.
  Axiom k_lb: 2 <= k.
  Axiom q_lb: 2^k < q.
  Axiom q_gtb_1: (1 <? q)%positive = true.
End CIRCOM.

Module C : CIRCOM.
Definition q := BabyJubjub.p.
Definition k := 253.

Fact prime_q: prime q.
Proof. exact BabyJubjub.is_prime. Qed.

Fact two_lt_q: 2 < q.
Proof. unfold q, BabyJubjub.p. lia. Qed.

Fact k_lb: 2 <= k.
Proof. unfold k. lia. Qed.

Fact q_lb: 2^k < q.
Proof. unfold k, q, BabyJubjub.p. lia. Qed.

Lemma q_gtb_1: (1 <? q)%positive = true.
Proof.
  pose proof two_lt_q.
  apply Pos.ltb_lt. lia.
Qed.

End C.

Export C.

Global Hint Rewrite q_gtb_1 : circom.
Global Hint Rewrite two_lt_q : circom.
Global Ltac fqsatz := fsatz_safe; autorewrite with circom; auto.
Global Ltac unwrap_C :=
  pose proof prime_q as prime_q;
  pose proof two_lt_q as two_lt_q;
  pose proof k_lb as k_lb;
  pose proof q_lb as q_lb.

Declare Scope circom_scope.
Delimit Scope circom_scope with circom.

Global Notation "x <z y" := (F.to_Z x < y) (at level 50) : circom_scope.
Global Notation "x <=z y" := (F.to_Z x <= y) (at level 50) : circom_scope.
Global Notation "x >z y" := (F.to_Z x > y) (at level 50) : circom_scope.
Global Notation "x >=z y" := (F.to_Z x >= y) (at level 50) : circom_scope.

Global Notation "x <q y" := (F.to_Z x < F.to_Z y) (at level 50) : circom_scope.
Global Notation "x <=q y" := (F.to_Z x <= F.to_Z y) (at level 50) : circom_scope.
Global Notation "x >q y" := (F.to_Z x > F.to_Z y) (at level 50) : circom_scope.
Global Notation "x >=q y" := (F.to_Z x >= F.to_Z y) (at level 50) : circom_scope.

Global Notation F := (ModularArithmetic.F q).

Global Notation "2" := (F.add F.one F.one : F) : circom_scope.

Definition binary (x: F) := x = F.zero \/ x = F.one.

Global Notation "P '?'" :=
  (match (@dec P _) with
    | left _ => true
    | right _ => false
    end)
  (at level 100).

Local Coercion Z.of_nat : nat >-> Z.
Local Coercion N.of_nat : nat >-> N.

Local Open Scope circom_scope.

Global Notation "x | ( n )" := (x <=z (2^n-1)%Z) (at level 40) : circom_scope.
Global Notation "xs |: ( n )" := (List.Forall (fun x => x | (n)) xs) (at level 40) : circom_scope.
Global Notation "^ x" := (@F.to_Z q x) (at level 30): circom_scope.

(* Facts about q/2 *)
Definition half := q / 2.
Notation "q//2" := half.

Lemma prime_odd: forall p,
  prime p ->
  p > 2 ->
  p mod 2 = 1.
Proof.
  intros.
  assert (rel_prime p 2). apply rel_prime_sym, H. lia.
  apply Zrel_prime_neq_mod_0 in H1; try lia.
  assert (0 <= p mod 2 < 2). apply Z_mod_lt. lia.
  lia.
Qed.

Lemma half_spec:
  q//2 + q//2 < q /\
  q <= q//2 + q//2 + 1.
Proof.
  unwrap_C.
  unfold half.
  replace (q / 2 + q / 2) with (q / 2 * 2) by lia.
  rewrite Modulo.Z.mul_div_eq' by lia.
  assert (0 <= q mod 2 < 2). apply Z_mod_lt. lia.
  rewrite prime_odd; auto; lia.
Qed.

Lemma half_lt_q: q//2 + q//2 < q.
Proof. pose proof half_spec. easy. Qed.

Lemma half_gt_q: q <= q//2 + q//2 + 1.
Proof. pose proof half_spec. easy. Qed.

Lemma half_geq_2: 2 <= q//2.
Proof.
  unwrap_C.
  assert (2*2 <= 2* q//2). {
    unfold half.
    replace (2*(q/2)) with ((q / 2) * 2) by nia.
    rewrite Modulo.Z.mul_div_eq' by lia.
    assert (0 <= q mod 2 < 2). apply Z_mod_lt. lia.
    rewrite prime_odd; auto; try lia.
    assert (2^2 <= q - 1).
    transitivity (2^k).
    apply Zpow_facts.Zpower_le_monotone; try lia.
    lia.
    lia.
  }
  lia.
Qed.

Lemma pow_nonzero: forall (a: N),
  a <= k ->
  @F.pow q (F.add F.one F.one) a <> F.zero.
Admitted.

Lemma to_Z_2pow: forall (a: N), a <= k ->
  ^(@F.pow q (F.add F.one F.one) a) = 2^a.
Admitted.

Local Close Scope circom_scope.


From Hammer Require Import Hammer.

Require Export Classical.
Require Import ClassicalChoice.
Require Export Relation_Definitions.
From ZornsLemma Require Import Relation_Definitions_Implicit.
Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Import Proj1SigInjective.
From ZornsLemma Require Import InverseImage.

Section ZL'.

Variable T:Type.
Variable R:relation T.
Hypothesis ord:order R.
Definition chain (S: Ensemble T) : Prop :=
forall x y:T, In S x -> In S y -> (R x y \/ R y x).
Definition maximal (x:T) : Prop :=
forall y:T, R x y -> x = y.
Variable chain_sup: forall S: Ensemble T, chain S ->
{ x:T | (forall y:T, In S y -> R y x) /\
(forall z:T, (forall y:T, In S y -> R y z) -> R x z) }.
Variable inflation: forall x:T,
{ y:T | R x y /\ x <> y /\ forall z:T, R x z -> R z y ->
z = x \/ z = y }.

Inductive tower : Ensemble T :=
| sup_intro: forall (S: Ensemble T), Included S tower ->
forall c:chain S,
In tower (proj1_sig (chain_sup S c))
| inflation_intro: forall x:T, In tower x ->
In tower (proj1_sig (inflation x)).

Lemma tower_is_chain: chain tower.
Proof. hammer_hook "ZornsLemma" "ZornsLemma.tower_is_chain".
unfold chain.
intros.
revert x H.
induction H0.
intros.
case (classic (forall y:T, In S y -> R y x)).
right.
apply (proj2_sig (chain_sup S c)).
assumption.

intro.
apply not_all_ex_not in H2.
destruct H2.
apply imply_to_and in H2.
destruct H2.
left.
apply (ord_trans ord) with x0.
pose proof (H0 x0 H2 x H1).
tauto.
apply (proj2_sig (chain_sup S c)).
assumption.

pose proof (proj2_sig (inflation x)).
simpl in H0.
destruct H0.
destruct H1.
remember (proj1_sig (inflation x)) as x'.

assert (forall y:T, In tower y -> R y x \/ R x' y).
intros.
induction H3.
case (classic (forall x0:T, In S x0 -> R x0 x)).
left.
apply (proj2_sig (chain_sup S c)).
assumption.

right.
apply not_all_ex_not in H5.
destruct H5.
apply imply_to_and in H5.
destruct H5.
apply (ord_trans ord) with x0.
pose proof (H4 x0).
tauto.
apply (proj2_sig (chain_sup S c)).
assumption.

assert (In tower x').
rewrite Heqx'.
apply inflation_intro.
assumption.

destruct IHtower0.
assert (In tower (proj1_sig (inflation x0))).
apply inflation_intro.
assumption.
case (IHtower (proj1_sig (inflation x0)) H6).
left.
assumption.
intro.
pose proof (proj2_sig (inflation x0)).
simpl in H8.
assert (x = x0 \/ x = proj1_sig (inflation x0)).
apply H8.
assumption.
assumption.
case H9.
right.
rewrite Heqx'.
rewrite H10.
apply (ord_refl ord).
left.
rewrite H10.
apply (ord_refl ord).
right.
apply (ord_trans ord) with x0.
assumption.
apply (proj2_sig (inflation x0)).

intros.
case (H3 x0 H4).
left.
apply (ord_trans ord) with x.
assumption.
assumption.
right.
assumption.
Qed.

Lemma ZL': False.
Proof. hammer_hook "ZornsLemma" "ZornsLemma.ZL'".
pose proof (proj2_sig (chain_sup tower tower_is_chain)).
simpl in H.
remember (proj1_sig (chain_sup tower tower_is_chain)) as x0.
assert (In tower x0).
rewrite Heqx0.
constructor 1.
auto with sets.

pose (x' := proj1_sig (inflation x0)).
assert (In tower x').
constructor 2.
assumption.

pose proof (proj2_sig (inflation x0)).
simpl in H2.
destruct H2.
destruct H3.
contradict H3.
apply (ord_antisym ord).
assumption.
destruct H.
apply H.
assumption.
Qed.

End ZL'.

Arguments chain {T}.
Arguments maximal {T}.

From ZornsLemma Require Export EnsemblesSpec.

Section ZL.

Variable T:Type.
Variable R:relation T.
Hypothesis ord: order R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
exists x:T, forall y:T, In S y -> R y x.

Definition chains := {S:Ensemble T | chain R S}.
Definition chains_ord := (fun S1 S2:chains =>
Included (proj1_sig S1) (proj1_sig S2)).

Lemma chains_order: order chains_ord.
Proof. hammer_hook "ZornsLemma" "ZornsLemma.chains_order".
constructor.
unfold reflexive.
unfold chains_ord.
auto with sets.

unfold transitive.
unfold chains_ord.
auto with sets.

unfold antisymmetric.
unfold chains_ord.
intros.
apply proj1_sig_injective.
auto with sets.
Qed.

Definition chains_sup_def : forall F: Ensemble chains,
chain chains_ord F -> chains.
refine (fun F H => exist _ [ x:T | exists S:chains, In F S /\
In (proj1_sig S) x ] _).
red; intros.
destruct H0.
destruct H1.
destruct H0.
destruct H1.
pose proof (H x0 x1).
destruct x0.
destruct x1.
simpl in H0.
destruct H0.
simpl in H1.
destruct H1.
apply H2 in H0.
unfold chains_ord in H0.
simpl in H0.
destruct H0.
apply c0.
apply H0.
exact H3.
exact H4.

apply c.
exact H3.
apply H0.
exact H4.
assumption.
Defined.

Lemma chains_sup_correct: forall (F:Ensemble chains)
(P:chain chains_ord F), let U := chains_sup_def F P in
(forall S:chains, In F S -> chains_ord S U) /\
(forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
chains_ord U T).
Proof. hammer_hook "ZornsLemma" "ZornsLemma.chains_sup_correct".
intros.
split.
intros.
unfold chains_ord.
unfold Included.
intros.
unfold U.
simpl.
constructor.
exists S.
auto.
intros.
unfold chains_ord.
unfold Included.
intros.
unfold U in H0.
simpl in H0.
destruct H0.
destruct H0.
destruct H0.
apply H in H0.
apply H0.
assumption.
Qed.

Definition chains_sup (F:Ensemble chains) (P:chain chains_ord F) :=
let U := chains_sup_def F P in
exist (fun U:chains =>
(forall S:chains, In F S -> chains_ord S U) /\
(forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
chains_ord U T))
(chains_sup_def F P) (chains_sup_correct F P).

Theorem ZornsLemma: exists x:T, maximal R x.
Proof. hammer_hook "ZornsLemma" "ZornsLemma.ZornsLemma".
pose proof (ZL' chains chains_ord chains_order chains_sup).

apply NNPP.
unfold maximal.
dintuition.
assert (forall x:T, ~ forall y:T, R x y -> x = y).
apply not_ex_all_not.
exact H0.
assert (forall x:T, exists y:T, ~ (R x y -> x = y)).
intro.
apply not_all_ex_not.
apply H1.
assert (forall x:T, exists y:T, R x y /\ x <> y).
intro.
pose proof (H2 x).
destruct H3.
apply imply_to_and in H3.
exists x0.
assumption.
clear H0 H1 H2.

assert (forall x:chains, exists y:chains,
chains_ord x y /\ x <> y /\ forall z:chains, chains_ord x z ->
chains_ord z y -> z = x \/ z = y).
intro.
destruct x.
pose proof (ub_of_chain x c).
destruct H0.
pose proof (H3 x0).
destruct H1.

pose (x' := Add x x1).
assert (chain R x').
unfold chain.
intros.
case H2.
case H4.
intros.
apply c.
assumption.
assumption.
intros.
destruct H5.
left.
apply ord_trans with x0.
apply H0.
assumption.
apply H1.
intros.
destruct H5.
case H4.
right.
apply ord_trans with x0.
apply H0.
assumption.
apply H1.
intros.
destruct H5.
left.
apply ord_refl.

exists (exist _ x' H2).
split.
unfold chains_ord.
simpl.
unfold Included.
intros.
constructor.
assumption.

split.
intuition.
injection H4.
intro.
assert (In x x1).
rewrite H1.
constructor 2.
auto with sets.
contradict H6.
apply ord_antisym.
assumption.
apply H0.
assumption.

intros.
destruct z.
unfold chains_ord in H4.
simpl in H4.
unfold chains_ord in H5.
simpl in H5.

case (classic (In x2 x1)).
right.
apply subset_eq_compatT.
apply Extensionality_Ensembles.
split.
assumption.
unfold Included.
intros.
case H7.
exact H4.
intros.
destruct H8.
assumption.

left.
apply subset_eq_compatT.
apply Extensionality_Ensembles.
split.
unfold Included.
intros.
assert (In x' x3).
apply H5.
assumption.
inversion H8.
assumption.
destruct H9.
contradiction H6.
assumption.

apply choice in H0.
destruct H0 as [f].
apply H.
intro.
apply exist with (f x).
apply H0.
Qed.

End ZL.

Arguments ZornsLemma {T}.

From ZornsLemma Require Import Quotients.

Section ZL_preorder.

Variable T:Type.
Variable R:relation T.
Hypothesis Rpreord: preorder R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
exists x:T, forall y:T, In S y -> R y x.

Definition premaximal (x:T) : Prop :=
forall y:T, R x y -> R y x.

Lemma ZornsLemmaForPreorders: exists x:T, premaximal x.
Proof. hammer_hook "ZornsLemma" "ZornsLemma.ZornsLemmaForPreorders".
pose (Requiv (x y:T) := R x y /\ R y x).
assert (equivalence Requiv).
constructor.
red; intros.
split; apply preord_refl; trivial.
red; intros.
destruct H.
destruct H0.
split; apply preord_trans with y; trivial.
red; intros.
destruct H.
split; trivial.

pose (Rquo := quotient Requiv).
let Hnew:=fresh"_H" in
unshelve refine (let Hnew:=_ in
let inducedR := induced_function2arg R H H Hnew in
let inducedR_prop := induced_function2arg_correct R H H Hnew in _).
intros.
assert (True_rect (R a1 b1) = True_rect (R a2 b2)).
apply Extensionality_Ensembles; split; red; intros.
destruct x.
red in H2.
simpl in H2.
red; simpl.
apply preord_trans with a1; trivial.
apply H0.
apply preord_trans with b1; trivial.
apply H1.
destruct x.
red in H2; simpl in H2.
red; simpl.
apply preord_trans with a2; trivial.
apply H0.
apply preord_trans with b2; trivial.
apply H1.
assert (True_rect (R a1 b1) I = True_rect (R a2 b2) I).
rewrite H2; trivial.
simpl in H3.
assumption.
clearbody inducedR_prop.
fold inducedR in inducedR_prop.

assert (exists x:Rquo, maximal inducedR x).
apply ZornsLemma.
constructor.
red; intros xbar.
destruct (quotient_projection_surjective xbar) as [x []].
rewrite inducedR_prop.
apply preord_refl; trivial.
red; intros xbar ybar zbar ? ?.
destruct (quotient_projection_surjective xbar) as [x].
destruct H2.
destruct (quotient_projection_surjective ybar) as [y].
destruct H2.
destruct (quotient_projection_surjective zbar) as [z].
destruct H2.
rewrite inducedR_prop in H0, H1.
rewrite inducedR_prop.
apply preord_trans with y; trivial.
red; intros xbar ybar ? ?.
destruct (quotient_projection_surjective xbar) as [x].
destruct H2.
destruct (quotient_projection_surjective ybar) as [y].
destruct H2.
rewrite inducedR_prop in H0, H1.
unfold quotient_projection.
apply subset_eq_compatT.
apply R_impl_equality_of_equiv_class; trivial.
split; trivial.

intros Sbar ?.
pose (S := inverse_image (quotient_projection _) Sbar).
unshelve refine (let H1:=ub_of_chain S _ in _).
red; intros.
pose proof (H0 (quotient_projection _ x) (quotient_projection _ y)).
rewrite 2 inducedR_prop in H3.
destruct H1.
destruct H2.
apply H3; trivial.

destruct H1.
exists (quotient_projection _ x).
intros ybar ?.
destruct (quotient_projection_surjective ybar) as [y].
destruct H3.
rewrite inducedR_prop.
apply H1.
constructor; exact H2.

destruct H0 as [xbar].
destruct (quotient_projection_surjective xbar) as [x].
destruct H1.
exists x.
red; intros.
red in H0.
unshelve refine (let H2:=H0 (quotient_projection Requiv y) _ in _).
rewrite inducedR_prop.
assumption.
unfold quotient_projection in H2.
injection H2; intros.
assert (In (equiv_class Requiv x) y).
rewrite H3.
constructor; apply equiv_refl; trivial.
destruct H4.
apply H4.
Qed.

End ZL_preorder.

Arguments premaximal {T}.