(* ********************************************** *)
(* Types and Semantics for Programming Languages  *)
(* ********************************************** *)

(* Place an X in front of the appropriate statement *)
(* [ ]  I have done Problems 1 and 2 *)
(* [ ]  I have done Problems 1 and 3 *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Export Maps.
Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive member {X : Type} : X -> list X -> Prop :=
   | member_here : forall x xs, member x (x::xs)
   | member_later : forall (x:X) xs x y,
       member x xs -> member x (y::xs).

Theorem app_member_left: forall (X:Type) (x:X) (xs ys : list X),
   member x xs -> member x (xs++ys).
Proof.
  intros.
  induction H.
  - simpl. apply member_here.
  - simpl. apply member_later. assumption. assumption.
Qed.

Theorem app_member_right : forall (X:Type) (x:X) (xs ys : list X),
   member x ys -> member x (xs ++ ys).
Proof.
  intros.
  induction xs.
  - simpl. assumption.
  - simpl. apply member_later. assumption... assumption.
Qed.

Theorem or_app_member: forall (X:Type) (x:X) (xs ys : list X),
    member x xs \/ member x ys -> member x (xs ++ ys).
Proof.
    intros.
    destruct H.
    - apply app_member_left. assumption.
    - apply app_member_right. assumption.
Qed.

Theorem app_or_member: forall (X:Type) (x:X) (xs ys : list X),
     member x (xs ++ ys) -> member x xs \/ member x ys.
Proof.
   intros.
   induction xs.
   - simpl in H. simpl. right. assumption.
   - simpl in H. inversion H. subst.
     + left. apply member_here.
     + subst. apply IHxs in H2. destruct H2.
       * left. apply member_later. assumption. assumption.
       * right. assumption.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* Arithmetic and boolean expressions *)

Definition state := total_map nat.

