From Undecidability.L.Datatypes Require Export LNat.
From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Import LTactics GenEncode.

(* ** Encoding for L-terms *)
MetaCoq Run (tmGenEncode "term_enc" term).
#[export] Hint Resolve term_enc_correct : Lrewrite.

(* register the non-constant constructors *)
#[global]
Instance term_var : computableTime' var (fun n _ => (1, tt)).
Proof.
  extract constructor. solverec.
Qed.

#[global]
Instance term_app : computableTime' L.app (fun s1 _ => (1, (fun s2 _ => (1, tt)))).
Proof.
  extract constructor. solverec.
Qed.

#[global]
Instance term_lam : computableTime' lam (fun s _ => (1, tt)).
Proof.
  extract constructor. solverec.
Qed.

Definition c__termsize := c__natsizeS + 7.
Lemma size_term_enc (s:term) :
  size (enc s) <= size s *c__termsize.
Proof.
  induction s;cbv [enc registered_term_enc] in *. all:cbn [size term_enc] in *.
  rewrite size_nat_enc. all: unfold c__termsize, c__natsizeS, c__natsizeO in *; solverec.
Qed.

Lemma size_term_enc_r (s:term) :
  size s <= size (enc s).
Proof.
  induction s;cbv [enc registered_term_enc] in *. all:cbn [size term_enc] in *.
  rewrite <- size_nat_enc_r. all:solverec.
Qed.


Require Export ReductionSystem.
Require Import UntypedArith.

Inductive term : Type :=
| tzero : term
| ttrue : term
| tfalse : term
| tsucc : term -> term
| tpred : term -> term
| tiszero : term -> term
| tif : term -> term -> term -> term
| twrong : term
.

Inductive bv : term -> Prop :=
| BV_True : bv ttrue
| BV_False : bv tfalse
.

Inductive nv : term -> Prop :=
| NV_Zero : nv tzero
| NV_Succ : forall (t : term), nv t -> nv (tsucc t)
.

Inductive badbool : term -> Prop :=
| BB_Nat : forall t, nv t -> badbool t
| BB_Wrong : badbool twrong
.

Inductive badnat : term -> Prop :=
| BN_Bool : forall t, bv t -> badnat t
| BN_Wrong : badnat twrong
.

