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

(**********************************************************************)
(*                      SF_Normal.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max.
Require Import IntensionalLib.SF_calculus.SF_Terms.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Tactics.
Require Import IntensionalLib.SF_calculus.SF_reduction.

Inductive status_val :=
| Active : status_val
| Passive : status_val
.

Fixpoint status M :=
match M with
| Ref _ => Active
| Op _ => Passive
| App (App (App (Op Fop) M1) _ ) _ => status M1
| App M1 _ => status M1
end.

(* normal terms *)

Inductive normal : SF -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_active : forall M1 M2, normal M1 -> normal M2 ->
                              status (App M1 M2) = Active ->
                              normal (App M1 M2)
| nf_compound : forall M1 M2, normal M1 -> normal M2 ->
                              compound (App M1 M2) -> normal (App M1 M2)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) sf_seqred1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M sf_seqred1.
Proof.
intros M nor; induction nor; split_all.
(* 4 *)
eapply2 ref_irreducible.
(* 3 *)
red; split_all. inversion H.
(* 2 *)
intro. intro. inversion H0; subst; simpl in *; try discriminate.
(* 4 *)
eapply2 IHnor1.
(* 3 *)
eapply2 IHnor2.
(* 2 *)
  inv1 compound; subst; split_all; discriminate.
(* 1 *)
intro. intro. inversion H0; subst; simpl in *; try (inversion H; fail).
eapply2 IHnor1.
eapply2 IHnor2.
Qed.

Theorem SF_progress : forall (M : SF), normal M \/ (exists N, sf_seqred1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 1 *)
inversion IHM1; split_all. 2: right; inversion H; exist (App x M2).
inversion IHM2; split_all.  2:right; inversion H0; exist (App M1 x).
gen_case H M1. case o; try (right; eauto; fail); left; auto.
inversion H; subst.
(* 2 *)
left; auto.
eapply2 nf_active. gen_case H5 s. gen_case H5 s1. discriminate.
(* 1 *)
gen2_case H3 H5 s.
left; case o; auto.
gen2_case H3 H5 s1.
gen2_case H3 H5 o; try (right; eauto; fail).
inversion H3; subst. inversion H8.
inversion H7; subst. left; eapply2 nf_active.
right; eauto. left; eapply2 nf_active.
right; eauto. inversion H5.
Qed.


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

(** Author: Bruno Barras *)

Require Import Relation_Definitions.

Section WfInclusion.
  Variable A : Type.
  Variables R1 R2 : A -> A -> Prop.

  Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z.
  Proof.
    induction 2.
    apply Acc_intro; auto with sets.
  Qed.

  Hint Resolve Acc_incl.

  Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
  Proof.
    unfold well_founded; auto with sets.
  Qed.

End WfInclusion.


From Coq Require Import EqNat.
From Coq Require Import List.
From VT Require Export Map.
From VT Require Export natutil.

(** machine states *)

(* (Word;Labels) w,f,l ::= i (nat nums) *)
Definition Word := nat.

Definition Label := Word.

Inductive Register : Set :=
  | r0
  | r1
  | r2
  | r3
  | r4
  | r5
  | r6
  | r7
  | r8
  | r9
  | r10
  | r11
  | r12
  | r13
  | r14
  | r15
  | r16
  | r17
  | r18
  | r19
  | r20
  | r21
  | r22
  | r23
  | r24
  | r25
  | r26
  | r27
  | r28
  | r29
  | r30
  | r31.

Inductive Perm: Type :=
  | R
  | W
  | X
  | RW
  | RX
  | WX
  | RWX.

Inductive Command : Set :=
  (* add rd;rs;rt *)
  | add : Register -> Register -> Register -> Command
  (* alloc rd;i *)
  | alloc : Register -> Word -> Command
  (* free rs;i *)
  | free : Register -> Word -> Command
  (* ld rd;rs(i) *)
  | ld : Register -> Register -> Word -> Command
  (* st rd(i);rs *)
  | st : Register -> Word -> Register -> Command
  (* mov rd;rs *)
  | mov : Register -> Register -> Command
  | movi : Register -> Word -> Command.

Inductive InstrSeq : Set :=
  (* c;I *)
  | iseq : Command -> InstrSeq -> InstrSeq
  (* bgti rs;i;f *)
  | bgti : Register -> Word -> Label -> InstrSeq -> InstrSeq
  (* jd f *)
  | jd : Label -> InstrSeq
  (* jmp r *)
  | jmp : Register -> InstrSeq.

(* (RegFile) R ::= {r := w}*)
Definition RegFile := Register -> Word.

(* (CodeHeap) C ::= {f := I} *)
Definition CodeHeap := Map Label InstrSeq.

(* (Heap) H ::= {l := w} *)
Definition Heap := Map Label Word.

(* (State) S ::= (H,R) *)
Definition State := (Heap * RegFile)%type.

(* Program P ::= (C,S,I) *)
Definition Program := (CodeHeap * (State * InstrSeq))%type.

