Require Import PPS.SOS.SOS.
Require Export PPS.Exp.

Set Implicit Arguments.

Reserved Notation "Sigma '|-a' e ⇓ v" (at level 40).
Reserved Notation "Sigma '|-b' e ⇓ v" (at level 40).

Section ArithRelation.

  Inductive aevalR : AExp -> SOS_Context nat -> nat -> Prop :=
  | EvNum  : forall Sigma n, Sigma |-a ANum n ⇓ n
  | EvVar  : forall Sigma x v,
      SOS_lookup Sigma x = Some v ->
      Sigma |-a AVar x ⇓ v
  | EvPlus : forall Sigma e1 e2 v1 v2 v,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      v = v1 + v2 ->
      Sigma |-a APlus e1 e2 ⇓ v
  | EvSub : forall Sigma e1 e2 v1 v2 v,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      v = v1 - v2 ->
      Sigma |-a AMinus e1 e2 ⇓ v
  | EvMult : forall Sigma e1 e2 v1 v2 v,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      v = v1 * v2 ->
      Sigma |-a AMult e1 e2 ⇓ v
  where "Sigma '|-a' e ⇓ v" := (aevalR e Sigma v).

End ArithRelation.

Section ArithFunction.

  Fixpoint aevalF (e : AExp) (c0 : SOS_Context nat) : option nat :=
    match e with
    | ANum n => Some n
    | AVar x => SOS_lookup c0 x
    | APlus e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 =>
        Some (v1 + v2)
      | _,_ => None
      end
    | AMult e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 =>
        Some (v1 * v2)
      | _,_ => None
      end
    | AMinus e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 =>
        Some (v1 - v2)
      | _,_ => None
      end
    end.

End ArithFunction.

Notation "Sigma '|-a' e ⇓ v" := (aevalR e Sigma v).

Section BoolRelation.

  Inductive bevalR : BExp -> SOS_Context nat -> bool -> Prop :=
  | EvT : forall Sigma, Sigma |-b BTrue ⇓ true
  | EvF : forall Sigma, Sigma |-b BFalse ⇓ false
  | EvLess : forall Sigma e1 e2 v1 v2 b,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      b = Nat.leb v1 v2 ->
      Sigma |-b BLess e1 e2 ⇓ b
  where "Sigma '|-b' e ⇓ v" := (bevalR e Sigma v).

End BoolRelation.

Section BoolFunction.

  Fixpoint bevalF (be : BExp) (c0 : SOS_Context nat) : option bool :=
    match be with
    | BTrue => Some true
    | BFalse => Some false
    | BLess e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 => Some (Nat.leb v1 v2)
      | _,_ => None
      end
    end.

End BoolFunction.

Notation "Sigma '|-b' e ⇓ v" := (bevalR e Sigma v).


From Coq Require Import Arith Lia.
Unset Elimination Schemes.

Section Acc.
  Variables (X: Type) (R: X -> X -> Prop).
  Inductive Acc (x: X) : Prop := AccC (h: forall y, R y x -> Acc y).
  Fact Acc_iff x :
    Acc x <-> forall y, R y x -> Acc y.
  Proof.
    split.
    - intros [h]. exact h.
    - apply AccC.
  Qed.
  Variable p: X -> Type.
  Variable F: (forall x, (forall y, R y x -> p y) -> p x).
  Definition W'
    : forall x, Acc x -> p x
    := fix f x a :=
         match a with AccC _ h => F x (fun y r => f y (h y r)) end.
  Definition wf := forall x, Acc x.
End Acc.

Arguments Acc {X}.
Arguments AccC {X R}.
Arguments W' {X R p}.
Arguments wf {X}.
Definition W {X R p} H F x := @W' X R p F x (H x).

Print Acc.

(* Only for well founded relations *)
Definition tst: Acc (fun x y => (y = x + 1)) 1.
Proof.
  constructor.
  intros y ey.
  enough (y = 0).
  - rewrite H.
    constructor.
    intros y' Hy'.
    exfalso.
    lia.
  - lia.
Defined.

Goal wf (fun x y => (y = x + 1)).
Proof.
intros x.
induction x.
- constructor. intros y hy. exfalso. lia.
- constructor. intros y hy.
  enough (x = y).
  rewrite <- H.
  apply IHx.
    lia.
Qed.