Definition ble_nat := leb.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

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

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation " 'REPEAT' c 'UNTIL' b 'END'" :=
  (CRepeat c b) (at level 80, right associativity).

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''

  | E_RepeatEnd : forall c st st' b,
      c / st || st' ->
      beval st' b = true ->
      (REPEAT c UNTIL b END) / st || st'

  | E_RepeatLoop : forall c st st' st'' b,
      c / st || st' ->
      beval st' b = false ->
      (REPEAT c UNTIL b END) / st' || st'' ->
      (REPEAT c UNTIL b END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + (* "b is true" *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  + (* "b is false" *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  + (* Case "E_WhileEnd" *)
    split. assumption. apply bexp_eval_false. assumption.
  + (* Case "E_WhileLoop" *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Lemma hoare_repeat : forall P Q b c,
  {{P}} c {{Q}} ->
  (fun st => Q st /\ ~ (bassn b st)) ->>  P ->
  {{P}} (REPEAT c UNTIL b END) {{fun st => Q st /\ bassn b st}}.
Proof.
  intros P Q b c HHoare HP st st' He.
  remember (REPEAT c UNTIL b END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
    - split.  apply (HHoare st st'). assumption. assumption.
      apply bexp_eval_true. assumption.
    - intros. apply IHHe2. reflexivity.
      apply (HP st'). split.
      apply (HHoare st st'). assumption. assumption.
      apply bexp_eval_false. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty
  | Tree : ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tbranch : tm -> tm -> tm -> tm
  | tleaf : tm
.

(* Values *)

(* STOPPED HERE *)
(* STOPPED HERE *)
(* STOPPED HERE *)
(* STOPPED HERE *)
(* STOPPED HERE *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse
  | v_branch : forall t1 t2 t3,
     value t2 ->
     value (tbranch t1 t2 t3)
  | v_leaf :
      value tleaf
.

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20, right associativity).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Definition relation a := a -> a -> Prop.

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation "t1 '==>*' t2" := (multi step t1 t2) (at level 40).

(* Contexts *)

Definition context := partial_map ty.

(* Typing relation *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  + (* Case "T_Var" *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  + (* Case "T_App" *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    - (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    - (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  + (* Case "T_If" *)
    right. destruct IHHt1...

    - (* t1 is a value *)
      destruct (cannonical_forms_bool t1); subst; eauto.

    - (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: String.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Arith.
Require Import Ascii.
Declare ML Module "string_syntax_plugin".

(** *** Definition of strings *)

(** Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.

Delimit Scope string_scope with string.
Bind Scope string_scope with string.
Open Local Scope string_scope.

(** Equality is decidable *)

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
 decide equality; apply ascii_dec.
Defined.

(** *** Concatenation of strings *)

Reserved Notation "x ++ y" (right associativity, at level 60).

Fixpoint append (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (s1' ++ s2)
  end

where "s1 ++ s2" := (append s1 s2) : string_scope.

(******************************)
(** Length                    *)
(******************************)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.

(******************************)
(** Nth character of a string *)
(******************************)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None
  | String c s' => match n with
                   | O => Some c
                   | S n' => get n' s'
                   end
  end.

(** Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
  forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
Proof.
intros s1; elim s1; simpl in |- *.
intros s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H; intros H1 H2 n; case n; auto.
rewrite H2; trivial.
rewrite H1; auto.
Qed.

(** The first elements of [s1 ++ s2] are the ones of [s1] *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
intros n0 H; apply Rec; auto.
apply lt_S_n; auto.
Qed.

(** The last elements of [s1 ++ s2] are the ones of [s2] *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n; rewrite plus_comm; simpl in |- *; auto.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
generalize (Rec s2 0); simpl in |- *; auto. intros.
rewrite <- Plus.plus_Snm_nSm; auto.
Qed.

(** *** Substrings *)

(** [substring n m s] returns the substring of [s] that starts
    at position [n] and of length [m];
    if this does not make sense it returns [""] *)

Fixpoint substring (n m : nat) (s : string) : string :=
  match n, m, s with
  | 0, 0, _ => EmptyString
  | 0, S m', EmptyString => s
  | 0, S m', String c s' => String c (substring 0 m' s')
  | S n', _, EmptyString => s
  | S n', _, String c s' => substring n' m s'
  end.

(** The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros p H; inversion H.
intros m' p; case p; simpl in |- *; auto.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
Qed.

(** The substring has at most [m] elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros m' p; case p; simpl in |- *; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Le.le_S_n; auto.
Qed.

(** *** Test functions *)

(** Test if [s1] is a prefix of [s2] *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.

(** If [s1] is a prefix of [s2], it is the [substring] of length
    [length s1] starting at position [O] of [s2] *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2; case s2; simpl in |- *; split; auto.
intros a s1' Rec s2; case s2; simpl in |- *; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.

(** Test if, starting at position [n], [s1] occurs in [s2]; if
    so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) : option nat :=
  match s2, n with
  | EmptyString, 0 =>
      match s1 with
      | EmptyString => Some 0
      | String a s1' => None
      end
  | EmptyString, S n' => None
  | String b s2', 0 =>
      if prefix s1 s2 then Some 0
      else
        match index 0 s1 s2' with
        | Some n => Some (S n)
        | None => None
        end
   | String b s2', S n' =>
      match index n' s1 s2' with
      | Some n => Some (S n)
      | None => None
      end
  end.

(* Dirty trick to avoid locally that prefix reduces itself *)
Opaque prefix.

(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
case H0; simpl in |- *; auto.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [Some m],
    [s1] does not occur in [s2] before [m] *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
intros p H2 H3; inversion H3.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl in |- *; auto.
intros H2 H3; red in |- *; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; intros H4; injection H4; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl in |- *; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; intros H3; injection H3; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [None], [s1] does not occur in [s2]
    after [n] *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
case m; intros; red in |- *; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl in |- *; auto.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl in |- *; auto with bool.
case s1; simpl in |- *; auto.
intros a s H H0 H1 H2; red in |- *; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl in |- *; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl in |- *; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.

(* Back to normal for prefix *)
Transparent prefix.

(** If we are searching for the [Empty] string and the answer is no
    this means that [n] is greater than the size of [s] *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None -> length s < n.
Proof.
intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl in |- *; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.

(** Same as [index] but with no optional type, we return [0] when it
    does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.

(** *** Concrete syntax *)

(**
  The concrete syntax for strings in scope string_scope follows the
  Coq convention for strings: all ascii characters of code less than
  128 are litteral to the exception of the character `double quote'
  which must be doubled.

  Strings that involve ascii characters of code >= 128 which are not
  part of a valid utf8 sequence of characters are not representable
  using the Coq string notation (use explicitly the String constructor
  with the ascii codes of the characters).
*)

Example HelloWorld := "	""Hello world!""
".


(* Test robustness of Groebner tactic in presence of disequalities *)

Require Export Reals.
Require Export Nsatz.

Open Scope R_scope.

Lemma essai :
 forall yb xb m1 m2 xa ya,
  xa <> xb ->
 yb - 2 * m2 * xb = ya - m2 * xa ->
 yb - m1 * xb = ya - m1 * xa ->
 yb - ya = (2 * xb - xa) * m2 ->
 yb - ya = (xb - xa) * m1.
Proof.
intros.
(* clear H. groebner used not to work when H was not cleared *)
nsatz.
Qed.


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

 Two-sided fibrations

 In this file, we study two-sided fibrations and we use two-sided displayed
 categories to define them. Note that the 'two-sided' in the name
 'two-sided displayed categories' is taken from two-sided fibrations, and defining
 two-sided fibrations is one of the main goal.

 Our definition is based on Definition 2.3.4 in
    https://arxiv.org/pdf/1806.06129.pdf
 Let's say we have the span `C₁ ⟵ D ⟶ C₂`. In the definition by Loregian and Riehl,
 the functor `D ⟶ C₂` has a cleaving and the functor `D ⟶ C₁` has an opcleaving.
 However, in our definition, it is the other way around. For us, the functor
 `D ⟶ C₁` has a cleaving and `D ⟶ C₂` has an opcleaving. This change has minor
 consequence. For example, if we consider the arrow category on a category `C`,
 then we have a two-sided fibration `C ⟵ Arr(C) ⟶ C` where the left functor is the
 domain and the right functor is the codomain. In the definition by Loregian and
 Riehl, this would be the other way around. If we would use their definition in our
 setting, then we would need to reveres the arrows when defining the arrow category.

 Contents
 1. Opcartesian morphisms
 2. Cartesian morphisms
 3. Cleavings
 4. Two-sided fibrations

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.

Local Open Scope cat.

Section TwoSidedFibration.
  Context {C₁ C₂ : category}
          (D : twosided_disp_cat C₁ C₂).

  (**
   1. Opcartesian morphisms
   *)
  Definition twosided_opcartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₃ : C₁)
         (y₃ : C₂)
         (xy₃ : D x₃ y₃)
         (f' : x₂ --> x₃)
         (g' : y₂ --> y₃)
         (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃),
       ∃! (ℓ : xy₂ -->[ f' ][ g' ] xy₃),
       fg ;;2 ℓ = fg'.

  Definition twosided_opcartesian_factorisation
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_opcartesian fg)
             {x₃ : C₁}
             {y₃ : C₂}
             {xy₃ : D x₃ y₃}
             {f' : x₂ --> x₃}
             {g' : y₂ --> y₃}
             (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃)
    : xy₂ -->[ f' ][ g' ] xy₃
    := pr11 (H _ _ _ _ _ fg').

  Definition twosided_opcartesian_factorisation_commutes
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_opcartesian fg)
             {x₃ : C₁}
             {y₃ : C₂}
             {xy₃ : D x₃ y₃}
             {f' : x₂ --> x₃}
             {g' : y₂ --> y₃}
             (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃)
    : fg ;;2 twosided_opcartesian_factorisation H fg' = fg'
    := pr21 (H _ _ _ _ _ fg').

  (**
   2. Cartesian morphisms
   *)
  Definition twosided_cartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₀ : C₁)
         (y₀ : C₂)
         (xy₀ : D x₀ y₀)
         (f' : x₀ --> x₁)
         (g' : y₀ --> y₁)
         (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂),
       ∃! (ℓ : xy₀ -->[ f' ][ g' ] xy₁),
       ℓ ;;2 fg = fg'.

  Definition twosided_cartesian_factorisation
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_cartesian fg)
             {x₀ : C₁}
             {y₀ : C₂}
             {xy₀ : D x₀ y₀}
             {f' : x₀ --> x₁}
             {g' : y₀ --> y₁}
             (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂)
    : xy₀ -->[ f' ][ g' ] xy₁
    := pr11 (H _ _ _ _ _ fg').

  Definition twosided_cartesian_factorisation_commutes
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_cartesian fg)
             {x₀ : C₁}
             {y₀ : C₂}
             {xy₀ : D x₀ y₀}
             {f' : x₀ --> x₁}
             {g' : y₀ --> y₁}
             (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂)
    : twosided_cartesian_factorisation H fg' ;;2 fg = fg'
    := pr21 (H _ _ _ _ _ fg').

  (**
   3. Cleavings
   *)
  Definition twosided_opcleaving
    : UU
    := ∏ (x : C₁)
         (y₁ y₂ : C₂)
         (xy₁ : D x y₁)
         (g : y₁ --> y₂),
       ∑ (xy₂ : D x y₂)
         (ℓ : xy₁ -->[ identity _ ][ g ] xy₂),
       twosided_opcartesian ℓ.

  Definition twosided_opcleaving_ob
             (H : twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : D x y₂
    := pr1 (H x y₁ y₂ xy₁ g).

  Definition twosided_opcleaving_mor
             (H : twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : xy₁ -->[ identity _ ][ g ] twosided_opcleaving_ob H xy₁ g
    := pr12 (H x y₁ y₂ xy₁ g).

  Definition twosided_opcleaving_opcartesian
             (H : twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : twosided_opcartesian (twosided_opcleaving_mor H xy₁ g)
    := pr22 (H x y₁ y₂ xy₁ g).

  Definition twosided_cleaving
    : UU
    := ∏ (x₁ x₂ : C₁)
         (y : C₂)
         (xy₂ : D x₂ y)
         (f : x₁ --> x₂),
       ∑ (xy₁ : D x₁ y)
         (ℓ : xy₁ -->[ f ][ identity _ ] xy₂),
       twosided_cartesian ℓ.

  Definition twosided_cleaving_ob
             (H : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : D x₁ y
    := pr1 (H x₁ x₂ y xy₂ f).

  Definition twosided_cleaving_mor
             (H : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : twosided_cleaving_ob H xy₂ f -->[ f ][ identity _ ] xy₂
    := pr12 (H x₁ x₂ y xy₂ f).

  Definition twosided_cleaving_cartesian
             (H : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : twosided_cartesian (twosided_cleaving_mor H xy₂ f)
    := pr22 (H x₁ x₂ y xy₂ f).

  Definition twosided_commute
             (H₁ : twosided_opcleaving)
             (H₂ : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             (xy : D x₂ y₁)
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : twosided_opcleaving_ob H₁ (twosided_cleaving_ob H₂ xy f) g
      -->[ identity _ ][ identity _ ]
      twosided_cleaving_ob H₂ (twosided_opcleaving_ob H₁ xy g) f.
  Proof.
    use (twosided_opcartesian_factorisation
           (twosided_opcleaving_opcartesian H₁ _ g)).
    use (twosided_cartesian_factorisation
           (twosided_cleaving_cartesian H₂ _ f)).
    refine (transportb
              (λ z, _ -->[ z ][ _ ] _)
              _
              (transportb
                 (λ z, _ -->[ _ ][ z ] _)
                 _
                 (twosided_cleaving_mor H₂ xy f ;;2 twosided_opcleaving_mor H₁ xy g))).
    - abstract
        (rewrite !id_left, !id_right ;
         apply idpath).
    - abstract
        (rewrite !id_left, !id_right ;
         apply idpath).
  Defined.

  Definition is_iso_twosided_commute
             (H₁ : twosided_opcleaving)
             (H₂ : twosided_cleaving)
    : UU
    := ∏ (x₁ x₂ : C₁)
         (y₁ y₂ : C₂)
         (xy : D x₂ y₁)
         (f : x₁ --> x₂)
         (g : y₁ --> y₂),
       is_iso_twosided_disp
         (identity_is_z_iso _)
         (identity_is_z_iso _)
         (twosided_commute H₁ H₂ xy f g).

  (**
   4. Two-sided fibrations
   *)
  Definition twosided_fibration
    : UU
    := ∑ (H₁ : twosided_opcleaving)
         (H₂ : twosided_cleaving),
       is_iso_twosided_commute H₁ H₂.
End TwoSidedFibration.

(**
 5. Discrete two-sided fibrations
 *)
Section DiscreteTwoSidedFibration.
  Context {C₁ C₂ : category}
          (D : twosided_disp_cat C₁ C₂).

  Definition discrete_twosided_opcartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₃ : C₁)
         (y₃ : C₂)
         (xy₃ : D x₃ y₃)
         (f' : x₂ --> x₃)
         (g' : y₂ --> y₃)
         (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃),
       xy₂ -->[ f' ][ g' ] xy₃.

  Definition discrete_twosided_opcartesian_is_opcartesian
             (HD : discrete_twosided_disp_cat D)
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (Hfg : discrete_twosided_opcartesian fg)
    : twosided_opcartesian D fg.
  Proof.
    intros x₃ y₃ xy₃ f' g' fg'.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intro ; intros ;
         use subtypePath ; [ intro ; apply isaset_disp_mor | ] ;
         apply HD).
    - simple refine (_ ,, _).
      + apply Hfg.
        exact fg'.
      + apply HD.
  Defined.

  Definition discrete_twosided_cartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₀ : C₁)
         (y₀ : C₂)
         (xy₀ : D x₀ y₀)
         (f' : x₀ --> x₁)
         (g' : y₀ --> y₁)
         (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂),
       xy₀ -->[ f' ][ g' ] xy₁.

  Definition discrete_twosided_cartesian_is_cartesian
             (HD : discrete_twosided_disp_cat D)
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (Hfg : discrete_twosided_cartesian fg)
    : twosided_cartesian D fg.
  Proof.
    intros x₃ y₃ xy₃ f' g' fg'.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intro ; intros ;
         use subtypePath ; [ intro ; apply isaset_disp_mor | ] ;
         apply HD).
    - simple refine (_ ,, _).
      + apply Hfg.
        exact fg'.
      + apply HD.
  Defined.

  Definition discrete_twosided_opcleaving
    : UU
    := ∏ (x : C₁)
         (y₁ y₂ : C₂)
         (xy₁ : D x y₁)
         (g : y₁ --> y₂),
       ∑ (xy₂ : D x y₂)
         (ℓ : xy₁ -->[ identity _ ][ g ] xy₂),
       discrete_twosided_opcartesian ℓ.

  Definition discrete_twosided_opcleaving_ob
             (H : discrete_twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : D x y₂
    := pr1 (H x y₁ y₂ xy₁ g).

  Definition discrete_twosided_opcleaving_mor
             (H : discrete_twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : xy₁ -->[ identity _ ][ g ] discrete_twosided_opcleaving_ob H xy₁ g
    := pr12 (H x y₁ y₂ xy₁ g).

  Definition discrete_twosided_opcleaving_opcartesian
             (H : discrete_twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : discrete_twosided_opcartesian (discrete_twosided_opcleaving_mor H xy₁ g)
    := pr22 (H x y₁ y₂ xy₁ g).

  Definition discrete_twosided_disp_cat_to_opcleaving
             (HD : discrete_twosided_disp_cat D)
             (HD' : discrete_twosided_opcleaving)
    : twosided_opcleaving D.
  Proof.
    intros x y₁ y₂ xy₁ g.
    simple refine (_ ,, _ ,, _).
    - exact (pr1 (HD' x y₁ y₂ xy₁ g)).
    - exact (pr12 (HD' x y₁ y₂ xy₁ g)).
    - apply (discrete_twosided_opcartesian_is_opcartesian HD).
      exact (pr22 (HD' x y₁ y₂ xy₁ g)).
  Defined.

  Definition discrete_twosided_cleaving
    : UU
    := ∏ (x₁ x₂ : C₁)
         (y : C₂)
         (xy₂ : D x₂ y)
         (f : x₁ --> x₂),
       ∑ (xy₁ : D x₁ y)
         (ℓ : xy₁ -->[ f ][ identity _ ] xy₂),
       discrete_twosided_cartesian ℓ.

  Definition discrete_twosided_cleaving_ob
             (H : discrete_twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : D x₁ y
    := pr1 (H x₁ x₂ y xy₂ f).

  Definition discrete_twosided_cleaving_mor
             (H : discrete_twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : discrete_twosided_cleaving_ob H xy₂ f -->[ f ][ identity _ ] xy₂
    := pr12 (H x₁ x₂ y xy₂ f).

  Definition discrete_twosided_cleaving_cartesian
             (H : discrete_twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : discrete_twosided_cartesian (discrete_twosided_cleaving_mor H xy₂ f)
    := pr22 (H x₁ x₂ y xy₂ f).

  Definition discrete_twosided_disp_cat_to_cleaving
             (HD : discrete_twosided_disp_cat D)
             (HD' : discrete_twosided_cleaving)
    : twosided_cleaving D.
  Proof.
    intros x y₁ y₂ xy₁ g.
    simple refine (_ ,, _ ,, _).
    - exact (pr1 (HD' x y₁ y₂ xy₁ g)).
    - exact (pr12 (HD' x y₁ y₂ xy₁ g)).
    - apply (discrete_twosided_cartesian_is_cartesian HD).
      exact (pr22 (HD' x y₁ y₂ xy₁ g)).
  Defined.
End DiscreteTwoSidedFibration.

Definition is_discrete_twosided_fibration
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD : discrete_twosided_disp_cat D)
  : UU
  := discrete_twosided_cleaving D × discrete_twosided_opcleaving D.

Definition discrete_twosided_fibration
           (C₁ C₂ : category)
  : UU
  := ∑ (D : twosided_disp_cat C₁ C₂)
       (HD : discrete_twosided_disp_cat D),
     is_discrete_twosided_fibration HD.

Coercion discrete_twosided_fibration_to_twosided_disp_cat
         {C₁ C₂ : category}
         (D : discrete_twosided_fibration C₁ C₂)
  : twosided_disp_cat C₁ C₂
  := pr1 D.

Definition discrete_twosided_disp_cat_is_fibration
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD : discrete_twosided_disp_cat D)
           (HD' : is_discrete_twosided_fibration HD)
  : twosided_fibration D.
Proof.
  simple refine (_ ,, _ ,, _).
  - apply discrete_twosided_disp_cat_to_opcleaving.
    + exact HD.
    + apply HD'.
  - apply discrete_twosided_disp_cat_to_cleaving.
    + exact HD.
    + apply HD'.
  - cbn.
    unfold is_iso_twosided_commute.
    intro ; intros.
    apply HD.
Defined.


From Coq Require Import Init.Nat Lia List.
From QuickChick Require Import QuickChick CheckerProofs EnumProofs.
From mathcomp Require Import ssreflect ssreflect.eqtype.

Import ListNotations.

Inductive Sorted : list nat -> Prop :=
  Sorted_nil : Sorted []
| Sorted_singl x : Sorted [x]
| Sorted_cons x y l :
    x <= y -> Sorted (y :: l) -> Sorted (x :: y :: l).

(* We need to derive a checker for the <= relation as well. *)
Derive DecOpt for (le x y).
Derive DecOpt for (Sorted l).

Instance DecOptsorted_sound  l : DecOptSoundPos (Sorted l).
Proof. derive_sound. Qed.

Lemma sorted_2000 : Sorted (repeat 1 2000).
Proof.
  time (repeat (first [ eapply Sorted_cons; [ apply le_n | ]
                      | eapply Sorted_singl ])).
Time Qed.

(* Tactic call ran for 7.39 secs (7.36u,0.03s) (success) *)
(* Finished transaction in 9.623 secs (9.623u,0.s) (successful) *)

(* Switch to 5000: *)
(* Tactic call ran for 79.948 secs (78.952u,0.851s) (success) *)
(* Finished transaction in 326.736 secs (240.418u,1.744s) (successful) *)

Lemma sorted_2000' : Sorted (repeat 1 2000).
Proof.
  time (eapply sound with (s := 2000); compute; reflexivity).
Time Qed.
(* Tactic call ran for 0.05 secs (0.05u,0.s) (success) *)
(* Finished transaction in 0.059 secs (0.058u,0.s) (successful) *)

Lemma sorted_5000' : Sorted (repeat 1 5000).
Proof.
  time (eapply sound with (s := 5000); compute; reflexivity).
Time Qed.


  Variable A : Prop .
  Variable R : A->A->Prop.

  Definition Rstar:A->A->Prop :=
     [x,y:A](P0:A->A->Prop)
             ((u:A)(P0 u u))
              ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y).

  Definition Rstar':A->A->Prop :=
      [x,y:A](P:A->A->Prop)
             (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y).

  Definition coherence: A->A->Prop :=
        [x:A][y:A](P:Prop)((z:A)(Rstar x z)->(Rstar y z)->P)->P.

(* Les 2 hypotheses du Lemme de Newman *)

  Axiom Hyp1:(x:A)(P:A->Prop)((y:A)((z:A)(R y z)->(P z))->(P y))->(P x).
  Axiom Hyp2:(x:A)(y:A)(z:A)(R x y)->(R x z)->(coherence y z).

(* Verification du lemme *)

  Lemma Rstar_reflexive: (x:A)(Rstar x x).
Proof [x:A][P0:A->A->Prop]
        [H:(u:A)(P0 u u)][_:(u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w)](H x).

  Lemma Rstar_R: (x:A)(y:A)(z:A)(R x y)->(Rstar y z)->(Rstar x z).
Proof [x,y,z:A][t1:(R x y)] [t2:(P0:A->A->Prop)
          ((u:A)(P0 u u))
           ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 y z)]
      [P:A->A->Prop][h1:(u:A)(P u u)]
        [h2:(u:A)(v:A)(w:A)(R u v)->(P v w)->(P u w)]
         (h2 x y z t1 (t2 [a,a0:A](P a a0) h1 h2)).

  Lemma Rstar_transitive: (x:A)(y:A)(z:A)(Rstar x y)->(Rstar y z)->(Rstar x z).
Proof [x,y,z:A][h:(P0:A->A->Prop)
        ((u:A)(P0 u u))
         ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)]
      (h [a,a0:A](Rstar a0 z)->(Rstar a z) [u:A][H:(Rstar u z)]H
        [u,v,w:A][t1:(R u v)][t2:(Rstar w z)->(Rstar v z)]
           [t3:(Rstar w z)](Rstar_R u v z t1 (t2 t3))).

  Lemma Rstar'_reflexive: (x:A)(Rstar' x x).
Proof [x:A][P:A->A->Prop][H:(P x x)][_:(u:A)(R x u)->(Rstar u x)->(P x x)]H.

  Lemma Rstar'_R: (x:A)(y:A)(z:A)(R x z)->(Rstar z y)->(Rstar' x y).
Proof [x,y,z:A][t1:(R x z)][t2:(Rstar z y)][P:A->A->Prop]
       [_:(P x x)][h2:(u:A)(R x u)->(Rstar u y)->(P x y)](h2 z t1 t2).

  Lemma Rstar'_Rstar:  (x:A)(y:A)(Rstar' x y)->(Rstar x y).
Proof [x,y:A][h:(P:A->A->Prop)
       (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)]
      (h [a,a0:A](Rstar a a0) (Rstar_reflexive x) [u:A](Rstar_R x u y)).

  Lemma Rstar_Rstar':  (x:A)(y:A)(Rstar x y)->(Rstar' x y).
Proof [x,y:A][h:(P0:A->A->Prop)
       ((u:A)(P0 u u))
        ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)]
       (h Rstar' [u:A](Rstar'_reflexive u)
         [u,v,w:A][h1:(R u v)]
          [h2:(Rstar' v w)](Rstar'_R u w v h1 (Rstar'_Rstar v w h2))).

  Lemma coherence_intro : (x:A)(y:A)(z:A)(Rstar x z)->(Rstar y z)
                                ->(coherence x y).
Proof [x,y,z:A][H:(Rstar x z)][H0:(Rstar y z)][P:Prop]
          [H1:(z0:A)(Rstar x z0)->(Rstar y z0)->P](H1 z H H0).

  Lemma Rstar_coherence : (x:A)(y:A)(Rstar x y)->(coherence x y).
Proof [x,y:A][h:(Rstar x y)](coherence_intro x y y h (Rstar_reflexive y)).

  Lemma coherence_sym: (x:A)(y:A)(coherence x y)->(coherence y x).
Proof [x,y:A][H:(P:Prop)((z:A)(Rstar x z)->(Rstar y z)->P)->P][P:Prop]
      [H0:(z:A)(Rstar y z)->(Rstar x z)->P]
       (H P [z:A][H1:(Rstar x z)][H2:(Rstar y z)](H0 z H2 H1)).

  Lemma Diagram:
   (x:A)((u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z))
     ->(y,z,u:A)(R x u)->(Rstar u y)
           ->(v:A)(R x v)->(Rstar v z)->(coherence y z).
Proof [x:A][hyp_ind:(u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)
                      ->(coherence y z)]
     [y,z,u:A][t1:(R x u)][t2:(Rstar u y)][v:A][u1:(R x v)][u2:(Rstar v z)]
        ([Hyp0:(x0,y0,z0:A)(R x0 y0)->(R x0 z0)
                    ->(P:Prop)((z1:A)(Rstar y0 z1)->(Rstar z0 z1)->P)->P]
             [hyp_ind0:(u0:A)(R x u0)->(y0,z0:A)(Rstar u0 y0)->(Rstar u0 z0)
                        ->(P:Prop)((z1:A)(Rstar y0 z1)->(Rstar z0 z1)->P)->P]
              (Hyp0 x u v t1 u1 (coherence y z)
                [z0:A][H:(Rstar u z0)][H0:(Rstar v z0)]
                   (hyp_ind0 u t1 y z0 t2 H (coherence y z)
                     [z1:A][H1:(Rstar y z1)][H2:(Rstar z0 z1)]
                        (hyp_ind0 v u1 z z1 u2
                          (Rstar_transitive v z0 z1 H0 H2)
                          (coherence y z)
                          [z2:A][H3:(Rstar z z2)][H4:(Rstar z1 z2)]
                            [P:Prop][H5:(z3:A)(Rstar y z3)->(Rstar z z3)->P]
                                (H5 z2
                                  (Rstar_transitive y z1 z2 H1 H4) H3))))
            Hyp2 hyp_ind).

  Lemma caseRxy:
    (x:A)((u:A)(R x u)->(y,z:A)(Rstar u y)->(Rstar u z)->(coherence y z))
        ->(y,z:A)(Rstar x y)->(Rstar x z)
                ->(u:A)(R x u)->(Rstar u y)->(coherence y z).
Proof [x:A][hyp_ind:(u:A)
           (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)]
  [y,z:A][h1:(Rstar x y)][h2:(Rstar x z)][u:A][t1:(R x u)][t2:(Rstar u y)]
        ([hyp_:(P:A->A->Prop)(P x x)
                  ->((u0:A)(R x u0)->(Rstar u0 z)->(P x z))->(P x z)]
           (hyp_ [_:A][a:A](coherence y a)
             (coherence_sym x y (Rstar_coherence x y h1))
             (Diagram x hyp_ind y z u t1 t2))
          (Rstar_Rstar' x z h2)).

  Lemma Ind_proof :
    (x:A)((u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z))
            ->(y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z).
Proof [x:A][hyp_ind:(u:A)
           (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)]
  [y,z:A][h1:(Rstar x y)][h2:(Rstar x z)]
     ([hyp_:(P:A->A->Prop)
              (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)]
        (hyp_ [_:A][a:A](coherence a z) (Rstar_coherence x z h2)
          (caseRxy x hyp_ind y z h1 h2))
       (Rstar_Rstar' x y h1)).

  Lemma Newman: (x:A)(y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z).
Proof [x:A](Hyp1 x
   [x:A](y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z) Ind_proof).

Quit.


Require Import CantorPairing Synthetic.
Require Import Lia.

Lemma Dec_sigT_transport {X} p q :
  Dec_sigT p -> (forall x : X, p x <-> q x) -> Dec_sigT q.
Proof.
  intros Dec_p Equiv. intros x.
  destruct (Dec_p x) as [H|H];
  [left | right]; firstorder.
Qed.

Lemma Dec_transport {X} p q :
  Dec p -> (forall x : X, p x <-> q x) -> Dec q.
Proof.
  intros [Dec_p] Equiv.
  constructor. intros x.
  destruct (Dec_p x) as [H|H];
  [left | right]; firstorder.
Qed.

Lemma dec_eq_nat (x y : nat) : dec (x = y).
Proof.
  unfold dec; decide equality.
Defined.

Lemma lt_dec x y : dec (x < y).
Proof.
  induction y in x |-*.
  - right. lia.
  - destruct x.
    left. lia.
    destruct (IHy x).
    left; lia. right; lia.
Qed.

Lemma dec_conj A B : dec A -> dec B -> dec (A /\ B).
Proof.
  intros [][]; unfold dec; intuition.
Defined.

Lemma dec_disj A B : dec A -> dec B -> dec (A \/ B).
Proof.
  intros [][]; unfold dec; intuition.
Defined.

Lemma dec_imp A B : dec A -> dec B -> dec (A -> B).
Proof.
  intros [][]; unfold dec; intuition.
Defined.

Lemma dec_neg A : dec A -> dec (~ A).
Proof.
  intros []; unfold dec; now (left + right).
Defined.

Lemma neg_and A B : dec A -> dec B -> ~(A /\ B) -> (~A \/ ~B).
Proof.
  intros [][] ?; tauto.
Defined.

Lemma neg_imp A B : dec A -> dec B -> ~(A -> B) -> A /\ ~B.
Proof.
  intros [][] ?; tauto.
Qed.

Hint Resolve neg_and neg_imp dec_eq_nat dec_conj dec_disj dec_imp dec_neg : decs.

(** * Decidability of bounded quantifiers. *)

Lemma dec_lt_bounded_sig N (p : nat -> Type) :
  (forall x, p x + (p x -> False)) -> { x & ((x < N) * p x)%type } + (forall x, x < N -> p x -> False).
Proof.
  intros Dec_p. induction N.
  right. intros []; lia.
  destruct (IHN) as [IH | IH].
  - left. destruct IH as [x Hx].
    exists x. split. destruct Hx. lia. apply Hx.
  - destruct (Dec_p N) as [HN | HN].
    + left. exists N. split. lia. apply HN.
    + right. intros x Hx.
      assert (x = N \/ x < N) as [->|] by lia; auto.
      now apply IH.
Defined.

Lemma dec_lt_bounded_exist' N p :
  Dec_sigT p -> (exists x, x < N /\ p x) + (forall x, x < N -> ~ p x).
Proof.
  intros Dec_p. induction N.
  right. intros []; lia.
  destruct (IHN) as [IH | IH].
  - left. destruct IH as [x Hx].
    exists x. split. lia. apply Hx.
  - destruct (Dec_p N) as [HN | HN].
    + left. exists N. split. lia. apply HN.
    + right. intros x Hx.
      assert (x = N \/ x < N) as [->|] by lia; auto.
Defined.

Lemma dec_lt_bounded_exist N p :
  Dec_sigT p -> dec (exists x, x < N /\ p x).
Proof.
  intros Dec_p.
  destruct (dec_lt_bounded_exist' N p Dec_p).
  now left. right. firstorder.
Defined.

Lemma dec_lt_bounded_forall N p :
  Dec_sigT p -> dec (forall x, x < N -> p x).
Proof.
  intros Dec_p. induction N.
  left. lia.
  destruct (Dec_p N) as [HN | HN].
  - destruct (IHN) as [IH | IH].
    +  left. intros x Hx.
    assert (x = N \/ x < N) as [->|] by lia; auto.
    + right. intros H. apply IH.
      intros x Hx. apply H. lia.
  - right. intros H. apply HN.
    apply H. lia.
Defined.

Lemma neg_lt_bounded_forall N p :
  Dec_sigT p -> (~ forall x, x < N -> p x) -> exists x, x < N /\ ~ p x.
Proof.
  intros Hp H.
  induction N. exfalso. apply H; lia.
  destruct (Hp N).
  - destruct IHN as [n ].
    + intros H1. apply H. intros.
      assert (x = N \/ x < N) as [->|] by lia.
      auto. now apply H1.
    + exists n. intuition lia.
  - exists N. auto.
Qed.

(** * The product type for Nat is witnessing. *)

Theorem ProductWO (p : nat -> nat -> Prop) :
  ( forall x y, dec (p x y) ) -> (exists x y, p x y) -> { x & { y & p x y }}.
Proof.
  intros Dec_p H.
  pose (P n := let (x, y) := decode n in p x y).
  assert ({n & P n}) as [n Hn].
  apply Witnessing_nat.
  - intros n.
    destruct (decode n) as [x y] eqn:E.
    destruct (Dec_p x y); (left + right); unfold P; now rewrite E.
  - destruct H as (x & y & H).
    exists (code (x, y)). unfold P.
    now rewrite inv_dc.
  - destruct (decode n) as [x y] eqn:E.
    exists x, y. unfold P in Hn; now rewrite E in Hn.
Qed.


Require Import List String.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

(* Largely copied from CPDT *)
Section ilist.
  Variable A : Type.

  Inductive ilist : nat -> Type :=
  | inil : ilist 0
  | icons : forall n, A -> ilist n -> ilist (S n).

  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

End ilist.

Arguments inil [A].
Arguments First [n].

Local Infix "::" := (@icons _ _).

Definition ihd' n (il : ilist Type n) : Type :=
  match il with
    | inil => Set
    | icons _ T _ => T
  end.

Definition ihd n (il : ilist Type (S n)) : Type := ihd' il.

Definition itl' n (il : ilist Type n) :=
  match il in ilist _ N return ilist Type (pred N) with
    | inil => inil
    | icons _ _ il' => il'
  end.

Definition itl n (il : ilist Type (S n)) : ilist Type n := itl' il.

Fixpoint iget n (i : fin n) : ilist Type n -> Type :=
  match i with
    | First _ => fun il => ihd il
    | Next _ i' => fun il => iget i' (itl il)
  end.

Section ilist_map.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint imap n (ls : ilist A n) : ilist B n :=
    match ls with
      | inil => inil
      | icons _ x ls' => icons (f x) (imap ls')
    end.
End ilist_map.

(* heterogeneous indexed lists *)
Section hilist.
  Inductive hilist : forall n, ilist Type n -> Type :=
  | hinil : hilist inil
  | hicons : forall n x (ls : ilist _ n), x -> hilist ls -> hilist (icons x ls).

  Definition hihd n (il : ilist Type (S n)) (hl : hilist il) : ihd il :=
    match hl in hilist il return ihd' il with
      | hinil => unit
      | hicons _ _ _ v _ => v
    end.

  Definition hitl n (il : ilist Type (S n)) (hl : hilist il) : hilist (itl il) :=
    match hl in hilist il return hilist (itl' il) with
      | hinil => hinil
      | hicons _ _ _ _ hl' => hl'
    end.

  Fixpoint higet n (i : fin n) : forall (ils : ilist Type n), hilist ils -> iget i ils :=
    match i in fin n return forall (ils : ilist Type n), hilist ils -> iget i ils with
      | First _ => fun _ hl => hihd hl
      | Next _ i' => fun _ hl => higet i' (hitl hl)
    end.
End hilist.


Require Import Lib.

Module HeytingTerms.

  (*************************************************)
  (* Identifiers *)

  (* Identifiers are indexed by natural numbers *)
  Definition X := nat.

  (* Decidability of identifier equality; this is identical to a similar theorem
   * for nats in Coq's standard library. *)
  Theorem eq_id_dec : forall x y : X, {x = y} + {x <> y}.
  Proof.
    intros x. induction x as [|x'].
    Case "x = 0". destruct y as [|y'].
    SCase "y = 0". left. reflexivity.
    SCase "y > 0". right. intros c. inversion c.
    Case "x > 0". intros y. destruct y as [|y'].
    SCase "y = 0". right. intros c. inversion c.
    SCase "y > 0". destruct IHx' with (y := y') as [eq|neq].
    SSCase "x' = y'". subst. left. reflexivity.
    SSCase "x' <> y'". right. unfold not in neq. intros c. inversion c.
      apply neq. apply H0.
  Defined.

  (*************************************************)
  (* Terms *)

  (* Terms may be nats, variables, +, *, and successor. Note that Kanckos
   * defines successor for both numerals and terms; this is important because
   * it's used to find inconsistencies (∀t, Suc t ⊃ 0 ⇒ ⊥).  *)
  Inductive T: Set :=
  | Nat: nat -> T
  | Var: X -> T
  | Plus: T -> T -> T
  | Mult: T -> T -> T
  | Suc : T -> T.  (* note that Kanckos defines succ for both nats and terms *)

  Notation "t1 + t2"  := (Plus t1 t2)
                           (at level 50, left associativity) : hterm_scope.
  Notation "t1 * t2"  := (Mult t1 t2)
                           (at level 40, left associativity) : hterm_scope.

  Bind Scope hterm_scope with T.  (* this doesn't help too much *)
  Delimit Scope hterm_scope with hterm. (* needed when a term isn't a fn arg *)

  (*************************************************)
  (* Decidability of term equality. Note that this is syntactic equality:
   * Nat O + Nat O is not the same as Nat O. *)

  Tactic Notation "hterm_cases" tactic(first) ident(c) :=
    first;
    [Case_aux c "Nat" | Case_aux c "Var" | Case_aux c "Plus"
     | Case_aux c "Mult" | Case_aux c "Suc"].

  Tactic Notation "wrong_shape" :=
    solve [right; intros contra; inversion contra].
  Tactic Notation "dest_ind" ident(hyp) ident(hypvar) ident(cvar) ident(c):=
    destruct hyp with (hypvar:=cvar) as [eq|neq];
    [Case_aux c "eq" | Case_aux c "neq"].
  Tactic Notation "eq_case" :=
    solve [left; inversion eq; subst; reflexivity].

  (* Proof that term equality is decidable. *)
  Open Scope hterm_scope.
  Theorem term_eq_dec : forall (t1 t2: T), {t1 = t2} + {t1 <> t2}.
  Proof.
    intros t1.
    hterm_cases (induction t1 as [n1|x1|r Hr r' Hr'|r Hr r' Hr'|t1])
                Case;
      intros t2;
      hterm_cases (destruct t2 as [n2|x2|s s'|s s'|t2]) SCase;
      try wrong_shape.
    Case "Nat".
    SCase "Nat". generalize dependent n2.
      induction n1 as [|n1']; destruct n2 as [|n2'];
        try wrong_shape; try (left; reflexivity).
      dest_ind IHn1' n2 n2' SSCase; try eq_case.
      SSCase "neq". right. unfold not in neq. intros c. inversion c.
        apply neq. apply f_equal. apply H0.
    Case "Var".
    SCase "Var". generalize dependent x2.
      induction x1 as [|x1']; destruct x2 as [|x2'];
      try wrong_shape; try (left; reflexivity).
      dest_ind IHx1' x2 x2' SSCase; try eq_case.
      SSCase "neq". right. unfold not in neq. intros c. inversion c. apply neq.
        subst. reflexivity.
    Case "Plus".
    destruct Hr with (t2:=s) as [eq|neq];
      destruct Hr' with (t2:=s') as [eq'|neq']; subst.
    SSCase "both equal". left. reflexivity.
    SSCase "r' <> s'". right. intros contra. unfold not in neq'. apply neq'.
    inversion contra. reflexivity.
    SSCase "r <> s". right. intros contra. unfold not in neq. apply neq.
    inversion contra. reflexivity.
    SSCase "r' <> s', r <> s".
    (* Note: this is syntactic equality, not equality of the evaluated term. *)
    right. intros contra. inversion contra. unfold not in neq.
    apply neq. apply H0.
    Case "Mult".
    destruct Hr with (t2:=s) as [eq|neq];
      destruct Hr' with (t2:=s') as [eq'|neq']; subst.
    SSCase "both equal". left. reflexivity.
    SSCase "r' <> s'". right. intros contra. unfold not in neq'. apply neq'.
    inversion contra. reflexivity.
    SSCase "r <> s". right. intros contra. unfold not in neq. apply neq.
    inversion contra. reflexivity.
    SSCase "r' <> s', r <> s".
    (* Note: this is syntactic equality, not equality of the evaluated term. *)
    right. intros contra. inversion contra. unfold not in neq.
    apply neq. apply H0.
    Case "Suc". destruct IHt1 with (t2 := t2).
    SSCase "eq". left. subst. reflexivity.
    SSCase "neq". right. intros c. inversion c. apply n. apply H0.
  Defined.

  (* Substitution: var <-> term *)
  Fixpoint subst_t (x : X) (value : T) (term : T) : T :=
    match term with
      | Nat _ => term
      | Var y => if eq_id_dec x y then value else term
      | Plus t1 t2 => Plus (subst_t x value t1) (subst_t x value t2)
      | Mult t1 t2 => Mult (subst_t x value t1) (subst_t x value t2)
      | Suc t => Suc (subst_t x value t)
    end.

  Fixpoint abstract_t (value : T) (x : X) (term : T) : T :=
    if (term_eq_dec value term) then (Var x) else
      match term with
        | Plus t1 t2 => Plus (abstract_t value x t1) (abstract_t value x t2)
        | Mult t1 t2 => Mult (abstract_t value x t1) (abstract_t value x t2)
        | Suc t => Suc (abstract_t value x t)
        | _ => term
      end.

  (*************************************************)

  (* Arithmetic Equality *)
  Open Scope hterm_scope.

  (* Equality rules from Kanckos page 3, except for Inf1, defined below. *)
  Inductive eqha : T -> T -> Set :=
  | t_refl    : forall t, eqha t t
  | t_symm    : forall t1 t2, eqha t1 t2 -> eqha t2 t1
  | t_trans   : forall t1 t2 t3, eqha t1 t2 -> eqha t2 t3 -> eqha t1 t3
  | t_plus_id : forall t, eqha (t + Nat O) t
  | t_plus_rec: forall t1 t2, eqha (t1 + Suc(t2)) (Suc(t1 + t2))
  | t_mult_0  : forall t, eqha (t * Nat O) (Nat O)
  | t_mult_rec: forall t1 t2, eqha (t1 * Suc(t2)) (t1 + (t1 * t2))
  | t_rep_s   : forall t1 t2, eqha t1 t2 -> eqha (Suc t1) (Suc t2)
  | t_rep_plus_l : forall t1 t2 t3, eqha t1 t2 -> eqha (t1 + t3) (t2 + t3)
  | t_rep_plus_r : forall t1 t2 t3, eqha t2 t3 -> eqha (t1 + t2) (t1 + t3)
  | t_rep_mult_l : forall t1 t2 t3, eqha t1 t2 -> eqha (t1 * t3) (t2 * t3)
  | t_rep_mult_r : forall t1 t2 t3, eqha t2 t3 -> eqha (t1 * t2) (t1 * t3)
  | t_inf2    : forall t1 t2, eqha (Suc t1) (Suc t2) -> eqha t1 t2
  | t_suc     : forall n, eqha (Nat (S n)) (Suc (Nat n)).

  (* Kanckos also includes a proof of falsity, if Suc t = 0. This will be
   * included in the later definition of formulas Φ. *)

  Definition n0 := Nat O.
  Definition n1 := Suc n0.
  Definition n2 := Suc n1.
  Definition v0 := Var 0.
  Definition v1 := Var 1.
  Definition v2 := Var 2.

  (* Some example arithmetic derivations. *)
  Fact haf1 : eqha (n0 + n0) (n1 * n0).
  Proof.
    apply t_trans with (t2 := n0).
    apply t_plus_id.
    apply t_symm. apply t_mult_0.
  Defined.
  Print haf1.

  Lemma plus_id_r : forall t : T, eqha t (t + n0).
  Proof.
    intros t. apply t_symm. apply t_plus_id.
  Qed.
  Print plus_id_r.

  Lemma mult1 : forall t:T, eqha (t*n1) t.
  Proof.
    intros t. unfold n1. apply t_trans with (t2:=t+(t*n0)).
    apply t_mult_rec. apply t_trans with (t2:=t+n0).
    apply t_rep_plus_r. apply t_mult_0.
    apply t_plus_id.
  Qed.
  Print mult1.

End HeytingTerms.

Module HeytingProps.

  Export HeytingTerms.
  Require Export List.

  (* Formulas and Atomic Propositions *)
  (* For the Kanckos paper, basic connectives are ∨, ∧, ⊃ (aka ⇒), ∃, ∀.
     Negation is derived as ¬A ≡ A ⊃ ⊥. *)
  Inductive Φ: Set :=
  | bot  : Φ
  | teq  : T -> T -> Φ
  | Disj : Φ -> Φ -> Φ
  | Conj : Φ -> Φ -> Φ
  | Imp  : Φ -> Φ -> Φ
  | Ex   : X -> Φ -> Φ
  | All  : X -> Φ -> Φ.

  Notation "⊥" := bot.

  Definition Neg (φ:Φ) := Imp φ bot.

  Tactic Notation "formula_cases" tactic(first) ident(c) :=
    first;
    [Case_aux c "bot" | Case_aux c "teq" | Case_aux c "disj" | Case_aux c "conj"
     | Case_aux c "imp" | Case_aux c "ex" | Case_aux c "all"].

  Fixpoint subst_φ (x : X) (t : T) (φ : Φ) : Φ :=
    match φ with
      | bot        => bot
      | teq t1 t2  => teq  (subst_t x t t1) (subst_t x t t2)
      | Disj φ1 φ2 => Disj (subst_φ x t φ1) (subst_φ x t φ2)
      | Conj φ1 φ2 => Conj (subst_φ x t φ1) (subst_φ x t φ2)
      | Imp φ1 φ2  => Imp  (subst_φ x t φ1) (subst_φ x t φ2)
      | Ex x' φ'   => if eq_id_dec x x' then φ else Ex  x' (subst_φ x t φ')
      | All x' φ'  => if eq_id_dec x x' then φ else All x' (subst_φ x t φ')
    end.

  Fixpoint abstract_φ (t : T) (x : X) (φ : Φ) : Φ :=
    match φ with
      | bot        => bot
      | teq t1 t2  => teq  (abstract_t t x t1) (abstract_t t x t2)
      | Disj φ1 φ2 => Disj (abstract_φ t x φ1) (abstract_φ t x φ2)
      | Conj φ1 φ2 => Conj (abstract_φ t x φ1) (abstract_φ t x φ2)
      | Imp φ1 φ2  => Imp  (abstract_φ t x φ1) (abstract_φ t x φ2)
      | Ex x' φ'   => if eq_id_dec x x' then φ else Ex  x' (abstract_φ t x φ')
      | All x' φ'  => if eq_id_dec x x' then φ else All x' (abstract_φ t x φ')
    end.

  Inductive unbound : Φ -> X -> Prop :=
  | ub_bot  : forall x', unbound bot x'
  | ub_teq  : forall t1 t2 x', unbound (teq t1 t2) x'
  | ub_disj : forall φ1 φ2 x',
                unbound φ1 x' -> unbound φ2 x' -> unbound (Disj φ1 φ2) x'
  | ub_conj : forall φ1 φ2 x',
                unbound φ1 x' -> unbound φ2 x' -> unbound (Conj φ1 φ2) x'
  | ub_imp  : forall φ1 φ2 x',
                unbound φ1 x' -> unbound φ2 x' -> unbound (Imp φ1 φ2) x'
  | ub_ex   : forall φ x x',
                x <> x' -> unbound φ x -> unbound (Ex x' φ) x
  | ub_all  : forall φ x x',
                x <> x' -> unbound φ x -> unbound (All x' φ) x.

  (* Logical Rules and Derivations *)
  (* structure for derivation trees *)
  Inductive proves: Φ -> Set :=
  | p_bot   : forall φ, proves bot -> proves φ
  | p_andi  : forall φ1 φ2, proves φ1 -> proves φ2 -> proves (Conj φ1 φ2)
  | p_ander : forall φ1 φ2, proves (Conj φ1 φ2) -> proves φ1
  | p_andel : forall φ1 φ2, proves (Conj φ1 φ2) -> proves φ2
  | p_oril  : forall φ1 φ2, proves φ1 -> proves (Disj φ1 φ2)
  | p_orir  : forall φ1 φ2, proves φ2 -> proves (Disj φ1 φ2)
  | p_ore   : forall φ1 φ2 φ3, proves (Disj φ1 φ2) -> proves_mstep φ1 φ3
                               -> proves_mstep φ2 φ3 -> proves φ3
  | p_impi  : forall φ1 φ2, proves_mstep φ1 φ2 -> proves (Imp φ1 φ2)
  | p_impe  : forall φ1 φ2, proves (Imp φ1 φ2) -> proves φ1 -> proves φ2
  | p_alli  : forall φ x, proves φ -> unbound φ x -> proves (All x φ)
  | p_alle  : forall φ x t, proves (All x φ) -> proves (subst_φ x t φ)
  | p_exi   : forall φ x t, proves φ -> proves (Ex x (abstract_φ t x φ))
  | p_exe   : forall φ1 x t φ2, proves (Ex x φ1)
                                -> proves_mstep (subst_φ x t φ1) φ2
                                -> proves φ2
  | p_arith : forall t1 t2, eqha t1 t2 -> proves (teq t1 t2)
  | p_ind   : forall φ x t, proves (subst_φ x (Nat O) φ)
                            -> proves_mstep φ (subst_φ x (Suc (Var x)) φ)
                            -> proves (subst_φ x t φ)
  | p_false : forall t, proves (teq (Suc t) (Nat O)) -> proves bot

  (* relation indicating that A proves B in multiple steps - problem! *)
  with proves_mstep : Φ -> Φ -> Set :=
  | ps_base : forall φ1 φ2, proves φ1 -> proves φ2 -> proves_mstep φ1 φ2
  | ps_step : forall φ1 φ2 φ3, proves φ1 -> proves φ2 ->
                               (proves_mstep φ2 φ3) -> (proves_mstep φ1 φ3).

  Definition atom1 := p_arith (n0+n0) (n1*n0) haf1.
  Print atom1.

  Definition ex_disj := p_oril (teq (n0+n0) (n1*n0)) bot atom1.
  Print ex_disj.

  Eval compute in ex_disj.

End HeytingProps.

Module TestHeytingProps.
  (* Unit tests for HeytingProps. *)

  Import HeytingProps.

  Theorem test_unbound_1 : unbound atom1 0.
  Proof. apply ub_teq. Qed.

  Theorem test_unbound_2 : unbound atom3 2.
  Proof. constructor. Qed.

  Theorem test_unbound_3 : unbound (Conj atom1 atom3) 0.
  Proof.
    apply ub_conj.
    Case "atom1". apply ub_teq.
    Case "atom3". apply ub_teq.
    (* automated: repeat constructor. Qed. *)
  Qed.

  Theorem test_unbound_4: unbound (All 1 (Ex 2 atom4)) 0.
  Proof.
    constructor.
    Case "1 <> 0". intros contra. inversion contra.
    Case "Ex 2". constructor.
    SCase "2 <> 1". intros contra. inversion contra.
    SCase "atom4". constructor.
  Qed.

  Theorem test_unbound_5: ~(unbound (All 1 (Ex 2 atom4)) 1).
  Proof.
    intros contra. inversion contra. subst. apply H1. reflexivity.
  Qed.

  Theorem test_unbound_6: ~(unbound (All 1 (Ex 2 atom4)) 2).
  Proof.
    intros contra. inversion contra. subst.
    inversion H3. subst. apply H2. reflexivity.
  Qed.
End TestHeytingProps.


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Bool.
Require Import List.
Require Export Decidable.

Require Import Tact.
Require Import Relation.

Definition incl {T : Type} (P Q : T -> Prop) :=
  forall x, P x -> Q x.

(** Kuratowski finite, I think. *)
Definition finite {T : Type} (P : T -> Prop) : Prop
  :=
  exists l, forall x, P x <-> In x l.

Lemma Is_true_decide :
  forall b, decidable (Is_true b).
Proof.
intro b.
destruct b.
  {
  left.
  exact I.
  }

  {
  right.
  intros H.
  destruct H.
  }
Qed.

Lemma dec_In :
  forall (T : Type) (x : T) (l : list T),
    (forall (x y : T), decidable (x = y))
    -> decidable (In x l).
Proof.
intros T x l Hdeceq.
induct l.

(** nil *)
{
right.
intro H.
destruct H.
}

(** cons *)
{
intros y l IH.
so (Hdeceq x y) as [Heq | Hneq].
  {
  subst.
  left; left; reflexivity.
  }

  {
  destruct IH as [Hin | Hnin].
    {
    left; right; auto.
    }

    {
    right.
    intro H.
    destruct H.
      {
      subst.
      destruct Hneq; reflexivity.
      }

      {
      contradiction.
      }
    }
  }
}
Qed.

Lemma dec_and_dep :
  forall P Q,
    decidable P
    -> (P -> decidable Q)
    -> decidable (P /\ Q).
Proof.
intros P Q HdecP HdecQ.
so HdecP as [Hyes | Hno].
  {
  so (HdecQ Hyes) as [Hyes' | Hno].
    {
    left; auto.
    }
  right.
  contradict Hno.
  destruct Hno; auto.
  }
right.
contradict Hno.
destruct Hno; auto.
Qed.

Lemma dec_equiv :
  forall (P Q : Prop),
    (P <-> Q)
    -> decidable P
    -> decidable Q.
Proof.
intros P Q Hiff Hdec.
destruct Hdec as [Hyes | Hno].
  {
  left.
  apply Hiff; auto.
  }

  {
  right.
  contradict Hno.
  apply Hiff; auto.
  }
Qed.

Lemma finite_decide :
  forall (T : Type) (P : T -> Prop),
    (forall (x y : T), decidable (x = y))
    -> finite P
    -> forall x, decidable (P x).
Proof.
intros T P Hdec Hfin x.
destruct Hfin as (l & Hl).
apply (dec_equiv (In x l)).
  {
  split.
    { intro H; apply Hl; auto. }

    { intro H; apply Hl; auto. }
  }
apply dec_In; auto.
Qed.

Lemma dec_exists_finite :
  forall (T : Type) (P Q : T -> Prop),
    incl P Q
    -> finite Q
    -> (forall x, decidable (P x))
    -> decidable (exists x, P x).
Proof.
intros T P Q HPQ Hfin Hdec.
destruct Hfin as (l & Hl).
cut (decidable (exists x, In x l /\ P x)).
  {
  intro H.
  destruct H as [Hyes | Hno].
    {
    left.
    destruct Hyes as (x & _ & Hx).
    exists x; auto.
    }

    {
    right.
    contradict Hno.
    destruct Hno as (x & Hx).
    exists x.
    split; auto.
    apply Hl; auto.
    }
  }
clear Hl.
induct l.

(** nil *)
{
right.
intro H.
destruct H as (x & Hin & _).
destruct Hin.
}

(** cons *)
{
intros x l IH.
so (Hdec x) as [Hyes | Hno].
  {
  left.
  exists x.
  split; auto.
  left; auto.
  }
destruct IH as [Hyes | Hno'].
  {
  destruct Hyes as (y & Hiny & Hy).
  left.
  exists y.
  split; auto.
  right; auto.
  }
right.
intros (y & Hiny & Hy).
destruct Hiny as [Heq | Hiny'].
  {
  subst y.
  contradiction.
  }
destruct Hno'.
eexists; eauto.
}
Qed.

Lemma dec_forall_imp_finite :
  forall (T : Type) (P Q : T -> Prop),
    finite P
    -> (forall x, P x -> decidable (Q x))
    -> decidable (forall x, P x -> Q x).
Proof.
intros T P Q Hfinite Hdec.
destruct Hfinite as (p & Hp).
apply (dec_equiv (forall x, In x p -> Q x)).
  {
  split.
    {
    intros Hall x Hx.
    apply Hall.
    apply Hp; auto.
    }

    {
    intros Hall x Hx.
    apply Hall.
    apply Hp; auto.
    }
  }
so (fun x Hx => Hp x ander Hx) as H.
clear Hp.
revert H.
induct p.

(** nil *)
{
intros _.
left.
intros x Hx.
destruct Hx.
}

(** cons *)
{
intros x p IH Hp.
exploit IH as H.
  {
  intros y Hy.
  apply Hp.
  right; auto.
  }
destruct H as [Hall | Hnall].
2:{
  right.
  contradict Hnall.
  intros y Hy.
  apply Hnall.
  right; auto.
  }
exploit (Hdec x) as H.
  {
  apply Hp.
  left; auto.
  }
destruct H as [HQx | HnQx].
2:{
  right.
  contradict HnQx.
  apply HnQx.
  left; auto.
  }
left.
intros y Hy.
destruct Hy as [Hy | Hy].
  {
  subst y.
  exact HQx.
  }

  {
  apply Hall; auto.
  }
}
Qed.

Lemma finite_equiv :
  forall (T : Type) (P Q : T -> Prop),
    (forall x, P x <-> Q x)
    -> finite P
    -> finite Q.
Proof.
intros T P Q HPQ Hfin.
destruct Hfin as (l & Hl).
exists l.
intros x.
rewrite <- HPQ.
rewrite -> Hl.
reflexivity.
Qed.

Lemma filter_to_finite :
  forall T (P : T -> Prop) l,
    (forall x, decidable (P x))
    -> (forall x, P x -> In x l)
    -> finite P.
Proof.
intros T P l Hdec Hl.
cut (exists l', forall x, In x l' <-> (In x l /\ P x)).
  {
  intros H.
  destruct H as (l' & Hl').
  exists l'.
  intros x.
  split.
    {
    intro Hx.
    apply Hl'; auto.
    }

    {
    intro Hx.
    apply Hl'; auto.
    }
  }
clear Hl.
induct l.

(** nil *)
{
exists nil.
intros x.
split.
  {
  intros H.
  destruct H.
  }

  {
  intros (H & _).
  destruct H.
  }
}

(** cons *)
{
intros x l IH.
destruct IH as (l' & Hl').
so (Hdec x) as [HPx | HnPx].
  {
  exists (cons x l').
  intros y.
  split.
    {
    intro Hy.
    destruct Hy as [Heq | Hy].
      {
      subst y.
      split; auto.
      left; auto.
      }

      {
      split.
        {
        right.
        apply Hl'; auto.
        }

        {
        apply Hl'; auto.
        }
      }
    }

    {
    intros (Hy & HPy).
    destruct Hy as [Heq | Hy].
      {
      subst y.
      left; auto.
      }

      {
      right.
      apply Hl'; auto.
      }
    }
  }

  {
  exists l'.
  intros y.
  split.
    {
    intro Hy.
    split.
      {
      right.
      apply Hl'; auto.
      }

      { apply Hl'; auto. }
    }

    {
    intros (Hy & HPy).
    destruct Hy as [Heq | Hy].
      {
      subst y.
      contradiction.
      }

      {
      apply Hl'; auto.
      }
    }
  }
}
Qed.

Lemma finite_subset :
  forall T (P Q : T -> Prop),
    incl P Q
    -> (forall x, decidable (P x))
    -> finite Q
    -> finite P.
Proof.
intros T P Q Hincl Hdec HQ.
destruct HQ as (l & Hl).
apply (filter_to_finite _ _ l); auto.
intros x Hx.
apply Hl.
apply Hincl; auto.
Qed.

Lemma finite_subset' :
  forall T (P Q : T -> Prop),
    (forall (x y : T), decidable (x = y))
    -> incl P Q
    -> (forall x, Q x -> decidable (P x))
    -> finite Q
    -> finite P.
Proof.
intros T P Q Hdeceq Hincl Hdec HQ.
so HQ as (l & Hl).
apply (filter_to_finite _ _ l); auto.
  {
  intro x.
  so (finite_decide _ _ Hdeceq HQ x) as [HQx | HnQx].
    {
    apply Hdec; auto.
    }

    {
    right.
    contradict HnQx.
    apply Hincl; auto.
    }
  }

  {
  intros x Hx.
  apply Hl.
  apply Hincl; auto.
  }
Qed.

Lemma finite_plus :
  forall (T : Type) (R : T -> T -> Prop) x,
    well_founded R
    -> (forall x y, decidable (R x y))
    -> (forall x, finite (fun y => R y x))
    -> finite (fun y => plus R y x).
Proof.
intros T R x Hwf Hdec Hfin.
wfinduct x using Hwf.
intros x IH.
so (Hfin x) as (l & Hl).
cut (exists m, forall y, (exists z, star R y z /\ R z x /\ In z l) <-> In y m).
  {
  intro H.
  destruct H as (m & Hm).
  exists m.
  intros y.
  split.
    {
    intro Hyx.
    apply Hm.
    so (plus_plusr _#4 Hyx) as (z & Hyz & Hzx).
    exists z.
    do2 2 split; auto.
    apply Hl; auto.
    }

    {
    intros Hy.
    so (Hm y ander Hy) as (z & Hyz & Hxz & Hz).
    apply plusr_plus.
    exists z; auto.
    }
  }
clear Hl.
induct l.

(** nil *)
{
exists nil.
intros y.
split.
  {
  intros (z & _ & _ & Hinz).
  destruct Hinz.
  }

  {
  intros Hiny.
  destruct Hiny.
  }
}

(** cons *)
{
intros z l IHl.
so (Hdec z x) as [Hzx | Hnxz].
  {
  so (IH _ Hzx) as (m1 & Hm1).
  destruct IHl as (m2 & Hm2).
  exists (z :: m1 ++ m2).
  intro y.
  split.
    {
    intros Hy.
    destruct Hy as (w & Hyw & Hwx & Hinw).
    destruct Hinw as [Heq | Hinw].
      {
      subst w.
      so (star_plus _#4 Hyw) as [Heq | Hyw'].
        {
        subst y.
        left; auto.
        }
      right.
      apply in_or_app.
      left.
      apply Hm1; auto.
      }

      {
      right.
      apply in_or_app.
      right.
      apply Hm2.
      exists w.
      auto.
      }
    }

    {
    intros Hiny.
    destruct Hiny as [Heq | Hiny].
      {
      subst z.
      exists y.
      do2 2 split; auto using star_refl.
      left; auto.
      }

      {
      so (in_app_or _#4 Hiny) as [Hiny' | Hiny'].
        {
        so (Hm1 _ ander Hiny') as Hyz.
        exists z.
        do2 2 split; auto.
          { apply plus_star; auto. }

          { left; auto. }
        }

        {
        so (Hm2 _ ander Hiny') as (w & Hyw & Hwx & Hinw).
        exists w.
        do2 2 split; auto.
        right; auto.
        }
      }
    }
  }

  {
  destruct IHl as (m2 & Hm2).
  exists m2.
  intro y.
  split.
    {
    intros Hy.
    destruct Hy as (w & Hyw & Hwx & Hinw).
    destruct Hinw as [Heq | Hinw]; auto.
      {
      subst w.
      contradiction.
      }
    apply Hm2.
    exists w.
    auto.
    }

    {
    intro Hiny.
    so (Hm2 _ ander Hiny) as (w & Hyw & Hwx & Hinw).
    exists w.
    do2 2 split; auto.
    right; auto.
    }
  }
}
Qed.

Lemma finite_star :
  forall (T : Type) (R : T -> T -> Prop) x,
    well_founded R
    -> (forall x y, decidable (R x y))
    -> (forall x, finite (fun y => R y x))
    -> finite (fun y => star R y x).
Proof.
intros T R x Hwf Hdec Hfin.
so (finite_plus _ _ x Hwf Hdec Hfin) as (l & Hl).
exists (cons x l).
intro y.
split.
  {
  intro Hyx.
  so (star_plus _#4 Hyx) as [Heq | Hyx'].
    {
    subst y.
    left; auto.
    }
  right.
  apply Hl; auto.
  }

  {
  intros Hiny.
  destruct Hiny as [Heq | Hiny].
    {
    subst y.
    apply star_refl.
    }

    {
    apply plus_star.
    apply Hl; auto.
    }
  }
Qed.

Lemma finite_exists :
  forall (S T : Type) (P : S -> Prop) (Q : S -> T -> Prop),
    finite P
    -> (forall x, P x -> finite (Q x))
    -> finite (fun y => exists x, P x /\ Q x y).
Proof.
intros S T P Q HfinP HfinQ.
destruct HfinP as (p & Hp).
cut (exists l, forall y, (exists x, In x p /\ Q x y) <-> In y l).
  {
  intros (l & Hl).
  exists l.
  intro y.
  split.
    {
    intros (x & Hx & Hxy).
    apply Hl.
    exists x.
    split; auto.
    apply Hp; auto.
    }

    {
    intro Hy.
    so (Hl _ ander Hy) as (x & Hx & Hxy).
    exists x.
    split; auto.
    apply Hp; auto.
    }
  }
so (fun x Hx => Hp x ander Hx) as H.
clear Hp.
revert H.
induct p.

(** nil *)
{
intros Hp.
exists nil.
intro y.
split.
  {
  intros (x & Hx & _).
  destruct Hx.
  }

  {
  intros Hy.
  destruct Hy.
  }
}

(** cons *)
{
intros x p IH Hp.
exploit IH as H.
  {
  intros z Hz.
  apply Hp.
  right.
  auto.
  }
destruct H as (l2 & Hl2).
so (HfinQ x (Hp x (or_introl (eq_refl _)))) as (l1 & Hl1).
exists (l1 ++ l2).
intro y.
split.
  {
  intros (z & Hz & Hzy).
  apply in_or_app.
  destruct Hz as [| Hz].
    {
    subst z.
    left.
    apply Hl1; auto.
    }

    {
    right.
    apply Hl2.
    exists z; auto.
    }
  }

  {
  intros Hy.
  so (in_app_or _#4 Hy) as [Hy' | Hy'].
    {
    so (Hl1 y ander Hy') as Hxy.
    exists x.
    split; auto.
    left; auto.
    }

    {
    so (Hl2 y ander Hy') as (z & Hz & Hzy).
    exists z.
    split; auto.
    right; auto.
    }
  }
}
Qed.