Definition beq_reg (r r' : Register) :=
  match r, r' with
  | r0, r0 => true
  | r1, r1 => true
  | r2, r2 => true
  | r3, r3 => true
  | r4, r4 => true
  | r5, r5 => true
  | r6, r6 => true
  | r7, r7 => true
  | r8, r8 => true
  | r9, r9 => true
  | r10, r10 => true
  | r11, r11 => true
  | r12, r12 => true
  | r13, r13 => true
  | r14, r14 => true
  | r15, r15 => true
  | r16, r16 => true
  | r17, r17 => true
  | r18, r18 => true
  | r19, r19 => true
  | r20, r20 => true
  | r21, r21 => true
  | r22, r22 => true
  | r23, r23 => true
  | r24, r24 => true
  | r25, r25 => true
  | r26, r26 => true
  | r27, r27 => true
  | r28, r28 => true
  | r29, r29 => true
  | r30, r30 => true
  | r31, r31 => true
  | _, _ => false
  end.

(** dynamic semantics *)

(* update register r with value n/R(r') *)
Definition uR (R : RegFile) r n r' := if beq_reg r r' then n else R r'.

(* update memory location l with value v or M(l') *)
Definition uH (H : Heap) l v l' := if beq_nat l l' then Some v else H l'.

(* update #n continuous memory (with arbitrary value) *)
(* The point of the {struct ident} annotation (see fixannot) is to let the user
    tell the system which argument decreases along the recursive calls. *)
Fixpoint uHn (H : Heap) (l : Label) (n : nat) {struct n} : Heap :=
  match n with
  | O => H
  | S n => uH (uHn H (S l) n) l l
  end.

(* free memory l with None or M(l') *)
Definition fH (H : Heap) l l' := if beq_nat l l' then None else H l'.

(* free #n continuous memory *)
Fixpoint fHn (H : Heap) (l : Label) (n : nat) {struct n} : Heap :=
  match n with
  | O => H
  | S n => fH (fHn H (S l) n) l
  end.

(* Operational semantics
    if c = ... then Nextc(H,R) = ... *)
Inductive Next : Command -> State -> State -> Prop :=
  (* add rd;rs;rt => (H;R{rd := R(rs)+R(rt)}) *)
  | stp_add :
      forall rd rs rt M R,
      Next (add rd rs rt) (M, R) (M, uR R rd (R rs + R rt))
  (* mov rd;rs => (H;R{rd := R(rs)}) *)
  | stp_mov :
      forall rd rs M R,
      Next (mov rd rs) (M, R) (M, uR R rd (R rs))
  | stp_movi : forall rd w H R, Next (movi rd w) (H, R) (H, uR R rd w)
  (* ld rd;rs(i) => (H;R{rd := H(R(rs)+i)})
                    when R(rs)+i \in dom(H) *)
  | stp_ld :
      forall rd w rs M R w',
      (* M (R rs + w) = Some w' *)
      lookup M (R rs + w) w' ->
      Next (ld rd rs w) (M, R) (M, uR R rd w')
  (* st rd(i);rs => (H{R(rd)+i := R(rs)};R)
                 when R(rd)+i \in dom(H) *)
  | stp_st :
      forall rd w rs M R w',
      lookup M (R rd + w) w' ->
      Next (st rd w rs) (M, R) (uH M (R rd + w) (R rs), R)
  (* alloc rd;i (M{l := _; ... ;l+i-1 := _};R{rd := l})
              where l;...;l+i-1 != dom(M)
              and _ is a random value *)
  | stp_alloc :
      forall rd M R l n,
      in_dom M l ->
      (forall i, i > l -> not_in_dom M i) ->
      Next (alloc rd n) (M, R) (uHn M (l+1) n, uR R rd (l+1))
  (* free rs;i => (M/{R(rs); ...; R(rs)+i-1},R)
              when R(rs); ...; R(rs)+i-1 \in dom(M) *)
  | stp_free :
      forall rd M R n,
      (forall i, i < n -> in_dom M (R rd + i)) ->
      Next (free rd n) (M, R) (fHn M (R rd) n, R).

(* if I = ... then (C,(H,R),I) |-> *)
Inductive Step : Program -> Program -> Prop :=
  (* c;I' => (C,Nextc(H,R),I') *)
  | stp_iseq :
      forall C S S' c I,
      Next c S S' ->
      Step (C, (S, iseq c I)) (C, (S', I))
  (* bgti rs,i,f;I' => (C,(H,R),I') when R(rs) <= i;
                       (C,(H,R),C(f)) when R(rs) > i *)
  | stp_bgti_lt :
      forall C S rs w l I I',
      (fun S : State => let (_, R) := S in R) S rs > w ->
      lookup C l I' ->
      Step (C, (S, bgti rs w l I)) (C, (S, I'))
  | stp_bgti_leq :
      forall C S rs w l I,
      (fun S : State => let (_, R) := S in R) S rs <= w ->
      Step (C, (S, bgti rs w l I)) (C, (S, I))
  (* jd f => (C,(H,R),C(f)) when f \in dom(C) *)
  | stp_jd :
      forall C S l I,
      lookup C l I ->
      Step (C, (S, jd l)) (C, (S, I))
  (* jmp r => (C,(H,R),C(R(r))) when R(r) \in dom(C) *)
  | stp_jmp :
      forall C S r I,
      lookup C ((fun S : State => let (_, R) := S in R) S r) I ->
      Step (C, (S, jmp r)) (C, (S, I)).

Notation "P |--> Q" := (Step P Q) (at level 150).

Lemma Deterministic:
  forall S S' S'' c, Next c S S' -> Next c S S'' -> S' = S''.
Proof.
  intros.
  destruct H; inversion H0; subst; auto.
  { unfold lookup in H, H7. rewrite H in H7. inversion H7; subst. auto. }
  { generalize (le_or_gt l l0). intros [Hleq | Hgt].
    { unfold gt in H1, H8. unfold lt in H1, H8. destruct Hleq; auto.
      generalize (H8 (S m) (Le.le_n_S l0 m Hleq)).
      destruct H. unfold not_in_dom in *. rewrite H. intros. inversion H2. }
     { generalize (H1 l0 Hgt). destruct H7. unfold not_in_dom in *.
       intros. rewrite H2 in H3. inversion H3. } }
Qed.


Require Import Setoid.
Require Import FunctionalExtensionality.
Set Implicit Arguments.

Require Export Unicode.Utf8_core.
Require Export Coq.Program.Program.
Require Import Relations RelationClasses Setoid.

Definition comp T U V (g:U->V) (f:T->U) := fun x => g (f x).

Lemma eq_rect_sym {A} {Q : A -> Type} (x y : A) (p : Q y) (prf : x = y) :
  eq_rect x Q (eq_rect y Q p x (eq_sym prf)) y prf = p.
Proof. destruct prf. simpl. reflexivity. Qed.

Lemma eq_rect_comm {A} {Q : A -> Type} (x y : A) (p : Q y) (prf : x = y) (prf' : y = x) :
  eq_rect x Q (eq_rect y Q p x prf') y prf = p.
Proof. replace prf' with (eq_sym prf) by apply proof_irrelevance. apply eq_rect_sym. Qed.

Section later_operator.

  Parameter later : Type -> Type.

  Fixpoint nlater n T := match n with
                           | 0 => T
                           | S n' => later (nlater n' T)
                         end.

  Parameter next : forall {T}, T -> later T.

  Parameter switch : later Type -> Type.

  Axiom switch_next : forall (T:Type), switch (next T) = later T.

  Parameter later_arrow : forall T U , later (T -> U) -> (later T -> later U).

  Parameter later_arrow' : forall T U , (later T -> later U) -> later (T -> U).

  (* proofs of the following two axioms should be eq_refl *)

  Axiom later_arrow_comm : forall T U (f:later(T->U)), later_arrow' (later_arrow f) = f.
  Axiom later_arrow_comm' : forall T U (f:later T-> later U), later_arrow (later_arrow' f) = f.

  Definition next_arrow T U (f: T -> U) := later_arrow (next f).

  (* proofs of the following four axioms should be eq_refl *)

  Axiom next_naturality : forall T U (f:T -> U) (v:T), next (f v) = (next_arrow f) (next v).

  Axiom next_arrow_comp : forall T U V (g:U->V) (f:T->U) x,
    next_arrow (comp g f) x = (next_arrow g) ((next_arrow f) x).

  Axiom next_arrow_id : forall T, next_arrow (id (A:=T)) = id (A:=later T).

  Axiom next_arrow_wird : forall T U V (M : forall {n}, nlater n T -> nlater n U -> nlater n V) n g,
    later_arrow ((next_arrow M) (next g)) = M (n := S n) (next g).

  Lemma next_arrow_curry : forall T U V (f: T->U->V) v,
    next_arrow (f v) = later_arrow (next_arrow f (next v)).
  Proof.
    intros; unfold next_arrow at 1; rewrite next_naturality.
    reflexivity.
  Qed.

  Lemma next_arrow_next : forall T U V (M : forall {n}, nlater n T -> nlater n U -> nlater n V) n g,
    next_arrow (M g) = M (n := S n) (next g).
  Proof.
    intros.
    rewrite next_arrow_curry.
    rewrite next_arrow_wird.
    reflexivity.
  Qed.

End later_operator.

Section fixpoint.

  Parameter fix_gen : forall {T}, ((later T) -> T) -> T.

  Notation " '(Σ' x , y ) " := (exist _ x y).

  (* proof of the following axiom should be eq_refl *)

  Axiom eqfix : forall T {G} , fix_gen (T:=T) G = G (next (fix_gen G)).

  Definition fixG := fix_gen (T:=Type).

  Definition fix_fold {G} (t : fixG G) := eq_rect _ id t _ eqfix.

  Definition fix_unfold {G} (t : G(next (fixG G))) := eq_rect _ (id(A:=Type)) t _ (eq_sym eqfix).

  Variable F : Type -> Type.

  Definition mu (F : Type -> Type) := fixG (fun T => F (switch T)).

  Lemma eqmu : mu F = F (later (mu F)).
  Proof.
    rewrite <- switch_next.
    apply (eqfix (G := fun T => F (switch T))).
  Qed.

  Definition fold (t : mu F) : F (later (mu F)) := eq_rect _ (id (A:=Type)) t _ eqmu.

  Definition unfold (t : F(later (mu F))) : mu F := eq_rect _ (id(A:=Type)) t _ (eq_sym eqmu).

  Lemma pi : forall (t : mu F), unfold (fold t) = t.
  Proof.
    intros; unfold fold, unfold.
    rewrite eq_rect_comm; reflexivity.
  Qed.

  Lemma pi' : forall (t : F (later (mu F))), fold (unfold t) = t.
  Proof.
    intros; unfold fold, unfold.
    rewrite eq_rect_comm; reflexivity.
  Qed.

  (*********************************************************)
  (* Definition for a fixpoint for which later_F(') exists *)
  (*********************************************************)

  Variable later_F : forall T, later (F T) -> F (later T).
  Variable later_F' : forall T, F (later T) -> later (F T).

  Variable later_F_comm : forall T (x:later (F T)), later_F' (later_F x) = x.
  Variable later_F_comm' : forall T (x:F (later T)), later_F (later_F' x) = x.

  Fixpoint nfold {n} : nlater n (mu F) -> F (nlater (S n) (mu F)) :=
    match n with
      | 0 => fun x => fold x
      | S n' => fun x => (later_F ((next_arrow nfold) x))
    end.

  Fixpoint nunfold {n} : F (nlater (S n) (mu F)) -> nlater n (mu F) :=
    match n with
      | 0 => fun x => unfold x
      | S n' => fun x => ((next_arrow nunfold) (later_F' x))
    end.

  Lemma npi_aux : forall n, comp nunfold nfold = id (A:= nlater n (mu F)).
  Proof.
    induction n; apply functional_extensionality; unfold comp; simpl; intros.
    apply pi.
    rewrite later_F_comm.
    rewrite <- next_arrow_comp.
    setoid_rewrite IHn.
    rewrite next_arrow_id; reflexivity.
  Qed.

  Lemma npi : forall n (t:nlater n (mu F)), nunfold (nfold t) =  t.
  Proof.
    intros; assert (Haux := npi_aux n).
    eapply equal_f in Haux; apply Haux.
  Qed.

  Lemma npi'_aux : forall n, comp nfold nunfold = id (A:=F (nlater (S n) (mu F))).
  Proof.
    induction n; apply functional_extensionality; unfold comp; simpl; intros.
    apply pi'.
    rewrite <- next_arrow_comp.
    setoid_rewrite IHn.
    rewrite next_arrow_id.
    apply later_F_comm'.
  Qed.

  Lemma npi' : forall n (t:F (nlater (S n) (mu F))), nfold (nunfold t) =  t.
  Proof.
    intros; assert (Haux := npi'_aux n).
    eapply equal_f in Haux; apply Haux.
  Qed.

  Definition next_F T (f: F T) : F (later T) := later_F (next f).

  Lemma fold_next : forall n (f:nlater n (mu F)),
    nfold (n:=S n) (next f) = next_F (nfold f).
  Proof.
    simpl; intros; rewrite <- next_naturality; reflexivity.
  Qed.

  Lemma unfold_next : forall n (f: F (nlater (S n) (mu F))),
    nunfold (n:=S n) (next_F f) = next (nunfold f).
  Proof.
    simpl; intros.
    unfold next_F; rewrite later_F_comm.
    rewrite <- next_naturality; reflexivity.
  Qed.

End fixpoint.

Section pure_lambda_calculus.

  Definition F := fun T => T -> T.
  Definition D := mu F.

  (* specializing the theory of fixpoint for the pure lambda calculus *)

  Definition later_F := (fun T => later_arrow' (T:=T) (U:=T)).
  Definition later_F' := (fun T => later_arrow (T:=T) (U:=T)).
  Definition later_F_comm := (fun T => later_arrow_comm' (T:=T) (U:=T)).
  Definition later_F_comm' := (fun T => later_arrow_comm (T:=T) (U:=T)).

  Definition ffun {n} (t : F (nlater (S n) D)) := nunfold F later_F t.
  Definition defun {n} (t : nlater n D) := nfold F later_F' t.

  Definition piF := npi F later_F' later_F later_F_comm'.
  Definition piF' := npi' F later_F' later_F later_F_comm.

  Definition defun_next := fold_next F later_F'.
  Definition ffun_next := unfold_next F later_F' later_F later_F_comm'.

  (* Definitions specific to the pure lambda calculus *)

  Definition const_fun {n} (t:nlater n D) := fun _ : nlater n D => t.
  Definition lift {n} (t: nlater (S n) D) := ffun (fun x => const_fun t x).
  Definition one_step {n} (x:nlater n D) := lift (next x).

  Definition app {n} (f:nlater n D) (s:nlater n D) := lift ((defun f) (next s)).

  Lemma lift_next : forall n (f:nlater (S n) D), lift (n:=S n) (next f) = next (lift f).
  Proof.
    intros; unfold lift.
    rewrite <- ffun_next.
    (* Lemma foo3 : forall n (f: nlater (S n) D), *)
    (*   (fun x : nlater (S (S n)) D => const_fun (n := S (S n)) (next f) x) = next_arrow (const_fun f). *)
    (* Proof. *)
    (*   intros; apply functional_extensionality; intros. *)
    (*   unfold const_fun. *)
    rewrite <- next_arrow_next.
    reflexivity.
  Qed.

  Lemma app_next : forall n (f:nlater n D) v,
    app (n:=S n) (next f) (next v) = next (app f v).
  Proof.
    intros.
    unfold app.
    rewrite <- lift_next.
    repeat rewrite defun_next.
    setoid_rewrite <- next_naturality.
    reflexivity.
  Qed.

  (* Definition of Omega and its reduction *)

  Definition Omega {n} := ffun (fun x => app (n:=S n) x x).

  Lemma Omega_step : forall n, app (n:=n) Omega Omega = one_step (app Omega Omega).
  Proof.
    intro n; unfold app at 1, Omega at 1.
    unfold defun, ffun.
    rewrite piF'.
    rewrite app_next.
    reflexivity.
  Qed.

  (* Definition of Y and its reduction *)

  Definition Y_aux {n} f := fun x => app (n:=n) f (app x x).

  Definition Y' {n} f := ffun (fun x => Y_aux (n:=S (S n)) (next f) x).

  Definition Y {n} := ffun (fun f => app (n := S n) (Y' f) (Y' f)).

  Lemma Y_aux_next : forall n (g:nlater (S (S n)) D),
    ffun (fun x => Y_aux (n:=S(S(S n))) (next g) x) = next (ffun (Y_aux g)).
  Proof.
    intros; rewrite <- ffun_next.
    rewrite <- next_arrow_next.
    reflexivity.
  Qed.

  Lemma Y'_next : forall n (g:nlater (S n) D), app (Y' (n:=S n) (next g)) (Y' (n:=S n) (next g)) = next (app (Y' (n:=n) g) (Y' (n:=n) g)).
  Proof.
    intros; unfold Y'.
    repeat rewrite <- app_next.
    setoid_rewrite <- (Y_aux_next (next g)).
    reflexivity.
  Qed.

  Lemma Y_step : forall n g , app (n:= S n) Y g = one_step (one_step (app g (app (Y' g) (Y' g)))).
  Proof with repeat rewrite app_next.
    intros n g.
    unfold app at 1, Y at 1, defun at 1; rewrite piF'.
    unfold app at 1, Y' at 1, Y_aux at 1, defun at 1; rewrite piF'...
    rewrite lift_next.
    rewrite Y'_next...
    reflexivity.
  Qed.

End pure_lambda_calculus.


(*
vim: set fenc=utf-8 ff=unix sts=2 sw=2 et ft=coq :
*)
(*
Copyright (C) 2016-2019 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 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.
*)

Require Import Way.Tactics.

Require Import Way.Beta.
Require Import Way.Open.
Require Import Way.Preterm.
Require Import Way.Relation.

(* The small-step conversion relation.

The calculus of constructions and related theories have a notion of type equivalence: if
two well-sorted types are "convertible" then the terms of one are the terms of the other.
Two terms (such as these types) are convertible if they are equal after applying some
sequence of reduction rules, such as those of beta reduction.

This is "small-step" since it has not yet been extended into an equivalence relation.
*)
Inductive step : relation :=

(* Terms are convertible if one beta reduces to the other. *)
| beta : forall (t u : preterm), Beta.beta t u -> step t u.

Hint Constructors step : way.

Definition conversion := equivalence step.

Hint Unfold conversion : way.

Module Examples.

Import Aliases.

Example conversion_relates_terms_with_common_beta_reducts :
  conversion
    (prod
      (app (abs (type 1) (bvar 0)) (type 0))
      (type 0))
    (prod
      (type 0)
      (app (abs (type 1) (bvar 0)) (type 0))).
Proof.
  apply (Equivalence.transitivity Conversion.step (prod (type 0) (type 0)));
  [ | apply Equivalence.symmetry ];
  infer.
Defined.

End Examples.


Require Import List.
Require Import Strings.String.
Import StringSyntax.
Open Scope string.

(* Comp is like Prop, but it allows for runtime errors in the interpreter and quantification. *)
  Inductive Comp : Type :=
  | Ret : Prop -> Comp
  | Err : string -> Comp
  | Forall {A} : (A -> Comp ) -> Comp.

(* Used for sequencing two Comp's. *)
  Fixpoint bind_comp (c : Comp) (f : Prop -> Comp) : Comp :=
    match c with
    | Ret x => f x
    | Err s => Err s
    | Forall f' => Forall (fun x => bind_comp (f' x) f) end.

(* Conjunct two Comp's. *)
  Definition and_comp (c1 c2 : Comp) : Comp :=
    bind_comp c1 (fun p => bind_comp c2 (fun q => Ret (p /\ q))).

  Inductive Ty :=
  | DP | S | ArrL : Ty -> Ty -> Ty
  | ArrR : Ty -> Ty -> Ty
  .

  Fixpoint ty_eq (t1 t2 : Ty) : {t1 = t2} + {t1 <> t2}.
    decide equality.
  Defined.

  Notation "x \ y" := (ArrL x y) (at level 40).
  Notation "x / y" := (ArrR x y).

  Definition VP := DP \ S.
  Definition TV := (DP \ S) / DP.

Module Ling.
  Parameter (E : Set).
  Parameter (mkE : string -> E).
  Parameter (eet : string -> E -> E -> Prop).
  Parameter (ett : string -> Prop -> E -> Prop).
  Parameter (et : string -> E -> Prop).

  Definition alt (p0 : Comp) (f : E -> Comp) (x : E) : Comp :=
    Ret (exists y, p0 = f y /\ x <> y).

  Definition addr := nat.

  Fixpoint val (t : Ty) : Type :=
    match t with
    | DP => E
    | S => Comp
    | ArrL t1 t2 => val t1 -> val t2
    | ArrR t1 t2 => val t2 -> val t1
                                  end.

(* Expressions of the language. *)
  Inductive exp : Ty -> Type :=
  | Val {t} : val t -> exp t (* inject pure values *)
  | undefined {t} : exp t (* undefined *)
  | everyone : exp DP
  | read (x : addr) (t : Ty) : exp t
  | store_cbv {t : Ty} : addr -> exp t -> exp t  (* explained below *)
  | store_cbn {t : Ty} : addr -> exp t -> exp t
  | compl {t1 t2 : Ty} : exp (t1) -> exp (t1 \ t2) -> exp (t2) (* compose left *)
  | compr {t1 t2 : Ty} : exp (t1 / t2) -> exp (t2) -> exp (t1) (* compose right *)
  | foc (s : addr) : exp DP -> exp DP
  | force : exp S -> exp S
  .

  Coercion Val : val >-> exp.

  Notation "x <| y" := (compl x y) (at level 41).
  Notation "x |> y" := (compr x y) (at level 40).

(*
  The heap is interacted with through the read, store_cbv, and store_cbn expressions.

Read takes in a heap index and a type, and returns an expression of that type (possibly undefined).

store_cbv and store_cbn are similar, but differ on what they actually store in the heap. Consider the following:

store_X (read 1 DP) 0 DP

if X is cbv, then the heap at index 0 will be exactly what's at index 1 at this point in time. Thus if 1 is changed later, 0 will stay the sae.

If X is cbn, then the heap at index 0 will  simply be the expression "read 1 DP". Thus if 1 is changed later, reading from index 0 will read the updated value.
*)

  Definition heap := forall (x : addr) (t : Ty), (exp t).

  Definition hset (x : addr) {t : Ty} (e : exp t) (h : heap) : heap.
   intros y t'.
   refine (if Nat.eqb x y then _ else h y t').
   destruct (ty_eq t t').
   rewrite <- e0; apply e.
   apply (h y t').
  Defined.

  Definition heap0 : heap := fun _ _ => undefined.

  (* We give expression semantics through an interpretation function.
  You can ignore the fuel component, it's only there to make Coq accept
the function as terminating.

   The semantics of expressions is mostly standard. The semantics is
continuation-passing, but it also keeps track of the heap. The heap is like the Ctx from before, but less information is tracked statically about what's in the heap. *)

  Fixpoint interp (fuel : nat) {t} (e : exp t) (hp : heap) {struct fuel} :
    ((val t -> heap -> Comp ) -> Comp ) :=
    match fuel with
      | 0 => fun _ => Err "out of fuel"
      | Datatypes.S fuel =>
        match e in exp t1 return (((val t1) -> heap -> Comp ) -> Comp) with
        | Val v => (fun k => (k v hp))
        | undefined => (fun _ => Err "undefined" )
        | everyone => (fun (k : E -> heap -> Comp) =>
                            Forall (fun x => k x hp))
        | read x t =>
           interp fuel (hp x t) hp
        | store_cbv x e => fun k =>
                (interp fuel e hp) (fun v hp' =>
                           k v (hset x (Val v) hp'))
        | store_cbn x e => fun k =>
          (interp fuel e hp) (fun v hp' =>
                           k v (hset x e hp'))
        | compl e1 e2 => fun k =>
                (interp fuel e1 hp) (fun x hp' =>
                        (interp fuel e2 hp') (fun f hp'' =>
                                k (f x) hp''))
        | compr e2 e1 => fun k =>
                (interp fuel e1 hp) (fun x hp' =>
                        (interp fuel e2 hp') (fun f hp'' =>
                                k (f x) hp''))
        (*
  The semantics of foc takes in a propositional antecedent, given by heap index s,
  and does the following:
  it behaves as the underlying expression, but also uses its continuation k to
  compute the focus alternatives. Thus we say that s is in the focus set of k,
  but differs by the value of x. *)
        | foc s e => fun k =>
          (interp fuel (hp s S) hp) (fun s0 _ =>
            (interp fuel e hp) (fun x hp' =>
                                  and_comp (k x hp')
                                           (alt s0 (fun x => k x hp') x)))
    (* Force is like LIFT + LOWER. It delineates a continuation so it cannot scope over the entire matrix clause, but only the subclause we care about. *)
        | force e => fun k =>
           k ((interp fuel e hp) (fun s hp' => s)) hp
            end end.

  Definition vp (s : string) : exp VP := @Val VP (fun x => Ret (et s x)).
  Definition dp (s : string) : exp DP := @Val DP (mkE s).

  Definition Interp {t} (e : exp t) (hp : heap) := interp 15 e hp.

  Definition eval (e : exp S) : (Comp ) :=
    Interp e (fun _ _ => undefined) (fun s hp => s ).

  Definition he (x : addr) := read x DP.

  Definition knows : exp TV :=
    @Val TV (fun x y => Ret (eet "knows" x y)).
  Definition thinks : exp ((DP \ S) / S) :=
    @Val ((DP \ S) / S) (fun x y =>
                           bind_comp x (fun x =>
                              Ret (ett "thinks" x y))).

  Parameter (Of : E -> E -> E).

  (* 's  *)
  Definition s : exp ((DP \ DP) / DP) :=
    @Val ((DP \ DP) / DP) Of.

  Compute (eval (everyone <| (vp "sleeps"))).

  Compute (eval (store_cbv 0 everyone <| (knows |> he 0))).

  Definition johns_coach :=
    store_cbv 0 (dp "john") <| (s |> dp "coach").

  Definition thinks_he_will_win : exp VP :=
    store_cbn 0 (thinks |> (he 0 <| vp "will_win")).

  Compute (eval (johns_coach <| thinks_he_will_win)).

  Definition bills_coach_too :=
    (store_cbv 0 (foc 1 (dp "bill")) <| (s |> dp "coach")) <| (read 0 VP).

  Definition and : exp ((S \ S) / S) :=
    @Val ((S \ S) / S) (fun x y => and_comp x y).

  Compute (eval (store_cbv 1 (johns_coach <| thinks_he_will_win) <| (and |> (force (bills_coach_too))))).

  (*
    simplified, we get:

    thinks (will_win bill) (bill's coach) /\
    thinks (will_win john) (john's coach) /\
    (exists x,
       (thinks (will_win john) (john's coach) =
        thinks (will_win x) (x's coach) /\
        x != bill)) *)


From Undecidability.TM Require Import TM_facts.
From Undecidability.L.TM Require Import TMEncoding.
From Complexity.Complexity Require Import NP Subtypes.
From Undecidability.L Require Import Tactics.LTactics.

(** For each Machine M (with n+1 tapes), we define this problem:
Given n tapes and a sizeBound and a step bound, does there exist a (small enough) first tape such that the machine halts on the resulting n+1 tapes in fewer steps than the step bound? *)

(** We contain this on haltsOrDiverges as our MutiTape2SingleTape-translation probably only knows upper bounds of the step count.  *)
Section mTM.
  Context {sig : finType} {n} (M : TM sig (S n)).

  Definition HaltsOrDiverges_mTM_fixed : Vector.t (tape sig) n * nat * nat -> Prop :=
    fun '(ts, maxSize, steps) =>
      forall t__cert' k res', loopM (initc M (t__cert':::ts)) k = Some res'
                      -> exists t__cert res, sizeOfTape t__cert <= maxSize
                                      /\ loopM (initc M (t__cert:::ts)) steps = Some res.

  Definition mTMGenNP_fixed' := (fun '(ts, maxSize, steps) =>
          exists t1, sizeOfTape t1 <= maxSize /\ exists f, loopM (initc M (t1:::ts)) steps = Some f).

  Definition mTMGenNP_fixed : {x | HaltsOrDiverges_mTM_fixed x} -> Prop :=
    restrictBy HaltsOrDiverges_mTM_fixed mTMGenNP_fixed'.

End mTM.

Arguments mTMGenNP_fixed {_ _} _.

Definition initTape_singleTapeTM (sig : Type) (s : list sig) :=
  match s with
    | [] => niltape sig
    | x::s => @leftof sig x s
  end.

Definition TMGenNP_fixed {sig : finType} (M : TM sig 1)
  := (fun '(ts, maxSize, steps) =>
        exists (cert : list sig), length cert <= maxSize
                            /\ exists res, execTM M [|initTape_singleTapeTM (ts++cert)|] steps = Some res).


Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Functor.Identity.
Require Import Category.Strict.
Require Import Functor.Composition.Core.
Require Import NaturalTransformation.Paths NaturalTransformation.Composition.Core.
Require Import Category.Morphisms FunctorCategory.Core.
Require Import Pseudofunctor.Core Pseudofunctor.RewriteLaws.
Require Import NaturalTransformation.Composition.Laws.
Require Import FunctorCategory.Morphisms.
Require LaxComma.CoreParts.
Require Import Trunc HoTT.Tactics Types.Paths Types.Sigma.

Import Functor.Identity.FunctorIdentityNotations.

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

Local Open Scope morphism_scope.
Local Open Scope category_scope.

(** Quoting David Spivak:

    David: ok
       so an object of [FC ⇓ D] is a pair [(X, G)], where [X] is a
       finite category (or a small category or whatever you wanted)
       and [G : X --> D] is a functor.
       a morphism in [FC ⇓ D] is a ``natural transformation diagram''
       (as opposed to a commutative diagram, in which the natural
       transformation would be ``identity'')
       so a map in [FC ⇓ D] from [(X, G)] to [(X', G')] is a pair
       [(F, α)] where [F : X --> X'] is a functor and
       [α : G --> G' ∘ F] is a natural transformation
       and the punchline is that there is a functor
       [colim : FC ⇓ D --> D]

     David: consider for yourself the case where [F : X --> X'] is
       identity ([X = X']) and (separately) the case where
       [α : G --> G ∘ F] is identity.
       the point is, you've already done the work to get this colim
       functor.
       because every map in [FC ⇓ D] can be written as a composition
       of two maps, one where the [F]-part is identity and one where
       the [α]-part is identity.
       and you've worked both of those cases out already.
       *)

Module Import LaxCommaCategory.
  Include LaxComma.CoreParts.LaxCommaCategoryParts.
  Section lax_comma_category_parts.
    Context `{Funext}.
    Variables A B : PreCategory.

    Variable S : Pseudofunctor A.
    Variable T : Pseudofunctor B.

    Context `{forall a b, IsHSet (Functor (S a) (T b))}.

    Local Notation object := (@object _ A B S T).
    Local Notation morphism := (@morphism _ A B S T).
    Local Notation compose := (@compose _ A B S T).
    Local Notation identity := (@identity _ A B S T).

    Local Ltac t_do_work :=
      repeat match goal with
               | _ => reflexivity
               | [ |- context[components_of ?T^-1 ?x] ]
                 => progress change (T^-1 x) with ((T x)^-1)
               | [ |- context[?F _1 ?m^-1] ]
                 => progress change (F _1 m^-1) with ((F _1 m)^-1)
               | _ => progress repeat iso_collapse_inverse_right'
             end.

    Local Ltac t_start :=
      simpl in *;
      repeat match goal with
               | [ H : ?x = _ |- _ ] => rewrite H; clear H; try clear x
             end;
      path_natural_transformation;
      simpl in *;
      rewrite !Category.Core.left_identity, !Category.Core.right_identity;
      rewrite !composition_of.

    Local Ltac t :=
      t_start;
      rewrite <- !Category.Core.associativity;
      (** A reflective simplifier would be really useful here... *)
      repeat match goal with
               | _ => progress t_do_work
               | [ |- context[components_of ?T ?x] ]
                 => simpl rewrite <- !(commutes_pT_F T)
               | [ |- context[components_of ?T ?x] ]
                 => simpl rewrite <- !(commutes T)
               | _ => iso_move_inverse
             end.

    (** Ugh. The following code constructs the type of the helper lemma:
<<
      Lemma associativity x1 x2 x3 x4
            (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4)
      : compose (compose m3 m2) m1 = compose m3 (compose m2 m1).
      Proof.
        refine (@path_morphism' _ _
                                (compose (compose m3 m2) m1)
                                (compose m3 (compose m2 m1))
                                (Category.Core.associativity _ _ _ _ _ _ _ _)
                                (Category.Core.associativity _ _ _ _ _ _ _ _)
                                _).
        simpl in *.
        repeat match goal with
                 | [ |- context[@morphism_inverse
                                     _ _ _ _
                                     (@isisomorphism_isomorphic
                                        _ _ _
                                        (Category.Morphisms.idtoiso
                                           ?C0
                                           (ap (p_morphism_of ?F (s:=_) (d:=_))
                                               (Category.Core.associativity ?C ?x1 ?x2 ?x3 ?x4 ?m1 ?m2 ?m3))))] ]
                   => generalize (@p_composition_of_coherent_inverse_for_rewrite _ C F x1 x2 x3 x4 m1 m2 m3);
                     generalize (Category.Morphisms.idtoiso
                                   C0
                                   (ap (p_morphism_of F (s:=_) (d:=_))
                                       (Category.Core.associativity C x1 x2 x3 x4 m1 m2 m3)))
                 | [ |- context[Category.Morphisms.idtoiso
                                     ?C0
                                     (ap (p_morphism_of ?F (s:=_) (d:=_))
                                         (Category.Core.associativity ?C ?x1 ?x2 ?x3 ?x4 ?m1 ?m2 ?m3))] ]
                   => generalize (@p_composition_of_coherent_for_rewrite _ C F x1 x2 x3 x4 m1 m2 m3);
                     generalize (Category.Morphisms.idtoiso
                                   C0
                                   (ap (p_morphism_of F (s:=_) (d:=_))
                                       (Category.Core.associativity C x1 x2 x3 x4 m1 m2 m3)))
               end.
        simpl.
        destruct_head morphism.
        destruct_head object.
        simpl in *.
        repeat match goal with
                 | [ |- context[p_composition_of ?F ?x ?y ?z ?m1 ?m2] ]
                   => generalize dependent (p_composition_of F x y z m1 m2)
                 | [ |- context[p_identity_of ?F ?x] ]
                   => generalize dependent (p_identity_of F x)
                 | [ |- context[p_morphism_of ?F ?x] ]
                   => generalize dependent (p_morphism_of F x)
                 | [ |- context[p_object_of ?F ?x] ]
                   => generalize dependent (p_object_of F x)
               end.
        simpl.
        clear.
        repeat (let H := fresh "x" in intro H).
        repeat match goal with H : _ |- _ => revert H end.
        intro.
>> *)

    Lemma associativity_helper
          {x x0 : PreCategory} {x1 : Functor x0 x}
          {x2 x3 : PreCategory} {x4 : Functor x3 x2} {x5 x6 : PreCategory}
          {x7 : Functor x6 x5} {x8 x9 : PreCategory} {x10 : Functor x9 x8}
          {x11 : Functor x9 x6} {x12 : Functor x9 x3} {x13 : Functor x0 x6}
          {x14 : Functor x9 x6} {x15 : Functor x8 x5} {x16 : Functor x x5}
          {x17 : Functor x9 x0} {x18 : Functor x8 x}
          {x19 : NaturalTransformation (x18 o x10) (x1 o x17)}
          {x20 : Functor x0 x3} {x21 : Functor x x2}
          {x22 : NaturalTransformation (x21 o x1) (x4 o x20)}
          {x23 : Functor x8 x2} {x24 : Functor x3 x6} {x25 : Functor x2 x5}
          {x26 : NaturalTransformation (x25 o x4) (x7 o x24)}
          {x27 : Functor x8 x5} {x28 : @Isomorphic (_ -> _) x27 (x25 o x23)%functor}
          {x29 : @Isomorphic (_ -> _) x23 (x21 o x18)%functor}
          {x30 : @Isomorphic (_ -> _) x16 (x25 o x21)%functor}
          {x31 : @Isomorphic (_ -> _) x15 (x16 o x18)%functor}
          {x32 : @Isomorphic (_ -> _) x14 (x13 o x17)%functor}
          {x33 : @Isomorphic (_ -> _) x13 (x24 o x20)%functor}
          {x34 : @Isomorphic (_ -> _) x12 (x20 o x17)%functor}
          {x35 : @Isomorphic (_ -> _) x11 (x24 o x12)%functor}
          {x36 : @Isomorphic (_ -> _) x14 x11}
          (x37 : (x36 : Category.Core.morphism _ _ _) =
                 (x35 ^-1
                      o (x24 oL x34 ^-1 o (associator_1 x24 x20 x17 o ((x33 : Category.Core.morphism _ _ _) oR x17 o (x32 : Category.Core.morphism _ _ _)))))%natural_transformation)
          {x38 : @Isomorphic (_ -> _) x15 x27}
          (x39 : x38 ^-1 =
                 (x31 ^-1 o (x30 ^-1 oR x18) o inverse (associator_1 x25 x21 x18)
                      o (x25 oL (x29 : Category.Core.morphism _ _ _)) o (x28 : Category.Core.morphism _ _ _))%natural_transformation)
    : (x7 oL (x36 : Category.Core.morphism _ _ _)
          o (x7 oL x32 ^-1 o associator_1 x7 x13 x17
                o (x7 oL x33 ^-1 o associator_1 x7 x24 x20 o (x26 oR x20)
                      o associator_2 x25 x4 x20 o (x25 oL x22) o
                      associator_1 x25 x21 x1 o ((x30 : Category.Core.morphism _ _ _) oR x1) oR x17)
                o associator_2 x16 x1 x17 o (x16 oL x19) o associator_1 x16 x18 x10
                o ((x31 : Category.Core.morphism _ _ _) oR x10)) o (x38 ^-1 oR x10))%natural_transformation =
      (x7 oL x35 ^-1 o associator_1 x7 x24 x12 o (x26 oR x12)
          o associator_2 x25 x4 x12
          o (x25
               oL (x4 oL x34 ^-1 o associator_1 x4 x20 x17 o (x22 oR x17)
                      o associator_2 x21 x1 x17 o (x21 oL x19)
                      o associator_1 x21 x18 x10 o ((x29 : Category.Core.morphism _ _ _) oR x10)))
          o associator_1 x25 x23 x10 o ((x28 : Category.Core.morphism _ _ _) oR x10))%natural_transformation.
    Proof.
      Time t. (* 18.647s *)
    Qed.

    Lemma associativity x1 x2 x3 x4
          (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4)
    : compose (compose m3 m2) m1 = compose m3 (compose m2 m1).
    Proof.
      refine (@path_morphism' _ A B S T _ _
                              (compose (compose m3 m2) m1)
                              (compose m3 (compose m2 m1))
                              (Category.Core.associativity _ _ _ _ _ _ _ _)
                              (Category.Core.associativity _ _ _ _ _ _ _ _)
                              _).
      simpl.
      Time apply associativity_helper.
      - Time exact (p_composition_of_coherent_for_rewrite _ _ _ _ _ _ _ _).
      - Time exact (p_composition_of_coherent_inverse_for_rewrite _ _ _ _ _ _ _ _).
    Defined.

    (** Ugh.  To construct the type of this lemma, the code is:
<<
Lemma left_identity (s d : object) (m : morphism s d)
      : compose (identity _) m = m.
      Proof.
        refine (@path_morphism' _ _
                               (compose (identity _) m) m
                               (Category.Core.left_identity _ _ _ _)
                               (Category.Core.left_identity _ _ _ _)
                               _).
        simpl in *.
        repeat match goal with
                 | [ |- context[@morphism_inverse
                                     _ _ _ _
                                     (@isisomorphism_isomorphic
                                        _ _ _
                                        (Category.Morphisms.idtoiso
                                           ?C0
                                           (ap (p_morphism_of ?F (s:=_) (d:=_))
                                               (Category.Core.left_identity ?C ?x ?y ?f))))] ]
                   => generalize (@p_left_identity_of_coherent_inverse_for_rewrite _ C F x y f);
                     generalize (Category.Morphisms.idtoiso
                                   C0
                                   (ap (p_morphism_of F (s:=_) (d:=_))
                                       (Category.Core.left_identity C x y f)))
                 | [ |- context[Category.Morphisms.idtoiso
                                     ?C0
                                     (ap (p_morphism_of ?F (s:=_) (d:=_))
                                         (Category.Core.left_identity ?C ?x ?y ?f))] ]
                   => generalize (@p_left_identity_of_coherent_for_rewrite _ C F x y f);
                     generalize (Category.Morphisms.idtoiso
                                   C0
                                   (ap (p_morphism_of F (s:=_) (d:=_))
                                       (Category.Core.left_identity C x y f)))
               end.
        simpl.
        destruct_head morphism.
        destruct_head object.
        simpl in *.
        repeat match goal with
                 | [ |- context[p_composition_of ?F ?x ?y ?z ?m1 ?m2] ]
                   => generalize dependent (p_composition_of F x y z m1 m2)
                 | [ |- context[p_identity_of ?F ?x] ]
                   => generalize dependent (p_identity_of F x)
                 | [ |- context[p_morphism_of ?F ?x] ]
                   => generalize dependent (p_morphism_of F x)
                 | [ |- context[p_object_of ?F ?x] ]
                   => generalize dependent (p_object_of F x)
               end.
        simpl.
        clear.
        repeat (let H := fresh "x" in intro H).
        repeat match goal with H : _ |- _ => revert H end.
        intro.
>> *)

    Lemma left_identity_helper
          {x x0 : PreCategory} {x1 : Functor x0 x}
          {x2 x3 : PreCategory} {x4 : Functor x3 x2} {x5 x6 : Functor x3 x0}
          {x7 : Functor x2 x} {x8 : NaturalTransformation (x7 o x4) (x1 o x6)}
          {x9 : Functor x2 x} {x10 : Functor x0 x0} {x11 : Functor x x}
          {x12 : @Isomorphic (_ -> _) x11 1%functor} {x13 : @Isomorphic (_ -> _) x10 1%functor}
          {x14 : @Isomorphic (_ -> _) x9 (x11 o x7)%functor} {x15 : @Isomorphic (_ -> _) x5 (x10 o x6)%functor}
          {x16 : @Isomorphic (_ -> _) x5 x6}
          {x17 : (x16 : Category.Core.morphism _ _ _) =
                 (left_identity_natural_transformation_1 x6 o ((x13 : Category.Core.morphism _ _ _) oR x6 o (x15 : Category.Core.morphism _ _ _)))%natural_transformation}
          {x18 : @Isomorphic (_ -> _) x9 x7}
          {x19 : x18 ^-1 =
                 (x14 ^-1 o (x12 ^-1 oR x7)
                      o inverse (left_identity_natural_transformation_1 x7))%natural_transformation}
    : (x1 oL (x16 : Category.Core.morphism _ _ _)
          o (x1 oL x15 ^-1 o associator_1 x1 x10 x6
                o (x1 oL x13 ^-1 o right_identity_natural_transformation_2 x1
                      o left_identity_natural_transformation_1 x1 o
                      ((x12 : Category.Core.morphism _ _ _) oR x1) oR x6) o associator_2 x11 x1 x6 o
                (x11 oL x8) o associator_1 x11 x7 x4 o ((x14 : Category.Core.morphism _ _ _) oR x4)) o
          (x18 ^-1 oR x4))%natural_transformation = x8.
    Proof.
      Time t. (* 3.959 s *)
    Qed.

    Lemma left_identity (s d : object) (m : morphism s d)
    : compose (identity _) m = m.
    Proof.
      refine (@path_morphism' _ A B S T _ _
                              (compose (identity _) m) m
                              (Category.Core.left_identity _ _ _ _)
                              (Category.Core.left_identity _ _ _ _)
                              _).
      simpl.
      Time refine left_identity_helper.
      - exact (p_left_identity_of_coherent_for_rewrite _ _ _ _).
      - exact (p_left_identity_of_coherent_inverse_for_rewrite _ _ _ _).
    Defined.

    (** To generate the type of this helper lemma, we used:
<<
      Lemma right_identity (s d : object) (m : morphism s d)
      : compose m (identity _) = m.
      Proof.
        refine (@path_morphism' _ _
                               (compose m (identity _)) m
                               (Category.Core.right_identity _ _ _ _)
                               (Category.Core.right_identity _ _ _ _)
                               _).
        simpl in *.
        repeat match goal with
                 | [ |- context[@morphism_inverse
                                     _ _ _ _
                                     (@isisomorphism_isomorphic
                                        _ _ _
                                        (Category.Morphisms.idtoiso
                                           ?C0
                                           (ap (p_morphism_of ?F (s:=_) (d:=_))
                                               (Category.Core.right_identity ?C ?x ?y ?f))))] ]
                   => generalize (@p_right_identity_of_coherent_inverse_for_rewrite _ C F x y f);
                     generalize (Category.Morphisms.idtoiso
                                   C0
                                   (ap (p_morphism_of F (s:=_) (d:=_))
                                       (Category.Core.right_identity C x y f)))
                 | [ |- context[Category.Morphisms.idtoiso
                                     ?C0
                                     (ap (p_morphism_of ?F (s:=_) (d:=_))
                                         (Category.Core.right_identity ?C ?x ?y ?f))] ]
                   => generalize (@p_right_identity_of_coherent_for_rewrite _ C F x y f);
                     generalize (Category.Morphisms.idtoiso
                                   C0
                                   (ap (p_morphism_of F (s:=_) (d:=_))
                                       (Category.Core.right_identity C x y f)))
               end.
        simpl.
        destruct_head morphism.
        destruct_head object.
        simpl in *.
        repeat match goal with
                 | [ |- context[p_composition_of ?F ?x ?y ?z ?m1 ?m2] ]
                   => generalize dependent (p_composition_of F x y z m1 m2)
                 | [ |- context[p_identity_of ?F ?x] ]
                   => generalize dependent (p_identity_of F x)
                 | [ |- context[p_morphism_of ?F ?x] ]
                   => generalize dependent (p_morphism_of F x)
                 | [ |- context[p_object_of ?F ?x] ]
                   => generalize dependent (p_object_of F x)
               end.
        simpl.
        clear.
        repeat (let H := fresh "x" in intro H).
        repeat match goal with H : _ |- _ => revert H end.
        intro.
>> *)

    Lemma right_identity_helper
          {x x0 : PreCategory} {x1 : Functor x0 x}
          {x2 x3 : PreCategory} {x4 : Functor x3 x2} {x5 x6 : Functor x3 x0}
          {x7 : Functor x2 x} {x8 : NaturalTransformation (x7 o x4) (x1 o x6)}
          {x9 : Functor x2 x} {x10 : Functor x3 x3} {x11 : Functor x2 x2}
          {x12 : @Isomorphic (_ -> _) x11 1%functor} {x13 : @Isomorphic (_ -> _) x10 1%functor}
          {x14 : @Isomorphic (_ -> _) x9 (x7 o x11)%functor} {x15 : @Isomorphic (_ -> _) x5 (x6 o x10)%functor}
          {x16 : @Isomorphic (_ -> _) x5 x6}
          {x17 : (x16 : Category.Core.morphism _ _ _) =
                 (right_identity_natural_transformation_1 x6 o (x6 oL (x13 : Category.Core.morphism _ _ _) o (x15 : Category.Core.morphism _ _ _)))%natural_transformation}
          {x18 : @Isomorphic (_ -> _) x9 x7}
          {x19 : x18 ^-1 =
                 (x14 ^-1 o (x7 oL x12 ^-1)
                      o inverse (right_identity_natural_transformation_1 x7))%natural_transformation}
    : (x1 oL (x16 : Category.Core.morphism _ _ _)
          o (x1 oL x15 ^-1 o associator_1 x1 x6 x10 o (x8 oR x10)
                o associator_2 x7 x4 x10
                o (x7
                     oL (x4 oL x13 ^-1 o right_identity_natural_transformation_2 x4
                            o left_identity_natural_transformation_1 x4 o
                            ((x12 : Category.Core.morphism _ _ _) oR x4))) o associator_1 x7 x11 x4 o
                ((x14 : Category.Core.morphism _ _ _) oR x4)) o (x18 ^-1 oR x4))%natural_transformation = x8.
    Proof.
      Time t. (* 3.26 s *)
    Qed.

    Lemma right_identity (s d : object) (m : morphism s d)
    : compose m (identity _) = m.
    Proof.
      refine (@path_morphism' _ A B S T _ _
                              (compose m (identity _)) m
                              (Category.Core.right_identity _ _ _ _)
                              (Category.Core.right_identity _ _ _ _)
                              _).
      simpl.
      Time refine right_identity_helper.
      - exact (p_right_identity_of_coherent_for_rewrite _ _ _ _).
      - exact (p_right_identity_of_coherent_inverse_for_rewrite _ _ _ _).
    Defined.
  End lax_comma_category_parts.
End LaxCommaCategory.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.X25519.C64.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 Export Adjoint.UnitCounit.
Require Import Common Category.Morphisms.

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

Local Open Scope natural_transformation_scope.

Section compose.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable E : PreCategory.

  Variable F : Functor C D.
  Variable F' : Functor D E.
  Variable G : Functor D C.
  Variable G' : Functor E D.

  Variable A' : F' ⊣ G'.
  Variable A : F ⊣ G.

  Section morphisms.
    Let ComposeAdjunctionsUnitMorphism'
    : NaturalTransformation (IdentityFunctor C)
                            ((G ∘ G') ∘ (F' ∘ F)).
    Proof.
      pose (Adjunction_Unit A) as η.
      pose (Adjunction_Unit A') as η'.
      refine ((fun (T : NaturalTransformation _ _) (U : NaturalTransformation _ _)
               => NTComposeT T ((G ∘ η' ∘ F) ∘ (U ∘ η))) _ _);
        nt_solve_associator.
    Defined.

    Definition ComposeAdjunctionsUnitMorphism
      := Eval cbv beta iota zeta delta [ComposeAdjunctionsUnitMorphism' NTC_Composable_term]
        in ComposeAdjunctionsUnitMorphism'.

    Let ComposeAdjunctionsCounitMorphism'
    : NaturalTransformation ((F' ∘ F) ∘ (G ∘ G'))
                            (IdentityFunctor E).
    Proof.
      pose (Adjunction_Counit A) as ε.
      pose (Adjunction_Counit A') as ε'.
      refine ((fun (T : NaturalTransformation _ _) (U : NaturalTransformation _ _)
               => NTComposeT ε' (NTComposeT U (NTComposeT (F' ∘ ε ∘ G') T))) _ _);
        nt_solve_associator.
    Defined.

    Definition ComposeAdjunctionsCounitMorphism
      := Eval cbv beta iota zeta delta [ComposeAdjunctionsCounitMorphism' NTC_Composable_term]
        in ComposeAdjunctionsCounitMorphism'.
  End morphisms.

  (* TODO(jgross): speed this up, automate it more *)
  Definition ComposeAdjunctions : F' ∘ F ⊣ G ∘ G'.
  Proof.
    exists ComposeAdjunctionsUnitMorphism
           ComposeAdjunctionsCounitMorphism;
    clear;
    simpl;
    abstract (
        repeat match goal with
                 | _ => intro
                 | _ => reflexivity
                 | _ => progress rewrite ?FIdentityOf, ?LeftIdentity, ?RightIdentity
                 | _ => rewrite <- ?FCompositionOf, Adjunction_UnitCounitEquation1
                 | _ => rewrite <- ?FCompositionOf, Adjunction_UnitCounitEquation2
                 | [ A : _ ⊣ _ |- _ = 1%morphism ]
                   => (etransitivity; [ | apply (Adjunction_UnitCounitEquation1 A) ];
                       instantiate; try_associativity ltac:(f_ap))
                 | [ A : _ ⊣ _ |- _ = 1%morphism ]
                   => (etransitivity; [ | apply (Adjunction_UnitCounitEquation2 A) ];
                       instantiate; try_associativity ltac:(f_ap))
                 | _ => repeat try_associativity_quick ltac:(rewrite <- !FCompositionOf);
                 progress repeat apply ap;
                 rewrite ?FCompositionOf
                 | [ |- appcontext[ComponentsOf ?T] ]
                   => simpl_do_clear try_associativity_quick_rewrite_rev (Commutes T);
                 try_associativity ltac:(apply concat_RightIdentity || apply concat_LeftIdentity)
                 | [ |- appcontext[ComponentsOf ?T] ]
                   => simpl_do_clear try_associativity_quick_rewrite (Commutes T);
                 try_associativity ltac:(apply concat_RightIdentity || apply concat_LeftIdentity)
               end
      ).
  Defined.
End compose.

Infix "o" := ComposeAdjunctions : adjunction_scope.
Infix "∘" := ComposeAdjunctions : adjunction_scope.


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

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

*)

(** Preambule. *)

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

(** Universe structure *)

Notation UUU := Set .

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

[ Inductive Empty_set : Set := . ]

*)

Notation empty := Empty_set.

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

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

*)

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

(** Coproducts .

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

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

Notation coprod := sum .

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

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

(** Dpendent sums.

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

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

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

(*

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

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

*)

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

Check (paths O O) .

(* End of the file uuu.v *)


Require Import Coq.micromega.Psatz.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Export Coq.Logic.Classical.
Require Export Coq.Logic.Classical_Prop.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Coq.Classes.Equivalence.
Require Export Coq.Classes.Morphisms.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.NatChoice.

Definition stream (A: Type): Type := {h: nat -> option A | forall x y, x < y -> h x = None -> h y = None}.

Definition stream_get {A: Type} (h: stream A) (n: nat) := proj1_sig h n.

Coercion stream_get: stream >-> Funclass.

Lemma stream_sound1: forall {A: Type} (h: stream A) (x y: nat), x <= y -> h x = None -> h y = None.
Proof.
  intros ? [h ?] ? ? ?.
  destruct H; auto; simpl.
  apply (e x (S m)).
  lia.
Qed.

Lemma stream_sound2: forall {A: Type} (h: stream A) (x y: nat), x <= y -> (exists a, h y = Some a) -> (exists a, h x = Some a).
Proof.
  intros.
  pose proof stream_sound1 h x y H.
  destruct (h x), (h y), H0; eauto.
  specialize (H1 eq_refl).
  congruence.
Qed.

Lemma stream_extensionality {A: Type}: forall h1 h2: stream A, (forall n, h1 n = h2 n) -> h1 = h2.
Proof.
  intros.
  destruct h1 as [h1 ?H], h2 as [h2 ?H]; simpl in *.
  assert (h1 = h2) by (extensionality n; auto).
  subst h2.
  assert (H0 = H1) by (apply proof_irrelevance).
  subst H1.
  auto.
Qed.

Tactic Notation "stream_extensionality" ident(x) :=
  match goal with
    [ |- ?X = ?Y ] =>
     apply stream_extensionality; intro x
  end.

Definition is_n_stream {A: Type} (n: nat) (h: stream A): Prop :=
  h n = None /\ forall n', n' < n -> h n' <> None.

Definition is_fin_stream {A: Type} (h: stream A): Prop :=
  exists n, h n = None.

Definition is_inf_stream {A: Type} (h: stream A): Prop :=
  forall n, h n <> None.

Definition is_at_least_n_stream {A: Type} (n: nat) (h: stream A): Prop :=
  forall n', n' < n -> h n' <> None.

Definition is_at_most_n_stream {A: Type} (n: nat) (h: stream A): Prop :=
  h n = None.

Definition is_empty_stream {A: Type}: stream A -> Prop :=
  is_n_stream 0.

Lemma n_stream_inf_stream_conflict {A: Type}: forall (h: stream A) (n: nat),
  is_n_stream n h ->
  is_inf_stream h ->
  False.
Proof.
  intros.
  destruct H.
  exact (H0 _ H).
Qed.

Lemma is_n_stream_pf {A: Type}: forall (h: stream A) (n m: nat),
  is_n_stream m h ->
  is_n_stream n h ->
  n = m.
Proof.
  intros ?.
  assert (forall n m, n < m -> is_n_stream m h -> is_n_stream n h -> False).
  {
    intros.
    destruct H0, H1.
    specialize (H2 n H).
    congruence.
  }
  intros; destruct (lt_eq_lt_dec n m) as [[?H | ?H] | ?H].
  + specialize (H _ _ H2 H0 H1); contradiction.
  + auto.
  + specialize (H _ _ H2 H1 H0); contradiction.
Qed.

Lemma at_most_n_stream_Sn {A: Type}: forall (h: stream A) (n: nat),
  is_at_most_n_stream (S n) h <->
  is_at_most_n_stream n h \/ is_n_stream (S n) h.
Proof.
  intros.
  split; [intro | intros [? | ?]].
  + destruct (h n) eqn:?H.
    - right.
      split; auto.
      intros; intro.
      rewrite (stream_sound1 h n' n) in H0 by (auto; lia).
      congruence.
    - left.
      auto.
  + hnf in H |- *.
    rewrite (stream_sound1 h n (S n)) by (auto; lia).
    auto.
  + destruct H; auto.
Qed.

Lemma at_most_n_stream_0 {A: Type}: forall (h: stream A),
  is_at_most_n_stream 0 h <-> is_n_stream 0 h.
Proof.
  intros; split; intros.
  + split; auto.
    intros; lia.
  + destruct H; auto.
Qed.

Lemma at_most_n_stream_spec {A: Type}: forall (h: stream A) (n: nat),
  is_at_most_n_stream n h <->
  exists m, m <= n /\ is_n_stream m h.
Proof.
  intros.
  induction n.
  + rewrite at_most_n_stream_0.
    split; intros.
    - exists 0; split; [lia | auto].
    - destruct H as [m [? ?]].
      replace m with 0 in H0 by lia.
      auto.
  + rewrite at_most_n_stream_Sn.
    rewrite IHn.
    split; intros.
    - destruct H as [[m [? ?]] | ?].
      * exists m; split; [lia | auto].
      * exists (S n); split; [lia | auto].
    - destruct H as [m [? ?]].
      destruct (le_gt_dec m n).
      * left; exists m; split; auto.
      * right.
        replace (S n) with m by lia.
        auto.
Qed.

Lemma is_fin_stream_spec {A}: forall (h: stream A),
  is_fin_stream h <-> exists n, is_n_stream n h.
Proof.
  intros.
  split; intro.
  + destruct H as [n ?].
    apply at_most_n_stream_spec in H.
    destruct H as [m [? ?]].
    exists m; auto.
  + destruct H as [n [? ?]].
    exists n; auto.
Qed.

Lemma at_most_n_stream_mono {A: Type}: forall (h: stream A) (n m: nat),
  n <= m ->
  is_at_most_n_stream n h ->
  is_at_most_n_stream m h.
Proof.
  intros.
  rewrite at_most_n_stream_spec in H0 |- *.
  destruct H0 as [m0 [? ?]].
  exists m0.
  split; [lia | auto].
Qed.

Lemma at_most_n_stream_is_fin_stream {A: Type}: forall (h: stream A) (n: nat),
  is_at_most_n_stream n h ->
  is_fin_stream h.
Proof.
  intros.
  rewrite at_most_n_stream_spec in H.
  rewrite is_fin_stream_spec.
  destruct H as [m [? ?]].
  exists m; auto.
Qed.

Lemma n_stream_or_inf_stream {A: Type}: forall (h: stream A),
  (exists n, is_n_stream n h) \/ is_inf_stream h.
Proof.
  intros.
  destruct (classic (is_fin_stream h)).
  + left.
    rewrite is_fin_stream_spec in H.
    auto.
  + right.
    hnf; intros; intro.
    apply H; clear H.
    exists n; auto.
Qed.

Lemma at_least_n_stream_Sn {A: Type}: forall (h: stream A) (n: nat),
  is_at_least_n_stream (S n) h <->
  is_at_least_n_stream n h /\ ~ is_n_stream n h.
Proof.
  intros.
  split; [intro | intros [? ?]].
  + split.
    - hnf in H |- *.
      intros; apply H; lia.
    - intros [? ?].
      exact (H n (le_n _) H0).
  + hnf in H |- *.
    intros; intro.
    apply H0; clear H0.
    split.
    - specialize ((fun HH => H n' HH H2): ~ n' < n).
      replace n with n' by lia; auto.
    - intros; apply H; auto.
Qed.

Lemma at_least_n_stream_0 {A: Type}: forall (h: stream A),
  is_at_least_n_stream 0 h <-> True.
Proof.
  intros.
  split; auto.
  intros _.
  hnf; intros.
  lia.
Qed.

Lemma at_least_n_stream_spec {A: Type}: forall (h: stream A) (n: nat),
  is_at_least_n_stream n h <->
  (exists m, m >= n /\ is_n_stream m h) \/ is_inf_stream h.
Proof.
  intros.
  induction n.
  + rewrite at_least_n_stream_0.
    split; auto; intros _.
    destruct (n_stream_or_inf_stream h) as [[m ?] | ?].
    - left; exists m; split; [lia | auto].
    - right; auto.
  + rewrite at_least_n_stream_Sn.
    rewrite IHn.
    split; intros.
    - destruct H as [[[m [? ?]] | ?] ?].
      * left; exists m; split; [| auto].
        destruct (Nat.eq_dec m n); [subst; tauto | lia].
      * right; auto.
    - destruct H as [[m [? ?]] | ?].
      * split.
       ++ left; exists m; split; [lia | auto].
       ++ intro.
          pose proof (is_n_stream_pf _ _ _ H0 H1).
          lia.
      * split.
       ++ right; auto.
       ++ intros [? ?].
          exact (H _ H0).
Qed.

Lemma is_inf_stream_spec {A}: forall (h: stream A),
  is_inf_stream h <-> forall n, ~ is_n_stream n h.
Proof.
  intros.
  split; intro.
  + intros.
    intros [? ?].
    exact (H _ H0).
  + destruct (n_stream_or_inf_stream h) as [[m ?] | ?]; [| auto].
    exfalso.
    exact (H _ H0).
Qed.

Lemma at_least_n_stream_mono {A: Type}: forall (h: stream A) (n m: nat),
  n <= m ->
  is_at_least_n_stream m h ->
  is_at_least_n_stream n h.
Proof.
  intros.
  rewrite at_least_n_stream_spec in H0 |- *.
  destruct H0 as [[m0 [? ?]] | ?].
  + left; exists m0.
    split; [lia | auto].
  + right; auto.
Qed.

Lemma inf_stream_is_at_least_n_stream_is_fin_stream {A: Type}: forall (h: stream A) (n: nat),
  is_inf_stream h ->
  is_at_least_n_stream n h.
Proof.
  intros.
  rewrite at_least_n_stream_spec.
  auto.
Qed.

Lemma at_most_n_stream_or_at_least_Sn_stream {A: Type}: forall (h: stream A) (n: nat),
  is_at_most_n_stream n h \/ is_at_least_n_stream (S n) h.
Proof.
  intros.
  destruct (n_stream_or_inf_stream h) as [[m ?] | ?]; [destruct (lt_dec n m) |].
  + right.
    rewrite at_least_n_stream_spec.
    left; exists m.
    split; [lia | tauto].
  + left.
    rewrite at_most_n_stream_spec.
    exists m.
    split; [lia | tauto].
  + right.
    rewrite at_least_n_stream_spec.
    right; auto.
Qed.

Lemma at_most_n_stream_or_at_least_n_stream {A: Type}: forall (h: stream A) (n: nat),
  is_at_most_n_stream n h \/ is_at_least_n_stream n h.
Proof.
  intros.
  destruct (at_most_n_stream_or_at_least_Sn_stream h n).
  + left; auto.
  + right.
    eapply at_least_n_stream_mono; [| eassumption].
    lia.
Qed.

(*
Definition stream_coincide {A: Type} (n: nat) (h1 h2: stream A): Prop :=
  forall m, m < n -> h1 m = h2 m.

Definition stream_app {A: Type} (h1 h2 h: stream A): Prop :=
  exists n,
    h1 n = None /\
    stream_coincide n h1 h /\
    (forall m, h (m + n) = h2 m).

Definition prefix_stream {A: Type} (h1 h2: stream A): Prop :=
  forall n, h1 n = None \/ h1 n = h2 n.

Definition strict_prefix_stream {A: Type} (h1 h2: stream A): Prop :=
  prefix_stream h1 h2 /\ exists n, h1 n <> h2 n.

Definition n_bounded_prefix_stream {A: Type} (m: nat) (h1 h2: stream A): Prop :=
  forall n, (h1 n = None /\ h2 (n + m) = None) \/ h1 n = h2 n.

Lemma stream_coincide_sym {A: Type}: forall (h1 h2: stream A) n,
  stream_coincide n h1 h2 ->
  stream_coincide n h2 h1.
Proof.
  intros.
  hnf; intros.
  specialize (H m H0); congruence.
Qed.

Lemma stream_coincide_trans {A: Type}: forall (h1 h2 h3: stream A) n,
  stream_coincide n h1 h2 ->
  stream_coincide n h2 h3 ->
  stream_coincide n h1 h3.
Proof.
  intros.
  hnf; intros.
  specialize (H m H1);
  specialize (H0 m H1); congruence.
Qed.

Lemma stream_coincide_weaken {A: Type}: forall n m (h1 h2: stream A),
  n <= m ->
  stream_coincide m h1 h2 ->
  stream_coincide n h1 h2.
Proof.
  intros.
  intros n0 ?.
  apply H0.
  lia.
Qed.

Lemma is_n_stream_None {A: Type}: forall n m (h: stream A), n <= m -> is_n_stream n h -> h m = None.
Proof.
  intros.
  destruct H0.
  apply (stream_sound1 h n m); auto.
Qed.

Lemma fstn_stream_coincide {A: Type}: forall n (h: stream A),
  stream_coincide n h (fstn_stream n h).
Proof.
  intros.
  intros m ?.
  rewrite fstn_stream_Some by lia.
  auto.
Qed.

Lemma prefix_stream_refl {A: Type}: forall (h: stream A), prefix_stream h h.
Proof.
  intros.
  hnf; intros.
  right; auto.
Qed.

Lemma prefix_stream_trans {A: Type}: forall (h1 h2 h3: stream A), prefix_stream h1 h2 -> prefix_stream h2 h3 -> prefix_stream h1 h3.
Proof.
  intros.
  hnf in H, H0 |- *; intros.
  specialize (H n); specialize (H0 n).
  destruct H, H0.
  + left; auto.
  + left; auto.
  + left; congruence.
  + right; congruence.
Qed.

Lemma prefix_stream_anti_sym {A: Type}: forall (h1 h2: stream A), prefix_stream h1 h2 -> prefix_stream h2 h1 -> h1 = h2.
Proof.
  intros.
  stream_extensionality n.
  hnf; intros.
  specialize (H n); specialize (H0 n).
  destruct H, H0; congruence.
Qed.

Lemma prefix_stream_comparable {A: Type}: forall (h1 h2 h: stream A), prefix_stream h1 h -> prefix_stream h2 h -> prefix_stream h1 h2 \/ prefix_stream h2 h1.
Proof.
  intros.
  destruct (classic (exists n, h1 n <> h2 n /\ h1 n <> None)); [right | left].
  + hnf; intros.
    destruct H1 as [m [? ?]].
    destruct (H0 n); [auto |].
    destruct (H n); [| right; congruence].
    assert (m < n).
    Focus 1. {
      destruct (le_dec n m); try lia.
      exfalso; apply H2.
      eapply stream_sound1; eauto.
    } Unfocus.
    destruct (H m); [congruence |].
    destruct (H0 m); [| congruence].
    left.
    apply stream_sound1 with m; auto. lia.
  + hnf; intros n.
    destruct (classic (h1 n = None)), (classic (h1 n = h2 n)); try tauto.
    exfalso.
    apply H1.
    eexists; eauto.
Qed.

Lemma fstn_stream_finite {A: Type}: forall n (h: stream A), is_fin_stream (fstn_stream n h).
Proof.
  intros.
  exists n.
  rewrite fstn_stream_None; auto.
Qed.

Lemma fstn_stream_prefix {A: Type}: forall n (h: stream A), prefix_stream (fstn_stream n h) h.
Proof.
  intros.
  hnf; intros m.
  destruct (le_dec n m).
  + rewrite fstn_stream_None; auto.
  + rewrite fstn_stream_Some; auto.
    lia.
Qed.

Lemma prefix_stream_coincide {A: Type}: forall n (h1 h2: stream A),
  prefix_stream h1 h2 ->
  is_at_least_n_stream n h1 ->
  stream_coincide n h1 h2.
Proof.
  intros.
  hnf; intros.
  specialize (H m).
  specialize (H0 m H1).
  tauto.
Qed.

Lemma is_at_least_n_stream_fstn_stream {A: Type}: forall n m (h: stream A), n <= m -> (is_at_least_n_stream n (fstn_stream m h) <-> is_at_least_n_stream n h).
Proof.
  intros.
  split; intros; hnf; intros.
  + specialize (H0 n' H1).
    rewrite fstn_stream_Some in H0 by lia.
    auto.
  + specialize (H0 n' H1).
    rewrite fstn_stream_Some by lia.
    auto.
Qed.

Lemma squeeze_stream_coincide {A: Type}: forall n (h1 h2: stream A),
  prefix_stream (fstn_stream n h1) h2 ->
  prefix_stream h2 h1 ->
  stream_coincide n h1 h2.
Proof.
  intros.
  hnf; intros.
  specialize (H m).
  specialize (H0 m).
  rewrite fstn_stream_Some in H by auto.
  destruct H, H0; congruence.
Qed.

Fixpoint app_fin_inf {A: Type} (l: list A) (f: nat -> A) :=
  match l with
  | nil => f
  | qa :: l0 => fun n =>
                match n with
                | 0 => qa
                | S m => app_fin_inf l0 f m
                end
  end.

Lemma app_fin_inf_list {A: Type}: forall l (h: nat -> A) m, m < length l -> Some (app_fin_inf l h m) = nth_error l m.
Proof.
  intros.
  revert l H; induction m; intros; simpl.
  + destruct l; [simpl in H; lia |].
    simpl; auto.
  + destruct l; [simpl in H; lia |].
    simpl.
    apply IHm.
    simpl in H; lia.
Qed.

Lemma app_fin_inf_fun {A: Type}: forall l (h: nat -> A) m, length l <= m -> app_fin_inf l h m = h (m - length l).
Proof.
  intros.
  revert m H; induction l; intros; simpl.
  + f_equal; lia.
  + destruct m; [simpl in H; lia |].
    rewrite IHl by (simpl in H; lia).
    f_equal.
Qed.

Lemma length_firstn_list_from_fun: forall {A} (f: nat -> A) n, length (fisrtn_list_from_fun f n) = n.
Proof.
  intros.
  induction n; simpl; auto.
  rewrite app_length, IHn.
  simpl.
  lia.
Qed.

Lemma nth_error_firstn_list_from_fun: forall {A} (f: nat -> A) n m, m < n -> nth_error (fisrtn_list_from_fun f n) m = Some (f m).
Proof.
  intros.
  revert m H; induction n; intros; simpl.
  + lia.
  + destruct (le_dec n m).
    - assert (n = m) by lia; subst.
      replace m with (length (fisrtn_list_from_fun f m) + 0) at 3 by (rewrite length_firstn_list_from_fun; lia).
      rewrite nth_error_app.
      simpl; auto.
    - rewrite nth_error_app1 by (rewrite length_firstn_list_from_fun; lia).
      apply IHn; lia.
Qed.

Lemma fstn_app_inf_fin {A: Type}: forall l (h: nat -> A) n,
  n >= length l ->
  fstn_stream n (inf_stream (app_fin_inf l h)) = fin_stream (l ++ fisrtn_list_from_fun h (n - length l)).
Proof.
  intros.
  stream_extensionality m.
  destruct (le_dec n m).
  + rewrite fstn_stream_None by auto.
    simpl.
    symmetry.
    apply nth_error_None_iff.
    rewrite app_length.
    rewrite length_firstn_list_from_fun.
    lia.
  + rewrite fstn_stream_Some by lia.
    simpl.
    destruct (le_dec (length l) m).
    - rewrite app_fin_inf_fun by auto.
      replace m with (length l + (m - length l)) at 2 by lia.
      rewrite nth_error_app.
      rewrite nth_error_firstn_list_from_fun by lia.
      auto.
    - rewrite nth_error_app1 by lia.
      rewrite app_fin_inf_list by lia.
      auto.
Qed.

Lemma inf_stream_construction {A: Type}: forall (P: stream A -> Prop) (init: list A),
  P (fin_stream init) ->
  (forall l, P (fin_stream l) -> exists qa, P (fin_stream (l ++ qa :: nil))) ->
  exists h, is_inf_stream h /\ forall n, n >= length init -> P (fstn_stream n h).
Proof.
  intros.
  pose (Q := fun l => P (fin_stream (init ++ l))).
  destruct (nat_stepwise_choice Q) as [h ?].
  + hnf.
    rewrite app_nil_r; auto.
  + subst Q; simpl; intros.
    specialize (H0 _ H1).
    destruct H0 as [qa ?]; exists qa.
    rewrite app_assoc.
    auto.
  + exists (inf_stream (app_fin_inf init h)).
    split; [apply inf_stream_inf |].
    intros.
    specialize (H1 (n - length init)).
    unfold Q in H1.
    rewrite (fstn_app_inf_fin init h n) by auto.
    auto.
Qed.

*)


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

From HoTT Require Import Basics.
From WildCat Require Import Basics Cat1.

Generalizable Variables m n X A B.

(** * Product categories *)

(** For now, we assume that [A] and [B] have the same invertibility dimension.  We could instead let them be different and take the min for the dimension of the product. *)

CoFixpoint isglob_prod `{IsGlob n A} `{IsGlob n B}
  : IsGlob n (A * B).
Proof.
  unshelve econstructor.
  - intros [a1 b1] [a2 b2]; exact ((a1 $-> a2) * (b1 $-> b2)).
  - intros [a1 b1] [a2 b2]. rapply isglob_prod.
Defined.

Global Existing Instance isglob_prod.

CoFixpoint isfunctor0_prod
           `{IsGlob m A1} `{IsGlob n B1} `{IsGlob m A2} `{IsGlob n B2}
           (F1 : A1 -> B1) (F2 : A2 -> B2)
           `{!IsFunctor0 F1} `{!IsFunctor0 F2}
  : IsFunctor0 (fun z:A1*A2 => (F1 (fst z), F2 (snd z))).
Proof.
  simple notypeclasses refine (Build_IsFunctor0 _ _ _).
  - intros [a1 a2] [b1 b2] [f1 f2]; cbn.
    exact (fmap F1 f1 , fmap F2 f2).
  - intros; cbn; apply isfunctor0_prod; apply isfunctor0_fmap.
Defined.

CoFixpoint iscat0_prod `{IsCat0 n A} `{IsCat0 n B}
  : IsCat0 n (A * B).
Proof.
  unshelve econstructor.
  - intros [a1 b1] [a2 b2] [a3 b3] [f1 g1] [f2 g2].
    exact (f1 $o f2, g1 $o g2).
  - intros [a1 b1].
    exact (cat_id a1, cat_id b1).
  - intros [a1 b1] [a2 b2] [a3 b3] [h k]; cbn.
    apply isfunctor0_prod; apply isfunctor0_postcomp.
  - intros [a1 b1] [a2 b2] [a3 b3] [h k]; cbn.
    refine (isfunctor0_prod (fun g => g $o h) (fun g => g $o k)).
  - intros ? [a1 b1] [a2 b2] [f g]; exact (f^$, g^$).
  - intros; rapply iscat0_prod.
Defined.

Global Existing Instance iscat0_prod.

CoFixpoint isfunctor0_pair `{IsGlob m X} `{IsGlob n A} `{IsGlob n B}
           (F : X -> A) `{!IsFunctor0 F} (G : X -> B) `{!IsFunctor0 G}
  : IsFunctor0 (fun x => (F x, G x)).
Proof.
  simple notypeclasses refine (Build_IsFunctor0 _ _ _).
  - intros x y f; exact (fmap F f, fmap G f).
  - intros x y; rapply isfunctor0_pair.
Defined.

Global Existing Instance isfunctor0_pair.

(** TODO: HasEquivs, 1-coherent categories *)


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.Base.

(* A well kinded type is well formed *)
Lemma kind_wfT
 :  forall ke sp t k
 ,  KindT   ke sp t k
 -> WfT (length ke) t.
Proof.
 intros ke sp t k HK. gen ke sp k.
 induction t; intros; inverts_kind; burn.
 lets D: IHt H4. burn.
Qed.
Hint Resolve kind_wfT.

Lemma kind_wfT_Forall
 :  forall ks sp k ts
 ,  Forall (fun t => KindT ks sp t k) ts
 -> Forall (WfT (length ks)) ts.
Proof.
 intros. norm. eauto.
Qed.
Hint Resolve kind_wfT_Forall.

Lemma kind_wfT_Forall2
 :  forall  (ke: kienv) (sp: stprops) ts ks
 ,  Forall2 (KindT ke sp) ts ks
 -> Forall  (WfT (length ke)) ts.
Proof.
 intros.
 eapply (Forall2_Forall_left (KindT ke sp)); burn.
Qed.
Hint Resolve kind_wfT_Forall2.

(* If a type is well kinded in an empty environment,
   then that type is closed. *)
Lemma kind_empty_is_closed
 :  forall sp t k
 ,  KindT   nil sp t k
 -> ClosedT t.
Proof.
 intros.
 have (@length ki nil = 0).
  rewrite <- H0.
  eapply kind_wfT. eauto.
Qed.
Hint Resolve kind_empty_is_closed.


(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph.
From mathcomp Require Import bigop order ssralg ssrnum ssrint.
From fourcolor Require Import hypermap geometry part.

(******************************************************************************)
(* Discharging arities to neighbouring faces. We specify how to compute the   *)
(* discharge 'score' of a face, using the 32 rules given by Robertson et al.  *)
(* to move charges across edges, and prove that some face has a positive      *)
(* score (called 'charge' by Robertson et. al). Each rule specifies a score   *)
(* adjustment between neighbouring faces, and is represented here by one or   *)
(* two part objects:                                                          *)
(*  drule1, drule2, ..., drule32 == the part encodings of discharge rules.    *)
(*  base_drules == the list of all discharge rules, with multiplicity. This   *)
(*                 list has 38 items, as drule1 is duplicated (it transfers 2 *)
(*                 points), drule2 and drule3 are specialized by hub arity    *)
(*                 (we use exact_fitp), drule10 and drule31 are specialized   *)
(*                 according to symmetry, and drule3 is specialized to let    *)
(*                 the mirror_part operation return an exact result.          *)
(*   the_drules == the exact list of parts used to adjust the initial scores. *)
(*                 Each part fitting at a dart x tranfers one unit from the   *)
(*                 face of x to that of edge (face^2 x); the two-face shift   *)
(*                 facilitates the use of the converse_part operation.        *)
(*   symmetrize_drules rs == complete the drule sequence by adding all the    *)
(*                 symmetrics of non-symmetrical part, where th symmetry is   *)
(*                 reflection across the third spoke; used to get the_drules. *)
(*     dscore x == the discharge score of the face F of x: 10 * (6 - #|F|),   *)
(*                 plus the adjustments from the_drules.                      *)
(*    dscore1 x == the score transferred from the face of x to that of edge x *)
(*                 (the number of parts in the_drules that fit face^-2 x).    *)
(*    dscore2 x == the total adjustment across the (edge x, x) edge, i.e.,    *)
(*                 dscore1 (edge x) - dscore1 x.                              *)
(* Specialization of drules to a given hub arity, or to a given part.         *)
(* pick_source_drules n rs == the parts in rs with size n, that is, the rules *)
(*                 for taking score units from the hub face.                  *)
(* pick_target_drules n rs == the converse of parts in rs compatible with hub *)
(*                 size n; these are the drules for adding score units to the *)
(*                 hub face.                                                  *)
(*  drule_fork n == a record type for the specializations of the_drules to    *)
(*                 hub size n, with fields cource_drules and target_drules,   *)
(*                 and a witness of the drule_fork_values predicate family    *)
(*                 asserting that these are the result of the pick_..._drules *)
(*                 functions above applied to the_drules.                     *)
(*  sort_drules p rs == a record, of type sort_drules_result, with fields     *)
(*                 nb_forced_drules, the number of rules in rs implied by p   *)
(*                 (whose part representation contains p); and field          *)
(*                 straddling_drules, the rules in rs that ar neither implied *)
(*                 nor excluded by p.                                         *)
(* --> sort_drules is used to compute bounds on scores to prune the           *)
(* combinatorial enumeration of parts. The correctness lemmas for those       *)
(* bounds use the following auxiliary definitions:                            *)
(*  dbound1 rs x == the number of part sectors in rs that fit at x.           *)
(*  dbound2 tr sr x == the number of part sectors in tr that fit at x, minus  *)
(*                 the number of those in sr that fit at x.                   *)
(*    dboundK n == 10 * (6 - n).                                              *)
(*  sort_drules_spec x srs m <-> predicate family, stating: for some m0, rs   *)
(*                 srs = SortDrulesResult m0 rs and m = m0 + dbound1 rs x.    *)
(******************************************************************************)

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

Definition drules := seq part.

Section DischargeRules.

Import PartSyntax.

Definition drule1 := Part $ * $ * $ 6+ $ * $ * $.

Definition drule2  := Part $ * $ 5 $ 7+ $ * $ * $.
Definition drule2' := Part $ * $ 5 $ 7+ $ * $ * $ * $.

Definition drule3  := Part $ 5 $ 6- $ 6+ $ * $ * $.
Definition drule3' := Part $ 5 $ 6- $ 6+ $ * $ * $ * $.

Definition drule4  := Part $ 6- $[5] 5 $ 6+ $ * $ * $ * $.
Definition drule4' := Part $ 6- $[5] 6 $ 6+ $ * $ * $ * $.

Definition drule5 := Part $ 6 $[6- 5] 6 $ 6+ $ * $ * $ * $.

Definition drule6 := Part $ 6 $[6-] 5 $[5] 7+ $ * $ * $ * $.

Definition drule7 := Part $ 6 $[6 6-] 6 $[5] 7+ $ * $ * $ * $.

Definition drule8 := Part $ 5 $ 6- $ 7+ $ * $ * $ * $ * $.

Definition drule9 := Part $ 6- $ 6- $ 7+ $ * $ * $ * $ 5 $.

Definition drule10  := Part $ 5 $ 5 $ 7+ $ 5 $ 6+ $ * $ * $.
Definition drule10' := Part $ 5 $ 5 $ 7+ $ 5 $ 5 $ * $ * $.

Definition drule11 := Part $ 6 $[5] 5 $ 7+ $ 5 $ 6+ $ * $ * $.

Definition drule12 := Part $ 5 $[5] 5 $ 7+ $ 5 $[5] 5 $ * $ * $.

Definition drule13 := Part $ 6 $[5] 5 $[5] 8+ $ 5 $ 5 $ * $ * $.

Definition drule14 := Part $ 5 $[5] 6 $ 7+ $ 5 $ * $ * $ * $.

Definition drule15 := Part $ 5 $ 6 $ 7+ $ 5 $ 7+ $ 5 $ 6 $.

Definition drule16 := Part $ 6 $ 6 $ 7+ $ 5 $ 5 $ 5 $ 6 $.

Definition drule17 := Part $ 5 $[6] 6 $ 7+ $ 5 $ 5 $ 7+ $ 5 $.

Definition drule18 := Part $ 6 $[5] 5 $[5] 7 $ 6+ $ * $ * $ 5 $.

Definition drule19 := Part $ 6 $ 6+ $ 8+ $[5] 5 $[5] 6 $ 5 $ 6 $.

Definition drule20 := Part $ 5 $ 6 $ 7+ $ 6 $ 6 $ 5 $ 5 $.

Definition drule21 := Part $ 6- $ 6 $[5] 7 $ 6+ $ * $ 5 $ 5 $.

Definition drule22 := Part $ 5 $ 6 $[5] 7 $ 6+ $ * $ 5 $ 6 $.

Definition drule23 := Part $ 5 $[5] 7 $ 7+ $ 5 $ * $ * $ * $.

Definition drule24 := Part $ 5 $ 5 $[5] 7 $ 7+ $ 6 $ 6 $ 5 $.

Definition drule25 := Part $ 5 $ 5 $ 7+ $[* * 5] 7 $[6] 5 $ 5 $ * $.

Definition drule26 := Part $ 6 $ 6 $[5] 7 $ 7+ $ 5 $ 5 $ 6 $.

Definition drule27 := Part $ 7+ $ 6 $[6 5 6+] 7 $ 7 $[5] 6- $ * $ * $.

Definition drule28 := Part $ 5 $ 5 $ 7+ $ 5 $ 5 $ * $ * $ 5 $.

Definition drule29 := Part $ 5 $[5] 5 $ 7+ $ 5 $ * $ * $ 5 $ 5 $.

Definition drule30 := Part $ 5 $ 5 $ 7+ $ 5 $[5] 6 $ 5 $ * $ * $.

Definition drule31  := Part $ 5 $[5] 5 $ 7+ $ 5 $[6+] 5 $ 6+ $ * $ 6+ $.
Definition drule31' := Part $ 5 $[5] 5 $ 7+ $ 5 $[5] 5 $ 6+ $ * $ 6+ $.

Definition drule32 := Part $ 5 $ 6 $[5] 7 $ 7+ $ 6 $ 5 $ 5 $ 5 $.

End DischargeRules.

Definition base_drules : drules := @seqn part 38
 drule1  drule1  drule2  drule2' drule3  drule3'  drule4  drule4' drule5
 drule6  drule7  drule8  drule9  drule10 drule10'
 drule11 drule12 drule13 drule14 drule15 drule16 drule17 drule18 drule19
 drule20 drule21 drule22 drule23 drule24 drule25 drule26 drule27 drule28 drule29
 drule30 drule31 drule31' drule32.

Fixpoint symmetrize_drules (r : drules) : drules :=
  if r is p :: r' then
    let p' := iter 5 (rot_part (size_part p).-1) (mirror_part p) in
    let psr := p :: symmetrize_drules r' in
    if cmp_part p p' is Psubset then psr else p' :: psr
  else r.

Definition the_drules := symmetrize_drules base_drules.

Import Order.TTheory GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Section Discharge.

Variable G : hypermap.

Definition dscore1 (x : G) : int := count (exact_fitp (inv_face2 x)) the_drules.

Definition dscore2 x : int := dscore1 (edge x) - dscore1 x.

Definition dscore x : int :=
  60%:Z - (10 * arity x)%:Z + \sum_(y in cface x) dscore2 y.

Lemma dscore_cface x y : cface x y -> dscore x = dscore y.
Proof.
by move=> xFy; rewrite /dscore (arity_cface xFy) (eq_bigl _ _ (same_cface xFy)).
Qed.

End Discharge.

Prenex Implicits dscore dscore1 dscore2.

Section DischargePlanar.

Variable G : hypermap.

Hypothesis geoG : planar_plain_cubic_connected G.
Let De2 := plain_eq geoG.
Let Dn3 := cubic_eq geoG.

Lemma sumz_connect (I : finType) (e : rel I) (F : I -> int) :
  connect_sym e -> \sum_(x in roots e) \sum_(y in connect e x) F y = \sum_y F y.
Proof.
move=> sym_e.
rewrite [RHS](partition_big (root e) (roots e)) => /= [|y _]; last first.
  exact: roots_root.
apply: eq_bigr => x /eqP-Dx; apply: eq_bigl => y.
by apply/rootP/eqP; rewrite ?Dx.
Qed.

Lemma dscore_roots : \sum_(x in froots face) @dscore G x = 120.
Proof.
set F := froots face; pose ten : int := 10%:R; rewrite -[RHS]/(ten *+ 12).
transitivity (\sum_(x in F) (ten *+ 6 + \sum_(y in cface x) (dscore2 y - ten))).
  by apply: eq_bigr => x; rewrite sumrB addrA addrAC sumr_const -!mulrnA !natz.
rewrite big_split /= (sumz_connect _ cfaceC) !sumrB !sumr_const !addrA.
apply/eqP; rewrite subr_eq addrAC (reindex_inj edgeI) subrK -mulrnDr -!mulrnA.
have <-: fcard face G = #|F| by apply: eq_card => x; apply: andbT.
by rewrite eqr_nat eqn_mul2l addnC -cubic_Euler; apply: geoG.
Qed.

Lemma posz_dscore : exists x : G, dscore x > 0.
Proof.
apply/existsP; have: ~~ (0 <= - (120 : int)) by []; apply: contraR.
rewrite negb_exists -dscore_roots -sumrN => /forallP-score_le0.
by apply: sumr_ge0 => x _; rewrite oppr_ge0 leNgt.
Qed.

Lemma dscore_mirror (x : G) : @dscore (mirror G) x = dscore x.
Proof.
rewrite /dscore arity_mirror (eq_bigl _ _ (cface_mirror x)); congr (_ + _).
suffices{x} score1F (x : G): @dscore1 (mirror G) (face x) = dscore1 x.
  rewrite (reindex_inj (@faceI G)) -(eq_bigl _ _ (fun y => cface1r y x)) /=.
  by apply: eq_bigr => y _; rewrite /dscore2 2!{1}score1F (plain_eq' geoG).
rewrite /dscore1 /the_drules; congr _%:Z.
elim: base_drules => [|p r IHp] //; pose n := size_part p.
pose rp i := iter i (rot_part n.-1) (mirror_part p).
have Erp i: size_part (rp i) = n.
  by elim: i => /= *; rewrite ?size_rot_part ?size_mirror_part.
have fit_rp i G1 x1:
  @exact_fitp G1 x1 (rp i) = exact_fitp (iter i face x1) (mirror_part p).
- elim: i {IHp} => //= i IHi in G1 x1 *.
  have [nFx1 | n'x1] := eqVneq (arity (face x1)) n.
    rewrite /= -{1}[x1](finv_f faceI) /finv nFx1 -fitp_rot ?Erp ?leq_pred //.
    by rewrite -iterS iterSr -IHi.
  rewrite /exact_fitp size_rot_part size_mirror_part Erp -/n.
  by rewrite !arity_face arity_iter_face in n'x1 *; rewrite (negPf n'x1).
move Dp1: (rp 5%N) => p1.
move: Dp1 {fit_rp}(fit_rp 5%N) {Erp}(Erp 5%N) => /= -> fit_p1 Ep1.
set x2' := inv_face2 x; pose x3 := face (face (face x)).
have Ex3: x3 = iter 5 face x2' by rewrite /x2' /inv_face2 /= !nodeK.
rewrite /= !(f_finv nodeI) in IHp Ex3 *.
case eq_pp1: (cmp_part p p1); rewrite //= {}IHp -/x2' -/x3;
 try by rewrite !fit_p1 // -Ex3 {1}Ex3 /= ?(finv_f faceI);
     rewrite -?(fitp_mirror geoG) mirror_mirror_part addnCA.
congr ((_ : bool) + _)%N; apply/idP/idP=> /andP[Exp fit_xp].
  have: @exact_fitp (mirror G) x3 p1.
    by rewrite /exact_fitp (fitp_cmp fit_xp) eq_pp1 /= andbT Ep1.
  rewrite fit_p1 Ex3 /= !(finv_f faceI).
  by rewrite -(fitp_mirror geoG) mirror_mirror_part.
rewrite -(fitp_mirror geoG) Ex3 -fit_p1.
by rewrite /exact_fitp (fitp_cmp fit_xp) eq_pp1 andbT Ep1.
Qed.

End DischargePlanar.

Section ScoreBound.

Variable nhub : nat. (* hub size *)

(* Rule selectors, by source or target arity, or by matching a part. The *)
(* "target arity" returns a list of converse rules. The "matching"       *)
(* selector returns a pair of the number of rules that are forced by the *)
(* part, plus the list of rules that straddle the part, discarding the   *)
(* rules that are disjoint from or forced by the part. The matching      *)
(* selector is part of the inner loop of the unavoidability computation. *)

Definition pick_source_drules : drules -> drules :=
  filter (fun p => size_part p == nhub).

Fixpoint pick_target_drules (r : drules) : drules :=
  if r is p :: r' then
    let: (u, p') := converse_part p in
    let tr := pick_target_drules r' in
    if u nhub then p' :: tr else tr
  else r.

Section SortDrules.

Record sort_drules_result := SortDrules {
  nb_forced_drules :> nat;
  straddling_drules :> drules
}.

Variable p : part.

Fixpoint sort_drules_rec n (rs r : drules) : sort_drules_result :=
  if r is p' :: r' then
    match cmp_part p p' with
    | Psubset => sort_drules_rec n.+1 rs r'
    | Pstraddle => sort_drules_rec n (p' :: rs) r'
    | Pdisjoint => sort_drules_rec n rs r'
    end
  else SortDrules n rs.

Definition sort_drules r := sort_drules_rec 0 [::] r.

End SortDrules.

(* A rule fork specializes the full set of discharge rules for a specific *)
(* hub size, so that the source/target arity selection is only performed  *)
(* once. We use a dependent predicate family to specify the computation.  *)

Inductive drule_fork_values : drules -> drules -> Prop :=
    DruleForkValues :
      drule_fork_values (pick_source_drules the_drules)
                        (pick_target_drules the_drules).

Record drule_fork := DruleFork {
   source_drules : drules;
   target_drules : drules;
   _ : drule_fork_values source_drules target_drules
}.

Variable rf : drule_fork.
Let rs : drules := source_drules rf.
Let rt : drules := target_drules rf.

Variable G : hypermap.
Hypothesis geoG : plain_cubic_pentagonal G.
Let pentaG : pentagonal G := geoG.
Let De2 := plain_eq geoG.
Let Dn3 := cubic_eq geoG.

Section BoundDart.

Definition dbound1 (r : drules) (x : G) := count (fitp x) r.

Definition dbound2 r r' x := (dbound1 r x)%:Z - (dbound1 r' x)%:Z.

Definition dboundK := if (nhub - 5)%N is n.+1 then - (n * 10)%:Z else 10%:Z.

Variables (x : G) ( (* hub *) p : part (* for sort_drules *)).
Hypotheses (nFx : arity x = nhub) (Ep : size_part p = nhub) (fit_xp : fitp x p).

Lemma dbound1_eq : dscore1 (face (face x)) = dbound1 rs x.
Proof.
congr _%:Z; rewrite /rs /source_drules; case: rf => _ _ [].
elim: the_drules => //= r dr ->.
by rewrite /exact_fitp /inv_face2 !faceK nFx eq_sym; case: ifP.
Qed.

Lemma sort_dbound1_eq ru:
  let rup := sort_drules p ru in dbound1 ru x = (rup + dbound1 rup x)%N.
Proof.
rewrite /= -[dbound1 _ _]addn0 -[0%N]/(0 + count (fitp x) [::])%N /sort_drules.
elim: ru 0%N [::] => //= r ru IHru m ru'.
rewrite (fitp_cmp fit_xp); case eq_pr: (cmp_part p r); rewrite //= -{}IHru.
  by rewrite -addnA 2!(addnCA (fitp x r)).
by rewrite addnS.
Qed.

Inductive sort_drules_spec (r : drules) : sort_drules_result -> nat -> Set :=
  SortDrulesSpec n r' : sort_drules_spec r (SortDrules n r') (n + dbound1 r' x).

Lemma sort_drulesP r : sort_drules_spec r (sort_drules p r) (dbound1 r x).
Proof. by rewrite sort_dbound1_eq; case: (sort_drules p r). Qed.

Lemma dbound2_leq : dscore2 (face (face x)) <= dbound2 rt rs x.
Proof.
rewrite /dbound2 -dbound1_eq ler_add2r lez_nat.
set y := inv_face2 _; rewrite /rt /target_drules; case: rf => _ _ [].
elim: the_drules => //= r dr IHdr; case Dr': (converse_part r) => [u r'].
case Hyr: (exact_fitp y r).
  move: (fitp_converse geoG Hyr); rewrite Dr' => /andP[].
  by rewrite {1 2}/y /inv_face2 !nodeK De2 !faceK nFx => -> /= ->.
by case: (u nhub) => //=; case: (fitp x r') => //; apply: ltnW.
Qed.

Lemma dboundK_eq : dboundK = 60%:Z - (10 * arity x)%:Z.
Proof.
rewrite -(subnKC (pentaG x)) nFx /dboundK; case: (nhub - 5)%N => // m.
by rewrite -addSnnS mulnDr PoszD opprD addNKr mulnC.
Qed.

End BoundDart.

Lemma dscore_cap1 (m : nat) :
   (forall y : G, dscore1 y <= m) ->
  forall x : G, 0 < dscore x -> forall d, (59 < (10 - m) * d -> arity x < d)%N.
Proof.
move=> ub_m x pos_x d max_m; apply: contraLR pos_x; rewrite -leqNgt => ledx.
have ltm10: (m < 10)%N by rewrite -subn_gt0; case: (10 - m)%N max_m.
have{max_m}: 60%:Z <= ((10 - m) * arity x)%:Z.
  by rewrite lez_nat (leq_trans max_m) ?leq_mul.
rewrite -leNgt -ler_subr_addr ler_subl_addl add0r => /le_trans-> //.
rewrite !PoszM -!mulrzz -![_ *~ _]sumr_const -sumrB ler_sum // => y _.
rewrite -(ler_add2r m%:Z) -PoszD subnK 1?ltnW // addrAC.
by rewrite ler_subr_addr ler_add2l ler_subl_addr ler_paddr.
Qed.

Lemma source_drules_range : ~~ Pr58 nhub -> rs = [::].
Proof.
rewrite /rs /source_drules; case: rf => _ _ [] not_u58.
have Eu: (fun p => size_part p == nhub)
            =1 (fun n => ~~ Pr58 n && (n == nhub)) \o size_part.
- by move=> p; rewrite /= andbC; case: eqP => // ->.
by rewrite /pick_source_drules (eq_filter Eu).
Qed.

Lemma dscore_cap2 (x : G) :
    arity x = nhub -> 0 < dscore x ->
  0 < dboundK + \sum_(y in cface x) dbound2 rt rs y.
Proof.
move=> nFx /lt_le_trans-> //; rewrite /dscore -dboundK_eq // ler_add2l.
do 2!rewrite (reindex_inj faceI) -(eq_bigl _ _ (fun y => cface1r y x)) /=.
by apply: ler_sum => y xFy; rewrite dbound2_leq // -(arity_cface xFy).
Qed.

End ScoreBound.


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

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.

Require Import ssrbool TestSuite.ssr_mini_mathcomp.

Variable T : Type.

Lemma test0 : forall a b c d : T, True.
Proof. by move=> a b {a} a c; exact I. Qed.

Variable P : T -> Prop.

Lemma test1 : forall a b c : T, P a -> forall d : T, True.
Proof. move=> a b {a} a _ d; exact I. Qed.

Definition Q := forall x y : nat, x = y.
Axiom L : 0 = 0 -> Q.
Axiom L' : 0 = 0 -> forall x y : nat, x = y.
Lemma test3 : Q.
by apply/L.
Undo.
rewrite /Q.
by apply/L.
Undo 2.
by apply/L'.
Qed.


Require Import List EqNat Bool SetOperations.
Require Import IL Exp Val SMT.

(** Helper function to merge SMT options **)
Definition combine (o1:smt) (o2: smt) :smt :=
   if [o1 = smtTrue] then o2 else
    if [o2 = smtTrue] then o1 else smtAnd o1 o2.

Lemma models_combine F E a b
: models F E (combine a b) <-> models F E (smtAnd a b).

Proof.
  unfold combine. repeat (cases; subst); simpl; intuition.
Qed.

Lemma models_combine_vars a b:
  freeVars (combine a b) [=] freeVars (smtAnd a b).

Proof.
  unfold combine. repeat(cases; subst); simpl; cset_tac.
Qed.

(** Function to generate the guard expression for one expression **)
Fixpoint undef e :=
  match e with
  | BinOp op a b
    => combine (combine (undef a) (undef b))
              (if [op = BinOpDiv]
               then smtAnd (smtNeg (constr b (Con Integers.Int.zero)))
                           (smtNeg (smtAnd (constr a (Con (Integers.Int.repr Integers.Int.min_signed)))
                                           (constr b (Con Integers.Int.mone))))
               else smtTrue)
  | UnOp n a => undef a
  | Con v => smtTrue
  | Var v => smtTrue
  end.

Fixpoint undefLift (el: list op) :=
  match el with
  | nil => smtTrue
  | e::el' => combine (undef e) (undefLift el')
  end.

Definition guardGen s p cont :=
  if [s = smtTrue] then cont else
    match p with
    | source => smtAnd s cont
    | target => smtImp s cont
    end.

Lemma freeVars_guardGen s p t
  : freeVars (guardGen s p t) ⊆ freeVars s ∪ freeVars t.
Proof.
  unfold guardGen; repeat cases; eauto with cset.
Qed.

Lemma models_guardGen_source F E s cont
: models F E (guardGen s source cont) <-> models F E (smtAnd s cont).

Proof.
 unfold guardGen; cases; subst; simpl; intuition.
Qed.

Lemma models_guardGen_target F E s cont
: models F E (guardGen s target cont) <-> models F E (smtImp s cont).
Proof.
 unfold guardGen; cases; subst; simpl; intuition.
Qed.

Lemma freeVars_undef e
  : freeVars (undef e) ⊆ Ops.freeVars e.
Proof.
  intros. general induction e; simpl in * |- *; eauto with cset.
  - unfold combine in *.
    repeat cases; simpl;
      only 1: repeat cases in COND.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
    + cset_tac.
Qed.

Lemma freeVars_undefLift el
  : freeVars (undefLift el) ⊆ list_union (List.map Ops.freeVars el).
Proof.
  general induction el; simpl in * |- *; eauto.
  - rewrite list_union_start_swap.
    unfold combine; repeat cases; simpl;
      try rewrite IHel; try rewrite freeVars_undef; eauto with cset.
Qed.