Fact Acc_ext {X} {R R': X -> X -> Prop} :
  (forall x y, R' x y -> R x y) -> forall x, Acc R x -> Acc R' x.
Proof.
  intros H.
  apply W'. intros x IH.
  constructor. intros y H1%H.
  apply IH, H1.
Qed.

(* 26.1.2 *)
Fact ex2612: forall X R (x: X), Acc R x <-> (forall y, R y x -> Acc R y).
Proof.
  intros X R x.
  split.
  - intros [H] y Ryx.
    apply H, Ryx.
  - intros H.
    constructor.
    apply H.
Qed.

(* 26.1.3 *)
Fact ex2613: forall X R (x: X), Acc R x -> ~ R x x.
Proof.
  intros X R x.
  Print W'.
  apply (W' (p := fun x => ~R x x)).
  intros x' H' H''.
  apply (H' x' H'').
  apply H''.
Qed.

(* 26.1.4 *)
Fact ex2614: forall X (R: X -> X -> Prop) (x y: X),
  R x y -> R y x -> ~ Acc R x.
Proof.
  refine (fix F X R x y H1 H2 H {struct H} := let (f) := H in _).
  apply (F X R y x).
  - apply H2.
  - apply H1.
  - apply f.
    apply H2.
Qed.

(* 26.1.5 TODO *)
(* 26.1.6 TODO *)

Fact lt_wf :
  wf lt.
Proof.
  Print hnf.
  hnf.
  enough (forall n x, x < n -> Acc lt x) by eauto.
  induction n as [|n IH].
  - easy.
  - intros x H. constructor. intros y H1. apply IH. lia.
Defined.

Section Lexical_product.
  Variables (X: Type) (R: X -> X -> Prop).
  Variables (Y: Type) (S: Y -> Y -> Prop).
  Definition lex (a b: X * Y) : Prop :=
    R (fst a) (fst b) \/ fst a = fst b /\ S (snd a) (snd b).
  Fact lex_wf :
    wf R -> wf S -> wf lex.
  Proof.
    intros H1 H2 [x y]. revert x y.
    refine (W H1 _). intros x IH1.
    refine (W H2 _). intros y IH2.
    constructor. intros [x' y']. unfold lex at 1. cbn. intros [H|[-> H]].
    - apply IH1, H.
    - apply IH2, H.
  Defined.
End Lexical_product.
Arguments lex {X} R {Y}.
Arguments lex_wf {X R Y S}.

Section Retract.
  Variables (X Y: Type) (R: Y -> Y -> Prop) (sigma: X -> Y).
  Definition retract (x x': X) := R (sigma x) (sigma x').
  Fact retract_wf :
    wf R -> wf retract.
  Proof.
    intros H.
    enough (forall y x,  sigma x = y -> Acc retract x) by (hnf;eauto).
    refine (W H _). intros y IH x H1.
    constructor. intros x' H2.
    apply (IH (sigma x')). 2:reflexivity.
    destruct H1. exact H2.
  Defined.
  Definition size_rec :
    wf(R) -> forall p: X -> Type,
      (forall x, (forall x', R (sigma x') (sigma x) -> p x') -> p x) ->
      forall x, p x.
  Proof.
    intros R_wf p. apply (W (retract_wf R_wf)).
  Defined.
End Retract.
Arguments retract_wf {X Y R}.

From Coq Require Import FunctionalExtensionality.

Fact Acc_pure X (R: X -> X -> Prop) :
  forall x (a a': Acc R x), a = a'.
Proof.
  enough (forall x (a: Acc R x) (a a': Acc R x), a = a') by eauto.
  refine (W' _). intros x IH [h] [h']. f_equal.
  extensionality y. extensionality r. apply IH, r.
Qed.

Print Assumptions Acc_pure.

Fact W_eq
     {X} {R: X -> X -> Prop} {R_wf: wf R}
     {p: X -> Type}
     {F: forall x, (forall y, R y x -> p y) -> p x}
     (x: X)
  : W R_wf F x = F x (fun y _ => W R_wf F y).
Proof.
  unfold W. destruct (R_wf x) as [h]. cbn.
  f_equal. extensionality y. extensionality r.
  f_equal. apply Acc_pure.
Qed.

Fact W_unique
     {X} {R: X -> X -> Prop} {R_wf: wf R}
     {p: X -> Type}
     {F: forall x, (forall y, R y x -> p y) -> p x}
     (f f': forall x, p x)
  : (forall x, f x = F x (fun y r => f y)) ->
    (forall x, f' x = F x (fun y r => f' y)) ->
    forall x, f x = f' x.
Proof.
  intros H1 H2.
  apply (W R_wf). intros x IH.
  rewrite H1, H2.
  f_equal. extensionality y. extensionality r.
  apply IH,r.
Qed.

(* A function useed for hiding lia-generated termination proofs *)
Definition tau {X x} : X := x.

(** Euclidean division with W *)

(* Guarded step function, y pulled out as parameter *)
Definition Div (y x : nat) (h: forall x', x' < x -> nat) : nat.
Proof.
  refine (if le_lt_dec x y then 0 else S (h (x - S y) tau)).
  lia.
Defined.

Definition div x y : nat := W lt_wf (Div y) x.
Compute div 16 3.
Fact div_eq x y :
  div x y = if le_lt_dec x y then 0 else S (div (x - S y) y).
Proof.
  exact (W_eq x).
Qed.

Print Assumptions div_eq.

(** GCDs with W *)
(* Note: Pairing introduces considerable bureaucratic pain *)

Module GCD.
Implicit Types (x y: nat) (a b: nat * nat).
Definition sigma a := fst a + snd a.

Definition GCD a : (forall b, sigma b < sigma a -> nat) -> nat.
Proof.
  (* must take h late because of dependency on a *)
  refine (match a with
          | (0, y) => fun _ => y
          | (S x, 0) => fun _ => S x
          | (S x, S y) => fun h => match (le_lt_dec x y) with
                               | left H => h (S x, y - x) tau
                               | right H => h (x - y, S y) tau
                               end
          end).
  all: cbn; lia.
Defined.

Definition gcd x y : nat := W (retract_wf sigma lt_wf) GCD (x,y).

Compute gcd 49 63.

Fact gcd_eq3 x y :
  gcd (S x) (S y) = if le_lt_dec x y
                    then gcd (S x) (y - x)
                    else gcd (x - y) (S y).
Proof.
  refine (W_eq _).
Qed.

Fact gcd_eq x y :
  gcd x y = match x, y with
            | 0, y => y
            | S x, 0 => S x
            | S x, S y => if le_lt_dec x y
                         then gcd (S x) (y - x)
                         else gcd (x - y) (S y)
            end.
Proof.
  unfold gcd. rewrite W_eq.
  destruct x. reflexivity.
  destruct y; reflexivity.
Qed.

End GCD.

(** Ackermann with W *)

Definition ACK a : (forall b, lex lt lt b a -> nat) -> nat.
Proof.
  (* must take h late because of dependency on a *)
  (* tuned so that computation works,
     "_" in place of tau, auto instead of lia.
     Fragile, I don't understand it *)
  refine (match a with
          | (0, y) => fun _ => S y
          | (S x, 0) => fun h => h (x, 1) tau
          | (S x, S y) => fun h => h (x, h (S x, y) tau) _
          end).
  Unshelve.
  all: unfold lex; cbn; auto.
Defined.

Definition ack x y : nat := W (lex_wf lt_wf lt_wf) ACK (x,y).

Compute ack 3 3.

Fact ack_eq x y :
  ack x y = match x, y with
            | 0, y => S y
            | S x, 0 => ack x 1
            | S x, S y => ack x (ack (S x) y)
            end.
Proof.
  unfold ack. rewrite W_eq.
  destruct x. reflexivity.
  destruct y; reflexivity.
Qed.

(** Unfolding equation without FE *)

Section Unfolding.
  Variables
    (X: Type) (R: X -> X -> Prop)
    (p: X -> Type)
    (F: forall x, (forall y, R y x -> p y) -> p x).

  Implicit Types (x y : X) (f: forall x, p x).

  Definition Ext :=
    forall x h h', (forall y r, h y r = h' y r) -> F x h = F x h'.

  Variable F_ext: Ext.

  Lemma W'_ext x a a' :
    W' F x a = W' F x a'.
  Proof.
    revert x a a'.
    enough (forall x (a: Acc R x), forall a a', W' F x a = W' F x a') by eauto.
    refine (W' (fun x IH => _)).
    intros [phi] [phi']. cbn.
    apply F_ext. intros y r.
    apply IH, r.
  Qed.

  Definition sat f :=
    forall x, f x = F x (fun y _ => f y).

  Variable R_wf: wf R.

  Fact W_eq' :
    sat (W R_wf F).
  Proof.
    intros x. unfold W. destruct (R_wf x) as [phi]. cbn.
    apply F_ext. intros y r. apply W'_ext.
  Qed.

  Fact unique f f' :
    sat f -> sat f' -> forall x, f x = f' x.
  Proof.
    intros H1 H2.
    apply (W R_wf). intros x IH.
    rewrite H1, H2. apply F_ext. exact IH.
  Qed.
End Unfolding.
Arguments Ext {X R p} F.
Arguments W_eq' {X R p F} F_ext R_wf.

Fact Div_ext y :
  Ext (Div y).
Proof.
  intros x h h' H. unfold Div.
  destruct le_lt_dec as [H1|H1].
  - reflexivity.
  - f_equal. apply H.
Qed.

Fact GCD_ext :
  Ext GCD.GCD.
Proof.
  intros [x y] h h' H.
  destruct x. reflexivity.
  destruct y. reflexivity.
  unfold GCD.GCD.
  destruct le_lt_dec as [H1|H1]; apply H.
Qed.

Fact ACK_ext :
  Ext ACK.
Proof.
  intros [x y] h h' H.
  destruct x. reflexivity.
  destruct y; cbn.
  - apply H.
  - rewrite H. unfold tau. rewrite H. reflexivity.
Qed.

(** Padding *)

Section Padding.
  Variables (X: Type) (R: X -> X -> Prop).
  Definition des x (a: Acc R x) : forall y, R y x -> Acc R y :=
    match a with AccC _ phi => phi end.
  Fixpoint pad n x (a: Acc R x) : Acc R x :=
    match n with
    | 0 => a
    | S n' => AccC x (fun y r => pad n' y (des x a y r))
    end.
  Variables (x: X) (a: Acc R x) (n:nat).
  Eval cbn in pad (4 + n) x a.
End Padding.

(** Classical Characterization *)

From Coq Require Import Classical_Prop.

Section Classical.
  Variables (X: Type) (R: X -> X -> Prop).
  Implicit Types (x y: X) (p: X -> Prop).

  Fact char_wf_ind :
    wf R <-> forall p: X -> Prop, (forall x, (forall y, R y x -> p y) -> p x) -> forall x, p x.
  Proof.
    split; intros H.
    - intros p. apply W. exact H.
    - refine (H (Acc R) _). apply AccC.
  Qed.

  Definition pro_pred p := forall x, p x -> exists y, p y /\ R y x.
  Definition pro x := exists p, p x /\ pro_pred p.

  Fact pro_disjoint x :
    Acc R x -> pro x -> False.
  Proof.
    revert x. refine (W' _). intros x IH.
    intros (p&H1&H2). apply H2 in H1 as (y&H1&H3).
    eapply IH. exact H3. exists p. easy.
  Qed.

  Fact pro_exhaustive_xm x :
    Acc R x \/ pro x.
  Proof.
    classical_right.
    exists (fun x => ~Acc R x). split. exact H.
    clear. intros x H.
    apply NNPP. contradict H. constructor. intros y H1.
    apply NNPP. contradict H. exists y; easy.
  Qed.

  Fact char_wf_pro_xm :
    wf R <-> ~ex pro.
  Proof.
    split.
    - intros H (x&H1). specialize (H x).
      eapply pro_disjoint; eassumption.
    - intros H x.
      destruct (pro_exhaustive_xm x) as [H1|H1]. exact H1.
      contradict H. exists x. exact H1.
  Qed.

  Definition min p x := p x /\ forall y, p y -> ~R y x.

  Fact pro_min_xm p :
    pro_pred p <-> ~ ex (min p).
  Proof.
    split; intros H.
    - intros (x&H2&H3).
      apply H in H2 as (y&H2&H4). eapply H3; eassumption.
    - intros x H2. apply NNPP. contradict H.
      exists x. split. exact H2.
      intros y H4 H5. apply H. exists y; easy.
  Qed.

  Fact pro_min_pred_xm :
    ~ex pro <-> forall p, ex p -> ex (min p).
  Proof.
    split; intros H.
    - intros p [x H1].
      apply NNPP. intros H2%pro_min_xm.
      apply H. exists x,p; easy.
    - intros (y&p&H1&H2%pro_min_xm).
      apply H2, H. exists y. exact H1.
  Qed.

  Fact char_wf_min_xm :
    wf R <-> forall p, ex p -> ex (min p).
  Proof.
    rewrite char_wf_pro_xm. apply pro_min_pred_xm.
  Qed.
End Classical.
Print Assumptions char_wf_min_xm.

(** Transitive closure *)

Section Transitive_closure.
  Variables (X: Type) (R: X -> X -> Prop).
  Inductive TC (x y: X) : Prop :=
  | TC1 : R x y -> TC x y
  | TC2 y' : TC x y' -> R y' y -> TC x y.
  Fact TC_wf :
    wf R -> wf TC.
  Proof.
    intros H. hnf.
    refine (W H _). intros y IH.
    constructor. intros x H1.
    destruct H1 as [H1|y' H1 H2].
    - apply IH, H1.
    - apply IH in H2. destruct H2 as [H2].
      apply H2, H1.
  Qed.
  Fact TC_ind x (p: X -> Prop) :
    (forall y, R x y -> p y) ->
    (forall y' y, p y' -> R y' y -> p y) ->
    forall y, TC x y -> p y.
  Proof.
    intros e1 e2.
    refine (fix f y a := match a with
                         | TC1 _ _ r => e1 y r
                         | TC2 _ _ y' a r => e2 y' y _ r
                         end).
    refine (f y' a).
  Qed.
  Fact TC_trans x y z :
    TC x y -> TC y z -> TC x z.
  Proof.
    intros H. revert z. apply TC_ind.
    - intros z. apply TC2, H.
    - intros y' z. apply TC2.
  Qed.
End Transitive_closure.

Section Successor_relation.
  Definition R_S (x y: nat) := S x = y.
  Fact R_S_wf :
    wf R_S.
  Proof.
    hnf. induction x as [|x IH].
    - constructor. unfold R_S at 1. easy.
    - constructor. unfold R_S at 1. intros y [= ->]. exact IH.
  Qed.
End Successor_relation.

(** Existential Witness Operator *)

Module EWO.
Section EWO.
  Variable p: nat -> Prop.
  Variable p_dec: forall n, p n + ~p n.
  Implicit Types x y: nat.

  Let R x y := (x = S y) /\ ~p y.

  Fact R_Acc x y :
    p (x + y) -> Acc R y.
  Proof.
    induction x as [|x IH] in y |-*;
      intros H; constructor; intros ? [-> H1].
    - exfalso. easy.
    - apply IH. rewrite <-plus_n_Sm. easy.
  Qed.

  Fact R_Acc_Sigma :
    forall x, Acc R x -> sigT p.
    refine (W' _). intros x IH.
    destruct (p_dec x) as [H1|H1].
    - exists x. exact H1.
    - apply (IH (S x)). easy.
  Qed.

  Fact EWO :
    ex p -> sigT p.
  Proof.
    intros H.
    apply (R_Acc_Sigma 0).
    destruct H as [x H].
    apply (R_Acc x 0).
    rewrite plus_0_r. exact H.
  Qed.
End EWO.
End EWO.

(** Exercise: Prove that (TC R_S) is < on numbers *)

Fact exercise_loop (X: Type) (R: X -> X -> Prop) :
  forall x y, R x y -> R y x -> ~Acc R x.
Proof.
  intros x y H1 H2 H3. revert x H3 y H1 H2.
  refine (W' _). intros x IH y H1 H2.
  eapply IH; eassumption.
Qed.

(** Extraction *)

Require Import Extraction.
Recursive Extraction GCD.gcd.


(**

This file contains a formalization of the syntax of propositional logic as the initial algebra of a
functor.

Following Goldblatt's 'Topoi', all of the connectives are treated as primitive. As stated there,
they are _a priori_ distinct; their interdefinability is naturally propositional, not definitional.

Written by: Langston Barrett, 2019

*)

(** ** Contents

  - Definition of PL syntax as an initial algebra
  - Definition of a PL valuation in [bool]
  - TODO: Definition of a PL valuation in an (order-theoretic) algebra
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.NaturalNumbers.

Require Import UniMath.MoreFoundations.Bool.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.FunctorAlgebras.

Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.

Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.terminal.

Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors.
Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Adamek.

Local Open Scope cat.
Local Open Scope cocont_functor_hset_scope.

Section PL.

Let times x y := BinProductObject _ (BinProductsHSET x y).
Local Infix "⊗" := times.

Variable (vars : hSet).

(**
<<
    PL_functor Var Rec :=
        Var            (* -- arity 1, sentences *)
      + Rec            (* -- arity 1, ¬ (not) *)
      + (Rec × Rec)    (* -- arity 2, ∧ (and) *)
      + (Rec × Rec)    (* -- arity 2, ∨ (or) *)
      + (Rec × Rec)    (* -- arity 2, → (implies) *)
>>
 *)

Definition PL_functor : omega_cocont_functor HSET HSET :=
  (omega_cocont_constant_functor (vars : HSET)) + Id + (Id * Id) + (Id * Id) + (Id * Id).

(*
Definition PL_functor : omega_cocont_functor HSET HSET :=
  ' vars + Id + (Id * Id) + (Id * Id) + (Id * Id).
 *)

(** The following three statements are crucial for performance. *)
Definition PL_functor' : functor HSET HSET := pr1 PL_functor.
Let is_omega_cocont_PL_functor' : is_omega_cocont PL_functor' := pr2 PL_functor.
Opaque is_omega_cocont_PL_functor'.

Lemma PL_functor_initial :
  Initial (category_FunctorAlg PL_functor').
Proof.
  apply (colimAlgInitial InitialHSET is_omega_cocont_PL_functor' (ColimCoconeHSET _ _)).
Defined.

Let PL_alg : algebra_ob PL_functor' := InitialObject PL_functor_initial.

(** The underlying set of the initial algebra *)
Definition PL : hSet := alg_carrier _ PL_alg.

Definition PL_type : UU := pr1hSet PL.

Definition PL_var : HSET⟦vars, PL⟧.
  refine (_ · alg_map _ PL_alg).
  intro v; do 4 apply inl; exact v.
Defined.

Definition PL_not : HSET⟦PL, PL⟧.
  refine (_ · alg_map _ PL_alg).
  intro s; do 3 apply inl; apply inr; exact s.
Defined.

Definition PL_and : HSET⟦PL ⊗ PL, PL⟧.
  refine (_ · alg_map _ PL_alg).
  intro s; do 2 apply inl; apply inr; exact s.
Defined.

Definition PL_and_fun (x : PL_type) (y : PL_type) : PL_type :=
  PL_and (make_dirprod x y).

Definition PL_or : HSET⟦PL ⊗ PL, PL⟧.
  refine (_ · alg_map _ PL_alg).
  intro s; do 1 apply inl; apply inr; exact s.
Defined.

Definition PL_or_fun (x : PL_type) (y : PL_type) : PL_type :=
  PL_or (make_dirprod x y).

Definition PL_impl : HSET⟦PL ⊗ PL, PL⟧.
  refine (_ · alg_map _ PL_alg).
  intro s; apply inr; exact s.
Defined.

Definition PL_impl_fun (x : PL_type) (y : PL_type) : PL_type :=
  PL_impl (make_dirprod x y).

Definition PL_iff_fun (x : PL_type) (y : PL_type) : PL_type :=
  PL_and_fun (PL_impl (make_dirprod x y)) (PL_impl (make_dirprod y x)).

Declare Scope PL.
Delimit Scope PL with PL.
Notation "¬" := (PL_not) : PL.
Infix "∧" := (PL_and) : PL.
Infix "∨" := (PL_or) : PL.
Infix "⇒" := (PL_impl) : PL.
Infix "⇔" := (PL_iff_fun) (at level 90) : PL.

Definition make_PL_algebra (X : hSet) (vs : vars -> X) (not : X -> X)
           (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X) :
  algebra_ob PL_functor'.
Proof.
  exists X.
  cbn; do 5 (try (apply sumofmaps)).
  - assumption. (* vs *)
  - exact not.
  - apply (invweq (weqfunfromdirprod _ _ _)); exact and.
  - apply (invweq (weqfunfromdirprod _ _ _)); exact or.
  - apply (invweq (weqfunfromdirprod _ _ _)); exact impl.
Defined.

(** The fold, or catamorphism: given the same structure of operations on any
    other set, we can construct an interpretation of PL in that set. *)
Definition PL_fold_alg_mor {X : hSet} (vs : vars -> X)
           (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X) :
  algebra_mor PL_functor' PL_alg (make_PL_algebra X vs not and or impl).
Proof.
  apply (InitialArrow PL_functor_initial (make_PL_algebra X vs not and or impl)).
Defined.

Definition PL_fold {X : hSet} (vs : vars -> X)
           (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X) :
  PL -> X := mor_from_algebra_mor _ (PL_fold_alg_mor vs not and or impl).

(** Some lemmas expressing the computational behavior of [PL_fold] *)
Section FoldComputationLemmas.
  Context {X : hSet} (vs : vars -> X)
          (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X).

  Let fold := PL_fold vs not and or impl.
  Let mor := PL_fold_alg_mor vs not and or impl.
  Let comm := algebra_mor_commutes _ _ _ mor.

  Lemma PL_fold_var : ∏ z, fold (PL_var z) = vs z.
  Proof.
    reflexivity.
  Qed.

  Lemma PL_fold_not : ∏ p, fold (PL_not p) = not (fold p).
  Proof.
    intro.
    do 3 apply (maponpaths (λ x, (inl : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply eqtohomot in comm.
    specialize (comm p).
    exact comm.
  Qed.

  Lemma PL_fold_and : ∏ p q, fold (PL_and (make_dirprod p q)) = and (fold p) (fold q).
  Proof.
    intros p q.
    do 2 apply (maponpaths (λ x, (inl : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply eqtohomot in comm.
    specialize (comm (make_dirprod p q)).
    exact comm.
  Qed.

  Lemma PL_fold_or : ∏ p q, fold (PL_or (make_dirprod p q)) = or (fold p) (fold q).
  Proof.
    intros p q.
    apply (maponpaths (λ x, (inl : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply eqtohomot in comm.
    specialize (comm (make_dirprod p q)).
    exact comm.
  Qed.

  Lemma PL_fold_impl : ∏ p q, fold (PL_impl (make_dirprod p q)) = impl (fold p) (fold q).
  Proof.
    intros p q.
    apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm.
    apply eqtohomot in comm.
    specialize (comm (make_dirprod p q)).
    apply comm.
  Qed.
End FoldComputationLemmas.

(** The induction principle.

    Mirrors the proof for lists.
 *)
Section PL_ind.

Context {P : PL -> UU} (PhSet : ∏ l, isaset (P l)).
Context (P_vars : ∏ v : vars, P (PL_var v))
        (P_not : ∏ pl, P pl -> P (PL_not pl))
        (P_and : ∏ pl1 pl2, P pl1 -> P pl2 -> P (PL_and (make_dirprod pl1 pl2)))
        (P_or : ∏ pl1 pl2, P pl1 -> P pl2 -> P (PL_or (make_dirprod pl1 pl2)))
        (P_impl : ∏ pl1 pl2, P pl1 -> P pl2 -> P (PL_impl (make_dirprod pl1 pl2))).

Let P' : UU := ∑ pl : PL, P pl.
Let P'_vars (v : vars) : P' := (PL_var v,, P_vars v).
Let P'_not (pl : P') : P' := (PL_not (pr1 pl),, P_not _ (pr2 pl)).
Let P'_and (pl1 pl2 : P') : P' :=
  (PL_and (make_dirprod (pr1 pl1) (pr1 pl2)),,
   P_and _ _ (pr2 pl1) (pr2 pl2)).
Let P'_or (pl1 pl2 : P') : P' :=
  (PL_or (make_dirprod (pr1 pl1) (pr1 pl2)),,
   P_or _ _ (pr2 pl1) (pr2 pl2)).
Let P'_impl (pl1 pl2 : P') : P' :=
  (PL_impl (make_dirprod (pr1 pl1) (pr1 pl2)),,
   P_impl _ _ (pr2 pl1) (pr2 pl2)).

Definition P'HSET : HSET.
Proof.
  use make_hSet.
  - exact P'.
  - abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]).
Defined.

Opaque is_omega_cocont_PL_functor'.

Lemma is_algebra_morphism_pr1_PL_fold :
  is_algebra_mor _ PL_alg PL_alg (λ l, pr1 (@PL_fold P'HSET P'_vars P'_not P'_and P'_or P'_impl l)).
Proof.
apply (BinCoproductArrow_eq_cor _ BinCoproductsHSET).
- apply funextfun; intro x; induction x as [x2 | x3].
  + induction x2 as [x4 | x5].
    * induction x4 as [x6 | x7].
      -- cbn in x6.
         (* This line takes forever, more performance work to be done. *)
         (* apply (maponpaths pr1 (@PL_fold_var P'HSET P'_vars P'_not P'_and P'_or P'_impl x6)). *)
Abort.

End PL_ind.

End PL.

(** A valuation for atomic sentences can be extended to one for all sentences. *)
Definition bool_valuation {vars : hSet} (V : vars -> bool) : PL vars -> bool.
Proof.
  use (@PL_fold vars boolset).
  - assumption. (* V *)
  - exact negb.
  - exact andb.
  - exact orb.
  - exact implb.
Defined.


(** * Imp: Simple Imperative Programs
    From software foundation.

    Contents includes:
    Aexp
        - Aexp eval
    Bexp
        - Bexp eval
    cmd
        - operational semantics

*)

(** In this chapter, we take a more serious look at how to use Coq as
    a tool to study other things.  Our case study is a _simple
    imperative programming language_ called Imp, embodying a tiny core
    fragment of conventional mainstream languages such as C and Java.

    Here is a familiar mathematical function written in Imp.

       Z := X;
       Y := 1;
       while Z <> 0 do
         Y := Y * Z;
         Z := Z - 1
       end
*)

From Babel Require Import TerminalDogma.

From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
From Babel Require Import Maps.

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

(* ################################################################# *)
(** * Expressions With Variables *)

(** Let's return to defining Imp, where the next thing we need to do
    is to enrich our arithmetic and boolean expressions with
    variables. To keep things simple, we'll assume that all variables
    are global and that they only hold numbers. *)

(* ================================================================= *)
(** ** States *)

(** Since we'll want to look variables up to find out their current
    values, we'll use total maps from the [Maps] chapter.

    A _machine state_ (or just _state_) represents the current values
    of all variables at some point in the execution of a program. *)

(** For simplicity, we assume that the state is defined for
    _all_ variables, even though any given program is only able to
    mention a finite number of them.  Because each variable stores a
    natural number, we can represent the state as a total map from
    strings (variable names) to [nat], and will use [0] as default
    value in the store. *)

Definition state := total_map nat.

(* ================================================================= *)
(** ** Syntax  *)

(** We can add variables to the arithmetic expressions we had before
    simply by including one more constructor: *)

Inductive aexp : Type :=
    | ANum (n : nat)
    | AId (x : string)
    | APlus (a1 a2 : aexp)
    | AMinus (a1 a2 : aexp)
    | AMult (a1 a2 : aexp).

(** Defining a few variable names as notational shorthands will make
    examples easier to read: *)
(*
Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
*)

(** The definition of [bexp]s is unchanged (except that it now refers
    to the new [aexp]s): *)

Inductive bexp : Type :=
    | BTrue
    | BFalse
    | BEq (a1 a2 : aexp)
    | BNeq (a1 a2 : aexp)
    | BLe (a1 a2 : aexp)
    | BGt (a1 a2 : aexp)
    | BNot (b : bexp)
    | BAnd (b1 b2 : bexp).

(* ================================================================= *)
(** ** Notations *)

(** To make Imp programs easier to read and write, we introduce some
    notations and implicit coercions.  You do not need to understand
    exactly what these declarations do.  Briefly, though:
        - The [Coercion] declaration stipulates that a function (or
            constructor) can be implicitly used by the type system to
            coerce a value of the input type to a value of the output
            type.  For instance, the coercion declaration for [AId]
            allows us to use plain strings when an [aexp] is expected;
            the string will implicitly be wrapped with [AId].
        - [Declare Custom Entry com] tells Coq to create a new
            "custom grammar" for parsing Imp expressions and
            programs. The first notation declaration after this tells Coq
            that anything between [<{] and [}>] should be parsed using
            the Imp grammar. Again, it is not necessary to understand the
            details, but it is important to recognize that we are
            defining _new_ interpretations for some familiar operators
            like [+], [-], [*], [=], [<=], etc., when they occur between
            [<{] and [}>]. *)

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.

Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                    (in custom com at level 0, only parsing,
                    f constr at level 0, x constr at level 9,
                    y constr at level 9) : com_scope.
Notation "x + y"   := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y"   := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y"   := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := BTrue (in custom com at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := BFalse (in custom com at level 0).
Notation "x <= y"  := (BLe x y) (in custom com at level 70, no associativity).
Notation "x > y"   := (BGt x y) (in custom com at level 70, no associativity).
Notation "x = y"   := (BEq x y) (in custom com at level 70, no associativity).
Notation "x <> y"  := (BNeq x y) (in custom com at level 70, no associativity).
Notation "x && y"  := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b"   := (BNot b) (in custom com at level 75, right associativity).

Open Scope com_scope.

(** We can now write [3 + (X * 2)] instead  of [APlus 3 (AMult X 2)],
    and [true && ~(X <= 4)] instead of [BAnd true (BNot (BLe X 4))]. *)

(*
Definition example_aexp : aexp := <{ 3 + (X * 2) }>.
Definition example_bexp : bexp := <{ true && ~(X <= 4) }>.
*)

(* ================================================================= *)
(** ** Evaluation *)

Fixpoint aeval (st : state) (a : aexp) : nat :=
    match a with
    | ANum n => n
    | AId x => st x
    | <{a1 + a2}> => (aeval st a1) + (aeval st a2)
    | <{a1 - a2}> => (aeval st a1) - (aeval st a2)
    | <{a1 * a2}> => (aeval st a1) * (aeval st a2)
    end.

Fixpoint beval (st : state) (b : bexp) : bool :=
    match b with
    | <{true}>      => true
    | <{false}>     => false
    | <{a1 = a2}>   => (aeval st a1) =? (aeval st a2)
    | <{a1 <> a2}>  => negb ((aeval st a1) =? (aeval st a2))
    | <{a1 <= a2}>  => (aeval st a1) <=? (aeval st a2)
    | <{a1 > a2}>   => negb ((aeval st a1) <=? (aeval st a2))
    | <{~ b1}>      => negb (beval st b1)
    | <{b1 && b2}>  => andb (beval st b1) (beval st b2)
    end.

(** We can use our notation for total maps in the specific case of
    states -- i.e., we write the empty state as [(_ !-> 0)]. *)

Definition empty_st := (_ !-> 0).

(** Also, we can add a notation for a "singleton state" with just one
    variable bound to a value. *)
Notation "x '!->' v" := (x !-> v ; empty_st) (at level 100).

(* ################################################################# *)
(** * Commands *)

(** Now we are ready define the syntax and behavior of Imp
    _commands_ (or _statements_). *)

(* ================================================================= *)
(** ** Syntax *)

(** Informally, commands [c] are described by the following BNF
    grammar.

        c := skip | x := a | c ; c | if b then c else c end
            | while b do c end
*)

(** Here is the formal definition of the abstract syntax of
    commands: *)

Inductive com : Type :=
    | CSkip
    | CAsgn (x : string) (a : aexp)
    | CSeq (c1 c2 : com)
    | CIf (b : bexp) (c1 c2 : com)
    | CWhile (b : bexp) (c : com).

(** As we did for expressions, we can use a few [Notation]
    declarations to make reading and writing Imp programs more
    convenient. *)

Notation "'skip'"  :=
            CSkip (in custom com at level 0) : com_scope.
Notation "x := y"  :=
            (CAsgn x y)
            (in custom com at level 0, x constr at level 0,
                y at level 85, no associativity) : com_scope.
Notation "x ; y" :=
            (CSeq x y)
            (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
            (CIf x y z)
            (in custom com at level 89, x at level 99,
            y at level 99, z at level 99) : com_scope.
Notation "'while' x 'do' y 'end'" :=
            (CWhile x y)
            (in custom com at level 89, x at level 99, y at level 99) : com_scope.

(** For example, here is the factorial function again, written as a
    formal Coq definition.  When this command terminates, the variable
    [Y] will contain the factorial of the initial value of [X]. *)
(*
Definition fact_in_coq : com :=
    <{ Z := X;
        Y := 1;
        while Z <> 0 do
        Y := Y * Z;
        Z := Z - 1
        end }>.
*)

(* ################################################################# *)
(** * Evaluating Commands *)

(** Next we need to define what it means to evaluate an Imp command.
    The fact that [while] loops don't necessarily terminate makes
    defining an evaluation function tricky... *)

(* ================================================================= *)
(** ** Evaluation as a Relation *)

(** Here's a better way: define [ceval] as a _relation_ rather than a
    _function_ -- i.e., make its result a [Prop] rather than a
    [state], similar to what we did for [aevalR] above. *)

(** This is an important change.  Besides freeing us from awkward
    workarounds, it gives us a ton more flexibility in the definition.
    For example, if we add nondeterministic features like [any] to the
    language, we want the definition of evaluation to be
    nondeterministic -- i.e., not only will it not be total, it will
    not even be a function! *)

(** We'll use the notation [st =[ c ]=> st'] for the [ceval] relation:
    [st =[ c ]=> st'] means that executing program [c] in a starting
    state [st] results in an ending state [st'].  This can be
    pronounced "[c] takes state [st] to [st']". *)

(* ----------------------------------------------------------------- *)
(** *** Operational Semantics *)

(** Here is an informal definition of evaluation, presented as inference
    rules for readability:

                            -----------------                            (E_Skip)
                            st =[ skip ]=> st

                            aeval st a = n
                    -------------------------------                      (E_Asgn)
                    st =[ x := a ]=> (x !-> n ; st)

                            st  =[ c1 ]=> st'
                            st' =[ c2 ]=> st''
                            ---------------------                           (E_Seq)
                            st =[ c1;c2 ]=> st''

                            beval st b = true
                            st =[ c1 ]=> st'
                --------------------------------------               (E_IfTrue)
                st =[ if b then c1 else c2 end ]=> st'

                            beval st b = false
                            st =[ c2 ]=> st'
                --------------------------------------              (E_IfFalse)
                st =[ if b then c1 else c2 end ]=> st'

                            beval st b = false
                    -----------------------------                 (E_WhileFalse)
                    st =[ while b do c end ]=> st

                            beval st b = true
                            st =[ c ]=> st'
                    st' =[ while b do c end ]=> st''
                    --------------------------------                 (E_WhileTrue)
                    st  =[ while b do c end ]=> st''
*)

(** Here is the formal definition.  Make sure you understand
    how it corresponds to the inference rules. *)

Reserved Notation
            "st '=[' c ']=>' st'"
            (at level 40, c custom com at level 99,
            st constr, st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
    | E_Skip : forall st,
        st =[ skip ]=> st
    | E_Asgn  : forall st a n x,
        aeval st a = n ->
        st =[ x := a ]=> (x !-> n ; st)
    | E_Seq : forall c1 c2 st st' st'',
        st  =[ c1 ]=> st'  ->
        st' =[ c2 ]=> st'' ->
        st  =[ c1 ; c2 ]=> st''
    | E_IfTrue : forall st st' b c1 c2,
        beval st b = true ->
        st =[ c1 ]=> st' ->
        st =[ if b then c1 else c2 end]=> st'
    | E_IfFalse : forall st st' b c1 c2,
        beval st b = false ->
        st =[ c2 ]=> st' ->
        st =[ if b then c1 else c2 end]=> st'
    | E_WhileFalse : forall b st c,
        beval st b = false ->
        st =[ while b do c end ]=> st
    | E_WhileTrue : forall st st' st'' b c,
        beval st b = true ->
        st  =[ c ]=> st' ->
        st' =[ while b do c end ]=> st'' ->
        st  =[ while b do c end ]=> st''

    where "st =[ c ]=> st'" := (ceval c st st').

(** The cost of defining evaluation as a relation instead of a
    function is that we now need to construct _proofs_ that some
    program evaluates to some result state, rather than just letting
    Coq's computation mechanism do it for us. *)

(* ================================================================= *)
(** ** Determinism of Evaluation *)

(** Changing from a computational to a relational definition of
    evaluation is a good move because it frees us from the artificial
    requirement that evaluation should be a total function.  But it
    also raises a question: Is the second definition of evaluation
    really a partial _function_?  Or is it possible that, beginning from
    the same state [st], we could evaluate some command [c] in
    different ways to reach two different output states [st'] and
    [st'']?

    In fact, this cannot happen: [ceval] _is_ a partial function: *)

Theorem ceval_deterministic: forall c st st1 st2,
        st =[ c ]=> st1  ->
        st =[ c ]=> st2 ->
        st1 = st2.
Proof.
    intros c st st1 st2 E1 E2.
    generalize dependent st2.
    induction E1; intros st2 E2; inversion E2; subst.
    - (* E_Skip *) reflexivity.
    - (* E_Asgn *) reflexivity.
    - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in E1_1, IHE1_2.
    apply IHE1_2. assumption.
    - (* E_IfTrue, b evaluates to true *)
        apply IHE1. assumption.
    - (* E_IfTrue,  b evaluates to false (contradiction) *)
        rewrite H in H5. discriminate.
    - (* E_IfFalse, b evaluates to true (contradiction) *)
        rewrite H in H5. discriminate.
    - (* E_IfFalse, b evaluates to false *)
        apply IHE1. assumption.
    - (* E_WhileFalse, b evaluates to false *)
    reflexivity.
    - (* E_WhileFalse, b evaluates to true (contradiction) *)
    rewrite H in H2. discriminate.
    - (* E_WhileTrue, b evaluates to false (contradiction) *)
    rewrite H in H4. discriminate.
    - (* E_WhileTrue, b evaluates to true *)
    rewrite (IHE1_1 st'0 H3) in E1_1, IHE1_2.
    apply IHE1_2. assumption.  Qed.


Require Import List.
Import ListNotations.

Inductive Tree (A : Type) : Type :=
| E0 : Tree A
| N0 : A -> list (Tree A) -> Tree A.

Arguments E0 {A}.
Arguments N0 {A} _ _.

Fixpoint tmap {A B : Type} (f : A -> B) (t : Tree A) : Tree B :=
match t with
| E0 => E0
| N0 v ts => N0 (f v) (map (tmap f) ts)
end.


Lemma less_equal_or (i j : nat) :
  i <= j \/ j <= i.
Proof.
  induction i.
  - left. apply le_0_n.
  - destruct IHi.
    + destruct H.
      * right. apply le_S, le_n.
      * left. apply le_n_S, H.
    + right. apply le_S, H.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) (lf2 : natural) (lf1 : natural)
  : natural := lf1.


(* Razonamiento automatizado 2020-2
   Loyola Cruz Luis Fernando.
   Reyes Granados Naomi Itzel.
   Tarea 5, Tácticas Lógica clásica*)

Require Import Classical.

Parameters (p q r s u v C:Prop)
           (A: Set)
           (a z:A)
           (P Q S B R: A -> Prop).

Check classic.

Check classic u.

Check classic (u\/v).

Check NNPP.

Check NNPP v.

Check NNPP (u -> v).

Lemma trans: forall P Q R :Prop, ((P\/Q->False)->R) /\ (R->False) -> ((P\/Q->False)->False).
Proof.
intros.
destruct H.
apply H1.
apply H.
assumption.
Qed.

Lemma syhi: forall P Q R :Prop, ((~(P \/ Q) -> R) /\ ~R) -> (P \/ Q).
intro.
intro.
intro.
unfold not.
intro.
destruct H.
cut (~~(P0 \/ Q0)).
intro.
apply NNPP.
assumption.
unfold not.
apply (trans P0 Q0 R0).
split.
assumption.
assumption.
Qed.

Theorem ej1: ((p->q) /\ (~(p \/ r) -> s) /\ (p \/ q -> r)) -> (~s -> r).
Proof.
unfold not.
intros.
destruct H.
destruct H1.
cut (p\/r).
intro.
destruct H3.
apply H2.
left.
assumption.
assumption.
apply (syhi p r s).
split.
unfold not.
assumption.
unfold not.
assumption.
Qed.

Theorem ej2: ((p/\~q) /\ (p -> ~q)) -> (~(p->q) /\ (q->~p)).
Proof.
unfold not.
intros.
destruct H.
destruct H.
split.
intro.
apply H0.
assumption.
apply H2.
assumption.
intros.
apply H1.
assumption.
Qed.

Theorem eje3: (forall x:A, P x -> ~B x) -> (R a -> (forall x:A, R x -> B x) -> ~P a).
Proof.
intros.
unfold not.
intro.
absurd (B a).
apply H.
assumption.
apply H1.
assumption.
Qed.

Theorem eje4: (((exists x:A, P x /\ ~Q x) -> (forall y:A, P y -> R y)) /\ (exists x:A, P x /\ S x) /\ (forall x:A, P x -> ~R x)) -> (exists x:A, S x /\ Q x).
Proof.
intros.
destruct H.
destruct H0.
destruct H0.
destruct H0.
exists x.
split.
assumption.
apply NNPP.
unfold not.
intro.
absurd (R x).
apply H1.
assumption.
apply H.
exists x.
split.
assumption.
unfold not.
assumption.
assumption.
Qed.


Definition nat_caset :=
fun (P : nat -> Type) (f : P 0)
  (f0 : forall n : nat, P (S n)) =>
fix F (n : nat) {struct n} : P n :=
  match n as n0 return (P n0) with
  | 0 => f
  | S n0 => f0 n0
  end.

(* Scheme nat_caset := Elimination for nat Sort Type. *)
(* Print nat_caset. *)

Inductive nat := O | S (m:nat).

Scheme Case for list Sort Prop.
Scheme Case for list Sort Type.
Print list_case_nodep.
Scheme Elimination for list Sort Prop.
Scheme Elimination for list Sort Type.
Print list_case.
Print list_caset.
Scheme Minimality for list Sort Prop.
Scheme Induction for list Sort Prop.
Scheme Minimality for list Sort Type.
Scheme Induction for list Sort Type.

Print list_rect.
Print list_caset.
Print list_ind.
Print list_case.

Print list_case_nodep.
Print list_ind_nodep.
Print list_caset_nodep.
Print list_rect_nodep.

Scheme Case for nat Sort Prop.
Print nat_case_nodep.
Print nat_case.
Scheme Elimination for nat Sort Prop.
Print nat_case.

Scheme Elimination for le Sort Prop.
Scheme Induction for le Sort Prop.

Print le_case_dep.
Print le_ind_dep.

Test Nonrecursive Elimination Schemes.
Set Nonrecursive Elimination Schemes.
Test Nonrecursive Elimination Schemes.

Inductive roseTree := tree (xs:list roseTree).
Print roseTree_rect.
(* Scheme Induction for roseTree Sort Type. *)

Inductive nat := O | S (n:nat).
Inductive nat2 := O2 | S2 (n:nat2).
Print nat_rec.

Scheme  for nat Sort Prop.

Scheme Equality for nat Sort Prop.
Scheme Induction for nat Sort Prop.
Scheme Rewrite for nat Sort Prop.
Case Analysis Scheme for nat Sort Prop.


Require Export Omega.
Require Export ArithRing.

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

Theorem minus_S: forall x y, y <= x ->  S x - y = S (x - y).
induction x.
intros y; case y; simpl; auto.
intros y' Hlt; omega.
intros y; case y; auto.
intros y' Hlt; simpl; rewrite <- IHx.
case y'; simpl; auto.
omega.
Qed.

Theorem minus_minus: forall x y, x <= y ->  y - (y - x) = x.
induction x.
intros y _; rewrite <- minus_n_O; auto with arith.
intros y Hle; elim Hle.
simpl; rewrite <- minus_n_n; auto.
intros y' Hle' Heq; simpl (S y' - S x).
rewrite minus_S.
rewrite IHx.
auto.
omega.
omega.
Qed.

Lemma simpl_int_prop:
 forall m x d n n', n' + (m + 1) <= x -> 0 < d -> x < n ->  ( x - d < x < n ).
intros; omega.
Qed.

Lemma simpl_int_prop2:
 forall p x m n, ( 1 < p < m ) -> ( n+(m+1) <= x  ) ->  ( 1 < p < x ).
intros; omega.
Qed.

Lemma simpl_int_prop3:
 forall x n d m n', n <= x -> ( n'+(m+1) <= x ) ->  (x - d < n) -> (x - n < d).
intros; omega.
Qed.

Lemma simpl_int_prop4: forall x n,  (x - (x - n) <= x).
intros; omega.
Qed.

Definition not_mult (n m : nat) : Prop := forall p,  (m <> p * n).

Definition partial_prime (m n : nat) : Prop :=
   forall p, ( 1 < p < m ) ->  not_mult p n.

Definition pre_prime (n : nat) : Prop := partial_prime n n.

Fixpoint fact (n : nat) : nat :=
 match n with 0 => 1 | S p => S p * fact p end.

Fixpoint fact_ex (m n : nat) {struct n} : nat :=
 match n with
   O => 1
  | S p => if eq_nat_dec (S p) m then fact p else S p * fact_ex m p
 end.

Theorem fact_ex_eq: forall m n, ( 1 < m <= n ) ->  fact n = m * fact_ex m n.
induction n.
intros; omega.
intros Hint; lazy zeta iota beta delta [fact fact_ex]; fold fact fact_ex.
case (eq_nat_dec (S n) m).
intros; subst m; auto.
intros; rewrite IHn.
ring.
omega.
Qed.

Theorem le_1_fact: forall n,  (1 <= fact n).
induction n.
auto with arith.
simpl.
generalize (n * fact n); intros; omega.
Qed.

Theorem le_fact: forall n,  (n <= fact n).
induction n.
auto with arith.
lazy zeta iota beta delta [fact]; fold fact.
pattern (S n) at 1; replace (S n) with (S n * 1).
apply mult_le_compat_l.
apply le_1_fact.
ring.
Qed.

Definition mult_dec_aux:
 forall m n m', n < m' ->  ({ not_mult m n }) + ({ ~ not_mult m n }).
intros m n m'; generalize m n; clear m n; elim m'.
intros m n H; assert False.
omega.
elim H0.
intros m'' f m n Hlt.
elim (le_gt_dec m n).
intros Hle.
destruct m.
destruct n.
right; unfold not_mult.
intros H; apply (H 1); ring.
left; intros p.
rewrite <- mult_n_O.
discriminate.
elim (f (S m) (minus n (S m))).
unfold not_mult; intros Hn; left.
intros p Heq; apply (Hn (p - 1)).
rewrite Heq; rewrite mult_minus_distr_r.
replace (1 * S m) with (S m); ring.
intros Hm; right; intros Hn; apply Hm.
intros p Heq.
apply (Hn (p + 1)).
rewrite (le_plus_minus (S m) n).
rewrite Heq.
ring.
assumption.
omega.
destruct n.
intros _; right; intros Hn; apply (Hn 0).
ring.
intros Hgt; left; intros p Heq.
destruct p.
simpl in Heq |-; discriminate Heq.
simpl in Heq |-.
rewrite Heq in Hgt.
generalize Hgt; case (p * m).
rewrite <- plus_n_O.
exact (lt_irrefl m).
intros; omega.
Defined.

Definition mult_dec := fun m n => mult_dec_aux m n (S n) (le_n (S n)).

Theorem pre_prime_multiple_diff:
 forall m n d x,
 ( 1 < m < x ) -> n = x - d -> ~ not_mult m (x - d) -> pre_prime x ->  (0 < d).
intros m n d x Hint Heq Hm Hpr.
elim (le_lt_or_eq 0 d); trivial.
intros; subst d.
elim Hm; rewrite <- minus_n_O; apply Hpr.
omega.
auto with arith.
Qed.

Theorem partial_prime_step:
 forall m n, partial_prime m n -> not_mult m n ->  partial_prime (S m) n.
intros m n Hppr Hnm p Hint.
elim (Lt.le_lt_or_eq p m).
intros Hlt.
apply Hppr.
omega.
intros; subst p; assumption.
omega.
Qed.

Theorem partial_prime_rev:
 forall m n, partial_prime (S m) n ->  partial_prime m n.
intros n m Hppr p Hint; apply Hppr.
omega.
Qed.

Theorem partial_prime_le:
 forall m m' n, m <= m' -> partial_prime m' n ->  partial_prime m n.
intros m m' n Hle; elim Hle; clear Hle m'.
trivial.
intros m' Hle Hind Hppr; apply Hind; apply partial_prime_rev; auto.
Qed.

Theorem partial_prime_revstep:
 forall m n, 1 < m -> partial_prime (S m) n ->  not_mult m n.
intros n m Hlt Hppr.
apply Hppr.
omega.
Qed.

Definition partial_prime_dec:
 forall n m,  ({ partial_prime m n }) + ({ ~ partial_prime m n }).
intros n m; destruct m.
left.
unfold partial_prime.
intros; assert False.
omega.
elim H0.
destruct m.
left; unfold partial_prime; intros; assert False.
omega.
elim H0.
induction m.
left; unfold partial_prime; intros; assert False.
omega.
elim H0.
elim IHm.
intros Hppr; elim (mult_dec (S (S m)) n).
intros Hnm; left; apply partial_prime_step; trivial.
intros Hm; right; intros Hpr.
elim Hm.
apply Hpr; (try omega).
intros Hnpr; right; intros Hpr; elim Hnpr;
 apply partial_prime_le with (S (S (S m))); auto with arith.
Defined.

Definition pre_prime_dec (n : nat) : ({ pre_prime n }) + ({ ~ pre_prime n }) :=
   partial_prime_dec n n.

Theorem pre_prime2: pre_prime 2.
intros p Hint; assert False; [omega | elim H].
Qed.

Definition find_divisor:
 forall n m,
 ( 1 < n < m ) ->
 ~ not_mult n m ->
 forall p,
 (forall k, ( p < k < m ) ->  (m <> n * k)) ->  ({z : nat | m = n * z}).
intros n m Hlt Hm p; elim p.
intros Hn.
elim Hm.
intros k Hint.
elim (le_or_lt k 0).
intros Hk0; assert (Hk0': k = 0).
omega.
subst k; omega.
intros H0ltk.
elim (le_or_lt m k).
intros Hmk.
destruct n.
omega.
destruct n.
omega.
repeat rewrite <- mult_n_Sm in Hint.
generalize Hint; generalize (k * n); intros; omega.
intros Hkm.
apply (Hn k).
omega.
rewrite Hint; ring.
intros p' Hind Hnfound.
elim (eq_nat_dec m (n * S p')).
intros Heq; exists (S p'); assumption.
intros Hn; apply Hind.
intros k Hint; elim (le_lt_or_eq (S p') k).
intros; apply Hnfound; omega.
intros; subst k; assumption.
omega.
Qed.

Theorem pre_prime_decompose:
 forall x,
 ~ pre_prime x ->
  (exists y , pre_prime y /\ (( 1 < y < x ) /\ (exists z , x = y * z )) ).
intros x; elim x  using (well_founded_ind Wf_nat.lt_wf).
clear x; intros x Hind1.
generalize (le_n x).
assert (forall p, ( x <= p < x ) ->  not_mult p x).
intros; assert False.
omega.
elim H0.
generalize H; clear H; pattern x at 1 4; elim x.
intros H H0 H1.
elim H1.
intros p Hint.
apply H.
omega.
intros y Hind p Hint Hle.
elim (mult_dec y x).
intros Hn; apply Hind.
intros p' Hint'.
elim (le_lt_or_eq y p').
intros Hlt.
apply p.
omega.
intros; subst p'; assumption.
omega.
omega.
assumption.
intros Hm.
destruct y.
elim Hm.
unfold not_mult.
intros k Heq.
rewrite <- mult_n_O in Heq.
subst x.
omega.
destruct y.
elim Hle.
intros k Hint'; apply (p k).
omega.
elim (find_divisor (S (S y)) x) with x.
intros z Heq.
elim (pre_prime_dec (S (S y))).
intros Hpr.
exists (S (S y)).
split; auto.
split.
omega.
exists z; assumption.
intros Hnpr.
elim (Hind1 (S (S y))).
intros p' [Hpr' [Hint' [z' Heq']]].
exists p'.
split.
assumption.
split.
omega.
exists (z * z').
rewrite Heq; rewrite Heq'; ring.
omega.
assumption.
omega.
assumption.
intros; omega.
Qed.

Theorem plus_one_not_mult: forall p q r, 1 < p ->  (p * q + 1 <> p * r).
intros p q; elim q.
intros r; destruct r.
intros; omega.
replace (p * S r) with (p + p * r).
generalize (p * r); intros; omega.
ring.
intros q' Hind r.
destruct r.
generalize (p * S q'); intros; omega.
replace (p * S q' + 1) with (p + (p * q' + 1)).
replace (p * S r) with (p + p * r).
intros Hlt Heq.
apply (Hind r).
trivial.
apply plus_reg_l with p.
trivial.
ring.
ring.
Qed.

Theorem infinite_primes: forall n,  (exists m : nat , n <= m /\ pre_prime m ).
intros n; elim (pre_prime_dec (fact n + 1)).
intros H; exists (fact n + 1); split; trivial.
apply le_trans with (fact n).
apply le_fact.
auto with arith.
intros Hnpr; elim (pre_prime_decompose _ Hnpr).
intros p [Hpr [Hint [z Heq]]].
exists p.
split.
elim (le_or_lt n p); auto.
intros Hlt.
rewrite (fact_ex_eq p) in Heq.
elim (plus_one_not_mult p (fact_ex p n) z).
omega.
trivial.
omega.
assumption.
Qed.

Theorem partial_prime_next:
 forall x m m',
 partial_prime m x ->
 (forall p, ( m <= p < m' ) ->  ~ pre_prime p) ->  partial_prime m' x.
intros x m m' Hppr Hsm p Hint.
intros y Heq.
elim (pre_prime_dec p).
intros Hpr.
assert (Hintp:  1 < p < m ).
split.
omega.
elim (Lt.le_or_lt m p).
intros Hle; elim (Hsm p); (trivial; (try omega)).
trivial.
elim Hppr with p y; auto.
intros Hnpr.
elim (pre_prime_decompose _ Hnpr); intros p' [Hpr' [Hintp' [z Heq']]].
assert (Hint':  1 < p' < m ).
split.
omega.
elim (Lt.le_or_lt m p').
intros Hle; elim (Hsm p'); (trivial; (try omega)).
trivial.
elim Hppr with p' (y * z); auto.
rewrite Heq.
rewrite Heq'.
ring.
Qed.


(* Recursive types *)

Require Import Env.
Require Import TransitiveClosure.

Inductive Ty :=
        | t_arr  : Ty -> Ty -> Ty
        | t_unit : Ty
        | t_fix  : Ty -> Ty
        | t_var  : Var -> Ty.

Inductive Exp :=
        | var    : Var -> Exp
        | lambda : Ty  -> Exp -> Exp
        | app    : Exp -> Exp -> Exp
        | fixx   : Ty  -> Exp -> Exp

        | fold   : Ty  -> Exp -> Exp
        | unfold : Exp -> Exp

        | unitt  : Exp.

Definition TTEnv := Env unit.
Definition TEnv := Env Ty.

Fixpoint raiseT (e : Ty) (a b : nat) :=
 match e with
 | t_var v     => t_var  (raise' a b v)
 | t_arr  p q  => t_arr  (raiseT p a b) (raiseT p a b)
 | t_unit      => t_unit
 | t_fix  x    => t_fix  (raiseT x a (S b))
 end.

Fixpoint subT' (e e' : Ty) (v : Var) :=
 match e with
 | t_var v'     => subst' v v' t_var e'
 | t_fix t      => t_fix (subT' t (raiseT e' 1 0) (S v))

 | t_arr  p q  => t_arr  (subT' p e' v) (subT' p e' v)
 | t_unit      => t_unit
 end.

Definition subT e e' := subT' e e' 0.

Inductive TyWf (env:TTEnv) : Ty -> Prop :=
 | twf_env v : InEnv v tt env -> TyWf env (t_var v)
 | twf_arr t1 t2
   : TyWf env t1
  -> TyWf env t2
  -> TyWf env (t_arr t1 t2)
 | twf_fix t
   : TyWf (tt :: env) t
  -> TyWf        env  (t_fix t)

 | twf_unit : TyWf env t_unit.

(* Is TyWf necessary?
   Is there a way to make the TyWf[]t requirements neater or less repetitive? *)
Inductive TYPE (env : TEnv) : Exp -> Ty -> Prop :=
 | ty_env (v : Var) (t : Ty)
   : InEnv v t env
  -> TyWf [] t
  -> TYPE env (var v) t

 | ty_lam b t1 t2
   : TYPE (t1 :: env) b t2
  -> TyWf [] (t_arr t1 t2)
  -> TYPE env (lambda t1 b) (t_arr t1 t2)

 | ty_app e1 e2 t1 t2
   : TYPE env e1 (t_arr t1 t2)
  -> TYPE env e2 t1
  -> TyWf [] t2
  -> TYPE env (app e1 e2) t2

 | ty_fixx t e
   : TYPE (t :: env) e t
  -> TyWf [] t
  -> TYPE env (fixx t e) t

 | ty_fold t e
   : TYPE env e          (subT t (t_fix t))
  -> TyWf [] (t_fix t)
  -> TYPE env (fold t e) (t_fix t)

 | ty_unfold t e
   : TYPE env e          (t_fix t)
  -> TyWf [] (subT t (t_fix t))
  -> TYPE env (unfold e) (subT t (t_fix t)).

Lemma unicity
	(env: TEnv) (e : Exp) (t1 t2 : Ty)
	(Ht1 : TYPE env e t1)
	(Ht2 : TYPE env e t2)
	: t1 = t2.
Proof.
  revert t2 Ht2.
  induction Ht1; intros; inversion Ht2; subst; try congruence.

  apply IHHt1 in H2. congruence.

  apply IHHt1_1 in H2. congruence.

  apply IHHt1 in H1. congruence.
Qed.

Fixpoint raise (e : Exp) (a b : nat) :=
 match e with
 | var v       => var (raise' a b v)
 | lambda t x  => lambda t (raise x a (S b))
 | app f x     => app (raise f a b) (raise x a b)
 | fixx t x    => fixx t (raise x a (S b))

 | fold t e    => fold t (raise e a b)
 | unfold e    => unfold (raise e a b)

 | unitt       => unitt
 end.

Lemma raise_0_id (e : Exp) (n : nat) :
	raise e 0 n = e.
Proof.
 revert n.
 induction e; intros; simpl; try (rewrite IHe1, IHe2); try rewrite IHe; try rewrite IHe3; try reflexivity.
 unfold raise, raise'.
 destruct (ge_dec v n); auto.
Qed.

Lemma raise_S (e : Exp) (a b : nat) :
	raise e (S a) b = raise (raise e a b) 1 b.
Proof.
 revert a b.
 induction e; intros; simpl; try (rewrite IHe1, IHe2); try rewrite IHe; try rewrite IHe3; try reflexivity.
 unfold raise, raise'.
 destruct (ge_dec v b); auto.
 destruct (ge_dec (a+v) b); auto.
  omega.
 destruct (ge_dec v b); auto.
  omega.
Qed.

Fixpoint subst (e e' : Exp) (v : Var) :=
 match e with
 | var v'       => subst' v v' var e'
 | lambda t x   => lambda t (subst x (raise e' 1 0) (S v))
 | app    f x   => app (subst f e' v) (subst x e' v)
 | fixx   t x   => fixx t (subst x (raise e' 1 0) (S v))

 | fold t e    => fold t (subst e e' v)
 | unfold e    => unfold (subst e e' v)

 | unitt       => unitt
 end.

Lemma weakening_insert
        (env : TEnv) (e : Exp) (te tvi : Ty) (vi : Var) :
        TYPE env e te ->
        TYPE (insert env vi tvi) (raise e 1 vi) te.
 intros Hte.
 revert vi tvi.
 induction Hte; intros; try solve [constructor; auto]; simpl.

 apply ty_env.
  unfold raise'.
   destruct (ge_dec v vi).
   apply get_insert_ge; assumption.
   apply get_insert_lt; try assumption; omega.
  assumption.

 apply ty_lam.
  rewrite <- uninsert.
  apply IHHte. assumption.

 eapply ty_app; eauto.

 eapply ty_fixx.
  rewrite <- uninsert; auto.
  assumption.
Qed.

Lemma weakening_cons
	(env : TEnv) (e : Exp) (te : Ty) tv :
	TYPE env e te ->
	TYPE (tv :: env) (raise e 1 0) te.
Proof.
 rewrite <- insert_0.
 apply weakening_insert.
Qed.

Lemma substitution_ix env x t t' e e':
      TYPE (insert env x t) e'             t' ->
      TYPE env              e              t  ->
      x <= length env                         ->
      TYPE env              (subst e' e x) t'.
Proof.
 intros He' He Hlen.
 remember (insert env x t) as ENV.
 revert e x t env HeqENV He Hlen.
 induction He'; intros; subst; simpl; try constructor; try assumption.
  apply subst_cases; intros; subst.
   eapply InEnv_insert in H. rewrite <- H. assumption.
   apply insert_minus in H; try apply ty_env; try assumption; try omega.
   apply insert_pre in H; try apply ty_env; try assumption; try omega.

 eapply IHHe'; eauto; try reflexivity.
  apply weakening_cons; assumption.
  simpl; omega.

 eapply ty_app.
  eapply IHHe'1; auto.
  eapply IHHe'2; auto.
  assumption.

 eapply IHHe'; simpl; try omega; try reflexivity.
  apply weakening_cons.
  assumption.

 eapply IHHe'; eauto.
 eapply IHHe'; eauto.
Qed.

Lemma substitution env t t' e e':
      TYPE (t :: env)       e'             t' ->
      TYPE env              e              t  ->
      TYPE env              (subst e' e 0) t'.
Proof.
 intros.
 eapply substitution_ix; try rewrite insert_0; try eassumption; try omega.
Qed.

Inductive val : Exp -> Prop :=
 | v_lambda t b
   : val (lambda t b)
 | v_fold t e
   : val e
  -> val (fold t e)
 | v_u
   : val unitt.

Inductive e_step: Exp -> Exp -> Prop :=
 | e_ap1 e1 e1' e2
   : e_step      e1          e1'
  -> e_step (app e1 e2) (app e1' e2)
 | e_ap2 e1 e2 e2'
   : val e1
  -> e_step         e2          e2'
  -> e_step (app e1 e2) (app e1 e2')

 | e_lam  t b x
   : val x
  -> e_step (app (lambda t b) x) (subst b x 0)

 | e_fixx t e
   : e_step (fixx t e) (subst e (fixx t e) 0)

 | e_fold t e e'
   : e_step e e'
  -> e_step (fold t e) (fold t e')

 | e_unfold1 e e'
   : e_step e e'
  -> e_step (unfold e) (unfold e')
 | e_unfoldF t e
   : val (fold t e)
  -> e_step (unfold (fold t e)) e.

Theorem preservation env e e' t:
        TYPE env e t ->
        e_step e e'  ->
        TYPE env e' t.
Proof.
 intros Ht He.
 revert env t Ht.
 induction He; intros; inversion Ht; subst;
   try solve [try econstructor; try eapply IHHe; eassumption];
   try (eapply substitution; eassumption).
  inversion H2. subst.
  eapply substitution; eassumption.
  inversion H1; subst; assumption.
Qed.

Theorem progress e t:
        TYPE [] e t ->
        val e \/ exists e', e_step e e'.
Proof.
 remember [] as ENV.
 intros Ht.
 induction Ht; subst;
  try solve [apply not_InEnv_nil in H; destruct H];
  try solve [left; econstructor; eassumption].

 destruct IHHt1; try reflexivity.
 destruct IHHt2; try reflexivity.
 inversion H0; subst; inversion Ht1; subst.
 right.
  eexists. apply e_lam. assumption.
 destruct H1.
 right.
  eexists. apply e_ap2; eassumption.

 destruct H0.
 right.
  eexists. apply e_ap1; eassumption.

 right. eexists. eapply e_fixx.

 destruct IHHt; try reflexivity.
  left. constructor. assumption.
  destruct H0.
   right. eexists. constructor. eassumption.

 destruct IHHt; auto.
  inversion H0; subst; inversion Ht; subst.
  right. eexists. apply e_unfoldF. assumption.

  destruct H0.
  right. eexists. apply e_unfold1. eassumption.
Qed.


Require Import List Logic Nat Omega ListDec.
Import ListNotations.
From Block
Require Import finite lib definitions ramsey lemma2choice.

(* ***************** *)
(* **** Lemma 3 **** *)
(* ***************** *)
(* "If L is in C_k then so is L_s for any s in the alphabet" *)
Lemma lemma3 : forall (k : block_pumping_constant) (L : language),
    block_cancellable_matching_with k L ->
    forall (Ld : language) (x : word), is_derivative L Ld x -> block_cancellable_matching_with k Ld.
Proof.
  intros k L H_BC Ld x H_Lx w bps.
  assert (H_non_empty :=  about_bps_nonempty k w bps).
  (* Case analysis on w at this step, absurdo the empty string *)
  destruct w.
  - (* When the word is empty, explosion occurs *)
    spec H_BC ([] : word) bps.
    destruct H_BC as [bp1 [bp2 [H_lt H_BC]]].
    destruct_bps bps about_bps.
    destruct about_bps as [H_length [H_incr H_last]].
    unfold length in H_last; inversion H_last.
    assert (H_useful := about_incr_length_last k definitions.d bps).
    spec H_useful H_non_empty H_length H_incr.
    rewrite H0 in H_useful.
    destruct k as [k about_k]. unfold p_predicate in about_k.
    simpl in H_useful; omega.
  - (* We need to basically argue that the derivative word's breakpoints
       set can also be breakpoints for the larger word. *)
    (* bps is a breakpoint set for some random word in the derivative. *)
    (* We need to extract two breakpoints, and then manipulate them
       into breakpoints for the original word by incrementing by length. *)
    (** Setting the strong induction on word length requires some proof engineering **)
    remember (length x) as n.
    assert (H_move := Nat.eq_refl (length x)).
    rewrite <- Heqn in H_move at 2. clear Heqn.
    generalize dependent x.
    (** Strong induction on word length! **)
    induction n as [|n IHn] using strong_induction; intros x H_Lx H_x_length.
    + (* When the derivative marker is epsilon, Ld = L *)
      (* So we use exactly the same breakpoint set, no shifting! *)
      apply length_zero_iff_nil in H_x_length.
      subst x.
      spec H_BC (t::w) bps.
      destruct H_BC as [bp1 [bp2 [H_lt H_BC]]].
      exists bp1, bp2.
      split. assumption.
      assert (H_Lx_copy := H_Lx);
      spec H_Lx (t::w);
      spec H_Lx_copy (firstn bp1 (t :: w) ++ skipn bp2 (t :: w));
      rewrite app_nil_l in *.
      split; intro H.
      ++ apply H_Lx; apply H_BC; apply H_Lx_copy; assumption.
      ++ apply H_Lx_copy; apply H_BC; apply H_Lx; assumption.
         (* Done with base case! *)
    + (* I need to shift all the breakpoints in bps rightwards by length x *)
      remember (map (plus n) bps) as shifted_bps.
      assert (H_guarantee := shifted_gt bps n).
      (* Now I need to show that these can also make a set of breakpoints *)
      assert (about_shifted_bps : breakpoint_set_predicate shifted_bps (x++t::w) k).
      { destruct_bps bps about_bps.
        destruct about_bps as [H_length [H_incr H_last]].
        subst shifted_bps.
        split.
        rewrite map_length. assumption.
        split. now apply (about_plus_increasing n).
        rewrite app_length. rewrite plus_comm.
        assert (H_last_copy := H_last).
        rewrite about_last_nth in H_last_copy.
        rewrite about_last_nth.
        rewrite map_length.
        (* Switch the default variable *)
        replace (nth (length bps - 1) (map (add n) bps) definitions.d)
          with (nth (length bps - 1) (map (add n) bps) (add n definitions.d)).
        2 : { eapply (@nth_indep nat). rewrite map_length.
              destruct k as [k about_k]; unfold p_predicate in about_k.
              rewrite H_length. simpl; omega. }
        rewrite map_nth. rewrite unfold_length_S. simpl; omega. }
      (* Now we have the breakpoint set to feed to BC(k, L) *)
      spec H_BC (x++t::w) (exist (fun l => breakpoint_set_predicate l (x++t::w) k) shifted_bps about_shifted_bps).
      (* Now we can get the breakpoints from BC(k, L) *)
      destruct H_BC as [bp1 [bp2 [H_lt H_BC]]].
      destruct_bp bp1 about_bp1; destruct_bp bp2 about_bp2.
      (* Now we want to argue that shifting them back,
       these again-shifted breakpoints are also breakpoints for bps *)
      assert (about_bp1' : breakpoint_predicate (bp1-n) k (t::w) bps).
      { (* Proving that the first one still is *)
        unfold breakpoint_predicate.
        unfold breakpoint_predicate in about_bp1.
        simpl in *.
        rewrite Heqshifted_bps in about_bp1.
        (* Now we have something that looks straightforward *)
        (* In nat, as long as you're adding then minusing you're fine. *)
        apply (in_map (fun a => a - n) (map (add n) bps) bp1) in about_bp1.
        assert ((map (fun a : nat => a - n) (map (add n) bps)) = bps).
        { rewrite map_map.
          now apply map_plus_minus. }
        rewrite H in about_bp1. exact about_bp1. }
      assert (about_bp2' : breakpoint_predicate (bp2-n) k (t::w) bps).
      { (* Proving that the second one still is *)
        unfold breakpoint_predicate.
        unfold breakpoint_predicate in about_bp2.
        simpl in *.
        rewrite Heqshifted_bps in about_bp2.
        (* Now we have something that looks straightforward *)
        (* In nat, as long as you're adding then minusing you're fine. *)
        apply (in_map (fun a => a - n) (map (add n) bps) bp2) in about_bp2.
        assert ((map (fun a : nat => a - n) (map (add n) bps)) = bps).
        { rewrite map_map.
          now apply map_plus_minus. }
        rewrite H in about_bp2; exact about_bp2. }
      (* Proving the extra obligation for nats and zeroes *)
      exists (exist _ (bp1 - n) about_bp1').
      exists (exist _ (bp2 - n) about_bp2').
    simpl in *. split.
    apply lt_minus_n. assumption.
    { apply H_guarantee. rewrite <- Heqshifted_bps.
      unfold breakpoint_predicate in about_bp1.
      simpl in about_bp1; assumption. }
    assert (H_keep1 : bp1 >= n).
    { apply H_guarantee. rewrite <- Heqshifted_bps.
      unfold breakpoint_predicate in about_bp1.
      simpl in about_bp1; assumption. }
    assert (H_keep2 : bp2 >= n).
    { apply H_guarantee. rewrite <- Heqshifted_bps.
      unfold breakpoint_predicate in about_bp2.
      simpl in about_bp2; assumption. }
    (* Somewhere I needed to reassure the proof context that all bp1's are
       greater than n *)
    assert (H_Lx_copy := H_Lx).
    clear -H_BC H_Lx H_Lx_copy H_x_length H_keep1 H_keep2.
    subst n.
    assert (H_useful := about_deriv_eq bp1 bp2 x (t::w) H_keep1 H_keep2).
    split; intro H_in.
      ++ spec H_Lx (t::w). apply H_Lx.
         apply H_BC.
         clear H_BC H_Lx.
         rewrite <- H_useful.
         spec H_Lx_copy (firstn (bp1 - length x) (t :: w) ++ skipn (bp2 - length x) (t :: w)).
         apply H_Lx_copy; assumption.
      ++ spec H_Lx (t::w).
         apply H_Lx in H_in. clear H_Lx.
         apply H_BC in H_in.
         spec H_Lx_copy (firstn (bp1 - (length x)) (t :: w) ++ skipn (bp2 - (length x)) (t :: w)).
         apply H_Lx_copy.
         rewrite H_useful; assumption.
Qed.

Lemma lemma3' : forall (k : block_pumping_constant) (L : language),
    block_cancellable_matching_with k L ->
    forall (Ld : language), is_deriv L Ld -> block_cancellable_matching_with k Ld.
Proof.
  intros k L H_bc.
  assert (H_useful := lemma3 k L H_bc).
  intros Ld H_deriv.
  destruct H_deriv as [x H_deriv].
  spec H_useful Ld x.
  spec H_useful. red. intros.
  spec H_deriv w. tauto. assumption.
Qed.

(* A dependent version of lemma3 *)
Lemma lemma3_dep : forall (k : block_pumping_constant) (L : {l | bc_sigma k l}),
    forall (Ld : language) (x : word), is_derivative (proj1_sig L) Ld x ->
                                  block_cancellable_matching_with k Ld.
Proof.
  intros k L_dep L_d x H_deriv.
  assert (H_useful := lemma3 k (proj1_sig L_dep)).
  destruct L_dep as [L_dep H_BC].
  spec H_useful H_BC L_d x.
  spec H_useful H_deriv. assumption.
Qed.


(*! Utilities | Show typeclass (α → string) !*)
Require Export Coq.Strings.String.

Class Show (A: Type) :=
  { show: A -> string }.

Module Show_nat.
  Lemma digit_lt_base m {n} : not (m + n < m).
  Proof.
    red; intros; eapply Le.le_Sn_n; eauto using Le.le_trans, Plus.le_plus_l.
  Qed.

  Definition string_of_base10_digit (n: {n | n < 10}) :=
    match n with
    | exist _ 0 _ => "0" | exist _ 1 _ => "1" | exist _ 2 _ => "2" | exist _ 3 _ => "3" | exist _ 4 _ => "4"
    | exist _ 5 _ => "5" | exist _ 6 _ => "6" | exist _ 7 _ => "7" | exist _ 8 _ => "8" | exist _ 9 _ => "9"
    | exist _ n pr => False_rect _ (digit_lt_base 10 pr)
    end%string.

  Fixpoint string_of_nat_rec (fuel: nat) (n: nat) :=
    match fuel with
    | O => ""%string
    | S fuel =>
      match (Compare_dec.lt_dec n 10) with
      | left pr  => string_of_base10_digit (exist _ n pr)
      | right pr => append (string_of_nat_rec fuel (PeanoNat.Nat.div n 10)) (string_of_nat_rec fuel (PeanoNat.Nat.modulo n 10))
      end
    end.

  Definition string_of_nat (n: nat) :=
    string_of_nat_rec (S n) n.
End Show_nat.

Instance Show_nat : Show nat :=
  { show := Show_nat.string_of_nat }.

Instance Show_string : Show string :=
  {| show x := x |}.