(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics.
Require Import WildCat.Core.
Require Import WildCat.Equiv.
Require Import WildCat.NatTrans.
Require Import WildCat.FunctorCat.

(** ** Opposite categories *)

Definition op (A : Type) := A.
Notation "A ^op" := (op A).

(** This stops typeclass search from trying to unfold op. *)
#[global] Typeclasses Opaque op.

Global Instance isgraph_op {A : Type} `{IsGraph A}
  : IsGraph A^op.
Proof.
  apply Build_IsGraph.
  unfold op; exact (fun a b => b $-> a).
Defined.

Global Instance is01cat_op {A : Type} `{Is01Cat A} : Is01Cat A^op.
Proof.
  apply Build_Is01Cat.
  + cbv; exact Id.
  + cbv; exact (fun a b c g f => f $o g).
Defined.

(** We don't invert 2-cells as this is op on the first level. *)
Global Instance is2graph_op {A : Type} `{Is2Graph A} : Is2Graph A^op.
Proof.
  intros a b; unfold op in *; cbn; exact _.
Defined.

Global Instance is1cat_op {A : Type} `{Is1Cat A} : Is1Cat A^op.
Proof.
  srapply Build_Is1Cat; unfold op in *; cbv in *.
  - intros a b.
    apply is01cat_hom.
  - intros a b.
    apply is0gpd_hom.
  - intros a b c h.
    srapply Build_Is0Functor.
    intros f g p.
    cbn in *.
    exact (p $@R h).
  - intros a b c h.
    srapply Build_Is0Functor.
    intros f g p.
    cbn in *.
    exact (h $@L p).
  - intros a b c d f g h; exact (cat_assoc_opp h g f).
  - intros a b f; exact (cat_idr f).
  - intros a b f; exact (cat_idl f).
Defined.

Global Instance is1cat_strong_op A `{Is1Cat_Strong A}
  : Is1Cat_Strong (A ^op).
Proof.
  srapply Build_Is1Cat_Strong; unfold op in *; cbn in *.
  - intros a b c d f g h; exact (cat_assoc_opp_strong h g f).
  - intros a b f.
    apply cat_idr_strong.
  - intros a b f.
    apply cat_idl_strong.
Defined.

(* Opposites are (almost) definitionally involutive. You can test this by uncommenting the stuff below. *)

(*
Definition test1 A `{Is01Cat A} : A = (A^op)^op := 1.
Definition test2 A `{x : Is01Cat A} : x = is01cat_op (A^op) := 1.
Definition test3 A `{x : Is2Graph A} : x = is2graph_op (A^op) := 1.
(** Doesn't work *)
Definition test4 A `{x : Is1Cat A} : x = is1cat_op (A^op) := 1.
*)

(** Opposite groupoids *)

Global Instance is0gpd_op A `{Is0Gpd A} : Is0Gpd (A^op).
Proof.
  srapply Build_Is0Gpd; unfold op in *; cbn in *.
  intros a b.
  apply gpd_rev.
Defined.

Global Instance op0gpd_fun A `{Is0Gpd A} :
  Is0Functor( (fun x => x) : A^op -> A).
Proof.
  srapply Build_Is0Functor; unfold op in *; cbn.
  intros a b.
  exact (fun f => f^$).
Defined.

(** ** Opposite functors *)

Global Instance is0functor_op A B (F : A -> B)
  `{IsGraph A, IsGraph B, x : !Is0Functor F}
  : Is0Functor (F : A^op -> B^op).
Proof.
  apply Build_Is0Functor.
  intros a b.
  cbn; apply fmap.
  assumption.
Defined.

Global Instance is1functor_op A B (F : A -> B)
  `{Is1Cat A, Is1Cat B, !Is0Functor F, !Is1Functor F}
  : Is1Functor (F : A^op -> B^op).
Proof.
  apply Build_Is1Functor; unfold op in *; cbn in *.
  - intros a b; rapply fmap2; assumption.
  - intros a; exact (fmap_id F a).
  - intros a b c f g; exact (fmap_comp F g f).
Defined.

(** Bundled opposite functors *)
Definition fun01_op (A B : Type) `{IsGraph A} `{IsGraph B}
  : Fun01 A B -> Fun01 A^op B^op.
Proof.
  intros F.
  rapply (Build_Fun01 A^op B^op F).
Defined.

(** Opposite natural transformations *)

Definition transformation_op {A} {B} `{Is01Cat B}
           (F : A -> B) (G : A -> B) (alpha : F $=> G)
  : @Transformation A^op (fun _ => B^op) _
                     (G : A^op -> B^op) (F : A^op -> B^op).
Proof.
  unfold op in *.
  cbn in *.
  intro a.
  apply (alpha a).
Defined.

Global Instance is1nat_op A B `{Is01Cat A} `{Is1Cat B}
       (F : A -> B) `{!Is0Functor F}
       (G : A -> B) `{!Is0Functor G}
       (alpha : F $=> G) `{!Is1Natural F G alpha}
  : Is1Natural (G : A^op -> B^op) (F : A^op -> B^op) (transformation_op F G alpha).
Proof.
  unfold op in *.
  unfold transformation_op.
  cbn.
  intros a b f.
  srapply isnat_tr.
Defined.

(** Opposite categories preserve having equivalences. *)
Global Instance hasequivs_op {A} `{HasEquivs A} : HasEquivs A^op.
Proof.
  srapply Build_HasEquivs; intros a b; unfold op in *; cbn.
  - exact (b $<~> a).
  - apply CatIsEquiv.
  - apply cate_fun'.
  - apply cate_isequiv'.
  - apply cate_buildequiv'.
  - rapply cate_buildequiv_fun'.
  - apply cate_inv'.
  - rapply cate_isretr'.
  - rapply cate_issect'.
  - intros f g s t.
    exact (catie_adjointify f g t s).
Defined.

Global Instance isequivs_op {A : Type} `{HasEquivs A}
       {a b : A} (f : a $-> b) {ief : CatIsEquiv f}
  : @CatIsEquiv A^op _ _ _ _ _ b a f.
Proof.
  assumption.
Defined.

Global Instance hasmorext_op {A : Type} `{H0 : HasMorExt A}
  : HasMorExt A^op.
Proof.
  snrapply Build_HasMorExt.
  intros a b f g.
  refine (@isequiv_Htpy_path _ _ _ _ _ H0 b a f g).
Defined.

Lemma natequiv_op {A B : Type} `{Is01Cat A} `{HasEquivs B}
  (F G : A -> B) `{!Is0Functor F, !Is0Functor G}
  : NatEquiv F G -> NatEquiv (G : A^op -> B^op) F.
Proof.
  intros [a n].
  snrapply Build_NatEquiv.
  { intro x.
    exact (a x). }
  rapply is1nat_op.
Defined.


From CoqAlgs Require Import Base.

Module Type StackSpec.

Parameter Stack : Type -> Type.

(** Basic stack-building operations. *)

Parameter empty :
  forall {A : Type}, Stack A.

Parameter push :
  forall {A : Type}, A -> Stack A -> Stack A.

Parameter top :
  forall {A : Type}, Stack A -> option A.

Parameter pop :
  forall {A : Type}, Stack A -> option (Stack A).

Definition unpush {A : Type} (s : Stack A) : option (A * Stack A) :=
match top s, pop s with
    | None, _ => None
    | _, None => None
    | Some x, Some s' => Some (x, s')
end.

(** Secondary operations. *)
Parameter isEmpty :
  forall {A : Type}, Stack A -> bool.

Parameter size :
  forall {A : Type}, Stack A -> nat.

Parameter fmap :
  forall {A B : Type}, (A -> B) -> Stack A -> Stack B.

(** Properties of the basic operations. *)

Parameter top_empty :
  forall {A : Type}, top (@empty A) = None.

Parameter top_push :
  forall {A : Type} (x : A) (s : Stack A),
    top (push x s) = Some x.

Parameter pop_empty :
  forall {A : Type}, pop (@empty A) = None.

Parameter pop_push :
  forall {A : Type} (x : A) (s : Stack A),
    pop (push x s) = Some s.

(** Properties of [isEmpty]. *)

Parameter isEmpty_empty :
  forall {A : Type}, isEmpty (@empty A) = true.

Parameter isEmpty_push :
  forall {A : Type} (x : A) (s : Stack A),
    isEmpty (push x s) = false.

Parameter isEmpty_top :
  forall {A : Type} (s : Stack A),
    isEmpty s = true -> top s = None.

Parameter isEmpty_pop :
  forall {A : Type} (s : Stack A),
    isEmpty s = true -> pop s = None.

(** Properties of [size]. *)

Parameter size_empty :
  forall {A : Type}, size (@empty A) = 0.

Parameter size_push :
  forall {A : Type} (x : A) (s : Stack A),
    size (push x s) = 1 + size s.

End StackSpec.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* CONTEXT FREE LANGUAGES                                                *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import emptyrules.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* CONTEXT-FREE LANGUAGES - DEFINITIONS                                  *)
(* --------------------------------------------------------------------- *)

Section ContextFreeLanguages_Definitions.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Definition lang := sentence -> Prop.

Definition lang_of_g (g: cfg non_terminal terminal): lang :=
fun w: sentence => produces g w.

Definition lang_eq (l k: lang) :=
forall w, l w <-> k w.

Definition empty_lang (l: lang): Prop:=
~ exists w: sentence,
l w.

Definition non_empty_lang (l: lang): Prop:=
exists w: sentence,
l w.

Definition contains_empty (l: lang): Prop:=
l [].

Definition contains_non_empty (l: lang): Prop:=
exists w: sentence,
l w /\ w <> [].

End ContextFreeLanguages_Definitions.

Infix "==" := lang_eq (at level 80).

Definition cfl (terminal: Type) (l: lang terminal): Prop:=
exists non_terminal: Type,
exists g: cfg non_terminal terminal,
l == lang_of_g g.

(* --------------------------------------------------------------------- *)
(* CONTEXT-FREE LANGUAGES - LEMMAS                                       *)
(* --------------------------------------------------------------------- *)

Section ContextFreeLanguages_Lemma.

Variables non_terminal non_terminal' terminal: Type.

Lemma produces_empty_equiv_contains_empty:
forall g: cfg non_terminal terminal,
produces_empty g <-> contains_empty (lang_of_g g).
Proof.
intros g.
unfold produces_empty.
unfold contains_empty.
unfold lang_of_g.
split; auto.
Qed.

Lemma produces_non_empty_equiv_contains_non_empty:
forall g: cfg non_terminal terminal,
produces_non_empty g <-> contains_non_empty (lang_of_g g).
Proof.
intros g.
unfold produces_non_empty.
unfold contains_non_empty.
unfold lang_of_g.
split; auto.
Qed.

Lemma g_equiv_lang_eq:
forall g: cfg non_terminal terminal,
forall g': cfg non_terminal' terminal,
g_equiv g' g -> lang_of_g g' == lang_of_g g.
Proof.
unfold g_equiv.
unfold lang_of_g.
unfold lang_eq.
intros g g' H1.
split.
- intros H2.
  apply H1.
  exact H2.
- intros H2.
  apply H1.
  exact H2.
Qed.

Lemma lang_eq_sym:
forall l1 l2: lang terminal,
l1 == l2 ->
l2 == l1.
Proof.
unfold lang_eq.
intros l1 l2 H1 w.
split.
- intros H2.
  apply H1.
  exact H2.
- intros H2.
  apply H1.
  exact H2.
Qed.

Lemma lang_eq_trans:
forall l1 l2 l3: lang terminal,
l1 == l2 ->
l2 == l3 ->
l1 == l3.
Proof.
unfold lang_eq.
intros l1 l2 l3 H1 H3 w.
split.
- intros H4.
  apply H3.
  apply H1.
  exact H4.
- intros H4.
  apply H1.
  apply H3.
  exact H4.
Qed.

Lemma lang_eq_change_g:
forall l: lang terminal,
forall g: cfg non_terminal terminal,
forall g': cfg non_terminal' terminal,
l == lang_of_g g ->
g_equiv g' g ->
l == lang_of_g g'.
Proof.
intros l g g' H1 H2.
apply g_equiv_lang_eq in H2.
apply lang_eq_trans with (l2 := lang_of_g g).
- exact H1.
- apply lang_eq_sym.
  exact H2.
Qed.

Lemma cfl_lang_eq:
forall (l1 l2: lang terminal),
cfl l1 -> l1==l2 -> cfl l2.
Proof.
intros l1 l2 H1 H2.
unfold cfl in H1.
destruct H1 as [nt1 [g1 H1]].
exists nt1, g1.
apply lang_eq_trans with (l2:=l1).
- apply lang_eq_sym.
  exact H2.
- exact H1.
Qed.

End ContextFreeLanguages_Lemma.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import Logic. Import Decidable.
Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Key_Properties.

Require Import Coq.Strings.String.

Lemma TypedReduce_unique: forall (v v1 v2 : exp) (A: typ),
    value v -> (exists B, Etyping nil v B) -> TypedReduce v A v1 -> TypedReduce v A v2 -> v1 = v2.
Proof.
  intros v v1 v2 A Val H R1 R2.
  gen v2.
  lets R1': R1.
  induction R1; introv R2;
    try solve [inverts* R2];
    try solve [forwards*: TypedReduce_toplike R1' R2].
  - (* mergel *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2;
      try solve [forwards*: TypedReduce_toplike R1 R2'];
      try solve [inverts* H'].
    +
      inverts* H'.
      forwards* Con: disjoint_val_consistent H13 H8 H11.
    +
      inverts* H1.
  - (* merger *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2;
      try solve [forwards*: TypedReduce_toplike R1 R2'];
      try solve [inverts* H'].
    +
      inverts* H'.
      forwards* Con: disjoint_val_consistent H13 H8 H11.
      forwards*: Con H7 R1.
      forwards*: H15 H7 R1.
    +
      inverts* H1.
  - (* and *)
    inverts* R2;
      try solve [inversion H2]. (* inversion ord (t_and _ _) *)
    forwards*: IHR1_1.
    forwards*: IHR1_2.
    congruence.
Qed.

Theorem step_unique: forall A (e e1 e2 : exp),
    Etyping nil e A -> step e e1 -> step e e2 -> e1 = e2.
Proof.
  introv Typ Red1.
  gen A e2.
  lets Red1' : Red1.
  induction Red1;
    introv Typ Red2.
  - Case "beta3".
    inverts* Red2.
    + SCase "beta3".
      inverts* Typ.
      inverts* H10. (* Typing condition for the following assert *)
      assert (v' = v'0) by forwards*: TypedReduce_unique H1 H9.
      congruence.
    + SCase "app1".
      inverts* H6.
    + SCase "app2".
      forwards*: step_not_value H6.
  - Case "annov".
    inverts* Red2.
    + SCase "annov".
      forwards*: TypedReduce_unique H0 H5.
      inverts* Typ.
    + SCase "anno".
      forwards*: step_not_value H4.
  - Case "appl".
    inverts* Red2.
    + SCase "absv".
      forwards*: step_not_value Red1.
    + SCase "appl".
      inverts* Typ.
      forwards*: IHRed1.
      congruence.
    + SCase "appr".
      forwards*: step_not_value Red1.
  - Case "appr".
    inverts* Red2;
      try solve [forwards*: step_not_value Red1].
    + SCase "appl".
      forwards*: step_not_value H4.
    + SCase "appr".
      inverts* Typ.
      forwards*: IHRed1.
      congruence.
  - Case "mergel".
    inverts* Red2;
      try solve [forwards*: step_not_value Red1].
    + SCase "mergel".
      inverts* Typ;
        forwards*: IHRed1;
        congruence.
  - Case "merger".
    inverts* Red2;
      try solve [forwards*: step_not_value Red1].
    + SCase "mergel".
      forwards*: step_not_value H4.
    + SCase "merger".
      inverts* Typ;
        forwards*: IHRed1;
        congruence.
  - Case "anno".
    inverts* Red2;
      inverts* Typ;
      try solve [inverts* Red1];
      try solve [lets*: step_not_value Red1].
    forwards*: IHRed1.
    congruence.
  - Case "fix".
    inverts* Red2.
Qed.


Require Import Recdef Bool.

Require Import List.
Import ListNotations.

Inductive Even : nat -> Prop :=
| Even0 : Even 0
| EvenSS : forall n : nat, Even n -> Even (S (S n)).

Function isEven (n : nat) : bool :=
match n with
| 0 => true
| 1 => false
| S (S n') => isEven n'
end.

Lemma isEven_spec :
  forall n : nat, reflect (Even n) (isEven n).
Proof.
  intro.
  functional induction (isEven n); try constructor.
    constructor.
    inversion 1.
    destruct IHb; constructor.
      constructor. assumption.
      inversion 1; subst. contradiction.
Qed.

Module Unbundled.

Class Dec (P : Prop) : Type :=
{
  b : bool;
  spec : reflect P b;
}.

Coercion cast (P : Prop) {d : Dec P} : bool := b.

Print Graph.

#[refine]
#[export]
Instance Dec_Even (n : nat) : Dec (Even n) :=
{
  b := isEven n
}.
Proof.
  apply isEven_spec.
Defined.

(* Doesn't work. *)
Fail Definition silly (n : nat) : bool :=
  if Even n then true else false.

End Unbundled.

Module Bundled.

Class Dec : Type :=
{
  P : Prop;
  b : bool;
  spec : reflect P b;
}.

Coercion cast (d : Dec) : bool := b.

#[refine]
#[export]
Instance Dec_Even (n : nat) : Dec :=
{
  P := Even n;
  b := isEven n;
}.
Proof.
  apply isEven_spec.
Defined.

(* Still no luck. *)
Fail Definition silly (n : nat) : bool :=
  if Even n then true else false.

End Bundled.

Module Canonical.

Module Dec.

Record class (P : Prop) := Class
{
  b :> bool;
  spec : reflect P b;
}.

Structure type := Pack
{
  P : Prop;
  class_of :> class P;
}.

Definition dec (t : type) : bool :=
  let 'Pack _ (Class _ b _) := t in b.

Arguments dec {t} : simpl never.
Arguments Class {P} _.

Module theory.
(* Notation "x == y" := (42) (at level 70). *)
End theory.

End Dec.

Import Dec.theory.

Definition Even_class (n : nat) : Dec.class (Even n).
Proof.
  split with (isEven n).
  apply isEven_spec.
Defined.

Canonical Structure Dec_Even (n : nat) : Dec.type :=
  Dec.Pack (Even n) (Even_class n).

(* Still no success. *)
Fail Definition silly (n : nat) : bool :=
  if Even n then true else false.

End Canonical.

From Typonomikon Require Import M.

Module ThisMustWork.

Class Dec (P : Prop) : Type :=
{
  dec : bool;
  dec_spec : reflect P dec;
}.

Arguments dec      _ {Dec}.
Arguments dec_spec _ {Dec}.

#[refine]
#[export]
Instance Dec_isEven (n : nat) : Dec (Even n) :=
{
  dec := isEven n;
}.
Proof.
  apply isEven_spec.
Defined.

Definition not_so_silly (n : nat) : bool :=
  if dec (Even n) then true else false.

Compute not_so_silly 6.

#[refine]
#[export]
Instance Dec_False : Dec False :=
{
  dec := false
}.
Proof.
  constructor.
  destruct 1.
Defined.

#[refine]
#[export]
Instance Dec_True : Dec True :=
{
  dec := true
}.
Proof.
  constructor.
  trivial.
Defined.

#[refine]
#[export]
Instance Dec_or {P Q : Prop} (DP : Dec P) (DQ : Dec Q) : Dec (P \/ Q) :=
{
  dec := dec P || dec Q
}.
Proof.
  destruct (dec_spec P), (dec_spec Q); cbn; constructor.
    1-3: auto.
    intros [p | q]; contradiction.
Defined.

#[refine]
#[export]
Instance Dec_and {P Q : Prop} (DP : Dec P) (DQ : Dec Q) : Dec (P /\ Q) :=
{
  dec := dec P && dec Q
}.
Proof.
  destruct (dec_spec P), (dec_spec Q); cbn; constructor.
    split; assumption.
    all: intros [p' q']; contradiction.
Defined.

#[refine]
#[export]
Instance Dec_impl {P Q : Prop} (DP : Dec P) (DQ : Dec Q) : Dec (P -> Q) :=
{
  dec := negb (dec P) || dec Q
}.
Proof.
  destruct (dec_spec P), (dec_spec Q);
  cbn; constructor; intros.
    assumption.
    intro. apply n, H. assumption.
    assumption.
    contradiction.
Defined.

#[refine]
#[export]
Instance Dec_not
  {P : Prop} (DP : Dec P) : Dec (~ P) :=
{
  dec := negb (dec P)
}.
Proof.
  destruct (dec_spec P); constructor.
    intro. contradiction.
    assumption.
Defined.

#[refine]
#[export]
Instance Dec_exists
  {A : Type} {P : A -> Prop}
  (SA : Searchable A) (DP : forall x : A, Dec (P x))
  : Dec (exists x : A, P x) :=
{
  dec := dec (P (search (fun x : A => dec (P x))))
}.
Proof.
  destruct (@dec_spec _ (DP (search (fun x : A => dec (P x)))));
  constructor.
    exists (search (fun x : A => dec (P x))). assumption.
    intros [x p]. destruct (dec (P (search (fun x : A => dec (P x))))) eqn: Heq.
      destruct (@dec_spec _ (DP (search (fun x : A => dec (P x))))).
        contradiction.
        congruence.
      pose (search_spec (fun x : A => dec (P x)) Heq x). clearbody e. cbn in e.
        destruct (dec_spec (P x)).
          congruence.
          contradiction.
Defined.

#[refine]
#[export]
Instance Dec_forall
  {A : Type} {P : A -> Prop}
  (SA : Searchable A) (DP : forall x : A, Dec (P x))
  : Dec (forall x : A, P x) :=
{
  dec := negb (dec (~ P (search (fun x : A => dec (~ P x)))))
}.
Proof.
  destruct (dec_spec (~ P (search (fun x : A => dec (~ P x)))));
  constructor.
    intro. apply n, H.
    cut (forall x : A, dec (~ P x) = false).
      intros. cbn in H. specialize (H x). destruct (dec_spec (P x)).
        assumption.
        cbn in H. congruence.
      apply (search_spec (fun x : A => dec (~ P x))).
        destruct (dec_spec (~ P (search (fun x : A => dec (~ P x))))).
          contradiction.
          reflexivity.
Defined.

End ThisMustWork.

Module WeakEquality.

Class WeakEquality (A : Type) : Type :=
{
  weq : A -> A -> Prop;
  weq_spec :
    forall x y : A, x = y -> weq x y;
}.

Notation "x ~=~ y" := (weq x y) (at level 50).

#[refine]
#[export]
Instance WeakEquality_Unit : WeakEquality unit :=
{
  weq := fun _ _ => True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance WeakEquality_Empty : WeakEquality False :=
{
  weq := fun _ _ => True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance WeakEquality_Fun
  {A B : Type} : WeakEquality (A -> B) :=
{
  weq := fun f g => forall x : A, f x = g x;
}.
Proof.
  intros f g [] x. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_Fun'
  {A B : Type} (WEB : WeakEquality B): WeakEquality (A -> B) :=
{
  weq := fun f g => forall x : A, weq (f x) (g x);
}.
Proof.
  intros f g [] x. apply weq_spec. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_Sum
  {A B : Type} (WEA : WeakEquality A) (WEB : WeakEquality B) : WeakEquality (A + B) :=
{
  weq := fun x y =>
    match x, y with
    | inl a1, inl a2 => weq a1 a2
    | inr b1, inr b2 => weq b1 b2
    | _     , _      => False
    end
}.
Proof.
  destruct x, y; intro H; inversion H; subst; clear H.
    apply weq_spec. reflexivity.
    apply weq_spec. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_Prod
  {A B : Type} (WEA : WeakEquality A) (WEB : WeakEquality B) : WeakEquality (A * B) :=
{
  weq := fun x y =>
    match x, y with
    | (a1, b1), (a2, b2) => weq a1 a2 /\ weq b1 b2
    end
}.
Proof.
  destruct x, y.
  intro H.
  inversion H; subst; clear H.
  split.
    apply weq_spec. reflexivity.
    apply weq_spec. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_List
  {A B : Type} (WEA : WeakEquality A) : WeakEquality (list A) :=
{
  weq := fix f (x y : list A) : Prop :=
    match x, y with
    | [], [] => True
    | h1 :: t1, h2 :: t2 => weq h1 h2 /\ f t1 t2
    | _, _ => False
    end
}.
Proof.
  induction x as [| h1 t1]; destruct y as [| h2 t2]; cbn; intro H.
    trivial.
    1-2: inversion H.
    inversion H; subst. split.
      apply weq_spec. reflexivity.
      apply IHt1. reflexivity.
Defined.

Set Warnings "-require-in-module".
From Typonomikon Require Import F2.
Set Warnings "require-in-module".

#[refine]
#[export]
Instance WeakEquality_Stream
  {A B : Type} (WEA : WeakEquality A) : WeakEquality (Stream A) :=
{
  weq := sim;
}.
Proof.
  destruct 1. apply sim_refl.
Defined.

End WeakEquality.

Module StrongInequality.

Class StrongDisequality (A : Type) : Type :=
{
  sdeq : A -> A -> Prop;
  sdeq_spec :
    forall x y : A, sdeq x y -> x <> y;
}.

Notation "x =/= y" := (sdeq x y) (at level 50).

#[refine]
#[export]
Instance StrongDisequality_Unit : StrongDisequality unit :=
{
  sdeq := fun _ _ => False;
}.
Proof.
  destruct 1.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Empty : StrongDisequality False :=
{
  sdeq := fun _ _ => True;
}.
Proof.
  destruct x.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Sum
  {A B : Type} (SDA : StrongDisequality A) (SDB : StrongDisequality B) : StrongDisequality (A + B) :=
{
  sdeq := fun x y =>
    match x, y with
    | inl a1, inl a2 => sdeq a1 a2
    | inr b1, inr b2 => sdeq b1 b2
    | inl _ , inr _  => True
    | inr _ , inl _  => True
    end
}.
Proof.
  destruct x, y; intros H1 H2;
  inversion H2; subst.
    apply sdeq_spec in H1. contradiction.
    apply sdeq_spec in H1. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Prod
  {A B : Type} (SDA : StrongDisequality A) (SDB : StrongDisequality B) : StrongDisequality (A * B) :=
{
  sdeq := fun x y =>
    match x, y with
    | (a1, b1), (a2, b2) => sdeq a1 a2 \/ sdeq b1 b2
    end
}.
Proof.
  destruct x, y; intros H1 H2;
  inversion H2; subst.
  destruct H1.
    apply sdeq_spec in H. contradiction.
    apply sdeq_spec in H. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Fun
  {A B : Type} : StrongDisequality (A -> B) :=
{
  sdeq := fun f g => exists x : A, f x <> g x;
}.
Proof.
  intros f g [x H] p. subst. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Fun'
  {A B : Type} (SDB : StrongDisequality B) : StrongDisequality (A -> B) :=
{
  sdeq := fun f g => exists x : A, sdeq (f x) (g x);
}.
Proof.
  intros f g [x H] p. subst. apply sdeq_spec in H. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_List
  {A B : Type} (SDA : StrongDisequality A) : StrongDisequality (list A) :=
{
  sdeq := fix f (x y : list A) : Prop :=
    match x, y with
    | [], [] => False
    | h1 :: t1, h2 :: t2 => sdeq h1 h2 \/ f t1 t2
    | _, _ => True
    end
}.
Proof.
  induction x as [| h1 t1];
  destruct y as [| h2 t2];
  cbn; intro H;
  inversion 1; subst.
    contradiction.
    destruct H.
      apply sdeq_spec in H. contradiction.
      apply (IHt1 t2). apply H. reflexivity.
Defined.

Set Warnings "-require-in-module".
From Typonomikon Require Import F2.
Set Warnings "require-in-module".

Inductive Ex {A : Type} (R : A -> A -> Prop) : Stream A -> Stream A -> Prop :=
| Ex_hd :
    forall s1 s2 : Stream A, R (hd s1) (hd s2) -> Ex R s1 s2
| Ex_tl :
    forall s1 s2 : Stream A, Ex R (tl s1) (tl s2) -> Ex R s1 s2.

#[refine]
#[export]
Instance StrongDisequality_Stream
  {A B : Type} (SDA : StrongDisequality A) : StrongDisequality (Stream A) :=
{
  sdeq := Ex sdeq;
}.
Proof.
  induction 1; inversion 1; subst.
    apply sdeq_spec in H. contradiction.
    contradiction.
Defined.

End StrongInequality.

Class Pointed (A : Type) : Type :=
{
  point : A;
}.

Set Warnings "-cannot-define-projection".

Class Inhabited (A : Type) : Prop :=
{
  inhabitant : A;
}.

#[export]
Instance Inhabited_Pointed
  (A : Type) (inst : Pointed A)
  : Inhabited A :=
{
  inhabitant := point;
}.

#[export]
Instance Pointed_nat : Pointed nat :=
{
  point := 0
}.

Module StrongNegation.

Class StrongNegation (A : Type) : Type :=
{
  NOT : Type;
  NOT_spec : NOT -> A -> False;
}.

Arguments NOT A {StrongNegation}.

#[refine]
#[export]
Instance StrongNegation_Default
  (A : Type) : StrongNegation A | 999 :=
{
  NOT := A -> False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Pointed
  (A : Type) (inst : Pointed A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Inhabited
  (A : Type) (inst : Inhabited A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_True :
  StrongNegation True :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_False :
  StrongNegation False :=
{
  NOT := True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_or
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P \/ Q) :=
{
  NOT := NOT P * NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_and
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P /\ Q) :=
{
  NOT := NOT P + NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_impl
  (P Q : Prop) (QSN : StrongNegation Q)
  : StrongNegation (P -> Q) :=
{
  NOT := P * NOT Q;
}.
Proof.
  destruct 1. intro pq. apply QSN.
    assumption.
    apply pq. assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_forall
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (forall x : A, P x) :=
{
  NOT := {x : A & NOT (P x)};
}.
Proof.
  intros [x np] H.
  apply (PSN x).
    assumption.
    apply H.
Defined.

#[refine]
#[export]
Instance StrongNegation_exists
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (exists x : A, P x) :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_subset
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A | P x} :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_sigma
  (A : Type) (P : A -> Type)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A & P x} :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

Compute NOT (forall n : nat, True).
Compute NOT (NOT (forall n : nat, True)).
Compute NOT nat.

End StrongNegation.

Module StrongNegation_Prop.

Class StrongNegation (A : Prop) : Type :=
{
  NOT : Prop;
  NOT_spec : NOT -> A -> False;
}.

Arguments NOT A {StrongNegation}.

#[refine]
#[export]
Instance StrongNegation_Default
  (A : Prop) : StrongNegation A | 999 :=
{
  NOT := A -> False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Pointed
  (A : Prop) (inst : Pointed A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Inhabited
  (A : Prop) (inst : Inhabited A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_True :
  StrongNegation True :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_False :
  StrongNegation False :=
{
  NOT := True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_or
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P \/ Q) :=
{
  NOT := NOT P /\ NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_and
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P /\ Q) :=
{
  NOT := NOT P \/ NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_impl
  (P Q : Prop) (QSN : StrongNegation Q)
  : StrongNegation (P -> Q) :=
{
  NOT := P /\ NOT Q;
}.
Proof.
  destruct 1. intro pq. apply QSN.
    assumption.
    apply pq. assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_forall
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (forall x : A, P x) :=
{
  NOT := exists x : A, NOT (P x);
}.
Proof.
  intros [x np] H.
  apply (PSN x).
    assumption.
    apply H.
Defined.

#[refine]
#[export]
Instance StrongNegation_exists
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (exists x : A, P x) :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

Compute NOT (forall n : nat, True).
Compute NOT (NOT (forall n : nat, True)).

End StrongNegation_Prop.

Module StrongNegation_Type.

Class StrongNegation (A : Type) : Type :=
{
  TNOT : Type;
  TNOT_spec : TNOT -> A -> False;
}.

Arguments TNOT A {StrongNegation}.

#[refine]
#[export]
Instance StrongNegation_Default
  (A : Type) : StrongNegation A | 999 :=
{
  TNOT := A -> False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Pointed
  (A : Type) (inst : Pointed A)
  : StrongNegation A :=
{
  TNOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Inhabited
  (A : Type) (inst : Inhabited A)
  : StrongNegation A :=
{
  TNOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_True :
  StrongNegation unit :=
{
  TNOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_False :
  StrongNegation False :=
{
  TNOT := True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_or
  (A B : Type) (PSN : StrongNegation A) (QSN : StrongNegation B)
  : StrongNegation (A + B) :=
{
  TNOT := TNOT A * TNOT B;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_and
  (A B : Type) (PSN : StrongNegation A) (QSN : StrongNegation B)
  : StrongNegation (A * B) :=
{
  TNOT := TNOT A + TNOT B;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_fun
  (A B : Type) (QSN : StrongNegation B)
  : StrongNegation (A -> B) :=
{
  TNOT := A * TNOT B;
}.
Proof.
  destruct 1. intro pq. apply QSN.
    assumption.
    apply pq. assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_pi
  (A : Type) (P : A -> Type)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (forall x : A, P x) :=
{
  TNOT := {x : A & TNOT (P x)};
}.
Proof.
  intros [x np] H.
  apply (PSN x).
    assumption.
    apply H.
Defined.

#[refine]
#[export]
Instance StrongNegation_subset
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A | P x} :=
{
  TNOT := forall x : A, TNOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_sigma
  (A : Type) (P : A -> Type)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A & P x} :=
{
  TNOT := forall x : A, TNOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

Compute TNOT (forall n : nat, True).
Compute TNOT (TNOT (forall n : nat, True)).
Compute TNOT nat.

End StrongNegation_Type.

(** Klasy zbierające poszczególne implementacje izomorficznych typów są
    w ogólności potrzebne nawet jeżeli mamy homotopiczną teorię typów,
    bo przecież używanie izomorfizmów zrobionych ze ścieżek kosztuje. *)

Module Natural.

Class Natural (A : Type) : Type :=
{
  zero : A;
  succ : A -> A;
  rect :
    forall P : A -> Type,
      P zero -> (forall n : A, P n -> P (succ n)) ->
        forall n : A, P n;

  add : A -> A -> A;
  sub : A -> A -> A;

  mul : A -> A -> A;

  pred : A -> option A;
}.

#[export]
Instance Natural_nat : Natural nat :=
{
  zero := 0;
  succ := S;
  rect := nat_rect;

  add := plus;
  sub := minus;

  mul := mult;

  pred n := match n with | 0 => None | S n' => Some n' end
}.

End Natural.

Require Import ZArith.

Module Integral.

Class Integral (A : Type) : Type :=
{
  zero : A;
  succ : A -> A;
  pred : A -> A;

  add : A -> A -> A;
  sub : A -> A -> A;

  mul : A -> A -> A;
}.

#[export]
Instance Integral_Z : Integral Z :=
{
  zero := 0;
  succ := Z.succ;
  pred := Z.pred;

  add := Z.add;
  sub := Z.sub;

  mul := Z.mul;
}.

End Integral.

Require Import QArith.

Module Rational.

Class Rational (A : Type) : Type :=
{
  zero : A;

  add : A -> A -> A;
  sub : A -> A -> A;

  mul : A -> A -> A;
  div : A -> A -> option A;
}.

#[export]
Instance Rational_Q : Rational Q :=
{
  zero := 0;
  add := Qplus;
  sub := Qminus;

  mul := Qmult;
  div p q := if Qeq_bool q 0 then None else Some (Qdiv p q);
}.

End Rational.

Module Sequence.

Class Sequence (A L : Type) : Type :=
{
  nil : L;
  cons : A -> L -> L;

  rect :
    forall P : L -> Type,
      P nil -> (forall (h : A) (t : L), P t -> P (cons h t)) ->
        forall l : L, P l;

  snoc : L -> A -> L;

  app : L -> L -> L;
  rev : L -> L -> L;

  (* no map with this definition *)
}.

End Sequence.

(** TODO:
    - HoTTowa baza
    - hierarchia algebraiczna
    - typy skończone
*)

(** Trzeba mieć pod ręką zarówno trójstronne porównania, jak i te klasyczne (mniejszy lub równy).
    Dzięki eleganckiej koercji można tych bardziej ogólnych, czyli trójstronnych, używać też tam
    gdzie potrzeba nam [bool]a. Koercja w drugą stronę jest upierdliwsza, a raczej brak jej wcale. *)

Inductive Cmp : Type := Lt | Eq | Gt.

Definition Cmp2bool (c : Cmp) : bool :=
match c with
| Lt => true
| Eq => true
| Gt => false
end.

Coercion Cmp2bool : Cmp >-> bool.

(** Uwaga: daje nam to też koercję [(A -> A -> comparison) >-> (A -> A -> bool)], czyli elegancko. *)

(** Uwaga2: [Cmp] jest już w bibliotece standardowej i nazywa się [comparison]. *)

(** Inna fajna rzecz: generyczne Exists/Forall, w tym generyczne w sensie ilości argumentów (vararg). *)


Require Import List.
Import ListNotations.
Require Import PeanoNat.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.NatInt.NZOrder.

From VLG Require Import matcher.
From VLG Require Import ltac.

Definition Sigma := matcher.Sigma.
Definition Sigma_dec := matcher.Sigma_dec.
Definition String := matcher.String.

Lemma String_dec : forall s s' : String, {s = s'} + {s <> s'}.
Proof. decide equality. apply Sigma_dec. Qed.

Definition State : Type := regex.
Definition transition : Sigma -> State -> State := derivative.
Definition accepts : String -> State -> bool := exp_matchb.
Definition accepting : State -> bool:= nullable.

Lemma accepts_nil: forall(fsm : State),
    accepting fsm = accepts [] fsm.
Proof.
  intros fsm. reflexivity.
Qed.

Lemma accepts_transition : forall cand a fsm,
    accepts cand (transition a fsm)
    = accepts (a :: cand) fsm.
Proof.
  auto.
Qed.

Inductive eq_models : State -> regex -> Prop :=
| SReq (fsm : State) (r : regex)
       (H1 : forall(s : String), true = accepts s fsm <-> exp_match s r) :
    eq_models fsm r.

Definition init_state (r : regex) : State := r.
Definition init_state_inv (fsm : State) : regex := fsm.
(** Facts about inverting init_state **)
Lemma invert_init_correct' : forall(r : regex) (s : String),
    exp_match s (init_state_inv (init_state r)) <-> exp_match s r.
Proof.
  intros. split; auto.
Qed.

Definition Label : Type := String.
Definition Prefix : Type := String.
Definition Suffix : Type := String.
Definition Token : Type := Label * Prefix.
Definition Rule : Type := Label * regex.

Lemma ru_dec : forall (ru1 ru2 : Rule), {ru1 = ru2} + {ru1 <> ru2}.
Proof.
  intros. destruct ru1. destruct ru2.
  destruct (String_dec l l0); destruct (regex_dec r r0); subst; auto;
    right; intros C; destruct n; inv C; auto.
Qed.

Definition sRule : Type := Label * State.

(** Facts about accepts/accepting **)
Lemma accepts_matches : forall(s : String) (fsm : State),
    true = accepts s fsm <-> exp_match s (init_state_inv fsm).
Proof.
  intros. split; intros; apply match_iff_matchb; auto.
Qed.

(* no external depends after this *)
Lemma accepting_nilmatch : forall fsm,
    true = accepting fsm
    <-> exp_match [] (init_state_inv fsm).
Proof.
  intros. split; intros.
  - apply accepts_matches. rewrite <- accepts_nil. auto.
  - apply accepts_matches in H. rewrite accepts_nil. auto.
Qed.

Lemma inv_eq_model : forall(fsm : State),
    eq_models fsm (init_state_inv fsm).
Proof.
  intros fsm. apply SReq. intros s. rewrite accepts_matches. split; auto.
Qed.

Lemma inv_transition : forall cand a fsm,
    exp_match cand (init_state_inv (transition a fsm))
    <-> exp_match (a :: cand) (init_state_inv fsm).
Proof.
  intros. repeat rewrite <- accepts_matches. rewrite accepts_transition.
  split; auto.
Qed.


Require Coq.ZArith.Zpower Coq.ZArith.Znumtheory Coq.ZArith.ZArith Coq.ZArith.Zdiv.
Require Coq.micromega.Lia Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith.
Require Crypto.Util.ZUtil.AddGetCarry.
Require Crypto.Util.ZUtil.AddModulo.
Require Crypto.Util.ZUtil.CC.
Require Crypto.Util.ZUtil.CPS.
Require Crypto.Util.ZUtil.Definitions.
Require Crypto.Util.ZUtil.DistrIf.
Require Crypto.Util.ZUtil.Div.
Require Crypto.Util.ZUtil.Div.Bootstrap.
Require Crypto.Util.ZUtil.Divide.
Require Crypto.Util.ZUtil.EquivModulo.
Require Crypto.Util.ZUtil.Ge.
Require Crypto.Util.ZUtil.Hints.
Require Crypto.Util.ZUtil.Hints.Core.
Require Crypto.Util.ZUtil.Hints.PullPush.
Require Crypto.Util.ZUtil.Hints.ZArith.
Require Crypto.Util.ZUtil.Hints.Ztestbit.
Require Crypto.Util.ZUtil.Land.
Require Crypto.Util.ZUtil.LandLorBounds.
Require Crypto.Util.ZUtil.LandLorShiftBounds.
Require Crypto.Util.ZUtil.Lor.
Require Crypto.Util.ZUtil.Le.
Require Crypto.Util.ZUtil.Lnot.
Require Crypto.Util.ZUtil.Log2.
Require Crypto.Util.ZUtil.ModInv.
Require Crypto.Util.ZUtil.Modulo.
Require Crypto.Util.ZUtil.Modulo.Bootstrap.
Require Crypto.Util.ZUtil.Modulo.PullPush.
Require Crypto.Util.ZUtil.Morphisms.
Require Crypto.Util.ZUtil.Mul.
Require Crypto.Util.ZUtil.MulSplit.
Require Crypto.Util.ZUtil.N2Z.
Require Crypto.Util.ZUtil.Notations.
Require Crypto.Util.ZUtil.Odd.
Require Crypto.Util.ZUtil.Ones.
Require Crypto.Util.ZUtil.Opp.
Require Crypto.Util.ZUtil.Peano.
Require Crypto.Util.ZUtil.Pow.
Require Crypto.Util.ZUtil.Pow2.
Require Crypto.Util.ZUtil.Pow2Mod.
Require Crypto.Util.ZUtil.Quot.
Require Crypto.Util.ZUtil.Rshi.
Require Crypto.Util.ZUtil.Sgn.
Require Crypto.Util.ZUtil.Shift.
Require Crypto.Util.ZUtil.Sorting.
Require Crypto.Util.ZUtil.Stabilization.
Require Crypto.Util.ZUtil.Tactics.
Require Crypto.Util.ZUtil.Tactics.CompareToSgn.
Require Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Crypto.Util.ZUtil.Tactics.DivideExistsMul.
Require Crypto.Util.ZUtil.Tactics.LinearSubstitute.
Require Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Crypto.Util.ZUtil.Tactics.PeelLe.
Require Crypto.Util.ZUtil.Tactics.PrimeBound.
Require Crypto.Util.ZUtil.Tactics.PullPush.
Require Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Crypto.Util.ZUtil.Tactics.SimplifyFractionsLe.
Require Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Crypto.Util.ZUtil.Tactics.Ztestbit.
Require Crypto.Util.ZUtil.Testbit.
Require Crypto.Util.ZUtil.Z2Nat.
Require Crypto.Util.ZUtil.ZSimplify.
Require Crypto.Util.ZUtil.ZSimplify.Autogenerated.
Require Crypto.Util.ZUtil.ZSimplify.Core.
Require Crypto.Util.ZUtil.ZSimplify.Simple.
Require Crypto.Util.ZUtil.Zselect.


Require Export prosa.analysis.facts.behavior.completion.

(** * Deadlines *)

(** In this file, we observe basic properties of the behavioral job
    model w.r.t. deadlines. *)
Section DeadlineFacts.

  (** Consider any given type of jobs with costs and deadlines... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job}.

  (** ... any given type of processor states. *)
  Context {PState: eqType}.
  Context `{ProcessorState Job PState}.

  (** We begin with schedules / processor models in which scheduled jobs
    always receive service. *)
  Section IdealProgressSchedules.

    (** Consider a given reference schedule... *)
    Variable sched: schedule PState.

    (** ...in which complete jobs don't execute... *)
    Hypothesis H_completed_jobs: completed_jobs_dont_execute sched.

    (** ...and scheduled jobs always receive service. *)
    Hypothesis H_scheduled_implies_serviced: ideal_progress_proc_model PState.

    (** We observe that, if a job is known to meet its deadline, then
       its deadline must be later than any point at which it is
       scheduled. That is, if a job that meets its deadline is
       scheduled at time t, we may conclude that its deadline is at a
       time later than t. *)
    Lemma scheduled_at_implies_later_deadline:
      forall j t,
        job_meets_deadline sched j ->
        scheduled_at sched j t ->
        t < job_deadline j.
    Proof.
      move=> j t.
      rewrite /job_meets_deadline => COMP SCHED.
      case: (boolP (t < job_deadline j)) => //.
      rewrite -leqNgt => AFTER_DL.
      apply completion_monotonic with (t' := t) in COMP => //.
      apply scheduled_implies_not_completed in SCHED => //.
      move/negP in SCHED. contradiction.
    Qed.

  End IdealProgressSchedules.

  (** In the following section, we observe that it is sufficient to
      establish that service is invariant across two schedules at a
      job's deadline to establish that it either meets its deadline in
      both schedules or none. *)
  Section EqualProgress.

    (** Consider any two schedules [sched] and [sched']. *)
    Variable sched sched': schedule PState.

    (** We observe that, if the service is invariant at the time of a
       job's absolute deadline, and if the job meets its deadline in one of the schedules,
       then it meets its deadline also in the other schedule. *)
    Lemma service_invariant_implies_deadline_met:
      forall j,
        service sched j (job_deadline j) = service sched' j (job_deadline j) ->
        (job_meets_deadline sched j <-> job_meets_deadline sched' j).
    Proof.
      move=> j SERVICE.
      split;
        by rewrite /job_meets_deadline /completed_by -SERVICE.
    Qed.

  End EqualProgress.

End DeadlineFacts.


From Coq Require Import OrderedType.
From mathcomp Require Import ssreflect ssrbool eqtype.
From ssrlib Require Import Types.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Coq OrderedType with Boolean equality. *)

Module Type SsrOrderMinimal.
  Parameter t : eqType.
  Definition eqn : t -> t -> bool := fun x y => x == y.
  Parameter ltn : t -> t -> bool.
  Axiom ltn_trans : forall x y z : t, ltn x y -> ltn y z -> ltn x z.
  Axiom ltn_not_eqn : forall x y : t, ltn x y -> x != y.
  Parameter compare : forall x y : t, Compare ltn eqn x y.
End SsrOrderMinimal.

Module Type SsrOrder <: OrderedType.
  Parameter T : eqType.
  Definition t : Type := T.
  Definition eq : t -> t -> Prop := fun x y => x == y.
  Parameter ltn : t -> t -> bool.
  Definition lt : t -> t -> Prop := fun x y => ltn x y.
  Axiom eq_refl : forall x : t, eq x x.
  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.

  (* Derived facts *)
  Axiom ltn_trans : forall x y z : t, ltn x y -> ltn y z -> ltn x z.
  Axiom ltn_eqF : forall (x y : t), ltn x y -> (x == y) = false.
  Axiom ltnn : forall (x : t), ltn x x = false.
  Axiom nltn_eqVlt : forall (x y : t), (~~ ltn x y) = ((x == y) || ltn y x).
  Axiom ltn_neqAlt : forall (x y : t), ltn x y = (x != y) && ~~ (ltn y x).
  Axiom neq_ltn : forall (x y : t), (x != y) = (ltn x y) || (ltn y x).
End SsrOrder.

Module MakeSsrOrder (M : SsrOrderMinimal) <: SsrOrder.

  Definition T : eqType := M.t.

  Definition t : Type := T.

  Definition eq : t -> t -> Prop := fun x y => x == y.

  Definition ltn : t -> t -> bool := M.ltn.

  Definition lt : t -> t -> Prop := fun x y => ltn x y.

  Lemma eq_refl (x : t) : eq x x.
  Proof. exact: eqxx. Qed.

  Lemma eq_sym (x y : t) : eq x y -> eq y x.
  Proof. by rewrite /eq eq_sym. Qed.

  Lemma eq_trans (x y z : t) : eq x y -> eq y z -> eq x z.
  Proof. move=> Hxy Hyz. rewrite (eqP Hxy). exact: Hyz. Qed.

  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z :=
    M.ltn_trans.

  Lemma lt_not_eq (x y : t) : lt x y -> ~ eq x y.
  Proof. move=> Hlt Heq. by move/negP: (M.ltn_not_eqn Hlt). Qed.

  Definition compare : forall x y : t, Compare lt eq x y := M.compare.
  Lemma eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
  Proof.
    move=> x y.
    case Hxy: (x == y).
    - left; exact: Hxy.
    - right; move=> Heq.
      apply/negPf: Hxy.
      exact: Heq.
  Qed.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof. exact: lt_trans. Qed.

  Lemma ltn_eqF (x y : t) : ltn x y -> (x == y) = false.
  Proof. move=> H. apply/negP. exact: lt_not_eq. Qed.

  Lemma ltnn (x : t) : ltn x x = false.
  Proof. case H: (ltn x x) => //=. move: (ltn_eqF H). by rewrite eqxx. Qed.

  Lemma nltn_eqVlt (x y : t) : (~~ ltn x y) = ((x == y) || ltn y x).
  Proof.
    case Heq: (x == y) => /=.
    - by rewrite (eqP Heq) ltnn.
    - case Hlt: (ltn x y) => /=; symmetry.
      + apply/negP => Hyx. move: (ltn_trans Hlt Hyx). by rewrite ltnn.
      + move: Heq Hlt. case: (compare x y); by move=> ->.
  Qed.

  Lemma ltn_neqAlt (x y : t) : ltn x y = (x != y) && ~~ (ltn y x).
  Proof.
    rewrite nltn_eqVlt. case H: ((x != y) && ((y == x) || ltn x y)).
    - move/andP: H=> [H1 H2]. case/orP: H2 => H2.
      + by rewrite (eqP H2) eqxx in H1.
      + assumption.
    - apply/negP=> H2. move/negP: H; apply. rewrite (ltn_eqF H2) H2.
      by rewrite orbT.
  Qed.

  Lemma neq_ltn (x y : t) : (x != y) = (ltn x y) || (ltn y x).
  Proof.
    case: (compare x y) => H.
    - by rewrite (ltn_eqF H) H.
    - by rewrite H (eqP H) !ltnn.
    - by rewrite H eqtype.eq_sym (ltn_eqF H) orbT.
  Qed.

End MakeSsrOrder.

(* OrderedType with a default value and a successor function,
   useful for generating new values *)

Module Type HasSucc (Import T : SsrOrder).
  Parameter succ : t -> t.
End HasSucc.

Module Type HasLtn (Import T : SsrOrder).
  Parameter ltn : t -> t -> bool.
End HasLtn.

Module Type HasLtnSucc (Import T : SsrOrder) (Import L : HasLtn T) (Import S : HasSucc T).
  Parameter ltn_succ : forall (x : t), ltn x (succ x).
End HasLtnSucc.

Module Type SsrOrderWithDefaultSucc <: SsrOrder :=
  SsrOrder <+ HasDefault <+ HasSucc <+ HasLtnSucc.

(** Product of ordered types. *)

Module MakeProdOrderMinimal (O1 O2 : SsrOrder) <: SsrOrderMinimal with Definition t := prod_eqType O1.T O2.T.

  Definition t : eqType := prod_eqType O1.T O2.T.

  Definition eqn (x y : t) : bool := x == y.

  Definition ltn (x y : t) : bool :=
    O1.ltn (fst x) (fst y) || (fst x == fst y) && O2.ltn (snd x) (snd y).

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof.
    case: x => x1 x2; case: y => y1 y2; case: z => z1 z2. rewrite /ltn /=.
    case/orP=> [Hxy1 | /andP [Hxy1 Hxy2]]; (case/orP=> [Hyz1 | /andP [Hyz1 Hyz2]]).
    - by rewrite (O1.lt_trans Hxy1 Hyz1).
    - by rewrite -(eqP Hyz1) Hxy1.
    - by rewrite (eqP Hxy1) Hyz1.
    - by rewrite (eqP Hxy1) (eqP Hyz1) eqxx (O2.lt_trans Hxy2 Hyz2) orbT.
  Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof.
    case: x => x1 x2; case: y => y1 y2. rewrite /ltn /=.
    case/orP=> [Hxy1 | /andP [Hxy1 Hxy2]].
    - apply/eqP=> H. case: H => H1 H2. apply: (O1.lt_not_eq Hxy1). by apply/eqP.
    - apply/eqP=> H. case: H => H1 H2. apply: (O2.lt_not_eq Hxy2). by apply/eqP.
  Qed.

  Definition compare (x y : t) : Compare ltn eqn x y.
  Proof.
    case: x => x1 x2; case: y => y1 y2. rewrite /ltn /eqn.
    case: (O1.compare x1 y1) => H1.
    - apply: LT => /=. by rewrite H1.
    - case: (O2.compare x2 y2) => H2.
      + apply: LT => /=. by rewrite H1 H2 orbT.
      + apply: EQ => /=. by rewrite (eqP H1) (eqP H2).
      + apply: GT => /=. by rewrite (eqP H1) eqxx H2 orbT.
    - apply: GT => /=. by rewrite H1.
  Defined.

End MakeProdOrderMinimal.

Module MakeProdOrder (O1 O2 : SsrOrder) <: SsrOrder
    with Definition T := prod_eqType O1.T O2.T.
  Module M := MakeProdOrderMinimal O1 O2.
  Module P := MakeSsrOrder M.
  Include P.
End MakeProdOrder.

Module MakeProdOrderWithDefaultSucc (O1 O2 : SsrOrderWithDefaultSucc) <: SsrOrderWithDefaultSucc
    with Definition T := prod_eqType O1.T O2.T.
  Module M := MakeProdOrderMinimal O1 O2.
  Module P := MakeSsrOrder M.
  Include P.
  Definition default : t := (O1.default, O2.default).
  Definition succ (x : t) : t := (O1.succ (fst x), O2.default).
  Lemma ltn_succ (x : t) : ltn x (succ x).
  Proof.
    case: x => x y. rewrite /ltn /succ /=. rewrite /M.ltn /=.
    by rewrite O1.ltn_succ /=.
  Qed.
End MakeProdOrderWithDefaultSucc.

(** Union of ordered types. *)

Module MakeUnionOrderMinimal
       (V1 : SsrOrder) (V2 : SsrOrder) <: SsrOrderMinimal.

  Inductive ut : Type :=
  | C1 : V1.t -> ut
  | C2 : V2.t -> ut.

  Definition uo_eqb (x y : ut) : bool :=
    match x, y with
    | C1 x, C1 y => x == y
    | C2 x, C2 y => x == y
    | _, _ => false
    end.

  Lemma uo_eqP : Equality.axiom uo_eqb.
  Proof.
    move=> x y.
    case H: (uo_eqb x y).
    - apply: ReflectT.
      move: H; case: y; case: x => //=.
      + move=> x y H.
        rewrite (eqP H).
        reflexivity.
      + move=> x y H.
        rewrite (eqP H).
        reflexivity.
    - apply: ReflectF.
      move: H; case: y; case: x => //=.
      + move=> x y H1 [] H2.
        apply/negPf: H1.
        rewrite H2; exact: eqxx.
      + move=> x y H1 [] H2.
        apply/negPf: H1.
        rewrite H2; exact: eqxx.
  Qed.

  Canonical uo_eqMixin := EqMixin uo_eqP.
  Canonical uo_eqType := Eval hnf in EqType ut uo_eqMixin.

  Definition t : eqType := uo_eqType.

  Definition eqn : t -> t -> bool := uo_eqb.

  Definition ltn (x y : t) : bool :=
    match x, y with
    | C1 x, C1 y => V1.ltn x y
    | C1 _, C2 _ => true
    | C2 _, C1 _ => false
    | C2 x, C2 y => V2.ltn x y
    end.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof.
    case: z; case: y; case: x => //=.
    - exact: V1.lt_trans.
    - exact: V2.lt_trans.
  Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof.
    case: y; case: x => //=.
    - move=> x y H. apply/negP. exact: V1.lt_not_eq.
    - move=> x y H. apply/negP. exact: V2.lt_not_eq.
  Qed.

  Definition compare (x y : t) : Compare ltn eqn x y.
  Proof.
    case: y; case: x.
    - move=> x y.
      case H: (V1.compare x y).
      + apply: LT; assumption.
      + apply: EQ; assumption.
      + apply: GT; assumption.
    - move=> x y.
      by apply: GT.
    - move=> x y.
      by apply: LT.
    - move=> x y.
      case H: (V2.compare x y).
      + apply: LT; assumption.
      + apply: EQ; assumption.
      + apply: GT; assumption.
  Defined.

End MakeUnionOrderMinimal.

Module MakeUnionOrder
       (V1 : SsrOrder) (V2 : SsrOrder) <: SsrOrder.
  Module M := MakeUnionOrderMinimal V1 V2.
  Module O := MakeSsrOrder M.
  Include O.
  Definition c1 (x : V1.t) : t := M.C1 x.
  Definition c2 (x : V2.t) : t := M.C2 x.
End MakeUnionOrder.

(** A singleton ordered type. *)

Module UnitOrderMinimal <: SsrOrderMinimal.

  Definition t : eqType := unit_eqType.

  Definition eqn (x y : t) : bool := x == y.

  Definition ltn (x y : t) : bool := false.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof. done. Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof. done. Qed.

  Definition compare (x y : t) : Compare ltn eqn x y.
  Proof. by apply: EQ. Defined.

End UnitOrderMinimal.

Module UnitOrder <: SsrOrder.
  Module O := MakeSsrOrder UnitOrderMinimal.
  Include O.
End UnitOrder.

(** Convert orderType to SsrOrder. *)

From mathcomp Require Import order.
Import Order.Theory.

Module Type OrderType.
  Parameter d : unit.
  Parameter t : orderType d.
End OrderType.

Module SsrOrderMinimalOfOrderType (O : OrderType) <: SsrOrderMinimal.
  Local Open Scope order_scope.
  Definition t := Order.Total.eqType O.t.
  Definition eqn (x y : t) : bool := x == y.
  Definition ltn (x y : t) : bool := x < y.
  Lemma ltn_trans : forall x y z : t, ltn x y -> ltn y z -> ltn x z.
  Proof.
    move=> x y z. rewrite /ltn => Hxy Hyz. exact: (lt_trans Hxy Hyz).
  Qed.
  Lemma ltn_not_eqn : forall x y : t, ltn x y -> x != y.
  Proof.
    move=> x y. rewrite /ltn lt_def. rewrite eq_sym. move/andP=> [-> _]. reflexivity.
  Qed.
  Definition compare : forall x y : t, Compare ltn eqn x y.
  Proof.
    move=> x y. case Heq: (x == y).
    - exact: (EQ Heq).
    - case Hlt: (x < y).
      + exact: (LT Hlt).
      + apply: GT. rewrite /ltn lt_def. rewrite Heq /=. rewrite leNgt Hlt. reflexivity.
  Defined.
End SsrOrderMinimalOfOrderType.

Module SsrOrderOfOrderType (O : OrderType) <: SsrOrder.
  Module M := SsrOrderMinimalOfOrderType O.
  Module P := MakeSsrOrder M.
  Include P.
End SsrOrderOfOrderType.


(* Require Import CertiCoq. *)
From MetaCoq Require Import Template.Ast.
Require Import Arith List.

Import ListNotations.

(** Ideas for TemplateCoq translation validation that would let us connect the generated target file
    with the original Coq code.

    Author: Zoe Paraskevopoulou *)

(** * VST specs for compiled Coq programs

    The idea is that we want to derive a proof in Verifiable C (VST's separation
    logic) for compiled Coq programs. These specifications will relate the
    original Coq function (rather than L1g abstract syntax) with the compiled C
    code.

    Let [f : A -> B] be a Coq function and [f_in_C : compcert.exp] its
    translation. Then we want:

    forall (a: A) (v : compcert.val),
      {{ rep_A a v }} f_in_C(v)  {{ret. rep_B (f a) ret }}

    The separation logic predicate rep_A describes how Coq values of type A are
    laid out as a C data structure.

    For instance, if for simplicity we assume that Coq values of type [list A]
    will be represented as a null terminated linked lists, then rep_list will,
    very roughly, be

    Fixpoint rep_list (l: list A) (p: compcert.val) : mpred :=
      match l with
      |  h :: l' => rep_A h p ∗ rep_list l' (offset p 4)
         (* i.e. p is a struct pointer and p.head points to a C value in memory
          * that represents h and p.tail is a struct pointer that represents the
          * rest of the list *)
      |  nil => !! (p = null) && emp
    end.

    Then a C program may call f_in_C, and also we may use the above spec when we
    prove it correct in VST!

    To obtain this triple for a compiled program we'll make use of the
    semantic definition of the triple that (again very roughly) says

    {{ pre }} e {{ post }} iff forall h, pre h -> exists v h', eval (e, h) (v, h') /\ post v h'

    That is, to obtain the top-level theorem we need

    forall (a: A) (v : compcert.val) (h : heap),
       rep_A a v h -> exists v' h', eval (app e v, h) (v', h') /\ rep_B (f a) v'

   It should be possible to obtain a similar theorem for L1 -> C light just from
   our compiler correctness theorem.

   The following explains how can we obtain such a theorem for Coq -> L1 to
   eventually compose the two and derive the desired theorem.

  This idea seems to be similar with the one presented in
  https://pdfs.semanticscholar.org/58bb/00b882700d67779871a6208f288f68a0b71c.pdf
  where they verify an HOL -> ML extractor.

 *)

(* Assume we have this *)
Axiom (eval : Ast.term -> Ast.term).

Class Rep (A : Type) :=
  {
    (* An Ast.term represents a Coq value *)
    rep : A -> Ast.term -> Prop
  }.

(* Example 1 : nat *)

Fixpoint nat_rep (n : nat) (v : Ast.term) : Prop :=
  match n with
    | O =>
      match v with
        | Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 0 => True
        | _ => False
      end
    | S n =>
      match v with
        | Ast.tApp (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 1) [x] =>
          nat_rep n x
        | _ => False
      end
  end.

Instance NatRep : Rep nat := { rep n v := nat_rep n (eval v) }.

(* Example 2 : list *)

Fixpoint list_rep {A : Type} `{Rep A} (l : list A) (v : Ast.term) : Prop :=
  match l with
    | [] =>
      match v with
        | Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.list" 0) 0 => True
        | _ => False
      end
    | hd :: tl =>
      match v with
        | Ast.tApp (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.list" 0) 1) [typ; vhd; vtl] =>
          rep hd vhd /\ list_rep tl vtl
        | _ => False
      end
  end.

Instance ListRep {A : Type} `{Rep A} : Rep (list A) := { rep l v := list_rep l (eval v) }.

(* And so on. For inductive types we should be able to generate these instances automatically *)

(* Function types are more interesting *)

Instance ArrowRep {A B : Type} `{Rep A} `{Rep B} : Rep (A -> B) :=
  { rep f t :=
      forall (a : A) (v : Ast.term), rep a v -> rep (f a) (eval (Ast.tApp t [v]))
  }.

Instance ProdRep (B : Type -> Type) `{forall (A : Type) (H : Rep A), Rep (B A)}
: Rep (forall (A : Type), B A) :=
  { rep f t :=
      forall (A : Type) `{Rep A}, rep (f A) (eval (Ast.tApp t [qUnit]))
  }.

(* For every term f we reify we want to generate a proof that [rep f f_reified].
   If we can generate such a thing (can we?) then we could obtain the
   top-level theorem we want. *)

(* What about quantification over computationally irrelevant things? *)

Quote Definition qUnit := tt.

Instance ProdRep (B : Type -> Type) `{forall (A : Type) (H : Rep A), Rep (B A)}
: Rep (forall (A : Type), B A) :=
  { rep f t :=
      forall (A : Type) `{Rep A}, rep (f A) (eval (Ast.tApp t [qUnit]))
  }.

(* This resembles a lot the approach we follow in QuickChick to automatically
   generate correctness proofs for automatically generated generators. We do the
   proof term generation in OCaml, but I think it would be nice to do it in Coq
   and then reflect the terms. *)

Instance ProdRep (B : Type -> Type) `{forall (A : Type) (H : Rep A), Rep (B A)}
: Rep (forall (A : Type), B A) :=
  { rep f t :=
      forall (A : Type) `{Rep A}, rep (f A) (eval (Ast.tApp t [qUnit]))
  }.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals realsum distr.
(* ------- *) Require Import notations.

(* -------------------------------------------------------------------- *)
CoInductive or_spec (a b : bool) : bool -> bool -> Type :=
| OrT of a    : or_spec a b true  true
| OrF of ~~ a : or_spec a b false b.

Lemma orlP a b : or_spec a b a (a || b).
Proof. by case: (boolP a) => h; constructor. Qed.

Lemma orrP a b : or_spec b a b (a || b).
Proof. rewrite orbC;apply orlP. Qed.

(* -------------------------------------------------------------------- *)
Delimit Scope assn with A.

Definition predImpl {T} (P Q:pred T) :=
   [pred x | P x ==> Q x].

Notation "P /\ Q"   := (predI P%A Q%A) : assn.
Notation "P \/ Q"   := (predU P%A Q%A) : assn.
Notation "P ==> Q"  := (predImpl P%A Q%A) : assn.
Notation "~ P"      := (predC P%A) : assn.

Definition predP {T : Type} (P : T -> Prop) := [pred x | `[<P x>]].

Notation "`[< P >]" := (predP P) : assn.

Definition pswap {A B : Type} (P : pred (A * B)) :=
  [pred m | P (m.2, m.1)].


From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
From Undecidability.L Require Import L_facts LM_heap_def UpToCNary.

From Coq Require Import List.
Import Vector.VectorNotations ListNotations.

From Undecidability.TM Require Import TM_facts ProgrammingTools WriteValue CaseList Copy ListTM Hoare.
From Undecidability.TM.L Require Import Alphabets Eval.
From Undecidability.TM.L.CompilerBoolFuns Require Import Compiler_spec Compiler_facts ClosedLAdmissible.

Require Import Equations.Prop.DepElim.

Set Default Proof Using "Type".

Section APP_right.

  Definition APP_right : pTM (sigPro)^+ unit 2 :=
    App _;;
    WriteValue ( [appT]%list) @ [|Fin1|];;
    App _.

  Lemma APP_right_Spec :
    { f : UpToC (fun '(s1,s2)=>size (compile s1) + size (compile s2)) & forall s1 s2 : term,
    TripleT ≃≃([],[|Contains _ (compile s1);Contains _ (compile s2)|])
    (f (s1,s2)) APP_right (fun _ => ≃≃([],[|Contains _ (compile (L.app s1 s2));Void|])) }.
  Proof.
    eexists_UpToC f. [f]:refine (fun '(s1,s2) => _).
    intros s1 s2.
    unfold APP_right.
    hsteps_cbn.
    -rewrite app_assoc.  reflexivity.
    -reflexivity.
    - rewrite !(correct__leUpToC (App_steps_nice _) (_,_)).
      rewrite Encode_list_hasSize with (xs:=(compile s1 ++ compile s2)%list).
      rewrite Encode_list_hasSize_app, <- !Encode_list_hasSize. reflexivity.
    -assert (H': (fun x => 1) <=c (fun '(s1,s2)=>size (compile s1) + size (compile s2))).
     { eapply upToC_le. intros []. setoid_rewrite Encode_list_hasSize. setoid_rewrite <- Encode_list_hasSize_ge1. nia. }
    unfold f. unfold sigPro. cbn - ["-" "+"]. smpl_upToC. cbn. all:try smpl_upToC_solve.
  Qed.

End APP_right.

Lemma tabulate_nth [X : Type] [n : nat] (v : Vector.t X n): tabulate (fun i => v[@i]) = v.
Proof. depind v;cbn. all:congruence. Qed.

Hint Rewrite  Nat.eqb_refl tabulate_nth nth_tabulate: cleanupParamTM.

Ltac cleanupParamTM :=
  try fold Nat.add;rewrite ?Nat.eqb_refl, ?tabulate_nth, ?nth_tabulate;cbn.

Section MK_isVoid.

  Context {Σ : finType}.

  Definition MK_isVoid : pTM Σ^+ unit 1 :=
    Write (inl UNKNOWN).

  Lemma MK_isVoid_Sem :
    RealiseIn MK_isVoid (fun t '(r, t') => t = [| niltape|] -> isVoid (t'[@Fin0])) 1.
  Proof.
    eapply RealiseIn_monotone.
    { unfold MK_isVoid. TM_Correct. }
    easy.
    intros ? [] H ->. hnf in H. cbn in *. rewrite H. hnf. eauto.
  Qed.

  Lemma MK_isVoid_Spec :
   TripleT ≃≃([],[|Custom (eq niltape)|]) 1 MK_isVoid (fun _ => ≃≃([],[|Void|])).
  Proof.
    eapply RealiseIn_TripleT. now apply MK_isVoid_Sem. cbn. intros ? ? ? ? [_ H']%tspecE.
    specialize  (H' Fin0). eapply tspecI. easy. intros i; destruct_fin i;cbn. apply H. now vector_destruct tin.
  Qed.

  Fixpoint MK_isVoid_multi m' : pTM (Σ) ^+ unit m' :=
    match m' with
    0 => Nop
    | S m' => MK_isVoid @ [|Fin0|];;MK_isVoid_multi m'@(tabulate (fun i => Fin.FS i))
    end.

  Lemma helper n m i f:
    injective f ->
      lookup_index_vector (m:=m) (n:=n)
    (tabulate f)
    (f i) = Some i.
  Proof.
    revert n i f. induction m;cbn. easy.
    intros n i f Hinj. specialize (Fin.eqb_eq _ (f i) (f Fin0)) as H'.
    destruct Fin.eqb.
    -destruct H' as [H' _]. specialize (H' eq_refl). apply Hinj in H' as ->. easy.
    -destruct H' as [_ H']. destruct (fin_destruct_S i) as [[i' ->]| ->]. 2:now discriminate H'.
     specialize IHm with (f:= fun m => f (Fin.FS m) ). cbn in IHm. rewrite IHm. easy. intros ? ? ?%Hinj. now apply Fin.FS_inj.
  Qed.

  Instance Proper_tabulate X n: Proper (pointwise_relation _ eq ==> eq) (@tabulate X n).
  Proof.
    unfold pointwise_relation.
    induction n;hnf;intros f g H;cbn. reflexivity. f_equal. apply H. now apply IHn.
  Qed.

  Theorem MK_isVoid_multi_SpecT m' :
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) m')
    (m'*2) (MK_isVoid_multi m')
    (fun _ => ≃≃([],Vector.const Void m')).
  Proof using All.
    depind m';cbn. now hsteps_cbn.
    hstep. {hsteps_cbn;cbn. apply MK_isVoid_Spec. }
    cbn;intros _. rewrite Nat.eqb_refl,tabulate_nth;cbn.
    eapply ConsequenceT.
    {
      eapply LiftTapes_SpecT with (Q:=fun _ => _)(Q':=fun _ => _) (P:= Void:::Vector.const (Custom (eq niltape)) _). now eapply dupfree_tabulate_injective,Fin.FS_inj.
      eapply ConsequenceT . eassumption. 2:cbn;intro;reflexivity. 2:reflexivity.
      unfold Downlift,select. rewrite Vector_map_tabulate. cbn. now rewrite tabulate_nth.
    }
    1,3,4:reflexivity. cbn. intros _.
    rewrite lookup_index_vector_None. 2:{rewrite in_tabulate. intros (?&?). congruence. }
    eapply EntailsI. intros ? [_ H]%tspecE. eapply tspecI. easy. intros i. cbn.
    specialize (H i);cbn in H. destruct (fin_destruct_S i) as [[i' ->]| ->];cbn in H|-*. 2:easy.
    rewrite nth_tabulate in H. rewrite helper in H. easy. hnf. eapply Fin.FS_inj.
  Qed.

End MK_isVoid.
Opaque MK_isVoid_multi.

From Undecidability Require Import TM.L.Transcode.Boollist_to_Enc.
From Undecidability Require Import EncBoolsTM_boolList.
From Undecidability.TM.L Require Import SizeBoundsL.

Section mk_init_one.

  Variable Σ : finType.

  Variable s b : Σ^+.
  Variable (H_disj : s <> b).

  Variable (retr_pro : Retract sigPro Σ).
  Variable (retr_list : Retract (sigList bool) Σ).

   (* Tapes:
       0: bs (input, encBoolsTM)
       1: ter (input)
       2: intern, bs als listBool
       3: intern
       4: intern
       5: intern
     *)

  Definition M_init_one : pTM (Σ) ^+ unit 6:=
    encBoolsTM2boollist.M s retr_list @[|Fin0;Fin3|];;
    Rev _ ⇑ retr_list @ [|Fin3;Fin2;Fin4|];;
    BoollistToEnc.M retr_list retr_pro @[|Fin2;Fin3;Fin4;Fin5|];;
    APP_right ⇑ retr_pro  @[|Fin1;Fin3|].

  Lemma M_init_one_Spec :
    { f : UpToC (fun '(bs,ter)=>length bs + L_facts.size ter + 1) & forall (bs:list bool) (ter : L.term),
    TripleT ≃≃([],[|Custom (eq (encBoolsTM s b bs));Contains _ (compile ter);Void;Void;Void;Void|])
    (f (bs,ter)) M_init_one (fun _ => ≃≃([],[|Custom (eq (encBoolsTM s b bs));Contains _ (compile (L.app ter (encBoolsL bs)));Void;Void;Void;Void|])) }.
  Proof using H_disj.
    eexists_UpToC f.
    {
    [f]:refine (fun '(bs,ter) => _).
    intros bs ter.
    unfold M_init_one.
    hstep. { hsteps_cbn. cbn. eapply (projT2 (encBoolsTM2boollist.SpecT _ H_disj)). }
    cbn. intros _. hstep. { hsteps_cbn. cbn. tspec_ext. } 2:reflexivity.
    cbn. intros _. hstep.
    {
      hsteps_cbn. cbn. eapply ConsequenceT. eapply BoollistToEnc.SpecT with (bs:=rev bs).
      all:cbn. now tspec_ext. now rewrite rev_involutive. reflexivity.
    } 2:reflexivity.
    cbn. intros _. hsteps_cbn.
     now eapply (projT2 (APP_right_Spec)). 1,2:now cbn;tspec_ext.
     subst f. cbn beta. cbn beta iota.  reflexivity.
    }
    etransitivity.
    {
       unfold f. eapply upToC_le with (F:=fun '(bs,ter) => _). intros [bs ter].
       rewrite (correct__leUpToC (Rev_steps_nice _)).
       rewrite (correct__leUpToC (BoollistEnc.boollist_size)).
       do 3 rewrite (correct__leUpToC (correct__UpToC _)).
       rewrite rev_length.
       rewrite !size_le_sizeP.
       unfold sizeP;rewrite !sizeP_size.
       rewrite (correct__leUpToC size_L_enc_bools).
       reflexivity.
    }
       smpl_upToC_solve.
  Qed.

End  mk_init_one.

Section mk_init.

  Variable Σ : finType.
  Variable s b : Σ^+.
  Variable (H_disj : s <> b).

  Context (retr_pro : Retract sigPro Σ) (retr_bools : Retract (sigList bool) Σ).

  Variable m k : nat.

  Notation aux n := (Fin.L k (Fin.L m n)) (only parsing).
  Notation auxm n := (Fin.L k (Fin.R 6 n)) (only parsing).
  Notation auxk n := (Fin.R (6 + m) n) (only parsing).

  Fixpoint M_init' (sim:term) {k'} : (Vector.t (Fin.t k) k') -> pTM (Σ) ^+ unit ((6 + m)+ k).
  Proof using m s retr_bools retr_pro.
    simple notypeclasses refine (match k' with
    0 => fun _ => MK_isVoid_multi _ @ [|aux Fin1;aux Fin2;aux Fin3;aux Fin4; aux Fin5|];;
        WriteValue ( (compile sim)) ⇑ retr_pro @ [|aux Fin1|]
    | S k' =>
    fun ren =>
      _;;M_init_one s retr_pro retr_bools @ [|auxk (ren[@Fin0]);aux Fin1;aux Fin2;aux Fin3;aux Fin4;aux Fin5|]
    end). all:try exact _.
    2:{apply (M_init' sim _ (Vector.tl ren)). }
  Defined. (* because definition *)

  Theorem M_init'_SpecT k' (ren :Vector.t (Fin.t k) k') :
  { f : UpToC (fun '(sim,v) => L_facts.size sim + sumn (Vector.to_list (Vector.map (length (A:=bool)) v)) + 1)
  & forall sim (v:Vector.t (list bool) k),
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (6+m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v)
    (f (sim,v)) (M_init' sim ren)
    (fun _ => ≃≃([],
      ([|Custom (eq niltape);
        Contains retr_pro (compile (Vector.fold_right (fun l_i s => L.app s (encBoolsL l_i)) (select ren v) sim))
         ;Void;Void;Void;Void|]++Vector.const (Custom (eq niltape)) m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v))}.
  Proof using All.
    depind ren. all:cbn [compile Vector.fold_left M_init' Vector.tl Vector.caseS].
    {
      eexists_UpToC f. [f]:refine (fun '(sim,v) => _).
      {
        cbn. intros sim v.
        hstep. hsteps_cbn;cbn. exact (MK_isVoid_multi_SpecT 5). cbn;cleanupParamTM. 2:reflexivity.
        hsteps_cbn. reflexivity.
        cleanupParamTM.
        apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
        intros i. clear - i.
        repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
      }
      unfold f. etransitivity.
      {eapply upToC_le with (F:= (fun '(_,_) => _ ));intros []. unfold WriteValue_steps. rewrite !size_le_sizeP. unfold sizeP;rewrite !sizeP_size. reflexivity. }
      smpl_upToC_solve.
    }
    {
      eexists_UpToC f. [f]:refine (fun '(sim,v) => _).
      {
        cbn. intros sim v.
        hstep.
        3:reflexivity. now apply (projT2 IHren).
        cbn. intros _. hstep. { cbn. rewrite Vector_nth_R,nth_map'. cbn. eapply (projT2 (M_init_one_Spec H_disj _ _)). }
        cbn;fold Nat.add;rewrite Nat.eqb_refl;cbn. intros _.
        apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
        intros i. clear - i.
        repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
        rewrite nth_tabulate. destruct (Fin.eqb _ _) eqn:H'. 2:tauto.
        cbn. eapply Fin.eqb_eq in H' as ->. rewrite Vector_nth_R,nth_map'. cbn. tauto.
      }
      unfold f. etransitivity.
      {
        eapply upToC_le with (F:= (fun '(_,_) => _ ));intros [].
        do 2 rewrite (correct__leUpToC (correct__UpToC _)). reflexivity.
      }
      assert (Hnth : forall n h,(fun '(_, x) => | x[@h] |) <=c
          (fun '(sim, v) =>
          L_facts.size sim + sumn (Vector.to_list (n:=n) (Vector.map (length (A:=bool)) v)) +
          1)).
          {
          clear. intros. eapply upToC_le;intros [? ?].
          clear. revert h t0. induction n;intros i v. easy. depelim v. depelim i.
            now cbn;nia.
            cbn. rewrite IHn. unfold Vector.to_list. nia.
          }
      smpl_upToC.
      all:try smpl_upToC_solve. now apply Hnth.
      -clear - Hnth. induction n.
       +depelim ren;cbn. smpl_upToC_solve.
       +depelim ren;cbn.
        etransitivity.
        *eapply upToC_le with (F:= (fun '(_,_) => _ ));intros []. unfold select in IHn.  rewrite (correct__leUpToC (IHn ren) (_,_)). reflexivity.
        *smpl_upToC. all:try smpl_upToC_solve.
         etransitivity.
         {
           eapply upToC_le with (F:= (fun '(_,_) => _ ));intros [? ?].
           change (encBoolsL t0[@h]) with (Extract.enc t0[@h]).
           rewrite (correct__leUpToC size_L_enc_bools). reflexivity.
         }
           smpl_upToC. apply Hnth. smpl_upToC_solve.
    }
  Qed.

  Program Definition startRen := Vectors.tabulate (n:=k) (fun i => Fin.of_nat_lt (n:=k) (p:=k - 1 -proj1_sig (Fin.to_nat i)) _).
  Next Obligation.
  destruct Fin.to_nat;cbn. nia.
  Defined. (* because definition *)

  Lemma startRen_spec A (v:Vector.t A _): select startRen v = Vector.rev v.
  Proof.
    unfold select.
    apply eq_nth_iff'. intros i. rewrite nth_map'.
    unfold startRen.
    unshelve erewrite nth_tabulate, vector_nth_rev. 1:abstract (inv i;nia).
    f_equal.  eapply Fin.of_nat_ext.
  Qed.

  Import CasePair Code.CaseList.

  Definition M_init sim : pTM (Σ) ^+ unit ((6 + m)+ k) :=
    M_init' sim startRen.

  Theorem M_init_SpecT:
  { f : UpToC (fun '(sim,v) => L_facts.size sim + sumn (Vector.to_list (Vector.map (length (A:=bool)) v)) + 1)
    & forall sim (v:Vector.t (list bool) k),
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (6+m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v)
    (f (sim,v)) (M_init sim)
    (fun _ => ≃≃([],
      ([|Custom (eq niltape);
        Contains retr_pro (compile (Vector.fold_left (fun s l_i => L.app s (encBoolsL l_i)) sim v));
         Void;Void;Void;Void|]
         ++Vector.const (Custom (eq niltape)) m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v))}.
  Proof using H_disj.
    eexists_UpToC f. [f]:refine (fun '(sim,v) => _).
    intros.
    unfold M_init.
    eapply ConsequenceT. eapply (projT2 (M_init'_SpecT _)). reflexivity. 2:unfold f;reflexivity.
    cbn. intros _.
    rewrite vector_fold_left_right with (v:=v), <- (startRen_spec v).
    apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
    intros i. clear - i.
    repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
    unfold f;cbn beta.
    etransitivity.
    {
       eapply upToC_le with (F:= fun '(x,y)=>_);intros []. cbn.
      setoid_rewrite (correct__leUpToC (correct__UpToC _)). reflexivity.
    }
    smpl_upToC_solve.
  Qed.

End mk_init.

From Undecidability Require Import Enc_to_Boollist.

Section conv_output.

  Variable Σ : finType.
  Variable s b : Σ^+.
  Variable (retr_pro : Retract sigPro Σ).
  Variable (retr_list : Retract (sigList bool) Σ).

  Definition M_out : pTM (Σ) ^+ unit 4 :=
    EncToBoollist.M _ _ @ [|Fin0;Fin2;Fin3|];;
    Boollist2encBoolsTM.M s b _ @ [|Fin2;Fin1;Fin3|].

  Theorem M_out_SpecT :
    { f : UpToC (fun bs => length bs + 1) & forall bs,
    TripleT ≃≃([],[|Contains _ (compile (encBoolsL bs));Custom (eq niltape);Void;Void|])
      (f bs) M_out
      (fun _ => ≃≃([],
        ([|Custom (fun _ => True); Custom (eq (encBoolsTM s b bs)); Void;Void|])))}.
  Proof.
    eexists_UpToC f. [f]:refine (fun bs => _).
    intro bs.
    unfold M_out. hsteps_cbn;cbn.
    -eapply (projT2 (@EncToBoollist.SpecT _ _ _)).
    -eapply (projT2 (Boollist2encBoolsTM.SpecT _ _ _)).
    - cbn. rewrite rev_involutive. tspec_ext. easy.
    -unfold f.  setoid_rewrite (correct__leUpToC (correct__UpToC _)). rewrite rev_length. reflexivity.
    -unfold f. smpl_upToC_solve.
  Qed.

End conv_output.

From Undecidability.TM.L.HeapInterpreter Require UnfoldClosBounds.

Section main.

  Variable k : nat.
  Variable (R : Vector.t (list bool) k -> (list bool) -> Prop).

  Variable s : term.

  Hypothesis Hscl : closed s.

  Variable Hs1 : (forall v, forall m : list bool,
   L.eval (Vector.fold_left (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) (encBoolsL m)
   -> R v m).

  Variable Hs2 : (forall v, forall o : term,
                     L.eval (Vector.fold_left (n := k) (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) o ->
                     exists m : list bool, o = encBoolsL m).

  Definition n_main := 14.

  Definition Σ : Type := sigList bool + EvalL.Σintern.

  Definition retr_bools : Retract (sigList bool) Σ := (Retract_inl _ _).
  Definition retr_intern : Retract EvalL.Σintern Σ := (Retract_inr _ _).

  Definition retr_closs : Retract (sigList sigHClos) Σ
  := ComposeRetract retr_intern _.
  Definition retr_clos : Retract sigHClos Σ := ComposeRetract retr_closs _.
  Definition retr_pro : Retract sigPro Σ := ComposeRetract retr_clos _.

  Definition sym_s : Σ^+ := inr (inl (sigList_X true)).
  Definition sym_b : Σ^+ := inr (inl (sigList_X false)).

  (*
    auxiliary tapes:

    0    : T

   *)

  Notation aux n := (Fin.L k (Fin.R 1 n)).

  Definition garb : Σ^+ := inl UNKNOWN.

  Definition M_main : pTM (Σ ^+)  unit (1 + n_main + k):=
        M_init sym_s retr_pro retr_bools (1 + n_main - 6) k s ;;
        MK_isVoid_multi _ @ [|aux Fin5;aux Fin6;aux Fin7;aux Fin8;aux Fin9;aux Fin10;aux Fin11;aux Fin12;aux Fin13 |] ;;
        EvalL.M retr_intern retr_pro @ [| aux Fin0 ; aux Fin1 ; aux Fin2; aux Fin5 ; aux Fin6 ; aux Fin7 ; aux Fin8 ; aux Fin9 ; aux Fin10 ; aux Fin11 ; aux Fin12 |] ;;
        M_out sym_s sym_b retr_pro retr_bools @ [|aux Fin0;Fin.L k Fin0;aux Fin7;aux Fin8|].

  Lemma syms_diff : sym_s <> sym_b. Proof. cbv. congruence. Qed.

  Theorem M_main_Spec v:
    Triple ≃≃([],Vector.const (Custom (eq niltape)) (S n_main) ++ Vector.map (fun bs => Custom (eq (encBoolsTM sym_s sym_b bs))) v)
       M_main
      (fun _ t => exists m, t ≃≃ ([R v m]%list,
        (Custom (eq (encBoolsTM sym_s sym_b m)):::Vector.const (Custom (fun _ => True)) _))).
  Proof  using Hscl Hs1 Hs2.
    unfold M_main.
    hstep. { eapply TripleT_Triple,(projT2 (M_init_SpecT syms_diff _ _ _ _)). }
    cbn. intros _.
    start_TM.
    hstep. {hsteps_cbn;cbn. eapply TripleT_Triple. exact (MK_isVoid_multi_SpecT 9). }
    cbn;cleanupParamTM. intros _.
    hstep. {eapply LiftTapes_Spec_ex. now smpl_dupfree. cbn. refine (EvalL.Spec _ _ _). now eapply closed_compiler_helper. }
    cbn;cleanupParamTM.
    intros _. eapply Triple_exists_pre. intros s'.
    change (fun x => ?f x) with f.
    hintros Heval%eval_iff. specialize (Hs2 Heval) as (res&->).
    unfold_abbrev.
    eapply Triple_exists_con. eexists res.
    hstep. { eapply Consequence_pre. eapply TripleT_Triple. refine (projT2 (M_out_SpecT _ _ _ _) res). cbn. reflexivity. }
    cbn;cleanupParamTM. intros _.
    apply Hs1 in Heval.
    eapply EntailsI. intros tin [[] Hin]%tspecE.
    eapply tspecI;cbn. easy.
    intros i. specialize (Hin i). destruct_fin i;try exact Logic.I;cbn in *.
    now simpl_vector. eassumption.
  Qed.
End main.

Import UpToCNary.

Polymorphic Lemma upToC_mul_descend_nary (domain : list Type) (f g f' g': Rarrow domain nat):
  Uncurry f <=c Uncurry f'
  -> Uncurry g <=c Uncurry g'
  -> Fun' (fun x => App f x * App g x)
    <=c Fun' (fun x => App f' x * App g' x).
Proof.
  prove_nary upToC_mul_descend.
Qed.

Theorem M_main_SpecT k s (Hscl : closed s):
  { f : UpToC (fun '(i,m_r,m_v) => (i+1)*(i+m_v+1)*((m_v+1)*(i+1) + m_r)) &
  forall i v res,
    (Vector.fold_left (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) ⇓(i) (encBoolsL res)  ->
    TripleT ≃≃([],Vector.const (Custom (eq niltape)) (S n_main) ++ Vector.map (fun bs => Custom (eq (encBoolsTM sym_s sym_b bs))) v)
    (f (i,length res,sumn (Vector.to_list (Vector.map (length (A:=bool)) v)))) (M_main k s)
      (fun _ => ≃≃([],Custom (eq (encBoolsTM sym_s sym_b res)):::Vector.const (Custom (fun _ => True)) (13+S k)))}.
Proof.
  eexists_UpToC f. [f]:refine (fun '(i,m_r,m_v) => _).
  intros ? ? ? Red. unfold M_main.
  eapply ConsequenceT_pre. 2:reflexivity.
  {
  hstep. { eapply (projT2 (M_init_SpecT syms_diff _ _ _ _)). }
  2:{ set (f' := f__UpToC _). pose (H' := correct__UpToC _ :f' <=c _). rewrite (correct__leUpToC H'). subst f' H'; cbn beta;reflexivity. }
  cbn. intros _.
  start_TM.
  hstep. {hsteps_cbn;cbn. exact (MK_isVoid_multi_SpecT 9). } 2:reflexivity.
  cbn;cleanupParamTM. intros _.
  hstep. { eapply LiftTapes_SpecT. now smpl_dupfree. cbn. unshelve apply EvalL.SpecT. 3:now eapply closed_compiler_helper. 3:easy. }
  cbn;cleanupParamTM.
  intros _.
  hstep. now refine (projT2 (M_out_SpecT _ _ _ _) res).
  cbn;cleanupParamTM. intros _.
  eapply EntailsI. intros tin [[] Hin]%tspecE.
  eapply tspecI;cbn. easy.
  intros j. specialize (Hin j). destruct_fin j;try exact Logic.I;cbn in *.
  now simpl_vector. eassumption. cbn beta.
  set (l:= EvalL.steps _ _).
  pose (Hl:= proj2_sig UnfoldClosBounds.EvalL_steps_nice' _ _ _ _ _ : l <= _ ).
  rewrite Hl.   setoid_rewrite (correct__leUpToC (correct__UpToC _)) at 1. reflexivity.
  }
  set (f' := L_facts.size
      (Vector.fold_left _ _ _)). pose (H':= correct__leUpToC (size_fold_app k) (s,v) : f' <= _).
      cbn in H'. setoid_rewrite H'. clear f' H'.
  rewrite (LargestVar_fold s v) at 1.
  change (encBoolsL) with (Extract.enc (X:=list bool)).
  rewrite (correct__leUpToC size_L_enc_bools res).

  unfold f;cbn beta iota.
  set (m_s:= L_facts.size s). set (m_v:= sumn (Vector.to_list (Vector.map (length (A:=bool)) v))).
  set (m_r := length res).
  reflexivity.
  unfold f. cbn - ["+" "*"]. clear.
  assert ( (fun _ => 1) <=c (fun '(i, m_r,m_v) => (i + 1) * (i + m_v+1) * ((m_v + 1) * (i + 1) + m_r))) by smpl_upToC_solve.
  smpl_upToC.
  1,3:now smpl_upToC_solve.
  eapply leUpToC_proper_eq with (x:=fun '(i, m_r,m_v) => _) (x0:=fun '(i, m_r,m_v) => _).
  { intros [[]]. rewrite <- !Nat.mul_assoc. reflexivity. }
  { intros [[]]. rewrite <- !Nat.mul_assoc. reflexivity. }
  nary simple apply upToC_mul_descend_nary. reflexivity.
  nary simple apply upToC_mul_descend_nary. now smpl_upToC_solve.
  smpl_upToC.
  2,3:smpl_upToC_solve.
  transitivity ((fun '(t', x) => let '(t'0, x0) := t' in (0*x0)+(x + 1) * (t'0 + 1))).
  1,2:cbn.
  nary simple apply upToC_mul_descend_nary; now smpl_upToC_solve.
  smpl_upToC_solve.
Qed.

Theorem compiler_correct {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) :
  L_bool_computable_closed R -> TM_bool_computable_hoare' R.
Proof.
  intros H.
  destruct H as [sim [cs Hsim]].
  hnf.
  eexists _, _, sym_s, sym_b. split. eapply syms_diff. exists (M_main k sim).
  intros v. split.
  - eapply M_main_Spec. easy. all:firstorder.
  - intros. edestruct eval_evalIn. now apply eval_iff,Hsim.
    eexists. eapply (projT2 (M_main_SpecT _ cs)). easy.
Qed.