Inductive eval : term -> term -> Prop :=
| E_IfTrue : forall (t2 t3 : term),
eval (tif ttrue t2 t3) t2
| E_IfFalse : forall (t2 t3 : term),
eval (tif tfalse t2 t3) t3
| E_If : forall (t1 t1' t2 t3 : term),
eval t1 t1'
-> eval (tif t1 t2 t3) (tif t1' t2 t3)
| E_Succ : forall (t1 t1' : term),
eval t1 t1' -> eval (tsucc t1) (tsucc t1')
| E_PredZero : eval (tpred tzero) tzero
| E_PredSucc : forall t,
nv t -> eval (tpred (tsucc t)) t
| E_Pred : forall t1 t1',
eval t1 t1' -> eval (tpred t1) (tpred t1')
| E_IsZeroZero : eval (tiszero tzero) ttrue
| E_IsZeroSucc : forall t,
nv t -> eval (tiszero (tsucc t)) tfalse
| E_IsZero : forall t1 t1',
eval t1 t1'
-> eval (tiszero t1) (tiszero t1')
| E_IfWrong :
forall t1 t2 t3, badbool t1 -> eval (tif t1 t2 t3) twrong
| E_SuccWrong :
forall t1, badnat t1 -> eval (tsucc t1) twrong
| E_PredWrong :
forall t1, badnat t1 -> eval (tpred t1) twrong
| E_IsZeroWrong :
forall t1, badnat t1 -> eval (tiszero t1) twrong
.

Notation "t1 -w-> t2" := (eval t1 t2) (at level 60).

Lemma bv_is_nf : forall t,
bv t -> normal_form eval t.
Proof.
intros. unfold normal_form. unfold not.
induction H; intros; inversion H; inversion H0.
Qed.

Lemma nv_is_nf : forall t,
nv t -> normal_form eval t.
Proof.
intros. unfold normal_form. unfold not.
induction H.
- intros. inversion H. inversion H0.
- intros. destruct H0. destruct IHnv.
  inversion H0; subst. exists t1'. apply H2.
  inversion H2; subst. inversion H1; subst; inversion H.
  inversion H.
Qed.

Definition value t := nv t \/ bv t \/ t = twrong.

(* 3.5.7 *)
Theorem value_is_nf : forall t,
value t -> normal_form eval t.
Proof.
intros. destruct H.
- apply nv_is_nf. apply H.
- destruct H.
  + apply bv_is_nf. apply H.
  + rewrite -> H.
    unfold normal_form. unfold not.
    intros. destruct H0. subst. inversion H0.
Qed.

Lemma nv_succ_nv : forall t,
nv (tsucc t) -> nv t.
Proof.
intros. destruct t.
- apply NV_Zero.
- inversion H; subst. inversion H1.
- inversion H; subst. apply H1.
- inversion H; subst. apply H1.
- inversion H; subst. apply H1.
- inversion H; subst. apply H1.
- inversion H; subst. apply H1.
- inversion H; subst. apply H1.
Qed.

Lemma badnat_is_nf : forall t,
badnat t -> normal_form eval t.
Proof.
intros.
destruct H.
- apply bv_is_nf. apply H.
- intro. destruct H. inversion H.
Qed.

Lemma badbool_is_nf : forall t,
badbool t -> normal_form eval t.
Proof.
intros.
induction H.
- apply nv_is_nf in H. apply H.
- intro. destruct H. inversion H.
Qed.

(* 3.5.4, 3.5.14 *)
Theorem eval_deterministic :
  forall t t' t'',
  t -w-> t' -> t -w-> t'' -> t' = t''.
Proof.
intros.
generalize dependent t''.
induction H; intros.
- inversion H0; subst.
  + reflexivity.
  + inversion H4.
  + inversion H4. inversion H.
- inversion H0; subst.
  + reflexivity.
  + inversion H4.
  + inversion H4. inversion H.
- inversion H0; subst.
  + inversion H.
  + inversion H.
  + apply IHeval in H5. rewrite -> H5.
    reflexivity.
  + inversion H5; subst.
    inversion H1; subst.
    inversion H. apply nv_is_nf in H1.
    destruct H1. exists t1'. apply H.
    inversion H.
- inversion H0; subst.
  + apply IHeval in H2. rewrite -> H2.
    reflexivity.
  + inversion H2; subst.
    inversion H1; subst; inversion H.
    inversion H.
- inversion H0; subst.
  + reflexivity.
  + inversion H1.
  + inversion H1; subst. inversion H.
- inversion H0; subst.
  + reflexivity.
  + inversion H2; subst.
    apply nv_is_nf in H. destruct H.
    exists t1'0. apply H3.
    inversion H3; subst.
    inversion H1; subst; inversion H.
    inversion H.
  + inversion H2; subst.
    inversion H1.
- inversion H0; subst.
  + inversion H.
  + inversion H; subst.
    apply nv_is_nf in H2.
    destruct H2.
    exists t1'0. apply H3.
    inversion H3; subst.
    inversion H1; subst.
    inversion H2.
    inversion H2.
    inversion H2.
  + apply IHeval in H2.
    rewrite -> H2.
    reflexivity.
  + inversion H2; subst.
    inversion H1; subst.
    inversion H.
    inversion H.
    inversion H.
- inversion H0; subst.
  + reflexivity.
  + inversion H1.
  + inversion H1; subst.
    inversion H.
- inversion H0; subst.
  + reflexivity.
  + apply NV_Succ in H.
    apply nv_is_nf in H.
    destruct H.
    exists t1'. apply H2.
  + inversion H2; subst.
    inversion H1.
- inversion H0; subst.
  + inversion H.
  + apply NV_Succ in H2.
    apply nv_is_nf in H2.
    destruct H2.
    exists t1'. apply H.
  + apply IHeval in H2.
    rewrite -> H2.
    reflexivity.
  + apply badnat_is_nf in H2.
    destruct H2.
    exists t1'. apply H.
- inversion H0; subst.
  + inversion H; subst.
    inversion H1.
  + inversion H; subst.
    inversion H1.
  + apply badbool_is_nf in H.
    destruct H.
    exists t1'. apply H5.
  + reflexivity.
- inversion H0; subst.
  + apply badnat_is_nf in H.
    destruct H.
    exists t1'. apply H2.
  + reflexivity.
- inversion H0; subst.
  + inversion H.
    inversion H1.
  + inversion H; subst.
    inversion H1.
  + apply badnat_is_nf in H.
    destruct H.
    exists t1'. apply H2.
  + reflexivity.
- inversion H0; subst.
  + inversion H. inversion H1.
  + inversion H. inversion H1.
  + apply badnat_is_nf in H.
    destruct H.
    exists t1'. apply H2.
  + reflexivity.
Qed.

Inductive meval : term -> term -> Prop :=
| ME_Eval : forall t1 t2,
eval t1 t2 -> meval t1 t2
| ME_Refl : forall t1, meval t1 t1
| ME_Trans : forall t1 t2 t3,
meval t1 t2 -> meval t2 t3 -> meval t1 t3
.

Notation "t1 -w->* t2" := (meval t1 t2) (at level 60).

Inductive meval' : term -> term -> Prop :=
| ME'_Eval : forall t1 t2, eval t1 t2 -> meval' t1 t2
| ME'_Refl : forall t1, meval' t1 t1
| ME'_OneMany : forall t1 t2 t3,
eval t1 t2 -> meval' t2 t3 -> meval' t1 t3
.

Notation "t1 ~w~>* t2" := (meval' t1 t2) (at level 60).

Lemma meval'_transitive : transitive meval'.
Proof.
unfold transitive. intros.
induction H.
- apply ME'_OneMany with (t1 := t1) in H0. apply H0. apply H.
- apply H0.
- apply IHmeval' in H0.
  apply ME'_OneMany with (t1 := t1) in H0.
  apply H0. apply H.
Qed.

Lemma meval_iff_meval' : forall t1 t2,
t1 ~w~>* t2 <-> t1 -w->* t2.
Proof.
intros. split.
- intros. induction H.
  + apply ME_Eval in H. apply H.
  + apply ME_Refl.
  + apply ME_Eval in H.
    apply ME_Trans with (t1 := t1) in IHmeval'.
    apply IHmeval'. apply H.
- intros. induction H; subst.
  + apply ME'_Eval in H. apply H.
  + apply ME'_Refl.
  + apply meval'_transitive with (y := t2).
    apply IHmeval1.
    apply IHmeval2.
Qed.

(* 3.5.11 *)
Theorem meval_deterministic : forall t1 t2 t3,
t1 -w->* t2 -> t1 -w->* t3 -> normal_form eval t2 -> normal_form eval t3 -> t2 = t3.
Proof.
intros.
apply meval_iff_meval' in H.
apply meval_iff_meval' in H0.
induction H.
- induction H0.
  + apply eval_deterministic with (t := t1).
    apply H. apply H0.
  + destruct H2. exists t2. apply H.
  + induction H3.
    * apply eval_deterministic with (t' := t2) in H0.
      rewrite <- H0 in H3.
      destruct H1. exists t3. apply H3. apply H.
    * apply eval_deterministic with (t' := t0) in H.
      symmetry. apply H. apply H0.
    * apply eval_deterministic with (t' := t0) in H.
      rewrite <- H in H1.
      destruct H1. exists t3. apply H3. apply H0.
- induction H0.
  + destruct H1. exists t2. apply H.
  + reflexivity.
  + destruct H1. exists t2. apply H.
- induction H0.
  + apply eval_deterministic with (t' := t2) in H0.
    rewrite -> H0 in IHmeval'. destruct IHmeval'.
    apply ME'_Refl. apply H1. reflexivity. apply H.
  + destruct H2. exists t2. apply H.
  + apply eval_deterministic with (t' := t2) in H0.
    rewrite -> H0 in IHmeval'. destruct IHmeval'.
    apply H4. apply H1. reflexivity. apply H.
Qed.

Lemma meval_subterm_num : forall t1 t2,
t1 -w->* t2 -> tsucc t1 -w->* tsucc t2 /\ tpred t1 -w->* tpred t2 /\ tiszero t1 -w->* tiszero t2.
Proof.
intros. split.
- induction H.
  + apply ME_Eval. apply E_Succ. apply H.
  + apply ME_Refl.
  + apply ME_Trans with (t1 := tsucc t1) in IHmeval2.
    apply IHmeval2. apply IHmeval1.
- split.
  + induction H.
    * apply ME_Eval. apply E_Pred. apply H.
    * apply ME_Refl.
    * apply ME_Trans with (t1 := tpred t1) in IHmeval2.
      apply IHmeval2. apply IHmeval1.
  + induction H.
    * apply ME_Eval. apply E_IsZero. apply H.
    * apply ME_Refl.
    * apply ME_Trans with (t2 := tiszero t2).
      apply IHmeval1. apply IHmeval2.
Qed.

Lemma meval_subterm_if : forall t1 t1' t2 t3,
t1 -w->* t1' -> tif t1 t2 t3 -w->* tif t1' t2 t3.
Proof.
intros. induction H.
- apply ME_Eval. apply E_If. apply H.
- apply ME_Refl.
- apply ME_Trans with (t2 := tif t0 t2 t3).
  apply IHmeval1. apply IHmeval2.
Qed.

Fixpoint conv (t : UntypedArith.term) : term :=
match t with
| UntypedArith.tzero => tzero
| UntypedArith.ttrue => ttrue
| UntypedArith.tfalse => tfalse
| UntypedArith.tsucc t => tsucc (conv t)
| UntypedArith.tpred t => tpred (conv t)
| UntypedArith.tiszero t => tiszero (conv t)
| UntypedArith.tif t1 t2 t3 => tif (conv t1) (conv t2) (conv t3)
end.

Lemma stuck_if_go_wrong : forall t t',
t -w-> twrong -> conv t' = t -> normal_form UntypedArith.eval t' -> stuck t'.
Proof.
intros. generalize dependent t'.
induction H.
- intros. split.
  + apply H1.
  + intro.
    destruct H.
    inversion H; subst; inversion H0.
    inversion H; subst; inversion H0.
- intros. split.
  + apply H1.
  + intro. destruct H.
    * inversion H; subst; inversion H0.
    * inversion H; subst; inversion H0.
- intros. split.
  + apply H1.
  + intro. destruct H2.
    * inversion H2; subst; inversion H0.
    * inversion H2; subst; inversion H0.
- intros. split.
  + apply H1.
  + intro. destruct H2.
    * inversion H2; subst.
      simpl in H0. inversion H0.
      simpl in H0. inversion H0.
      apply IHeval in H5. destruct H5.
      destruct H5. left. assumption.
      apply UntypedArith.nv_is_nf in H3. assumption.
    * inversion H2; subst.
      inversion H0; subst. inversion H0.
- intros. split.
  + apply H1.
  + intro. destruct H.
    * inversion H; subst.
      inversion H0.
      inversion H0.
    * inversion H; subst.
      inversion H0.
      inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
    * inversion H2; subst; inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst.
      inversion H0. inversion H0.
    * inversion H2; subst; inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H.
    * inversion H; subst; inversion H0.
    * inversion H; subst; inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst; inversion H0.
    * inversion H2; subst; inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst; inversion H0.
    * inversion H2; subst; inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst; inversion H0.
    * inversion H2; subst; inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
      inversion H3; subst.
      inversion H; subst.
      inversion H4.
      inversion H; subst.
      inversion H5.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
- intros. split.
  + assumption.
  + intro. destruct H2.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
    * inversion H2; subst.
      inversion H0.
      inversion H0.
Qed.

Theorem go_wrong_if_stuck : forall t t',
normal_form UntypedArith.eval t' ->
stuck t' -> conv t' = t -> t -w->* twrong.
Proof.
  intros.
  destruct H0.
  subst.
  Abort.

Theorem stuck_iff_go_wrong : forall (t :UntypedArith.term),
stuck t <-> (conv t) -w->* twrong.
intros. split; intro.
- induction t.
  + inversion H.
    destruct H1. left. apply UntypedArith.NV_Zero.
  + inversion H.
    destruct H1. right. apply UntypedArith.BV_True.
  + inversion H.
    destruct H1. right. apply UntypedArith.BV_False.
  + inversion H. Abort.


(*
C2. Pebbling in Hypercubes - Part I
===================================
*)

From graph_pebbling Require Import A_primitives B_pebbling C1_basic_bounds.

(*
A graph on two vertices
-----------------------
*)
Section Edge_Graph.

Variable R : relation bool.
Variable k : nat.

Context `{R_dec : RelDecision _ _ R, R_irrefl : Irreflexive _ R}.

Definition edge_graph : graph := {|
  graph_vertex := bool;
  graph_edge := R;
  graph_edge_weight := λ _ _, k;
|}.

Global Instance basic_edge_graph :
  Basic_Graph edge_graph.
Proof.
esplit; typeclasses eauto.
Defined.

End Edge_Graph.

(*
Pebbling in a product
---------------------
*)
Section Product_Pebbling.

Context `{graph_G : Basic_Graph G}.
Context `{graph_H : Basic_Graph H}.

Definition sub_conf i : conf G -> conf (H ☐ G) := prod_sub_val i.

Lemma size_sub_conf i c : size (sub_conf i c) = size c.
Proof. apply size_prod_sub_val. Qed.

Lemma rsize_sub_conf k i c : rsize k (sub_conf i c) = rsize k c.
Proof. apply rsize_prod_sub_val. Qed.

Lemma sub_conf_add i c c' :
  sub_conf i (c .+ c') = sub_conf i c .+ sub_conf i c'.
Proof. apply prod_sub_val_add. Qed.

Lemma lookup_sub_conf i c v : sub_conf i c (i, v) = c v.
Proof. unfold sub_conf; cbn; dec (i = i); done. Qed.

Lemma lookup_sub_conf_ne i j c v : i ≠ j -> sub_conf i c (j, v) = 0.
Proof. unfold sub_conf; cbn; dec (j = i); done. Qed.

Ltac simpl_sub_conf := simpl_lookup lookup_sub_conf lookup_sub_conf_ne.

Lemma sub_conf_zero i :
  sub_conf i (const 0) = const 0.
Proof.
extensionality v; destruct v as [j v];
dec (i = j); simpl_sub_conf; done.
Qed.

Lemma sub_conf_alter i f v c :
  sub_conf i (alter f v c) = alter f (i, v) (sub_conf i c).
Proof.
extensionality p; destruct p as [j w]; dec (j = i); dec (w = v);
repeat (simpl_sub_conf; simpl_alter); congruence.
Qed.

Lemma sub_pebbling i (c c' : conf G) :
  c -->* c' -> sub_conf i c -->* sub_conf i c'.
Proof.
apply rtc_congruence; clear; intros c c'; inversion_clear 1.
apply one_pebble_step with (u:=(i,u))(v:=(i,v)).
- right; done.
- cbn; dec (u = v).
  + exfalso; apply graph_edge_irrefl in H_edge; done.
  + dec (i = i); simpl_sub_conf; apply H_conf.
- subst; rewrite ?sub_conf_alter; repeat f_equal; cbn.
  dec (i = i); dec (u = v); [exfalso|done].
  apply graph_edge_irrefl in H_edge; done.
Qed.

Lemma product_pebbling k i j (c : conf G) :
  E H i j -> weight H i j = k ->
  sub_conf i (const k .* c) -->* sub_conf j c.
Proof.
intros H_ij <-; revert c; apply fn_nat_ind.
- rewrite right_absorb_lift2, ?sub_conf_zero; done.
- intros c v IH; replace S with ((+) 1) by done.
  rewrite alter_add, left_distr, ?sub_conf_add; apply pebbling_add; [done|].
  apply rtc_once, one_pebble_step with (u:=(i,v))(v:=(j,v)).
  + left; done.
  + cbn; dec (v = v); simpl_sub_conf; cbn; simpl_insert; lia.
  + extensionality u; destruct u as [l u]; cbn in l.
    apply irrefl_ne in H_ij; dec (l = i); [|dec (l = j)]; dec (u = v);
    simpl_alter; simpl_sub_conf; cbn; simpl_insert; cbn; try congruence.
    dec (v = v); lia. lia.
Qed.

End Product_Pebbling.

(*
The generalized pebbling property
---------------------------------
*)
Section Pebbling_Property.

Context `{graph_G : Basic_Graph G, pebb_G : Pebbling_Graph G}.

Definition vertex_pebbling_property (n k p : nat) (t : V G) :=
  ∀ c, size c ≥ p + 1 - supp c -> ∃ c', c' .≤ c ∧
    rsize k c' ≥ size c + supp c - p - 1 ∧
    solvable G t n (c .- c').

Definition pebbling_property n k p :=
  ∀ t, vertex_pebbling_property n k p t.

Lemma extend_vertex_pebbling_property m n k p t :
  vertex_pebbling_bound G p t ->
  vertex_pebbling_property m k (m * p) t -> 2 ≤ m ≤ n ->
  vertex_pebbling_property n k (n * p) t.
Proof.
intros H1p H2p Hm c H1c.
assert (H2c : size c ≥ size c - (n - m)*p) by nia.
assert (supp c ≤ p) by (apply (supp_le_vertex_pebbling_bound t); done).
apply fn_minor_eq_supp in H2c as (c1 & H1 & H2 & H3); [|nia].
destruct (H2p c1) as (c2 & H4 & H5 & c3 & H6 & H7); [nia|].
assert (H8 : size (c .- c1) ≥ (n - m)*p) by (rewrite size_sub; [nia|done]).
apply (vertex_pebbling_repeat p t) in H8 as (c4 & H9 & H10); [|done].
exists c2; repeat split. trans c1; done. nia.
replace (c .- c2) with ((c .- c1) .+ (c1 .- c2)) by ext_lia.
eexists; split. apply pebbling_add; done. clia.
Qed.

End Pebbling_Property.

Global Arguments vertex_pebbling_property _ {_}.
Global Arguments pebbling_property _ {_}.

Lemma pebbling_property_unit_graph n k :
  pebbling_property unit_graph n k n.
Proof.
intros [] c Hc; cbn in Hc; assert (c () ≥ n) by lia; clear Hc.
exists (c .- const n); repeat split. clia. clia.
eexists; split; [done|]; clia.
Qed.

(*
Transferring the pebbling property via a homomorphism
-----------------------------------------------------
*)
Section Pebbling_Property_Homomorphism.

Context `{graph_G : Basic_Graph G}.
Context `{graph_H : Basic_Graph H}.
Context `{hom : Graph_Hom G H h}.
Context `{surj : Surj _ _ (=) h}.

Theorem surj_hom_vertex_pebbling_property n k p t :
  vertex_pebbling_property G n k p t -> vertex_pebbling_property H n k p (h t).
Proof.
intros Hp c Hc; destruct (Hp (inv_dmap h c)) as (c' & H1 & H2 & H3).
- rewrite size_inv_dmap, supp_inv_dmap; done.
- exists (dmap h c'); repeat split.
  + apply dmap_le; done.
  + red; etrans; [|apply rsize_dmap].
    rewrite size_inv_dmap, supp_inv_dmap in H2; done.
  + rewrite <-(inv_dmap_spec c), <-dmap_sub; [|done].
    apply surj_hom_solvable; done.
Qed.

Corollary surj_hom_pebbling_property n k p :
  pebbling_property G n k p -> pebbling_property H n k p.
Proof.
intros Hp t; destruct (surj t) as [t' <-].
apply surj_hom_vertex_pebbling_property; done.
Qed.

End Pebbling_Property_Homomorphism.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Category.
Require Export Category.Instance.Coq.
Require Export Coq.Sets.Ensembles.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* The category whose objects are Ensembles on some type, and whose morphisms
   are injective mappings. *)

Program Definition Ens : Category := {|
  obj     := ∃ T : Type, Ensemble T;
  hom     := fun A B =>
    ∃ f : ``A -> ``B, ∀ x : ``A, In _ (projT2 A) x ↔ In _ (projT2 B) (f x);
  homset  := fun P Q => {| equiv := fun f g => forall x, ``f x = ``g x |};
  id      := fun _ => (id; _);
  compose := fun _ _ _ f g =>  (``f \o ``g; _)
|}.
Next Obligation. equivalence; rewrite H, H0; reflexivity. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. proper; rewrite H, H0; reflexivity. Qed.

(* The category whose objects are Ensembles on a given type, and whose
   morphisms are injective mappings. *)

Program Definition EnsT (T : Type) : Category := {|
  obj     := Ensemble T;
  hom     := fun A B =>
    ∃ f : T -> T, ∀ x : T, In _ A x ↔ In _ B (f x);
  homset  := fun P Q => {| equiv := fun f g => forall x, ``f x = ``g x |};
  id      := fun _ => (id; _);
  compose := fun _ _ _ f g =>  (``f \o ``g; _)
|}.
Next Obligation. equivalence; rewrite H, H0; reflexivity. Qed.
Next Obligation. firstorder. Qed.
Next Obligation. proper; rewrite H, H0; reflexivity. Qed.


(* In this file we explain how to do the stack example from Section 4.3 of
   the Iris Lecture Notes *)

From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export notation lang.
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode.

Set Default Proof Using "Type".

(*  ---------------------------------------------------------------------- *)

Section stack_code.
  (* This section contains the code of the stack functions we specify *)

  Definition new_stack : val := λ: <>, ref NONEV.

  Definition push : val := λ: "s", λ: "x",
                           let: "hd" := !"s" in
                           let: "p" := ("x", "hd") in
                           "s" <- SOME (ref "p").

  Definition pop : val := (λ: "s",
                           let: "hd" := !"s" in
                           match: "hd" with
                             NONE => NONE
                           | SOME "l" =>
                             let: "p" := !"l" in
                             let: "x" := Fst "p" in
                             "s" <- Snd "p" ;; SOME "x"
                           end).
End stack_code.

(*  ---------------------------------------------------------------------- *)

Section stack_model.

  Context `{!heapGS Σ}.
  Notation iProp := (iProp Σ).
  Implicit Types ℓ : loc.
  (* Here is the basic is_stack representation predicate.
     A stack is a pointer to the head of a linked list.
     Thus we first specify what a linked list is. One option is the following.
   *)
  Fixpoint is_list (hd : val) (xs : list val) : iProp :=
    match xs with
    | [] => ⌜hd = NONEV⌝
    | x :: xs => ∃ ℓ hd', ⌜hd = SOMEV #ℓ⌝ ∗ ℓ ↦ (x,hd') ∗ is_list hd' xs
  end%I.

  Definition is_stack (s : val) (xs : list val): iProp :=
    (∃ (ℓ : loc) (hd : val), ⌜s = #ℓ⌝ ∗ ℓ ↦ hd ∗ is_list hd xs)%I.
End stack_model.

(*  ---------------------------------------------------------------------- *)
Section stack_spec.
  (* This section contains the specifications and proofs for the stack functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)
  Context `{!heapGS Σ}.

  Lemma new_stack_spec:
    {{{ True }}}
      new_stack #()
      {{{ s, RET s; is_stack s [] }}}.
  Proof.
    iIntros (ϕ) "_ HΦ".
    wp_lam.
    wp_alloc ℓ as "Hpt".
    iApply "HΦ".
    iExists ℓ, NONEV.
    iFrame; done.
  Qed.

  Lemma push_spec s xs (x : val):
    {{{ is_stack s xs }}}
      push s x
      {{{ RET #(); is_stack s (x :: xs) }}}.
  Proof.
    iIntros (ϕ) "Hstack HΦ".
    iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
    wp_lam. wp_let.
    wp_load.
    wp_let.
    wp_pair.
    wp_let.
    wp_alloc ℓ' as "Hptℓ'".
    wp_store.
    iApply "HΦ".
    iExists ℓ, (SOMEV #ℓ'); iFrame.
    iSplitR; first done.
    iExists ℓ', hd; by iFrame.
  Qed.

  Lemma pop_spec_nonempty s (x : val) xs:
    {{{ is_stack s (x :: xs) }}}
      pop s
      {{{ RET (SOMEV x); is_stack s xs }}}.
  Proof.
    iIntros (ϕ) "Hstack HΦ".
    iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
    iDestruct "Hlist" as (ℓ' hd' ->) "[Hptℓ' Hlist]".
    wp_lam.
    wp_load.
    wp_let.
    wp_match.
    wp_load.
    wp_let.
    wp_proj.
    wp_let.
    wp_proj.
    wp_store.
    wp_pures.
    iApply "HΦ".
    iExists ℓ, hd'; by iFrame.
  Qed.

  Lemma pop_spec_empty s:
    {{{ is_stack s [] }}}
      pop s
      {{{ RET NONEV; is_stack s [] }}}.
  Proof.
    iIntros (ϕ) "Hstack HΦ".
    iDestruct "Hstack" as (ℓ hd ->) "[Hpt %]"; subst.
    wp_lam.
    wp_load.
    wp_pures.
    iApply "HΦ".
    iExists ℓ, NONEV; by iFrame.
  Qed.

End stack_spec.

Section stack_model_ownership.
  Context `{!heapGS Σ}.
  Notation iProp := (iProp Σ).
  Implicit Types ℓ : loc.
  (* Here is the basic is_stack representation predicate.
     A stack is a pointer to the head of a linked list.
     Thus we first specify what a linked list is. One option is the following.
   *)
  Fixpoint is_list_own (hd : val) (Φs : list (val → iProp)) : iProp :=
    match Φs with
    | [] => ⌜hd = NONEV⌝
    | Φ :: Φs => ∃ ℓ x hd', ⌜hd = SOMEV #ℓ⌝ ∗ ℓ ↦ (x,hd') ∗ Φ x ∗ is_list_own hd' Φs
  end%I.

  Definition is_stack_own (s : val) (Φs : list (val → iProp)): iProp :=
    (∃ (ℓ : loc) (hd : val), ⌜s = #ℓ⌝ ∗ ℓ ↦ hd ∗ is_list_own hd Φs)%I.
End stack_model_ownership.

(*  ---------------------------------------------------------------------- *)
Section stack_ownership_spec.
  (* This section contains the specifications and proofs for the stack functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)
  Context `{!heapGS Σ}.

Lemma newstack_ownership_spec:
  {{{ True }}}
    new_stack #()
  {{{ s, RET s; is_stack s [] }}}.
Proof.
  iIntros (ϕ) "_ HΦ".
  wp_lam.
  wp_alloc ℓ as "Hpt".
  iApply "HΦ".
  iExists ℓ, NONEV.
  iFrame; done.
Qed.

Lemma push_ownership_spec s Φ Φs (x : val):
  {{{ is_stack_own s Φs ∗ Φ x }}}
    push s x
  {{{ RET #(); is_stack_own s (Φ :: Φs) }}}.
Proof.
  iIntros (Ψ) "[Hstack HΦx] HΨ".
  iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
  wp_lam; wp_let.
  wp_load.
  wp_alloc ℓ' as "Hptℓ'".
  wp_store.
  iApply "HΨ".
  iExists ℓ, (SOMEV #ℓ'); iFrame.
  iSplitR; first done.
  iExists ℓ', x, hd; by iFrame.
Qed.

Lemma pop_ownership_spec_nonempty s Φ Φs:
  {{{ is_stack_own s (Φ :: Φs) }}}
    pop s
  {{{x, RET (SOMEV x); Φ x ∗ is_stack_own s Φs }}}.
Proof.
  iIntros (Ψ) "Hstack HΨ".
  iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
  iDestruct "Hlist" as (ℓ' x hd' ->) "[Hptℓ' [HΦ Hlist]]".
  wp_lam.
  wp_load.
  wp_let.
  wp_match.
  wp_load.
  wp_let.
  wp_proj.
  wp_let.
  wp_proj.
  wp_store.
  wp_inj.
  iApply "HΨ".
  iFrame "HΦ".
  iExists ℓ, hd'; by iFrame.
Qed.

Lemma pop_ownership_spec_empty s:
  {{{ is_stack s [] }}}
    pop s
  {{{ RET NONEV; is_stack s [] }}}.
Proof.
  iIntros (ϕ) "Hstack HΦ".
  iDestruct "Hstack" as (ℓ hd ->) "[Hpt %]"; subst.
  wp_lam.
  wp_load.
  wp_pures.
  iApply "HΦ".
  iExists ℓ, NONEV; by iFrame.
Qed.

End stack_ownership_spec.

(* Exercise 1: Derive the other specifications from the lecture notes.
   Exercise 2: Derive the first specification from the second. That is, from is_stack_own define is_stack, and reprove all the methods in section stack_spec from the specifications in stack_ownership_spec.
 *)


From SMTCoq Require Import SMTCoq.
From SMTCoq Require Import PArray Int63.
Require Import GCHQ.
Import Datatypes.

Notation "'X'"  := (id true).

Notation "'O'"  := (id false).

Definition sol_pb1 :=
(
 (O :: O :: O :: O :: O :: O :: O :: X :: O :: O :: O :: X :: X :: X :: O :: X :: O :: X :: O :: O :: O :: O :: O :: O :: O :: nil) ::
 (O :: X :: X :: X :: X :: X :: O :: X :: O :: O :: X :: O :: O :: X :: X :: X :: X :: X :: O :: X :: X :: X :: X :: X :: O :: nil) ::
 (O :: X :: O :: O :: O :: X :: O :: X :: X :: X :: X :: X :: O :: O :: O :: X :: O :: X :: O :: X :: O :: O :: O :: X :: O :: nil) ::
 (O :: X :: O :: O :: O :: X :: O :: X :: O :: X :: X :: O :: O :: O :: O :: O :: O :: X :: O :: X :: O :: O :: O :: X :: O :: nil) ::
 (O :: X :: O :: O :: O :: X :: O :: X :: X :: O :: O :: O :: O :: O :: X :: O :: O :: X :: O :: X :: O :: O :: O :: X :: O :: nil) ::
 (O :: X :: X :: X :: X :: X :: O :: X :: X :: O :: O :: X :: X :: X :: X :: X :: X :: X :: O :: X :: X :: X :: X :: X :: O :: nil) ::
 (O :: O :: O :: O :: O :: O :: O :: X :: O :: X :: O :: X :: O :: X :: O :: X :: O :: X :: O :: O :: O :: O :: O :: O :: O :: nil) ::
 (X :: X :: X :: X :: X :: X :: X :: X :: O :: O :: O :: X :: X :: X :: O :: O :: O :: X :: X :: X :: X :: X :: X :: X :: X :: nil) ::
 (O :: X :: O :: O :: X :: O :: O :: O :: X :: X :: O :: X :: O :: X :: O :: O :: O :: X :: O :: X :: X :: O :: X :: O :: O :: nil) ::
 (O :: X :: O :: X :: X :: X :: X :: X :: X :: O :: O :: O :: X :: O :: O :: X :: X :: X :: X :: O :: X :: X :: X :: O :: X :: nil) ::
 (X :: O :: O :: O :: O :: X :: O :: X :: O :: O :: O :: O :: X :: O :: O :: X :: O :: X :: X :: X :: X :: O :: O :: X :: X :: nil) ::
 (X :: O :: X :: O :: X :: X :: X :: O :: X :: X :: X :: O :: X :: O :: X :: O :: O :: O :: O :: X :: O :: X :: O :: O :: O :: nil) ::
 (X :: X :: O :: O :: X :: X :: O :: X :: O :: X :: O :: X :: X :: X :: X :: X :: X :: O :: O :: X :: O :: O :: O :: O :: O :: nil) ::
 (X :: X :: X :: O :: O :: O :: X :: O :: O :: X :: O :: O :: X :: O :: O :: O :: O :: O :: O :: X :: O :: O :: O :: X :: O :: nil) ::
 (O :: X :: O :: O :: O :: O :: O :: O :: O :: O :: O :: X :: O :: X :: O :: X :: X :: O :: O :: X :: X :: X :: X :: O :: X :: nil) ::
 (X :: O :: O :: X :: O :: X :: X :: O :: O :: X :: X :: X :: O :: O :: X :: O :: O :: O :: X :: X :: X :: X :: X :: O :: X :: nil) ::
 (O :: O :: O :: X :: O :: X :: O :: X :: O :: X :: X :: O :: X :: X :: X :: X :: O :: O :: O :: O :: O :: X :: O :: X :: X :: nil) ::
 (X :: X :: X :: X :: X :: X :: X :: X :: O :: X :: X :: X :: O :: O :: X :: O :: O :: X :: X :: X :: O :: O :: O :: O :: O :: nil) ::
 (O :: O :: O :: O :: O :: O :: O :: X :: O :: X :: X :: O :: O :: X :: X :: X :: O :: X :: O :: X :: O :: X :: O :: O :: O :: nil) ::
 (O :: X :: X :: X :: X :: X :: O :: X :: O :: O :: X :: X :: O :: X :: X :: O :: O :: X :: X :: X :: O :: O :: X :: O :: X :: nil) ::
 (O :: X :: O :: O :: O :: X :: O :: X :: X :: X :: O :: O :: O :: O :: X :: X :: O :: O :: O :: O :: O :: X :: X :: O :: X :: nil) ::
 (O :: X :: O :: O :: O :: X :: O :: X :: O :: O :: O :: X :: O :: O :: O :: O :: O :: O :: O :: O :: O :: O :: X :: O :: O :: nil) ::
 (O :: X :: O :: O :: O :: X :: O :: X :: O :: X :: X :: O :: O :: O :: O :: O :: O :: X :: O :: O :: O :: O :: O :: O :: X :: nil) ::
 (O :: X :: X :: X :: X :: X :: O :: X :: X :: O :: O :: X :: X :: X :: X :: X :: X :: O :: X :: O :: X :: O :: O :: X :: X :: nil) ::
 (O :: O :: O :: O :: O :: O :: O :: X :: O :: O :: X :: X :: X :: O :: X :: O :: O :: X :: X :: X :: O :: O :: O :: O :: O :: nil) :: nil
).

Lemma verify_sol_pb1 : verify_sol pb1 sol_pb1.
Proof. by compute. Qed.

Lemma interp_free f u :
  interp f u =
   let ff f := finterp u (fun x => f (to_Z x))
   in ff (fun x => f (Int63Op.of_Z x))
   true false
  Bool.eqb mk_andb mk_implb mk_orb Datatypes.negb.
Proof.
simpl.
apply interp_ext; intro x.
by rewrite Int63Axioms.of_to_Z.
Qed.

Lemma sol_pb1_ok s : verify_sol pb1 s -> sol_pb1 = s.
Proof.
intro H.
apply (test_eq_correct pb1).
- by compute.
- by compute.
- by compute.
- by apply verify_sol_pb1.
- by exact H.
rewrite interp_free.
set (u := fun _ =>  _).
vm_compute in u.
set (ff := (fun _ => _)).
unfold u.
   lazy delta[is_true mk_andb mk_orb mk_implb
     seq.head seq.foldl seq.foldr seq.behead] iota beta.
unfold is_true.
verit.
Qed.

(*
Definition pb := pb2.
Definition es : sol := nil.
Definition tr (z : Z) := true.

Time Definition tt1 f :=
   Eval vm_compute in  finterp (gen_all pb) (fun x => f (to_Z x)).

Time Definition tt2 :=
  Eval lazy delta[tt1 mk_andb mk_orb
     seq.head seq.foldl seq.behead] iota beta in
  tt1 tr true false
  Bool.eqb mk_andb mk_implb mk_orb Datatypes.negb.

Ltac end_tac v :=
  let w := eval compute in v in
idtac w;
(timeout 40 (
    try (
     assert (Datatypes.implb tt2 ((tr w))); [
                          unfold tt2; verit | idtac];
                                  idtac "ho"; fail 1);
      idtac "false"; exact false)) ||
idtac "true"; exact true.

Ltac col i j n :=
  let u := constr:(Zeq_bool j n) in
  let v := eval compute in u in
     match v with true => exact nil
                 |false => apply cons;
                           [end_tac (i * n + j)%Z|
                            col i (j + 1)%Z n]
     end.

Ltac row i n :=
  let u := constr:(Zeq_bool i n) in
  let v := eval compute in u in
     match v with true => exact nil
                 |false => apply cons;
                           [col i 0%Z n|
                            row (i + 1)%Z n]
     end.

Definition s : sol.
row 0 (Z.of_nat (p_size pb)).
Defined.

Lemma verify_sol_s : verify_sol pb s.
Proof. by compute. Qed.

Lemma interp_free f u :
  interp f u =
   let ff f := finterp u (fun x => f (to_Z x))
   in ff (fun x => f (Int63Op.of_Z x))
   true false
  Bool.eqb mk_andb mk_implb mk_orb Datatypes.negb.
Proof.
simpl.
apply interp_ext; intro x.
by rewrite Int63Axioms.of_to_Z.
Qed.

Lemma s_ok s1 : verify_sol pb s1 -> s = s1.

Proof.
intro H.
apply (test_eq_correct pb).
- by compute.
- by compute.
- by compute.
- by apply verify_sol_s.
- by exact H.
rewrite interp_free.
set (u := fun _ =>  _).
compute in u.
set (ff := (fun _ => _)).
unfold u.
   lazy delta[is_true mk_andb mk_orb mk_implb
     seq.head seq.foldl seq.foldr seq.behead] iota beta.
verit.
Qed.

*)


From Complexity Require Import Complexity.Definitions.
From Undecidability.L Require Import L.
From Undecidability.L.Tactics Require Import LTactics.

Lemma resSizePoly_composition X Y Z `{encodable X} `{encodable Y} `{encodable Z} (f:X-> Y) (g : Y -> Z):
  resSizePoly f -> resSizePoly g -> resSizePoly (fun x => g (f x)).
Proof.
  intros Hf Hg.
  evar (fsize : nat -> nat). [fsize]:intros n0.
  exists fsize.
  {intros x. rewrite (bounds__rSP Hg). setoid_rewrite mono__rSP. 2:now apply (bounds__rSP Hf).
   set (n0:=size _). unfold fsize. reflexivity.
  }
  1,2:now unfold fsize;smpl_inO;eapply inOPoly_comp;smpl_inO.
Qed.

Lemma polyTimeComputable_composition X Y Z `{encodable X} `{encodable Y} `{encodable Z} (f:X-> Y) (g : Y -> Z):
  polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun x => g (f x)).
Proof.
  intros Hf Hg.
  evar (time : nat -> nat). [time]:intros n0.
  exists time.
  {extract. solverec.
   setoid_rewrite mono__polyTC at 2. 2:now apply (bounds__rSP Hf). set (size (enc x)). unfold time. reflexivity.
  }
  1,2:now unfold time;smpl_inO;eapply inOPoly_comp;smpl_inO.
  eapply resSizePoly_composition. all:eauto using resSize__polyTC.
Qed.

Lemma resSizePoly_composition2 X Y1 Y2 Z `{encodable X} `{encodable Y1} `{encodable Y2} `{encodable Z}
      (f1:X-> Y1) (f2:X-> Y2) (g : Y1 -> Y2 -> Z):
  resSizePoly f1 -> resSizePoly f2 -> resSizePoly (fun y => g (fst y) (snd y)) -> resSizePoly (fun x => g (f1 x) (f2 x)).
Proof.
  intros Hf1 Hf2 Hg.
  evar (fsize : nat -> nat). [fsize]:intros n0.
  exists fsize.
  {intros x. erewrite (bounds__rSP Hg (f1 x,f2 x)). setoid_rewrite mono__rSP.
   2:{ rewrite LProd.size_prod;cbn. rewrite (bounds__rSP Hf1). now rewrite (bounds__rSP Hf2). }
   set (n0:=size _). unfold fsize. reflexivity.
  }
  1,2:now unfold fsize;smpl_inO;eapply inOPoly_comp;smpl_inO.
Qed.

Lemma polyTimeComputable_composition2 X Y1 Y2 Z `{encodable X} `{encodable Y1} `{encodable Y2} `{encodable Z}
      (f1:X-> Y1) (f2:X-> Y2) (g : Y1 -> Y2 -> Z):
  polyTimeComputable f1 -> polyTimeComputable f2 -> polyTimeComputable (fun y => g (fst y) (snd y)) -> polyTimeComputable (fun x => g (f1 x) (f2 x)).
Proof.
  intros Hf1 Hf2 Hg. set (g':= fun y : Y1 * Y2 => g (fst y) (snd y)) in *.
  evar (time : nat -> nat). [time]:intros n0.
  exists time.
  {eapply computableTimeExt with (x:= fun x => g' (f1 x,f2 x)). now cbv.
   extract. solverec.
   setoid_rewrite mono__polyTC at 3.
   2:{ rewrite LProd.size_prod;cbn. rewrite (bounds__rSP Hf1). now rewrite (bounds__rSP Hf2). }
   set (size (enc x)). unfold time. reflexivity.
  }
  1,2:now unfold time;smpl_inO;eapply inOPoly_comp;smpl_inO.
  eapply resSizePoly_composition2. all:eauto using resSize__polyTC.
Qed.

Lemma resSizePoly_prod X Y Z `{encodable X} `{encodable Y} `{encodable Z} (f:X-> Y) (g : X -> Z):
  resSizePoly f -> resSizePoly g -> resSizePoly (fun x => (f x, g x)).
Proof.
  intros Hf Hg.
  evar (fsize : nat -> nat). [fsize]:intros n0.
  exists fsize.
  {intros x. rewrite LProd.size_prod;cbn [fst snd].
   rewrite (bounds__rSP Hf),(bounds__rSP Hg).
   set (n0:=size _). unfold fsize. reflexivity.
  }
  1,2:now unfold fsize;smpl_inO;eapply inOPoly_comp;smpl_inO.
Qed.

Lemma polyTimeComputable_prod X Y Z `{encodable X} `{encodable Y} `{encodable Z} (f:X-> Y) (g : X -> Z):
  polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun x => (f x, g x)).
Proof.
  intros Hf Hg.
  evar (time : nat -> nat). [time]:intros n0.
  exists time.
  {extract. solverec. set (size (enc x)). unfold time. reflexivity.
  }
  1,2:now unfold time;smpl_inO;eapply inOPoly_comp;smpl_inO.
  eapply resSizePoly_prod. all:eauto using resSize__polyTC.
Qed.

From Coq Require Import CRelationClasses CMorphisms.
Local Set Universe Polymorphism.

#[export]
Instance polyTimeComputable_proper_eq X Y {_: encodable X} {_ :  encodable Y}:
  Proper ( Morphisms.pointwise_relation X eq ==> arrow) (@polyTimeComputable X Y _ _).
Proof.
  intros ?? Heq [a b c d e].
  exists a. 2-3:eassumption.
  -eapply computableTimeExt. 2:easy. now hnf.
  -destruct e as [e H]. exists e. 2-3:easy. hnf in Heq. intros;rewrite <- Heq. apply H.
Qed.

#[export]
Instance polyTimeComputable_proper_eq_flip X Y {_: encodable X} {_ :  encodable Y}:
  Proper (Morphisms.pointwise_relation X eq ==> flip arrow) (@polyTimeComputable X Y _ _).
Proof.
  repeat intro. eapply polyTimeComputable_proper_eq. 2:easy. now symmetry.
Qed.

(** Applying n-ary polyTimeComputable lemmas *)

Local Set Universe Polymorphism.

Lemma polyTimeComputable_eta X Y {_: encodable X} {_ :  encodable Y} (f:X -> Y) :
  (polyTimeComputable f) = (polyTimeComputable (fun x => f x)).
Proof. reflexivity. Qed.

Smpl Add 2 rewrite polyTimeComputable_eta in *: nary_prepare.

Import GenericNary UpToCNary.

Lemma polyTimeComputable_simpl (X:list Type) Y {_: encodable(Rtuple X)} {_ :  encodable Y} (f:Rtuple X -> Y) :
  iffT (polyTimeComputable (fun x => Fun' f x)) (polyTimeComputable f).
Proof.
  split. (*Fail all:now setoid_rewrite Fun'_simpl. *)
  apply polyTimeComputable_proper_eq. 2:apply  polyTimeComputable_proper_eq_flip.
  all:hnf. all:apply Fun'_simpl.
Qed.

Smpl Add 2 rewrite polyTimeComputable_simpl in *: generic.

Ltac polyTimeComputable_domain G :=
  let universe := fresh in
  evar (universe:Type);
  match G with
  | @polyTimeComputable ?F _ _ _ _ =>
    let L := domain_of_prod universe F in
    let L := constr:(L) in
    exact (Mk_domain_of_goal L)
  end.

#[export]
Hint Extern 0 Domain_of_goal => (mk_domain_getter polyTimeComputable_domain) : domain_of_goal.

(*
Inductive onlyOnce :=.

Ltac polyTimeComputable_nary_setoid_rewrite_iffT_workaround (*setoid rewriting is broken and can't even preprocess when trying to rewrite with iffT sometimes (e.g. polyTimeComputable_prod_nary) due to Universe inconsistencies *):=
  lazymatch goal with
      H := onlyOnce |- _ => fail
         | |- _ => idtac
  end;
  let H':= fresh in
  pose (H':=onlyOnce);
  let X := fresh "X" in
  let f := fresh "f" in
  evar (X:Type);evar(f:X);
  match goal with
    |- polyTimeComputable ?g =>
    (eapply (@polyTimeComputable_proper_eq _ _ _ _ f);[hnf; repeat progress (smpl generic);unfold f;intros;reflexivity | ];subst X;subst f);
    try match goal with
          |- polyTimeComputable g => fail 2
        end
  | H : polyTimeComputable ?g |- _ =>
    (eapply (@polyTimeComputable_proper_eq_flip _ _ _ _ f) in H;[ | hnf; repeat progress (smpl generic);unfold f;intros;reflexivity ];subst X;subst f);
    try match type of H with
          polyTimeComputable g => fail 2
        end
  end
  ;clear H'.
Smpl Add polyTimeComputable_nary_setoid_rewrite_iffT_workaround : generic.

(* MOVE *)
Lemma polyTimeComputable_prod_nary (X: list Type) (Y Z:Type) `{encodable(Rtuple X)} `{encodable Y} `{encodable Z} (f: Rarrow X Y) (g : Rarrow X Z):

  polyTimeComputable (Uncurry f) -> polyTimeComputable (Uncurry g) -> polyTimeComputable (Fun' (fun x => (App f x, App g x))).
Proof.
  prove_nary polyTimeComputable_prod.
Qed. *)

Lemma pTC_destructuringToProj (domain : list Type)  X (regD:encodable(Rtuple domain)) (regX : encodable X) (f : Rarrow domain X)
  : polyTimeComputable (App f) -> polyTimeComputable (Fun' (App f)).
Proof. apply polyTimeComputable_simpl.  Qed.

Smpl Create polyTimeComputable.
Smpl Add 4 assumption : polyTimeComputable.

Smpl Add 5 simple apply polyTimeComputable_prod : polyTimeComputable.

Local Ltac pTC_composition :=
  lazymatch goal with
    |- polyTimeComputable (fun x : _ => _ _) => simple eapply polyTimeComputable_composition
  end.

Smpl Add 10 pTC_composition : polyTimeComputable.

Lemma pTC_fst X Y `{encodable X} `{encodable Y}: polyTimeComputable (@fst X Y).
Proof.
  eexists (fun _ => _). exact _. 1,2:now smpl_inO.
  eexists (fun x => x). 2,3:now smpl_inO. intros []. rewrite LProd.size_prod. cbn. lia.
Qed.
Smpl Add 0 simple apply pTC_fst : polyTimeComputable.

Lemma pTC_snd X Y `{encodable X} `{encodable Y}: polyTimeComputable (@snd X Y).
Proof.
  eexists (fun _ => _). exact _. 1,2:now smpl_inO.
  eexists (fun x => x). 2,3:now smpl_inO. intros []. rewrite LProd.size_prod. cbn. lia.
Qed.
Smpl Add 0 simple apply pTC_snd : polyTimeComputable.

Lemma pTC_cnst X Y `{encodable X} `{encodable Y} (c:Y): polyTimeComputable (fun (_:X) => c).
Proof.
  eexists (fun _ => 1).
  { extract.  cbn. solverec. } 1,2:now smpl_inO.
  eexists (fun x => size (enc c)). 2,3:now smpl_inO. lia.
Qed.
Smpl Add 0 simple apply pTC_cnst : polyTimeComputable.

Lemma pTC_id X `{encodable X} : polyTimeComputable (fun (x:X) => x).
Proof.
  eexists (fun _ => 1).
  { extract.  cbn. solverec. } 1,2:now smpl_inO.
  eexists (fun x => x). 2,3:now smpl_inO. lia.
Qed.
Smpl Add 0 simple apply pTC_id : polyTimeComputable.

Lemma pTC_S : polyTimeComputable S.
Proof.
  eexists (fun _ => _). exact _. 1,2:now smpl_inO.
  eexists (fun x => x + LNat.c__natsizeS + LNat.c__natsizeO). 2,3:now smpl_inO. intros. rewrite !LNat.size_nat_enc. lia.
Qed.
Smpl Add 0 simple apply pTC_S : polyTimeComputable.

Import Nat LNat.
Lemma pTC_mult X `{encodable X} f g: polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun (x:X) => f x * g x).
Proof.
  intros. eapply polyTimeComputable_composition2. 1,2:easy.
  evar (time:nat -> nat).
  eexists time.
  {extract. solverec. rewrite LProd.size_prod. cbn - [mult c__mult1].
   rewrite !LNat.size_nat_enc. [time]:exact (fun n => n*n). unfold time, c__mult1, mult_time, c__mult, c__natsizeO, c__natsizeS, c__add1, c__add. nia. }
  1,2:unfold time;now smpl_inO.
  eexists (fun n => n*n). all:unfold time. 2,3:now smpl_inO.
  intros []. rewrite LProd.size_prod,!LNat.size_nat_enc. cbn.
  unfold c__natsizeS, c__natsizeO. lia.
Qed.
Smpl Add 5 simple apply pTC_mult : polyTimeComputable.

Lemma pTC_plus X `{encodable X} f g: polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun (x:X) => f x + g x).
Proof.
  intros. eapply polyTimeComputable_composition2. 1,2:easy.
  evar (time:nat -> nat).
  eexists time.
  {extract. solverec. rewrite LProd.size_prod. cbn - [mult].
   rewrite !LNat.size_nat_enc. [time]:exact (fun n => 3*n). unfold time. cbn.
   unfold add_time, c__add, c__natsizeS, c__natsizeO. nia. }
  1,2:unfold time;now smpl_inO.
  eexists (fun n => n+n). all:unfold time. 2,3:now smpl_inO.
  intros []. rewrite LProd.size_prod,!LNat.size_nat_enc. cbn. lia.
Qed.
Smpl Add 5 simple apply pTC_plus : polyTimeComputable.

Lemma pTC_max X `{encodable X} f g: polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun (x:X) => max (f x) (g x)).
Proof.
  intros. eapply polyTimeComputable_composition2. 1,2:easy.
  evar (time:nat -> nat).
  eexists time.
  {extract. solverec. rewrite LProd.size_prod. cbn - [mult].
   rewrite !LNat.size_nat_enc. [time]:exact (fun n => n*n). unfold time. cbn.
   unfold max_time, c__max2, c__natsizeS, c__natsizeO.
   nia. }
  1,2:unfold time;now smpl_inO.
  eexists (fun n => n*n). all:unfold time. 2,3:now smpl_inO.
  intros []. rewrite LProd.size_prod,!LNat.size_nat_enc. cbn. lia.
Qed.
Smpl Add 5 simple apply pTC_max : polyTimeComputable.

Require Import smpl.Smpl.

Lemma pTC_pow_c X `{encodable X} f c: polyTimeComputable f -> polyTimeComputable (fun (x:X) => f x ^ c).
Proof.
  intros. induction c. all: cbn [Nat.pow].
  all:repeat smpl polyTimeComputable.
Qed.
Smpl Add 5 simple apply pTC_pow_c : polyTimeComputable.


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

(* Usual notions of neighborhood and degree for multigraphs. *)

(* The following notions are defined :                                  *)
(*      - mneighbor : relation between 2 vertices;                       *)
(*      - mneighborhood : list of neighbors of a vertex;                 *)
(*      - mdegree : number of neighbors of a vertex;                     *)
(*      - misolated : vertex without neighbor;                           *)
(*      - mpendant : vertex with only one neighbor.                      *)

Require Export Multigraphs.
Require Export GraphBasics.Degrees.

Section MULTIDEGREE.

Fixpoint mneighborhood (x : Vertex) (v : V_set) (a : A_set)
 (g : Multigraph v a) {struct g} : V_list :=
  match g with
  | M_empty => V_nil
  | M_vertex v' a' g' x' _ => mneighborhood x v' a' g'
  | M_edge v' a' g' x' y' _ _ =>
      if V_eq_dec x x'
      then y' :: mneighborhood x v' a' g'
      else
       if V_eq_dec x y'
       then x' :: mneighborhood x v' a' g'
       else mneighborhood x v' a' g'
  | M_eq v' _ a' _ _ _ g' => mneighborhood x v' a' g'
  end.

Fixpoint mdegree (x : Vertex) (v : V_set) (a : A_set)
 (g : Multigraph v a) {struct g} : nat :=
  match g with
  | M_empty => 0
  | M_vertex v' a' g' x' _ => mdegree x v' a' g'
  | M_edge v' a' g' x' y' _ _ =>
      if V_eq_dec x x'
      then S (mdegree x v' a' g')
      else
	if V_eq_dec x y'
	then S (mdegree x v' a' g')
	else mdegree x v' a' g'
  | M_eq v' _ a' _ _ _ g' => mdegree x v' a' g'
  end.

Lemma mdegree_mneighborhood :
 forall (x : Vertex) (v : V_set) (a : A_set) (g : Multigraph v a),
 mdegree x v a g = length (mneighborhood x v a g).
Proof.
        simple induction g; simpl in |- *; intros.
        trivial.

        trivial.

        case (V_eq_dec x x0); intros.
        rewrite H; auto.

        case (V_eq_dec x y); rewrite H; auto.

        trivial.
Qed.

End MULTIDEGREE.

Section REMULTIPLE_DEGREE.

Definition misolated (x : Vertex) (v : V_set) (a : A_set)
  (g : Multigraph v a) := forall y : Vertex, ~ a (A_ends x y).

Lemma mdegree_misolated :
 forall (v : V_set) (a : A_set) (g : Multigraph v a) (x : Vertex),
 misolated x v a g -> mdegree x v a g = 0.
Proof.
        unfold misolated in |- *; simple induction g; simpl in |- *; intros.
        trivial.

        auto.

        case (V_eq_dec x0 x); intros.
        absurd (A_union (E_set x y) a0 (A_ends x0 y)).
        auto.

        rewrite e; apply A_in_left; apply E_right.

        case (V_eq_dec x0 y); intros.
        absurd (A_union (E_set x y) a0 (A_ends x0 x)).
        auto.

        rewrite e; apply A_in_left; apply E_left.

        apply (H x0); red in |- *; intros.
        elim (H0 y0); apply A_in_right; trivial.

        apply (H x); rewrite e0; trivial.
Qed.

Definition mpendant (x : Vertex) (v : V_set) (a : A_set)
  (g : Multigraph v a) :=
  exists2 y : Vertex,
    a (A_ends x y) & (forall z : Vertex, a (A_ends x z) -> z = y).

(* Not sure how to fix this one... maybe it won't be needed? *)
(*Lemma mdegree_mpendant :
 forall (v : V_set) (a : A_set) (g : Multigraph v a) (x : Vertex),
 mpendant x v a g -> mdegree x v a g = 1.
Proof.
        unfold mpendant in |- *; simple induction g; simpl in |- *; intros.
        elim H; intros.
        inversion H0.

        auto.

        case (V_eq_dec x0 x); intros.
        rewrite (mdegree_misolated v0 a0 d x0).
        trivial.

        elim H0; rewrite e; intros.
        unfold misolated in |- *; red in |- *; intros.
        absurd (y0 = x1).
        red in |- *; intros.
        absurd (y = x1).
        red in |- *; intros; elim n0.
        rewrite H5; rewrite <- H4; trivial.

        apply H2; apply A_in_left; apply E_right.

        apply H2; apply A_in_right; trivial.

        case (V_eq_dec x0 y); intros.
        rewrite (mdegree_misolated v0 a0 d x0).
        trivial.

        elim H0; rewrite e; intros.
        unfold misolated in |- *; red in |- *; intros.
        absurd (y0 = x1).
        red in |- *; intros.
        absurd (x = x1).
        red in |- *; intros; elim n1.
        rewrite H5; rewrite <- H4; trivial.

        apply H2; apply A_in_left; apply E_left.

        apply H2; apply A_in_right; trivial.

        apply H; elim H0; intros.
        split with x1.
        apply (A_in_union_edge _ _ _ _ _ H1).
        apply E_not_set_eq123; auto.

        intros; apply H2; apply A_in_right; trivial.

        apply H; rewrite e0; trivial.
Qed.*)

Lemma mdegree_not_isolated :
 forall (v : V_set) (a : A_set) (g : Multigraph v a) (x : Vertex),
 (exists y : Vertex, a (A_ends x y)) -> mdegree x v a g > 0.
Proof.
        simple induction g; simpl in |- *; intros.
        elim H; intros.
        inversion H0.

        auto.

        case (V_eq_dec x0 x); intros.
        omega.

        case (V_eq_dec x0 y); intros.
        omega.

        apply H; elim H0; intros.
        split with x1.
        apply (A_in_union_edge _ _ _ _ _ H1).
        apply E_not_set_eq123; auto.

        apply H; rewrite e0; trivial.
Qed.

Lemma mdegree_not_mpendant :
 forall (v : V_set) (a : A_set) (g : Multigraph v a) (x : Vertex),
 (exists2 y : Vertex,
    a (A_ends x y) & (exists2 z : Vertex, a (A_ends x z) & y <> z)) ->
 mdegree x v a g > 1.
Proof.
        simple induction g; simpl in |- *; intros.
        elim H; intros.
        inversion H0.

        auto.

        case (V_eq_dec x0 x); intros.
        apply gt_n_S; apply mdegree_not_isolated.
        elim H0; rewrite e; intros.
        case (V_eq_dec x1 y); intros.
        elim H2; rewrite e0; intros.
        split with x2.
        apply (A_in_union_edge _ _ _ _ _ H3).
        apply E_not_set_eq24; auto.

        split with x1.
        apply (A_in_union_edge _ _ _ _ _ H1).
        apply E_not_set_eq24; auto.

        case (V_eq_dec x0 y); intros.
        apply gt_n_S; apply mdegree_not_isolated.
        elim H0; rewrite e; intros.
        case (V_eq_dec x x1); intros.
        elim H2; rewrite e0; intros.
        split with x2; apply (A_in_union_edge _ _ _ _ _ H3).
        apply E_not_set_eq14; trivial.

        split with x1; apply (A_in_union_edge _ _ _ _ _ H1).
        apply E_not_set_eq14; trivial.

        apply H; elim H0; intros.
        split with x1.
        apply (A_in_union_edge _ _ _ _ _ H1).
        apply E_not_set_eq123; auto.

        elim H2; intros.
        split with x2.
        apply (A_in_union_edge _ _ _ _ _ H3).
        apply E_not_set_eq123; auto.

        trivial.

        apply H; rewrite e0; trivial.
Qed.

End REMULTIPLE_DEGREE.


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

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

Print Assumptions sub.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Discreteness.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Cartesians.

Local Open Scope cat.
Local Open Scope mor_disp.

Section ProjectionsGlobalCleaving.
  Context {B : bicat}
          {D : disp_bicat B}
          (global_D : global_cleaving D).

  Definition global_lift
             {x y : B}
             (f : x --> y)
             (yy : D y)
    : D x
    := pr1 (global_D x y yy f).

  Definition mor_from_global_lift
             {x y : B}
             (f : x --> y)
             (yy : D y)
    : global_lift f yy -->[ f ] yy
    := pr12 (global_D x y yy f).

  Definition is_cartesian_mor_from_global_lift
             {x y : B}
             (f : x --> y)
             (yy : D y)
    : cartesian_1cell D (mor_from_global_lift f yy)
    := pr22 (global_D x y yy f).

  Section GlobalCleavingOnMor.
    Context (local_D : local_iso_cleaving D)
            {x y : B}
            (f : x --> y).

    Definition global_lift_mor
               {yy₁ yy₂ : D y}
               (ff : yy₁ -->[ id₁ y ] yy₂)
      : global_lift f yy₁ -->[ id₁ x ] global_lift f yy₂
      := cartesian_1cell_lift_1cell
           D
           _
           (is_cartesian_mor_from_global_lift f yy₂)
           (local_iso_cleaving_1cell
              local_D
              (mor_from_global_lift f yy₁ ;; ff)
              (comp_of_invertible_2cell
                 (lunitor_invertible_2cell _)
                 (rinvunitor_invertible_2cell _))).

    Section OnId.
      Context (yy : D y).

      Local Definition global_mor_id_mor
        : global_lift f yy -->[ id₁ x · f] yy
        := local_iso_cleaving_1cell
             local_D
             (mor_from_global_lift f yy)
             (lunitor_invertible_2cell _).

      Local Definition global_mor_id_factor
        : disp_invertible_2cell
            (id2_invertible_2cell (id₁ x · f))
            (id_disp (global_lift f yy) ;; mor_from_global_lift f yy)
            global_mor_id_mor.
      Proof.
        refine (transportf
                  (λ z, disp_invertible_2cell z _ _)
                  _
                  (vcomp_disp_invertible
                     (disp_invertible_2cell_lunitor _)
                     (inverse_of_disp_invertible_2cell
                        (disp_local_iso_cleaving_invertible_2cell
                           local_D
                           (mor_from_global_lift f yy)
                           (lunitor_invertible_2cell f))))).
        abstract
          (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           cbn ;
           apply lunitor_linvunitor).
      Defined.

      Definition global_mor_id_cell
        : disp_invertible_2cell
            (rwhisker_of_invertible_2cell
               _
               (id2_invertible_2cell _))
            (local_iso_cleaving_1cell
               local_D
               (mor_from_global_lift f yy ;; id_disp yy)
               (comp_of_invertible_2cell
                  (lunitor_invertible_2cell f)
                  (rinvunitor_invertible_2cell f)))
            global_mor_id_mor.
      Proof.
        refine (transportf
                  (λ z, disp_invertible_2cell z _ _)
                  _
                  (vcomp_disp_invertible
                     (disp_local_iso_cleaving_invertible_2cell
                        local_D
                        (mor_from_global_lift f yy ;; id_disp yy)
                        (comp_of_invertible_2cell
                           (lunitor_invertible_2cell _)
                           (rinvunitor_invertible_2cell _)))
                     (vcomp_disp_invertible
                        (disp_invertible_2cell_runitor _)
                        (inverse_of_disp_invertible_2cell
                           (disp_local_iso_cleaving_invertible_2cell
                              local_D
                              (mor_from_global_lift f yy)
                              (lunitor_invertible_2cell f)))))).
        abstract
          (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           cbn ;
           rewrite !vassocl ;
           rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite rinvunitor_runitor ;
           rewrite id2_left ;
           rewrite id2_rwhisker ;
           apply lunitor_linvunitor).
      Defined.

      Definition global_mor_id
        : disp_invertible_2cell
            (id2_invertible_2cell (id₁ x))
            (global_lift_mor (id_disp yy))
            (id_disp _).
      Proof.
        simple refine (_ ,, _).
        + exact (cartesian_1cell_lift_2cell
                   D
                   _
                   (is_cartesian_mor_from_global_lift f yy)
                   global_mor_id_cell
                   _
                   (id_disp (global_lift f yy) ,, global_mor_id_factor)).
        + use (cartesian_1cell_lift_2cell_invertible
                 D
                 (is_cartesian_mor_from_global_lift f yy)
                 _
                 _
                 _
                 (id_disp (global_lift f yy) ,, global_mor_id_factor)).
          exact (pr2 global_mor_id_cell).
      Defined.
    End OnId.

    Section OnComp.
      Context {yy₁ yy₂ yy₃ : D y}
              (ff : yy₁ -->[ id₁ y] yy₂)
              (gg : yy₂ -->[ id₁ y] yy₃).

      Definition global_mor_comp_mor
        : global_lift f yy₁ -->[ id₁ x · f ] yy₃
        := local_iso_cleaving_1cell
             local_D
             (mor_from_global_lift f yy₁ ;; ff ;; gg)
             (comp_of_invertible_2cell
                (lunitor_invertible_2cell _)
                (comp_of_invertible_2cell
                   (rinvunitor_invertible_2cell _)
                   (rinvunitor_invertible_2cell _))).

      Definition global_mor_comp_factor
        : disp_invertible_2cell
            (id2_invertible_2cell (id₁ x · f))
            (local_iso_cleaving_1cell local_D
               (global_lift_mor ff ;; global_lift_mor gg)
               (idempunitor x)
             ;; mor_from_global_lift f yy₃)
            global_mor_comp_mor.
      Proof.
        refine (transportf
                  (λ z, disp_invertible_2cell z _ _)
                  _
                  (vcomp_disp_invertible
                     (vcomp_disp_invertible
                        (disp_invertible_2cell_rwhisker
                           _
                           (disp_local_iso_cleaving_invertible_2cell
                              local_D
                              _
                              _))
                        (vcomp_disp_invertible
                           (disp_invertible_2cell_rassociator _ _ _)
                           (vcomp_disp_invertible
                              (disp_invertible_2cell_lwhisker
                                 _
                                 (pr2 (cartesian_1cell_lift_1cell D
                                         (mor_from_global_lift f yy₃)
                                         _
                                         _)))
                              (vcomp_disp_invertible
                                 (disp_invertible_2cell_lwhisker
                                    _
                                    (disp_local_iso_cleaving_invertible_2cell
                                       local_D
                                       _
                                       _))
                                 (vcomp_disp_invertible
                                    (disp_invertible_2cell_lassociator _ _ _)
                                    (disp_invertible_2cell_rwhisker
                                       _
                                       (vcomp_disp_invertible
                                          (pr2 (cartesian_1cell_lift_1cell
                                                  D
                                                  _
                                                  _
                                                  _))
                                          (disp_local_iso_cleaving_invertible_2cell
                                             local_D
                                             _
                                             _))))))))
                     (inverse_of_disp_invertible_2cell
                        (disp_local_iso_cleaving_invertible_2cell
                           local_D
                           _
                           _)))).
        abstract
          (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ;
           rewrite lwhisker_id2, !id2_left ;
           rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite lunitor_lwhisker ;
           rewrite runitor_lunitor_identity ;
           rewrite !vassocr ;
           rewrite rwhisker_vcomp ;
           rewrite linvunitor_lunitor ;
           rewrite id2_rwhisker ;
           rewrite id2_left ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite lunitor_triangle ;
           rewrite !vassocr ;
           rewrite vcomp_lunitor ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_left ;
           refine (_ @ id2_right _) ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           refine (_ @ id2_left _) ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite <- runitor_triangle ;
           rewrite runitor_lunitor_identity ;
           rewrite lunitor_lwhisker ;
           rewrite rwhisker_vcomp ;
           rewrite rinvunitor_runitor ;
           apply id2_rwhisker).
      Defined.

      Definition global_mor_comp_cell
        : disp_invertible_2cell
            (rwhisker_of_invertible_2cell
               _
               (id2_invertible_2cell _))
            (local_iso_cleaving_1cell
               local_D
               (mor_from_global_lift f yy₁
                ;;
                local_iso_cleaving_1cell local_D (ff ;; gg) (idempunitor y))
               (comp_of_invertible_2cell
                  (lunitor_invertible_2cell f)
                  (rinvunitor_invertible_2cell f)))
            global_mor_comp_mor.
      Proof.
        refine (transportf
                  (λ z, disp_invertible_2cell z _ _)
                  _
                  (vcomp_disp_invertible
                     (disp_local_iso_cleaving_invertible_2cell
                        local_D
                        _
                        _)
                     (vcomp_disp_invertible
                        (vcomp_disp_invertible
                           (disp_invertible_2cell_lwhisker
                              _
                              (disp_local_iso_cleaving_invertible_2cell
                                 local_D
                                 _
                                 _))
                           (disp_invertible_2cell_lassociator _ _ _))
                        (inverse_of_disp_invertible_2cell
                           (disp_local_iso_cleaving_invertible_2cell
                              local_D
                              _
                              _))))).
        abstract
          (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ;
           rewrite id2_rwhisker ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_left ;
           refine (_ @ id2_right _) ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_left ;
           refine (_ @ id2_right _) ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           rewrite <- runitor_triangle ;
           rewrite !vassocr ;
           rewrite lassociator_rassociator ;
           rewrite id2_left ;
           rewrite runitor_lunitor_identity ;
           apply idpath).
      Defined.

      Definition global_mor_comp
        : disp_invertible_2cell
            (id2_invertible_2cell _)
            (global_lift_mor
               (local_iso_cleaving_1cell local_D (ff ;; gg) (idempunitor y)))
            (local_iso_cleaving_1cell local_D
               (global_lift_mor ff ;; global_lift_mor gg)
               (idempunitor x)).
      Proof.
        simple refine (_ ,, _).
        - exact (cartesian_1cell_lift_2cell
                   D
                   _
                   (is_cartesian_mor_from_global_lift f yy₃)
                   global_mor_comp_cell
                   _
                   (local_iso_cleaving_1cell
                      local_D
                      (global_lift_mor ff ;; global_lift_mor gg)
                      (idempunitor x)
                    ,,
                    global_mor_comp_factor)).
        - use (cartesian_1cell_lift_2cell_invertible
                 D
                 (is_cartesian_mor_from_global_lift f yy₃)
                 _
                 _
                 _
                 (_ ,, _)).
          exact (pr2 global_mor_comp_cell).
      Defined.
    End OnComp.
  End GlobalCleavingOnMor.
End ProjectionsGlobalCleaving.

Section FiberFunctor.
  Context {B : bicat}
          (D : disp_bicat B)
          (HD₁ : disp_2cells_isaprop D)
          (HD₂ : disp_univalent_2_1 D)
          (global_D : global_cleaving D)
          (local_D : local_iso_cleaving D)
          {x y : B}
          (f : x --> y).

  Definition functor_from_cleaving_data
    : functor_data
        (discrete_fiber_category D HD₁ HD₂ local_D y)
        (discrete_fiber_category D HD₁ HD₂ local_D x).
  Proof.
    use make_functor_data.
    - exact (λ yy, global_lift global_D f yy).
    - exact (λ yy₁ yy₂ ff, global_lift_mor global_D local_D f ff).
  Defined.

  Definition functor_from_cleaving_is_functor
    : is_functor functor_from_cleaving_data.
  Proof.
    split.
    - intros yy.
      apply (disp_isotoid_2_1 _ HD₂ (idpath _)).
      exact (global_mor_id global_D local_D f yy).
    - intros yy₁ yy₂ yy₃ ff gg ; cbn in *.
      apply (disp_isotoid_2_1 _ HD₂ (idpath _)).
      exact (global_mor_comp global_D local_D f ff gg).
  Qed.

  Definition functor_from_cleaving
    : discrete_fiber_category D HD₁ HD₂ local_D y
      ⟶
      discrete_fiber_category D HD₁ HD₂ local_D x.
  Proof.
    use make_functor.
    - exact functor_from_cleaving_data.
    - exact functor_from_cleaving_is_functor.
  Defined.
End FiberFunctor.


Require Import Crypto.Algebra.Field.
Require Import Crypto.Util.GlobalSettings.
Require Import Crypto.Util.Sum Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Curves.Montgomery.Affine.
Require Import Crypto.Spec.WeierstrassCurve Crypto.Curves.Weierstrass.Affine.
Require Import Crypto.Curves.Weierstrass.AffineProofs.

Module M.
  Section MontgomeryCurve.
    Import BinNat.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}.

    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "- x" := (Fopp x).
    Local Notation "x ^ 2" := (x*x) (at level 30).
    Local Notation "x ^ 3" := (x*x^2) (at level 30).
    Local Notation "0" := Fzero.
    Local Notation "1" := Fone.
    Local Notation "2" := (1+1).
    Local Notation "3" := (1+2).
    Local Notation "4" := (1+1+1+1).
    Local Notation "9" := (3*3).
    Local Notation "27" := (4*4 + 4+4 +1+1+1).
    Local Notation "'∞'" := unit : type_scope.
    Local Notation "'∞'" := (inr tt) : core_scope.
    Local Notation "( x , y )" := (inl (pair x y)).
    Local Open Scope core_scope.

    Context {a b: F}
            {aw bw}
            {Haw : aw = (3-a^2)/(3*b^2)}
            {Hbw : bw = (2*a^3-9*a)/(27*b^3)}.

    Ltac t :=
      repeat
        match goal with
        | _ => solve [ trivial ]
        | _ => progress intros
        | _ => progress subst
        | _ => progress Tactics.DestructHead.destruct_head' @M.point
        | _ => progress Tactics.DestructHead.destruct_head' @prod
        | _ => progress Tactics.DestructHead.destruct_head' @sum
        | _ => progress Tactics.DestructHead.destruct_head' @and
        | _ => progress Sum.inversion_sum
        | _ => progress Prod.inversion_prod
        | _ => progress Tactics.BreakMatch.break_match_hyps
        | _ => progress Tactics.BreakMatch.break_match
        | _ => progress cbv [M.coordinates M.add M.zero M.eq M.opp proj1_sig
                             W.coordinates W.add W.zero W.eq W.opp
                             M.of_Weierstrass M.to_Weierstrass] in *
        | |- _ /\ _ => split | |- _ <-> _ => split
        end.

    Global Instance MontgomeryWeierstrassIsomorphism {_1 _2 _3 _4 _5 _6 _7}
           {discriminant_nonzero:id(4*aw*aw*aw + 27*bw*bw <> 0)}
           {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12}
           {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28} (* XXX: this is a workaround for nsatz assuming arbitrary characteristic *)
      :
      @Group.isomorphic_commutative_groups
        (@W.point F Feq Fadd Fmul aw bw)
        W.eq
        (@W.add F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv field _1 _2 aw bw)
        W.zero
        (@W.opp F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv aw bw field _1)

        (@M.point F Feq Fadd Fmul a b)
        M.eq
        (M.add(char_ge_3:=_3)(b_nonzero:=_4))
        M.zero
        (M.opp(b_nonzero:=_7))

        (M.of_Weierstrass(Haw:=Haw)(Hbw:=Hbw)(b_nonzero:=_5))
        (M.to_Weierstrass(Haw:=Haw)(Hbw:=Hbw)(b_nonzero:=_6)).
    Proof.
      eapply Group.commutative_group_by_isomorphism.
      { eapply W.commutative_group; trivial. }
      Time all:t.
      Time par: abstract fsatz.
    Qed.

  End MontgomeryCurve.
End M.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient Spaces.Nat.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Export Rlow Opens Functions
               Valuations LowerIntegrals
               D_op OpenFun Riesz1 Flip Random.

Set Implicit Arguments.
Close Scope nat.

(** A little tactic to compute with partial values *)

Lemma inc_seq_dec_r_prop (m : nat) A {La : Le A}
           (f : IncreasingSequence A) : forall p,
               La ((fun n => f (n + m)%nat) p)
                  ((fun n => f (n + m)%nat) (S p)).
Proof.
intros p; apply f.
Qed.

Definition inc_seq_dec_r (m : nat) A {La : Le A}
            {Pa : PartialOrder La}
           (f : IncreasingSequence A) : IncreasingSequence A :=
      Build_IncreasingSequence (fun n => f (n + m)%nat)
                (inc_seq_dec_r_prop m f).

Lemma sup_dec_r (m : nat) : forall f,
        sup Unit f = sup Unit (inc_seq_dec_r m f).
Proof.
intros f.
apply (antisymmetry SierLe).
+ apply imply_le.
  intros Hs.
  apply top_le_sup in Hs;
  apply top_le_sup.
  revert Hs; apply (Trunc_ind _);
  intros (n,Hn).
  apply tr.
  exists n; simpl.
  revert Hn;
  apply SierLe_imply.
  apply seq_increasing_le.
  induction m.
  - rewrite <- nat_plus_n_O;
    reflexivity.
  - transitivity (n + m)%nat;
    trivial.
    rewrite <- nat_plus_n_Sm.
    apply le_S; reflexivity.
+ apply imply_le.
  intros Hs.
  apply top_le_sup in Hs;
  apply top_le_sup.
  revert Hs; apply (Trunc_ind _);
  intros (n,Hn).
  apply tr.
  exists (n + m)%nat;
  simpl in *; trivial.
Qed.

Ltac S_compute_aux n := tryif (assumption || apply top_greatest) then
                     idtac else (
                     apply top_le_sup;
                     apply tr; exists n; simpl;
                     assumption || apply top_greatest).

Ltac S_compute n :=
         tryif (S_compute_aux n) then
               idtac else (rewrite (sup_dec_r n); S_compute n).

Definition switch : OS bool -> OS bool.
Proof.
intros U [].
refine (U false).
refine (U true).
Defined.

Definition Utrue : OS bool := fun x:bool => match x with
        | true => SierTop
        | false => SierBot
end.

Definition seq_sier : OS nat :=
   fun x:nat => match x with
        | O => SierBot
        | S O => SierBot
        | S (S O) => SierBot
        | S (S (S O))  => SierBot
        | S (S (S (S O))) => SierBot
        | S (S (S (S (S O)))) => SierBot
        | S (S (S (S (S (S O))))) => SierBot
        | S (S (S (S (S (S (S O)))))) => SierBot
        | S (S (S (S (S (S (S (S O))))))) => SierBot
        | _ => SierTop
end.

Definition seq_sier_mon : IncreasingSequence Sier.
Proof.
exists seq_sier.
intros n.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; reflexivity.
induction n.
simpl; apply top_greatest.
simpl; reflexivity.
Defined.

Lemma switch_compute : forall U : OS bool,
         IsTop (switch (Utrue) false).
Proof.
intros x; simpl.
S_compute O.
Qed.

Lemma seq_compute : IsTop (sup Unit (seq_sier_mon)).
Proof.
S_compute (S O).
Qed.

Definition open_b (b: bool) : OS bool := fun x => match b with
      | true => match x with
             | true => SierTop
             | false => SierBot
        end
      | false => match x with
             | true => SierBot
             | false => SierTop
        end
end.


Require Import POCS.

Definition State := disk.

Definition read_spec (a : addr) : Specification _ block unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      state' = state /\
      diskGet state a =?= r;
    recovered := fun _ state' =>
      state' = state
  |}.

Definition write_spec (a : addr) (v : block) : Specification _ _ unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      r = tt /\ state' = diskUpd state a v;
    recovered := fun _ state' =>
      state' = state \/ state' = diskUpd state a v
  |}.

Definition size_spec : Specification _ nat unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      state' = state /\ r = diskSize state;
    recovered := fun _ state' =>
      state' = state
  |}.

Module Type OneDiskAPI.

  Axiom init : proc InitResult.
  Axiom read : addr -> proc block.
  Axiom write : addr -> block -> proc unit.
  Axiom size : proc nat.
  Axiom recover : proc unit.

  Axiom abstr : Abstraction State.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom read_ok : forall a, proc_spec (read_spec a) (read a) recover abstr.
  Axiom write_ok : forall a v, proc_spec (write_spec a v) (write a v) recover abstr.
  Axiom size_ok : proc_spec size_spec size recover abstr.
  Axiom recover_wipe : rec_wipe recover abstr no_wipe.

  Hint Resolve init_ok : core.
  Hint Resolve read_ok : core.
  Hint Resolve write_ok : core.
  Hint Resolve size_ok : core.
  Hint Resolve recover_wipe : core.

End OneDiskAPI.


From Coq Require Export String Ascii NArith List.
From stdpp Require Import list strings.

Notation "'input' r0 .. rn" := (cons r0%string .. (cons rn%string nil) ..)
  (at level 200, r0 at level 0, rn at level 0, only parsing).

Definition example := input
"v...>>.vv>"
".vv>>.vv.."
">>.>v>...v"
">>v>>.>.v."
"v>v.vv.v.."
">.>>..v..."
".vv..>.>v."
"v.v..>>v.v"
"....v..v.>"
.

Inductive cell := Right | Down | Empty.
Definition parse (xs : list string) : list (list cell) :=
  map (fun row =>
    map (fun c =>
      if (c =? "v")%char then Down else if (c =? ">")%char then Right else Empty)
      (list_ascii_of_string row))
    xs.

Fixpoint init {A} (xs : list A) : list A :=
  match xs with
  | _ :: nil => nil
  | x :: xs => x :: init xs
  | nil => nil
  end.

(* [xs] is a row extended with the last cell at the beginning and the first cell at the end. *)
Fixpoint _move_right (xs : list cell) : list cell :=
  match xs with
  | Right :: Empty :: xs => Empty :: Right :: _move_right xs
  | x :: xs => x :: _move_right xs
  | nil => nil
  end.

Definition move_right : list (list cell) -> list (list cell) :=
  map (fun row => init (List.tl (_move_right (List.last row Empty :: row ++ List.hd Empty row :: nil)))).

Fixpoint zip_with {A B C} (f : A -> B -> C) (xs : list A) (ys : list B) : list C :=
  match xs, ys with
  | x :: xs, y :: ys => f x y :: zip_with f xs ys
  | _, _ => nil
  end.

Fixpoint transpose {A} (xs : list (list A)) : list (list A) :=
  match xs with
  | x :: nil => map (fun y => cons y nil) x
  | x :: xs => zip_with cons x (transpose xs)
  | nil => nil
  end.

Definition swap (c : cell) : cell :=
  match c with
  | Down => Right
  | Right => Down
  | Empty => Empty
  end.

Definition transpose' (xs : list (list cell)) : list (list cell) :=
  transpose (map (map swap) xs).

Definition move_down (xs : list (list cell)) : list (list cell) :=
  transpose' (move_right (transpose' xs)).

#[global] Instance EqDecision_cell : EqDecision cell.
Proof. solve_decision. Defined.

Fixpoint steps (fuel : nat) (xs : list (list cell)) : list (list cell) :=
  match fuel with
  | O => xs
  | S fuel =>
    let xs' := move_down (move_right xs) in
    steps fuel xs'
  end.

Definition show_map (xs : list (list cell)) : string :=
  let cell2ascii x :=
    match x with
    | Down => "v"
    | Right => ">"
    | Empty => "."
    end%char in
  let nl := String "010" "" in
  nl ++ String.concat nl (map (fun row => string_of_list_ascii (map cell2ascii row)) xs).

Fixpoint steps_to_stop (fuel : nat) (xs : list (list cell)) : N :=
  match fuel with
  | O => 0
  | S fuel =>
    let xs' := move_down (move_right xs) in
    if bool_decide (xs = xs') then 1 else N.succ (steps_to_stop fuel xs')
  end.

Definition solve (xs : list string) : N := steps_to_stop 999 (parse xs).

(* Compute solve example. *)

#[global] Open Scope N_scope.
#[global] Open Scope string_scope.

Definition solve12 xs := (solve xs, "Merry Christmas").