From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y : Universe, ((wd_ X Y /\ (wd_ Y A /\ (wd_ A B /\ (wd_ Y B /\ (wd_ X A /\ (wd_ X B /\ (col_ B X Y /\ col_ X A Y))))))) -> col_ X A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(***************************************************************************
* Safety for STLC with References - Definitions                            *
* Extented from "Type Safety for STLC" by                                  *
* Arthur Charguéraud, July 2007, Coq v8.1                                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory.

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

(** Grammar of types. *)

Parameter atm : Set.

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_ref   : typ -> typ
  | typ_unit  : typ.

(** Grammar of pre-terms. *)

Definition loc := var.

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_unit : trm
  | trm_loc : loc -> trm
  | trm_ref : trm -> trm
  | trm_get : trm -> trm
  | trm_set : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if k === i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_unit          => trm_unit
  | trm_loc l     => trm_loc l
  | trm_ref t1    => trm_ref (open_rec k u t1)
  | trm_get t1    => trm_get (open_rec k u t1)
  | trm_set t1 t2 => trm_set (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_trm_unit :
      term trm_unit
  | term_loc : forall l,
      term (trm_loc l)
  | term_new : forall t1,
      term t1 ->
      term (trm_ref t1)
  | term_get : forall t1,
      term t1 ->
      term (trm_get t1)
  | term_set : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_set t1 t2).

(** Store maps (sto) locations to values, and
    Store typing (phi) maps locations to type. *)

Definition sto := Env.env trm.
Definition phi := Env.env typ.

Inductive sto_ok : sto -> Prop :=
  | sto_ok_empty : sto_ok empty
  | sto_ok_push : forall mu l t,
      sto_ok mu -> term t ->
      sto_ok (mu & l ~ t).

(** Environment is an associative list mapping variables to types. *)

Definition env := Env.env typ.

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

(** Typing relation *)

Reserved Notation "E ! P |= t ~: T" (at level 69).

Inductive typing : env -> phi -> trm -> typ -> Prop :=
  | typing_var : forall E P x T,
      ok E ->
      binds x T E ->
      E ! P |= (trm_fvar x) ~: T
  | typing_abs : forall L E P U T t1,
      (forall x, x \notin L -> (E & x ~ U) ! P  |= t1 ^ x ~: T) ->
      E ! P |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E P t1 t2,
      E ! P |= t1 ~: (typ_arrow S T) -> E ! P  |= t2 ~: S ->
      E ! P  |= (trm_app t1 t2) ~: T
  | typing_trm_unit : forall E P,
      ok E ->
      E ! P |= trm_unit ~: typ_unit
  | typing_loc : forall E P l T,
      ok E ->
      binds l T P ->
      E ! P |= (trm_loc l) ~: (typ_ref T)
  | typing_new : forall E P t1 T,
      E ! P |= t1 ~: T ->
      E ! P |= (trm_ref t1) ~: (typ_ref T)
  | typing_get : forall E P t1 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= (trm_get t1) ~: T
  | typing_set : forall E P t1 t2 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= t2 ~: T ->
      E ! P |= (trm_set t1 t2) ~: typ_unit

where "E ! P |= t ~: T" := (typing E P t T).

(** Typing store *)

Definition sto_typing P mu :=
     sto_ok mu
  /\ (forall l, l # mu -> l # P)
  /\ (forall l T, binds l T P ->
        exists t, binds l t mu
               /\ empty ! P |= t ~: T).

Notation "P |== mu" := (sto_typing P mu) (at level 68).

(** Definition of values *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) ->
      value (trm_abs t1)
  | value_trm_unit :
      value trm_unit
  | value_loc : forall l,
      value (trm_loc l).

(** Reduction relation - one step in call-by-value *)

Definition conf := (trm * sto)%type.

Inductive red : conf -> conf -> Prop :=

  | red_beta : forall mu t1 t2,
      sto_ok mu ->
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2, mu) (t1 ^^ t2, mu)
  | red_new : forall mu t1 l,
      sto_ok mu ->
      value t1 ->
      l # mu ->
      red (trm_ref t1, mu) (trm_loc l, (mu & l ~ t1))
  | red_get : forall mu l t,
      sto_ok mu ->
      binds l t mu ->
      red (trm_get (trm_loc l), mu) (t, mu)
  | red_set : forall mu l t2,
      sto_ok mu ->
      value t2 ->
      red (trm_set (trm_loc l) t2, mu) (trm_unit, mu & l ~ t2)

  | red_app_1 : forall mu mu' t1 t1' t2,
      term t2 ->
      red (t1, mu) (t1', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1' t2, mu')
  | red_app_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1 t2', mu')
  | red_new_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_ref t1, mu) (trm_ref t1', mu')
  | red_get_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_get t1, mu) (trm_get t1', mu')
  | red_set_1 : forall mu mu' t1 t1' t2,
      red (t1, mu) (t1', mu') ->
      term t2 ->
      red (trm_set t1 t2, mu) (trm_set t1' t2, mu')
  | red_set_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_set t1 t2, mu) (trm_set t1 t2', mu').

Notation "c --> c'" := (red c c') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall P t t' mu mu' T,
  empty ! P |= t ~: T ->
  (t,mu) --> (t',mu') ->
  P |== mu ->
  exists P',
     extends P P'
  /\ empty ! P' |= t' ~: T
  /\ P' |== mu'.

Definition progress := forall P t mu T,
  empty ! P |= t ~: T ->
  P |== mu ->
     value t
  \/ exists t', exists mu', (t,mu) --> (t',mu').


From SimplyRatt Require Import Typing Worlds.

(* Typing examples *)

Example id_wt ty A (G : ctx ty) : ty <> later ->
    G ⊢ abs (var 0) ∶ (Arrow A A).
Proof.
  eauto.
Qed.

Example id_app_closed ty t A (G : ctx ty) :
  ty <> later ->
  G ⊢ t ∶ A ->
  G ⊢ app (abs (var 0)) t ∶ A.
Proof.
  eauto.
Qed.

Lemma now_not_later : now <> later.
Proof.
  intros C; inversion C.
Qed.

Lemma init_not_later : init <> later.
Proof.
  intros C; inversion C.
Qed.

Hint Resolve now_not_later init_not_later id_wt.

Example box_id_closed (G : ctx init)  A :
    G ⊢ box (abs (var 0)) ∶ Box (Arrow A A).
Proof.
  auto.
Qed.

Notation  Str := (Mu (Times Nat (TypeVar 0))).

Example wf_str : closed_type Str.
Proof.
 autounfold.  eauto.
Qed.

Notation const_str := (fixp (into (pair (natlit 0) (var 0)))).

Example const_str_wt (G : ctx init) :
    G ⊢ const_str ∶ Box Str.
Proof.
  repeat constructor.
Qed.

Definition str_unfold : Times Nat (Delay Str) = tsubst 0 (Times Nat (TypeVar 0)) (Delay Str).
Proof.
  reflexivity.
Qed.

Notation head := (abs (pr1 (out (var 0)))).

Example head_wt ty (G : ctx ty) :
  ty <> later ->
  G ⊢ head ∶ (Arrow Str Nat).
Proof.
  repeat econstructor. eauto. reflexivity.
Qed.

Notation const_str_head := (app head (unbox const_str)).

Example const_str_head_wt (G : ctx now) :
    G ⊢ const_str_head ∶ Nat.
Proof.
  repeat econstructor. eauto. apply str_unfold.
  simpl. eauto.
Qed.

Notation tail := (abs (pr2 (out (var 0)))).

Definition tail_wt ty (G : ctx ty)  :
  ty <> later ->
  G ⊢ tail ∶ Arrow Str (Delay Str).
Proof.
  repeat econstructor;eauto.
Qed.

Notation str_map  :=
  (abs (fixp (abs (into (pair ((app (unbox (var 2))) (app head (var 0))) (delay ((app (adv (var 1)) (adv (app tail (var 0))))))))))).

Example str_map_wf (G : ctx init) :
    G ⊢ str_map ∶ (Arrow (Box (Arrow Nat Nat)) (Box (Arrow Str Str))).
Proof.
  repeat econstructor;eauto.
Qed.

Notation str_filter := (abs (abs (fixp (abs (into (pair( case (app (unbox (var 3)) (app head (var 0))) (app head (var 1)) (promote (var 3))) (delay (app (adv (var 1)) (adv (app tail (var 0))))))))))).
Example str_filter_wt (G : ctx init) :
  G ⊢ str_filter ∶ Arrow (Box(Arrow Nat (Plus Unit Unit))) (Arrow Nat (Box(Arrow Str Str))).
Proof.
  repeat econstructor;eauto.
Qed.

Notation str_alternate := (fixp (abs (abs (into (pair (app head (var 1)) (delay (app ((app (adv (var 2)) (adv (app tail (var 1))))) (adv (app tail (var 0)))))))))).

Example str_alternate_wt (G : ctx init) :
  G ⊢ str_alternate ∶ Box(Arrow Str (Arrow Str Str)).
Proof.
  repeat econstructor;eauto.
Qed.

Notation Bool := (Plus Unit Unit).
Notation Clock := (Mu (Times Bool (TypeVar 0))).

Notation clock_alternate  := (fixp (abs (abs (into (pair (app (abs (pr1 (out (var 0)))) (var 1)) (delay (app ((app (adv (var 2)) (adv (app (abs (pr2 (out (var 0)))) (var 1))))) (adv (app (abs (pr2 (out (var 0)))) (var 0)))))))))).

Example clock_alternate_wt (G : ctx init) :
  G ⊢ clock_alternate ∶ Box (Arrow Clock (Arrow Clock Clock)).
Proof.
  repeat econstructor;eauto.
Qed.

Notation always := (fixp (into (pair (in1 unit) (delay (adv (var 0)))))).

Example always_wt (G : ctx init) : G ⊢ always ∶ Box Clock.
Proof.
  repeat econstructor;eauto.
Qed.

Notation never := (fixp (into (pair (in2 unit) (delay (adv (var 0)))))).
Example never_wt (G : ctx init)  : G ⊢ never ∶ Box Clock.
Proof.
  repeat econstructor;eauto.
Qed.

Notation half_step := (box (app (app (unbox clock_alternate) (unbox always)) (unbox never))).
Example half_step_wt (G : ctx init) : G ⊢ half_step ∶ Box Clock.
Proof.
  repeat econstructor;eauto. simpl.
  instantiate (1 := Times Bool (TypeVar 0)). reflexivity.
  reflexivity. instantiate (1 := Times Bool (TypeVar 0)). reflexivity.
  repeat constructor.
  repeat constructor.
Qed.

Notation on_tick := (fixp (abs (abs (into (pair (case (app head (var 0)) (app head (var 2)) (natlit 0)) (delay (app ((app (adv (var 2))) (adv (app tail (var 1)))) (adv (app tail (var 0)))))))))).
Example on_tick_wt (G : ctx init) :
  G ⊢ on_tick ∶ Box(Arrow Str (Arrow Clock Str)).
Proof.
  repeat econstructor;eauto; reflexivity.
Qed.


(** * Propositions with a distinguished point representing true *)
(** This allows for something between [bool] and [Prop], where we can
    computationally reduce things like [True /\ True], but can still
    express equality of types. *)
Require Import Coq.Setoids.Setoid.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

Delimit Scope pointed_prop_scope with pointed_prop.
Delimit Scope option_pointed_prop_scope with option_pointed_prop.
Inductive pointed_Prop := trivial | inject (_ : Prop).
Bind Scope pointed_prop_scope with pointed_Prop.

Definition to_prop (x : pointed_Prop) : Prop
  := match x with
     | trivial => True
     | inject p => p
     end.

Coercion option_pointed_Prop_of_bool (x : bool) : option pointed_Prop
  := if x then Some trivial else None.
Coercion option_pointed_Prop_of_pointed_Prop (x : pointed_Prop) : option pointed_Prop
  := Some x.

Definition prop_of_option (x : option pointed_Prop) : Prop
  := match x with
     | Some p => to_prop p
     | None => False
     end.

Definition and_pointed_Prop (x y : pointed_Prop) : pointed_Prop
  := match x, y with
     | trivial, y => y
     | x, trivial => x
     | inject p, inject q => inject (p /\ q)
     end.

Definition or_pointed_Prop (x y : pointed_Prop) : pointed_Prop
  := match x, y with
     | trivial, _ => trivial
     | _, trivial => trivial
     | inject p, inject q => inject (p \/ q)
     end.

Definition impl_pointed_Prop (x y : pointed_Prop) : pointed_Prop
  := match x, y with
     | trivial, y => y
     | _, trivial => trivial
     | inject p, inject q => inject (p -> q)
     end.

Definition not_option_pointed_Prop (x : option pointed_Prop) : option pointed_Prop
  := match x with
     | Some trivial => None
     | None => Some trivial
     | Some (inject p) => Some (inject (~p))
     end.
Arguments not_option_pointed_Prop _%option_pointed_prop.

Definition and_option_pointed_Prop (x y : option pointed_Prop) : option pointed_Prop
  := match x, y with
     | Some x, Some y => Some (and_pointed_Prop x y)
     | _, _ => None
     end.
Arguments and_option_pointed_Prop (_ _)%option_pointed_prop.

Definition or_option_pointed_Prop (x y : option pointed_Prop) : option pointed_Prop
  := match x, y with
     | Some x, Some y => Some (or_pointed_Prop x y)
     | Some x, None => Some x
     | None, Some y => Some y
     | None, None => None
     end.
Arguments or_option_pointed_Prop (_ _)%option_pointed_prop.

Definition impl_option_pointed_Prop (x y : option pointed_Prop) : option pointed_Prop
  := match x, y with
     | None, _ => Some trivial
     | Some x, Some y => Some (impl_pointed_Prop x y)
     | Some p, None => not_option_pointed_Prop p
     end.
Arguments impl_option_pointed_Prop (_ _)%option_pointed_prop.

Infix "/\" := and_pointed_Prop : pointed_prop_scope.
Infix "\/" := or_pointed_Prop : pointed_prop_scope.
(*Infix "->" := impl_pointed_Prop : pointed_prop_scope.*)
Infix "/\" := and_option_pointed_Prop : option_pointed_prop_scope.
Infix "\/" := or_option_pointed_Prop : option_pointed_prop_scope.
(*Infix "->" := impl_option_pointed_Prop : option_pointed_prop_scope.*)
Notation "~ P" := (not_option_pointed_Prop P) : option_pointed_prop_scope.

Ltac inversion_pointed_Prop_step :=
  match goal with
  | [ H : inject _ = inject _ |- _ ] => progress (inversion H; clear H)
  end.
Ltac inversion_pointed_Prop := repeat inversion_pointed_Prop_step.

Create HintDb push_prop_of_option discriminated.
Create HintDb push_to_prop discriminated.
#[global]
Hint Extern 1 => progress autorewrite with push_prop_of_option in * : push_prop_of_option.
#[global]
Hint Extern 1 => progress autorewrite with push_to_prop in * : push_to_prop.

Lemma to_prop_and P Q : to_prop (P /\ Q)%pointed_prop
                        <-> (to_prop P /\ to_prop Q).
Proof. destruct P, Q; simpl; tauto. Qed.
#[global]
Hint Rewrite to_prop_and : push_to_prop.

Lemma to_prop_or P Q : to_prop (P \/ Q)%pointed_prop
                       <-> (to_prop P \/ to_prop Q).
Proof. destruct P, Q; simpl; tauto. Qed.
#[global]
Hint Rewrite to_prop_or : push_to_prop.

Lemma to_prop_impl P Q : to_prop (impl_pointed_Prop P Q)%pointed_prop
                         <-> (to_prop P -> to_prop Q).
Proof. destruct P, Q; simpl; tauto. Qed.
#[global]
Hint Rewrite to_prop_impl : push_to_prop.

Lemma prop_of_option_and P Q : prop_of_option (P /\ Q)%option_pointed_prop
                               <-> (prop_of_option P /\ prop_of_option Q).
Proof. destruct P, Q; simpl; autorewrite with push_to_prop; tauto. Qed.
#[global]
Hint Rewrite prop_of_option_and : push_prop_of_option.

Lemma prop_of_option_or P Q : prop_of_option (P \/ Q)%option_pointed_prop
                               <-> (prop_of_option P \/ prop_of_option Q).
Proof. destruct P, Q; simpl; autorewrite with push_to_prop; tauto. Qed.
#[global]
Hint Rewrite prop_of_option_or : push_prop_of_option.

Lemma prop_of_option_impl P Q : prop_of_option (impl_option_pointed_Prop P Q)%option_pointed_prop
                               <-> (prop_of_option P -> prop_of_option Q).
Proof. destruct P as [ [|P] |], Q as [ [|Q] |]; simpl; tauto. Qed.
#[global]
Hint Rewrite prop_of_option_impl : push_prop_of_option.

Lemma prop_of_option_not P : prop_of_option (~P)%option_pointed_prop
                               <-> (~prop_of_option P).
Proof. destruct P as [ [|] | ]; simpl; tauto. Qed.
#[global]
Hint Rewrite prop_of_option_not : push_prop_of_option.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                       Star.v                                       *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.
Require Import IntensionalLib.Fieska_calculus.Fieska_Tactics.
Require Import IntensionalLib.Fieska_calculus.Fieska_reduction.
Require Import IntensionalLib.Fieska_calculus.Fieska_Normal.
Require Import IntensionalLib.Fieska_calculus.Fieska_Closed.
Require Import IntensionalLib.Fieska_calculus.Substitution.
Require Import IntensionalLib.Fieska_calculus.Fieska_Eval.

(* naive abstraction -- no optimisation *)

Fixpoint star M :=
match M with
  | Ref 0 => Op Iop
| Ref (S n) => App  (Op Kop)  (Ref n)
| Op o => App  (Op Kop) (Op o)
| App M1 M2 => App (App (Op Sop) (star M1)) (star M2)
end
.

Proposition star_beta: forall M N, sf_red (App (star M) N) (subst M N).
Proof.
induction M; split_all.
(* 3 *)
unfold subst; case n; split_all; unfold_op;  eapply2 succ_red.
insert_Ref_out. unfold lift. rewrite lift_rec_null_term.
eapply2 succ_red. eapply2 succ_red.
(* 1 *)
unfold subst; simpl.
eapply succ_red. eapply2 s_red.
eapply2 preserves_app_sf_red.
Qed.

(* optimising star *)

Fixpoint occurs0 M :=
match M with
| Ref 0 => true
| Ref (S _) => false
| Op _ => false
| App M1 M2 => (occurs0 M1) || (occurs0 M2)
end.

Lemma occurs_op: forall o, occurs0 (Op o) = false.
Proof. split_all. Qed.

Lemma occurs_app: forall M N, occurs0 (App M N) = occurs0 M || occurs0 N.
Proof. split_all. Qed.

Lemma occurs_closed: forall M, maxvar M = 0 -> occurs0 M = false.
Proof.
induction M; split_all. discriminate.
max_out. rewrite IHM1; auto; rewrite IHM2; auto.
Qed.

Lemma occurs_lift_rec_zero: forall M k, occurs0 (lift_rec M 0 (S k)) = false.
Proof.
induction M; split_all. relocate_lt.
replace (S k + n) with (S (k+n)) by omega. auto.
rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma occurs_lift_rec_succ: forall M n k, occurs0 (lift_rec M (S n) k) = occurs0 M.
Proof.
induction M; split_all. unfold relocate.
elim(test (S n0) n); split_all.
gen_case a n;try noway. replace (k + S n1) with (S (k+n1)) by omega. auto.
rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma occurs_subst_rec_succ: forall M N k, occurs0 (subst_rec M N (S k)) = occurs0 M.
Proof.
induction M; split_all. case n; split_all.
unfold insert_Ref. elim(compare (S k) (S n0)); split_all. elim a; split_all.
gen_case a0 n0; try omega.
unfold lift; eapply2 occurs_lift_rec_zero. rewrite IHM1; auto; rewrite IHM2; auto.
Qed.

Lemma occurs_false_subst_status:
forall M N, occurs0 M = false -> status (subst_rec M N 0) = status M.
Proof.
cut(forall p M, p>= rank M ->
 forall N, occurs0 M = false -> status (subst_rec M N 0) = status M).
split_all. eapply2 H.
induction p; split_all.
assert(rank M >0) by eapply2 rank_positive. noway.
induction M; intros.
(* 3 *)
 split_all. simpl in H0.
assert(n = S (pred n)). gen_case H0 n. discriminate.
rewrite H1. insert_Ref_out. auto.
(* 2 *)
split_all.
(* 1 *)
unfold subst_rec; fold subst_rec.
simpl in H0. simpl in H.
assert(occurs0 M1 = false /\ occurs0 M2 = false) by eapply2 orb_false_iff.
inversion H1.
generalize IHM1 H H2; clear IHM1 H H2; case M1; intros.
(* 3 *)
simpl in H2. unfold subst_rec; fold subst_rec.  unfold insert_Ref.
gen_case H2 n. discriminate.
(* 2 *)
gen_case H o.
(* 1 *)
generalize IHM1 H H2; clear IHM1 H H2; case f; intros.
(* 3 *)
simpl in H2. unfold subst_rec; fold subst_rec.  unfold insert_Ref.
gen_case H2 n.
(* 2 *)
simpl in H2.  unfold subst_rec; fold subst_rec.  discriminate.
case o; split_all.
rewrite ! IHp; auto. omega. simpl in H; omega.
(* 1 *)
unfold subst_rec; fold subst_rec.
generalize IHM1 H H2; clear IHM1 H H2; case f1; intros.
(* 3 *)
simpl in H2. unfold subst_rec; fold subst_rec.  unfold insert_Ref.
gen_case H2 n.  discriminate.
(* 2 *)
simpl in H2.  unfold subst_rec; fold subst_rec.
case o; split_all.
rewrite ! IHp; auto. simpl in H; omega.
assert(occurs0 f2 = false /\ occurs0 f0 = false) by eapply2 orb_false_iff.
tauto.
rewrite ! IHp; auto. simpl in H; omega.
assert(occurs0 f2 = false /\ occurs0 f0 = false) by eapply2 orb_false_iff.
tauto. simpl in H; omega.
assert(occurs0 f2 = false /\ occurs0 f0 = false) by eapply2 orb_false_iff.
tauto.
(* 1 *)
unfold subst_rec; fold subst_rec.
replace (status (App (App (App (App f3 f4) f2) f0) M2)) with (status (App (App (App f3 f4) f2) f0))
by auto.
replace (status (App
        (App
           (App (App (subst_rec f3 N 0) (subst_rec f4 N 0))
              (subst_rec f2 N 0)) (subst_rec f0 N 0))
        (subst_rec M2 N 0)))
with
(status (App
           (App (App (subst_rec f3 N 0) (subst_rec f4 N 0))
              (subst_rec f2 N 0)) (subst_rec f0 N 0))
        )
by auto.
replace (App
           (App (App (subst_rec f3 N 0) (subst_rec f4 N 0))
              (subst_rec f2 N 0)) (subst_rec f0 N 0))
with (subst_rec (App (App (App f3 f4) f2) f0) N 0) by auto.
rewrite  IHp; auto. simpl in *; omega.
Qed.

Lemma occurs_false_subst_normal:
forall M N, occurs0 M = false -> normal M -> normal (subst_rec M N 0).
Proof.
induction M; split_all.
unfold insert_Ref. generalize H; clear H. case n; split_all. discriminate.
assert(occurs0 M1 = false /\ occurs0 M2 = false) by eapply2 orb_false_iff.
inversion H1.
inversion H0. eapply2 nf_active.
replace(App (subst_rec M1 N 0) (subst_rec M2 N 0)) with (subst_rec (App M1 M2) N 0) by auto.
rewrite occurs_false_subst_status. auto. split_all.
apply nf_compound. eapply2 IHM1. eapply2 IHM2.
replace(App (subst_rec M1 N 0) (subst_rec M2 N 0)) with (subst_rec (App M1 M2) N 0) by auto.
eapply2 subst_rec_preserves_compounds.
Qed.

Lemma no_subst: forall M N P, occurs0 M = false -> subst_rec M N 0 = subst_rec M P 0.
Proof.
induction M; split_all.
gen_case H n. discriminate.
assert(occurs0 M1 = false /\ occurs0 M2 = false). rewrite <- orb_false_iff. auto.
inversion H0. rewrite (IHM1 N P); auto; rewrite (IHM2 N P); auto.
Qed.

(* Star abstraction optimised *)

Fixpoint star_opt M :=
match M with
| Ref 0 => Op Iop
| Ref (S n) => App (Op Kop) (Ref n)
| Op o => App (Op Kop) (Op o)
| App M1 M2 =>
  if occurs0 M1
  then App (App (Op Sop) (star_opt M1)) (star_opt M2)
  else match M2 with
         | Ref 0 => subst M1 (Op Sop)
         | _ => if occurs0 M2
                then App (App (Op Sop)  (star_opt M1))  (star_opt M2)
                else App (Op Kop) (subst M (Op Sop))
       end
end.

  (* characterising star_opt  *)

Lemma star_opt_eta: forall M, occurs0 M = false -> star_opt (App M (Ref 0)) = subst M (Op Sop).
Proof. intros. unfold star_opt; fold star_opt. rewrite H. split_all. Qed.

Lemma star_opt_occurs_false :
forall M, occurs0 M = false  -> star_opt M = App (Op Kop) (subst_rec M (Op Sop) 0).
Proof.
induction M; unfold star_opt; fold star_opt; split_all. gen_case H n; split_all. discriminate.
assert(occurs0 M1 = false /\ occurs0 M2 = false) by eapply2 orb_false_iff.
inversion H0. rewrite H1. rewrite H2. gen_case H2 M2. gen_case H2 n. discriminate.
Qed.

Lemma star_opt_occurs_true :
forall M1 M2, occurs0 (App M1 M2) = true -> M2 <> Ref 0 ->
star_opt (App M1 M2) = App (App (Op Sop) (star_opt M1)) (star_opt M2).
Proof.
cut(forall M, occurs0 M = true -> forall M1 M2, M = App M1 M2  -> M2 <> Ref 0 ->
star_opt M = App (App (Op Sop) (star_opt M1)) (star_opt M2)).
intros. eapply2 H.
(* 1 *)
induction M; intros; subst; inversion H0; subst.
simpl in H. assert(occurs0 M0 = true \/ occurs0 M3 = true) by eapply2 orb_true_iff.
inversion H2.
(* 2 *)
split_all. rewrite H3. auto.
(* 1 *)
split_all.
assert(occurs0 M0 = true \/ occurs0 M0 <> true) by decide equality.
assert(occurs0 M0 = false -> star_opt M0 = App (Op Kop) (subst M0 (Op Sop)))
by eapply2 star_opt_occurs_false.
inversion H4. rewrite H6. auto.
gen2_case H5 H6 (occurs0 M0). rewrite H3.
gen_case H1 M3. gen_case H1 n; rewrite H5; auto.
assert False by eapply2 H1. noway.
Qed.

Lemma star_opt_lift: forall M, star_opt (lift 1 M) = App k_op M.
Proof.
split_all.
assert(M = subst_rec (lift 1 M) (Op Sop) 0).
unfold lift; rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
rewrite H at 2.
eapply2 star_opt_occurs_false.
unfold lift. apply occurs_lift_rec_zero.
Qed.

Lemma star_opt_normal_app:
forall M N, normal (App M N) -> normal (star_opt M) -> normal (star_opt N)  ->
normal (star_opt (App M N)).
Proof.
split_all.
assert(occurs0 M = false -> normal (subst M (Op Sop))).
intro; eapply2 occurs_false_subst_normal. inversion H; auto.
assert(occurs0 M || occurs0 N = false -> normal (subst (App M N) (Op Sop))).
intro; eapply2 occurs_false_subst_normal.
gen2_case H2 H3 (occurs0 M).
gen3_case H H1 H3 N. gen3_case H H1  H3 n. gen3_case H1 H H3 (occurs0 f).
gen3_case H1 H H3 f0. gen3_case H1 H H3 n.
gen3_case H1 H H3 (occurs0 f1).
gen3_case H1 H H3 (occurs0 f2).
Qed.

Lemma star_opt_closed: forall M, maxvar M = 0 -> star_opt M = App k_op M.
Proof.
intros.
assert(occurs0 M = false).
induction M; simpl in *; split_all. discriminate.
max_out. rewrite IHM1; auto; rewrite IHM2; auto.
rewrite star_opt_occurs_false. rewrite subst_rec_closed; auto. omega. auto.
Qed.

Lemma star_opt_normal: forall M, normal M -> normal (star_opt M).
Proof.
match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H |
intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
]
end .
  induction M; intros r nf.
  (* 3 *)
  case n; split_all.
  (* 2 *)
  split_all.
(* 1 *)
simpl in *. eapply2 star_opt_normal_app.  eapply2 IHM1. omega. inversion nf; auto.
eapply2 IHM2. omega. inversion nf; auto.
Qed.

Lemma maxvar_lower: forall M, maxvar (subst M (Op Sop)) = pred (maxvar M).
Proof.
induction M; split_all; unfold subst, subst_rec; fold subst_rec.
case n; split_all.
rewrite max_pred. auto.
Qed.

Lemma maxvar_star_opt: forall M, maxvar (star_opt M) = pred (maxvar M).
Proof.
induction M; split_all.
case n; split_all.
rewrite max_pred.
case (occurs0 M1); split_all.
gen_case IHM2 M2.
gen_case IHM2 n. rewrite max_zero. apply maxvar_lower.
replace (subst_rec M1 (Op Sop) 0) with (subst M1 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower. auto.
replace (subst_rec M1 (Op Sop) 0) with (subst M1 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower. auto.
gen_case IHM2 (occurs0 f).
gen_case IHM2 f0. gen_case IHM2 n.
replace (subst_rec M1 (Op Sop) 0) with (subst M1 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower.
replace (subst_rec f (Op Sop) 0) with (subst f (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower. rewrite max_pred; auto.
replace (subst_rec M1 (Op Sop) 0) with (subst M1 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower.
replace (subst_rec f (Op Sop) 0) with (subst f (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower. rewrite max_pred; auto.
(* 1 *)
gen_case IHM2 (occurs0 f1).
gen_case IHM2 (occurs0 f2).
replace (subst_rec M1 (Op Sop) 0) with (subst M1 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower.
replace (subst_rec f1 (Op Sop) 0) with (subst f1 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower. rewrite max_pred; auto.
replace (subst_rec f2 (Op Sop) 0) with (subst f2 (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower.
replace (subst_rec f (Op Sop) 0) with (subst f (Op Sop)) by (unfold subst; auto).
rewrite maxvar_lower. rewrite max_pred; auto.
Qed.

Lemma lift_rec_preserves_star_opt:
forall M n k, lift_rec (star_opt M) n k = star_opt (lift_rec M (S n) k).
Proof.
induction M; intros.
(* 3 *)
case n; split_all. rewrite relocate_succ. auto.
(* 2 *)
split_all.
(* 1 *)
rewrite lift_rec_app.
unfold star_opt; fold star_opt.
rewrite occurs_lift_rec_succ.
case (occurs0 M1); split_all.
(* 2 *)
rewrite IHM1; rewrite IHM2; auto.
rewrite ! occurs_lift_rec_succ in *.
case (occurs0 M2); split_all.
generalize IHM2; clear IHM2; case M2; intros.
(* 4 *)
gen_case IHM2 n0.
(* 5 *)
unfold subst.   replace n with (0+n) by auto; rewrite ! lift_rec_subst_rec; auto.
(* 4 *)
rewrite relocate_succ. rewrite IHM1; auto.
(* 3 *)
split_all. rewrite IHM1; auto.
(* 2 *)
unfold lift_rec; fold lift_rec.
rewrite IHM1; rewrite IHM2; auto.
(* 1 *)
generalize IHM2; clear IHM2; case M2; intros.
(* 3 *)
gen_case IHM2 n0.
(* 4 *)
unfold subst.   replace n with (0+n) by auto; rewrite ! lift_rec_subst_rec; auto.
(* 3 *)
rewrite relocate_succ.  replace n with (0+n) by auto; rewrite ! lift_rec_subst_rec; auto.
(* 2 *)
unfold lift_rec; fold lift_rec.  unfold subst.
replace n with (0+n) by auto; rewrite ! lift_rec_subst_rec; auto.
(* 1 *)
unfold lift_rec; fold lift_rec.  unfold subst.
replace n with (0+n) by auto; rewrite ! lift_rec_subst_rec; auto.
Qed.

Lemma subst_rec_preserves_star_opt:
forall M N k, subst_rec (star_opt M) N k = star_opt (subst_rec M N (S k)).
Proof.
  induction M; split_all.
  (* 2 *)
  case n; split_all.
  unfold insert_Ref. elim(compare k n0); split_all.
elim a; split_all.    elim(compare (S k) (S n0)); split_all; try noway.
elim a1; split_all; try noway.
replace n0 with (S (pred n0)) by omega. auto.
elim(compare (S k) (S n0)); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
replace (lift_rec N 0 (S k)) with (lift 1 (lift_rec N 0 k)).
rewrite star_opt_lift. auto.
unfold lift. rewrite lift_rec_lift_rec; try omega.  auto.
elim(compare (S k) (S n0)); split_all; try noway.
elim a; split_all; try noway.
(* 1 *)
rewrite <- ! IHM2.
rewrite ! occurs_subst_rec_succ.
case (occurs0 M1); split_all.
(* 2 *)
rewrite IHM1; rewrite IHM2; auto.
(* 1 *)
gen_case IHM2 M2. gen_case IHM2 n.
unfold subst. replace k with (0+k) by auto. rewrite ! subst_rec_subst_rec. auto.
assert(App (Op Kop) (insert_Ref N n0 k) =
         star_opt (insert_Ref N (S n0) (S k))) by auto.
generalize H; clear H IHM2.
unfold insert_Ref.
elim(compare k n0); intro. elim a; intro.
elim(compare (S k) (S n0)); split_all; try noway. elim a1; split_all; try noway.
replace n0 with (S (pred n0)) by omega.
unfold subst. replace k with (0+k) by auto. rewrite ! subst_rec_subst_rec. simpl. insert_Ref_out.
auto.
subst. elim(compare (S n0) (S n0)); intro; try noway. elim a0; intro; try noway.
intro.
case N; unfold lift, lift_rec; fold lift_rec; split_all. relocate_lt.
replace (S n0 + n1) with (S (n0 + n1)) by omega.
unfold subst. replace n0 with (0+n0) by auto. rewrite ! subst_rec_subst_rec. simpl. insert_Ref_out.
auto.
unfold subst. replace n0 with (0+n0) by auto. rewrite ! subst_rec_subst_rec. simpl. insert_Ref_out.
auto.
unfold subst. replace n0 with (0+n0) by auto. rewrite ! subst_rec_subst_rec. simpl.
rewrite ! subst_rec_lift_rec; try omega. auto.
elim(compare (S k) (S n0)); split_all; try noway. elim a; split_all; try noway.
unfold subst. replace k with (0+k) by auto. rewrite ! subst_rec_subst_rec. simpl. insert_Ref_out.
auto.
unfold subst. replace k with (0+k) by auto. rewrite ! subst_rec_subst_rec. simpl. insert_Ref_out.
auto.
(* 1 *)
assert(subst_rec
           (if occurs0 f
            then App (App (Op Sop) (star_opt f)) (star_opt f0)
            else
             match f0 with
             | Ref 0 => subst f (Op Sop)
             | Ref (S _) =>
                 if occurs0 f0
                 then App (App (Op Sop) (star_opt f)) (star_opt f0)
                 else App (Op Kop) (subst (App f f0) (Op Sop))
             | Op _ =>
                 if occurs0 f0
                 then App (App (Op Sop) (star_opt f)) (star_opt f0)
                 else App (Op Kop) (subst (App f f0) (Op Sop))
             | App _ _ =>
                 if occurs0 f0
                 then App (App (Op Sop) (star_opt f)) (star_opt f0)
                 else App (Op Kop) (subst (App f f0) (Op Sop))
             end) N k =
         (if occurs0 (subst_rec f N (S k))
          then
           App (App (Op Sop) (star_opt (subst_rec f N (S k))))
             (star_opt (subst_rec f0 N (S k)))
          else
           match subst_rec f0 N (S k) with
           | Ref 0 => subst (subst_rec f N (S k)) (Op Sop)
           | Ref (S _) =>
               if occurs0 (subst_rec f0 N (S k))
               then
                App (App (Op Sop) (star_opt (subst_rec f N (S k))))
                  (star_opt (subst_rec f0 N (S k)))
               else
                App (Op Kop)
                  (subst (App (subst_rec f N (S k)) (subst_rec f0 N (S k)))
                     (Op Sop))
           | Op _ =>
               if occurs0 (subst_rec f0 N (S k))
               then
                App (App (Op Sop) (star_opt (subst_rec f N (S k))))
                  (star_opt (subst_rec f0 N (S k)))
               else
                App (Op Kop)
                  (subst (App (subst_rec f N (S k)) (subst_rec f0 N (S k)))
                     (Op Sop))
           | App _ _ =>
               if occurs0 (subst_rec f0 N (S k))
               then
                App (App (Op Sop) (star_opt (subst_rec f N (S k))))
                  (star_opt (subst_rec f0 N (S k)))
               else
                App (Op Kop)
                  (subst (App (subst_rec f N (S k)) (subst_rec f0 N (S k)))
                     (Op Sop))
           end)) by eapply2 IHM2.
clear IHM2.
rewrite ! occurs_subst_rec_succ in *.
gen_case H (occurs0 f).
rewrite IHM1; rewrite H; auto.
gen_case H (occurs0 f0).
rewrite IHM1; rewrite H; auto.
unfold subst, subst_rec; fold subst_rec.
replace k with (0+k) by auto. rewrite ! subst_rec_subst_rec.
auto.
Qed.

Proposition star_opt_beta: forall M N, sf_red (App (star_opt M) N) (subst M N).
Proof.
cut(forall p M, p>= rank M -> forall N, sf_red (App (star_opt M) N) (subst M N)).
split_all. eapply2 H.
induction p; split_all.
assert(rank M >0) by eapply2 rank_positive. noway.
induction M; intros.
(* 3 *)
unfold subst; case n; split_all; unfold_op;  eapply2 succ_red.
insert_Ref_out. unfold lift. rewrite lift_rec_null_term.
one_step.
(* 2 *)
red; one_step.
(* 1 *)
simpl in H.
unfold star_opt; fold star_opt.
assert(occurs0 M1 = false -> subst_rec M1 N 0 = subst_rec M1 (Op Sop) 0) by eapply2 no_subst.
gen_case H0 (occurs0 M1).
eval_tac.
eapply2 preserves_app_sf_red.
eapply2 IHM1. omega.
eapply2 IHM2. omega.
(* 1 *)
gen2_case H IHM2 M2. gen2_case H IHM2 n.
unfold subst, subst_rec; fold subst_rec. insert_Ref_out. unfold lift. rewrite lift_rec_null; auto.
rewrite H0;  auto.
(* 3 *)
eval_tac. insert_Ref_out. eapply2 preserves_app_sf_red. rewrite H0; auto.
(* 2 *)
eval_tac. eapply2 preserves_app_sf_red. rewrite H0; auto.
(* 1 *)
assert(occurs0 f = false -> subst_rec f N 0 = subst_rec f (Op Sop) 0) by eapply2 no_subst.
gen2_case H1 IHM2 (occurs0 f). eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 IHM1. omega.
 eval_tac.
unfold subst. eapply2 preserves_app_sf_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 IHp. omega. eapply2 IHp. omega.
auto.
(* 1 *)
assert(occurs0 f0 = false -> subst_rec f0 N 0 = subst_rec f0 (Op Sop) 0) by eapply2 no_subst.
gen3_case H2 H IHM2 f0. gen3_case H H2 IHM2 n.
(* 4 *)
 eval_tac. insert_Ref_out. unfold lift. rewrite lift_rec_null. eapply2 preserves_app_sf_red.
unfold subst in *. eapply2 IHM1. omega. rewrite H1; auto.
(* 3 *)
eval_tac. insert_Ref_out. rewrite H1; auto. rewrite H0; auto.
(* 2 *)
eval_tac. eapply2 preserves_app_sf_red. rewrite H0; auto. rewrite H1; auto.
(* 1 *)
assert(occurs0 f1 = false -> subst_rec f1 N 0 = subst_rec f1 (Op Sop) 0) by eapply2 no_subst.
assert(occurs0 f2 = false -> subst_rec f2 N 0 = subst_rec f2 (Op Sop) 0) by eapply2 no_subst.
gen2_case IHM2 H3 (occurs0 f1).  eval_tac. eapply2 preserves_app_sf_red.
unfold subst in *; eapply2 IHM1. omega.
eval_tac. eapply2 preserves_app_sf_red. unfold subst in *; eapply2 IHp. omega.
eval_tac. eapply2 preserves_app_sf_red. unfold subst in *; eapply2 IHp. omega.
unfold subst in *; eapply2 IHp. omega.
(* 1 *)
gen2_case IHM2 H4 (occurs0 f2).  eval_tac. eapply2 preserves_app_sf_red.
unfold subst in *; eapply2 IHM1. omega.
unfold subst in *. eapply2 IHM2. omega.
eval_tac.  eapply2 preserves_app_sf_red. rewrite H0; auto.
rewrite H1; auto. rewrite H3; auto. rewrite H4; auto.
Qed.

Lemma star_opt_beta2:
  forall M N1 N2, sf_red (App (App (star_opt (star_opt M)) N1) N2) (subst (subst M (lift 1 N2)) N1).
Proof.
  intros.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 star_opt_beta. auto.
match goal with
    |- multi_step sf_red1 (App (subst ?P ?Q) N2) _  =>
    replace(App (subst P Q) N2) with (subst (App P (lift 1 N2)) Q)
end
.
eapply2 subst_preserves_sf_red.
eapply transitive_red. eapply2 star_opt_beta. auto.
unfold subst, lift; split_all. repeat rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. auto.
Qed.

Lemma star_opt_beta3:
  forall M N1 N2 N3, sf_red (App (App (App (star_opt (star_opt (star_opt M))) N1) N2) N3)
                           (subst (subst (subst M (lift 2 N3)) (lift 1 N2)) N1).
Proof.
  intros.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 star_opt_beta2. auto.
match goal with
    |- multi_step sf_red1 (App (subst (subst ?P ?Q) ?R) N3) _  =>
    replace(App (subst (subst P Q) R) N3) with (subst (subst (App P (lift 2 N3)) Q) R)
end
.
eapply2 subst_preserves_sf_red.
eapply2 subst_preserves_sf_red.
eapply transitive_red. eapply2 star_opt_beta. auto.
unfold subst, lift; split_all. repeat rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. auto.
Qed.

Lemma star_opt_beta4:
  forall M N1 N2 N3 N4,
sf_red (App (App (App (App (star_opt (star_opt (star_opt (star_opt M)))) N1) N2) N3) N4)
                           (subst (subst (subst (subst M (lift 3 N4))(lift 2 N3)) (lift 1 N2)) N1).
Proof.
  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_opt_beta3. auto.
match goal with
    |- multi_step sf_red1 (App (subst (subst (subst ?P ?Q) ?R) ?T) N4) _  =>
    replace(App (subst(subst (subst P Q) R) T) N4)
    with (subst (subst (subst (App P (lift 3 N4)) Q) R) T)
end
.
eapply2 subst_preserves_sf_red.
eapply2 subst_preserves_sf_red.
eapply2 subst_preserves_sf_red.
eapply transitive_red. eapply2 star_opt_beta. auto.
unfold subst, lift; split_all. repeat rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. auto.
Qed.


From Undecidability.L.Datatypes Require Import LOptions LBool LNat Lists.
From Undecidability.L.Tactics Require Import LTactics ComputableTactics.
Require Import Nat.

Set Default Proof Using "Type".
Section demo.

(* for examples of usage see LBool/LNat/Lists/Option/Encoding etc*)

Definition unit_enc := fun (x:unit) => I.

Instance register_unit : registered  unit.
Proof.
  register unit_enc.
Defined. (* becuse class ? *)

(* example for higher-order-stuff *)

Definition on0 (f:nat->nat->nat) := f 0 0.

Instance term_on0 : computable on0.
Proof.
  extract.
Qed.

Lemma test_Some_nat : computable (@Some nat).
Proof.
  extract.
Qed.

(* *** Interactive Demo *)

Section PaperExample.

  (* Examples of the tactics that proof the correctness lemmata *)

  Import ComputableTactics.
  Import ComputableTactics.Intern.

  Goal computable orb.
  Proof.
    extractAs s.
    computable_using_noProof s.
    cstep.
    cstep.
    cstep.
    all:    cstep.
  Qed.

  (* Print cnst. *)

  (* Comming up with the conditions for the time bound *)
  Goal forall fT, computableTime' orb fT.
  Proof.
    intros.
    extractAs s.
    computable_using_noProof s.
    cstep.
    cstep. (* Note that the second goal got more specific *)
    cstep. (* Note that the second goal got more specific *)
    cstep.
    1,2:cstep. (* Note that the hole in the second goal got filled with True*)
    solverec.
  Abort.

  (* Finding the Time Bound *)

  Goal computableTime' orb (fun _ _ => (cnst "c1",fun _ _ => (cnst "c2",tt))).
  Proof.
    extract. solverec. (* Now the values are clear *)
  Abort.

  Goal computableTime' orb (fun _ _ => (1,fun _ _ => (3,tt))).
  Proof.
    extract. solverec.
  Abort.

  Import Datatypes.LNat.

  Goal computable Nat.add.
  Proof.
    unfold Nat.add.
    extractAs s.
    computable_using_noProof s.
    cstep.
    all:cstep.
    all:cstep.
  Qed.

  Goal computable (fix f (x y z : nat) := y + match y with |  S (S y) => S (f x y z) | _ => 0 end).
    extractAs s.
    computable_using_noProof s.
    cstep.
    all:cstep.
    all:cstep.
    all:cstep.
  Qed.

  Lemma supported3 : computable (fun (b:bool) => if b then (fix f x := match x with S x => f x | 0 => 0 end) else S).
    extractAs s.
    computable_using_noProof s.
    cstep.
    cstep.
    all:cstep.
    all:cstep.
  Qed.

  (* this is due to https://github.com/coq/coq/issues/9761 *)
  Lemma unsupported : computable (fix f (y : nat) {struct y}:= match y with | S (S y) => f y | _ => S end).
    extractAs s.
    computable_using_noProof s.
    repeat cstep.
    Fail Guarded.
  Abort.

    (* this is due to https://github.com/coq/coq/issues/9761 *)
  Lemma workarround : let f := (fix f (z y : nat) {struct y}:= match y with | S (S y) => f z y | _ => S z end) in computable (fun y z => f z y).
  Proof.
    intros f. assert (computable f) by (unfold f;extract).
    extract.
  Qed.

  Lemma unsupported2 :  computable 10.
  Proof.
    extract. (* not true*) Fail reflexivity.
  Abort.
  (* not a problem inside a function*)
  Goal computable (fun n : nat => 10).
  Proof.
    extract.
  Qed.

  Import Datatypes.Lists.
  Remove Hints term_map : typeclass_instances.

  Lemma map_term A B  (Rx : registered A)  (Ry: registered B):
    computable (@map A B).
  Proof.
    extractAs s.
    computable_using_noProof s.
    cstep.
    cstep.
    all:cstep.
  Qed.

  (*comming up with the condition *)

   Lemma termT_map A B (Rx : registered A)  (Ry: registered B):
    computableTime' (@map A B) (fun f fT => (cnst "c",fun xs _ => (cnst ("f",xs),tt))).
  Proof.
    extractAs s.
    computable_using_noProof s.
    cstep.
    cstep.
    repeat cstep.
  Abort.

  (* comming up with the time bound *)

  Lemma termT_map A B (Rx : registered A)  (Ry: registered B):
    computableTime' (@map A B) (fun f fT => (cnst "c",fun xs _ => (cnst ("f",xs),tt))).
  Proof.
    extract. solverec.
  Abort.

  Lemma term_map (X Y:Type) (Hx : registered X) (Hy:registered Y):
    computableTime' (@map X Y)
                   (fun f fT => (1,fun l _ => (fold_right (fun x res => fst (fT x tt) + res + 12) 8 l,tt))).
  Proof.
    extract.
    solverec.
  Qed.

  End PaperExample.

  (*
(* this is more or lest just a test for internalization automation... *)
Instance term_option_map X Y (Hy:registered Y) (Hx : registered X):computable (@option_map X Y).
Proof.
  compute' 0.
  computePrettyStep.

  Unshelve. Focus 4. unfold int. cbn. Lsimpl. unfold intApp'. Set Printing Implicit. split. unfold int. cbn.  hnf. reflexivity. cbn. Lsimpl.
  computePrettyStep.
  computePrettyStep.
  Unshelve. Focus 4. split. reflexivity. Lreflexivity.
  compute auto.
Qed.
   *)

End demo.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Divides.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)

From Coq Require Import Arith ArithRing Peano_dec Wf_nat.
From Coq Require Export Euclid.
From Bertrand Require Export Misc Power.

(** Division as a predicate *)

Definition is_div (a b q r : nat) : Prop := r < b /\ a = q * b + r.

Definition ex_div (a b : nat) : Prop :=
  exists q : nat, (exists r : nat, is_div a b q r).

Lemma div_x_nO : forall x y q r : nat, is_div x y q r -> y <> 0.
Proof.
intros x y q r; case y; auto.
intros (H1, H2); Contradict H1; auto with arith.
Qed.

Lemma div_x_O_r : forall x q r : nat, is_div 0 x q r -> r = 0.
Proof.
intros x q r (H1, H2).
apply plus_eqO with (y := q * x); rewrite H2; auto with arith.
Qed.

Lemma div_x_O_q : forall x q r : nat, is_div 0 x q r -> q = 0.
Proof.
intros x q r H'.
rewrite (div_x_O_r x q r) in H'; auto; case H'; intros H1 H2.
case (mult_eqO q x); auto.
rewrite H2; auto with arith.
intros H'1; Contradict H1; auto; rewrite H'1; auto with arith.
Qed.

Lemma div_pred :
 forall x y q : nat,
 0 < x -> is_div x y q 0 -> is_div (pred x) y (pred q) (pred y).
Proof.
intros x y q H' (H'1, H'2); split; auto.
generalize H'1; case y; simpl in |- *; auto with arith.
rewrite H'2; auto.
rewrite <- plus_n_O; auto.
generalize H'2; case q; simpl in |- *; auto.
intros H'3; Contradict H'; auto with arith.
rewrite H'3; auto with arith.
intros n H'3; generalize H'1; case y; simpl in |- *; auto with arith.
intros H'4; Contradict H'4; auto with arith.
Qed.

Lemma div_SxS :
 forall x y q r : nat,
 0 < r -> is_div x y q r -> is_div (pred x) y q (pred r).
Proof.
intros x y q r H' (H'1, H'2); split; auto.
apply Nat.le_lt_trans with (2 := H'1); auto with arith.
rewrite H'2; generalize H'; case r; simpl in |- *; auto.
intros H'3; Contradict H'3; auto with arith.
intros r'; rewrite <- plus_n_Sm; auto.
Qed.

Lemma div_unic_q :
 forall a b q1 q2 r1 r2 : nat,
 is_div a b q1 r1 -> is_div a b q2 r2 -> q1 = q2.
Proof.
intros a b q1 q2 r1 r2 (H0, H1) (H2, H3).
case (Nat.le_gt_cases q1 q2); intros H4.
case (proj1 (Nat.lt_eq_cases _ _) H4); auto; clear H4; intros H4.
Contradict H0; auto; apply Nat.le_ngt.
apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (q1 * b).
rewrite <- H1; rewrite H3; auto with arith.
apply Nat.le_trans with (q2 * b + 0); auto with arith.
replace (q1 * b + b) with (S q1 * b);
 [ repeat rewrite (fun x => Nat.mul_comm x b) | simpl in |- * ];
 auto with arith.
Contradict H2; auto; apply Nat.le_ngt.
apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (q2 * b).
rewrite <- H3; rewrite H1; auto with arith.
apply Nat.le_trans with (q1 * b + 0); auto with arith.
replace (q2 * b + b) with (S q2 * b);
 [ repeat rewrite (fun x => Nat.mul_comm x b) | simpl in |- * ];
 auto with arith.
Qed.

Lemma div_unic_r :
 forall a b q1 q2 r1 r2 : nat,
 is_div a b q1 r1 -> is_div a b q2 r2 -> r1 = r2.
Proof.
intros a b q1 q2 r1 r2 (H0, H1) (H2, H3).
apply Nat.add_cancel_l with (q1 * b).
rewrite <- H1; rewrite H3; rewrite (div_unic_q a b q1 q2 r1 r2); try split;
 auto with arith.
Qed.

Lemma quot_eq :
 forall a b c q1 r1 q2 r2 : nat,
 a = b -> is_div a c q1 r1 -> is_div b c q2 r2 -> q1 = q2.
Proof.
intros a b c q1 r1 q2 r2 H H0 H1; apply div_unic_q with (1 := H0) (r2 := r2).
rewrite H; auto.
Qed.

Lemma mult_div_r : forall x y q r : nat, is_div (x * y) y q r -> r = 0.
Proof.
intros x y q r (H1, H2).
apply div_unic_r with (a := x * y) (b := y) (q1 := q) (q2 := x); split;
 auto with arith.
apply Nat.le_lt_trans with (m := r); auto with arith.
Qed.

Lemma mult_div_q : forall x y q r : nat, is_div (x * y) y q r -> q = x.
Proof.
intros x y q r (H1, H2).
apply div_unic_q with (a := x * y) (b := y) (r1 := r) (r2 := 0); split; auto.
apply Nat.le_lt_trans with (m := r); auto with arith.
Qed.

Lemma diveucl_divex :
 forall a b : nat,
 diveucl a b -> exists q : _, (exists r : _, is_div a b q r).
Proof.
intros a b H; case H.
intros q r H' H'0; exists q; exists r; split; auto.
Qed.

Lemma div_ex :
 forall a b : nat, b <> 0 -> exists q : _, (exists r : _, is_div a b q r).
Proof.
intros a b H; apply diveucl_divex.
apply eucl_dev.
generalize H; case b; auto with arith.
Qed.
(*****************************************************************************
  * Divides
  * * b divides a -> [(divides a b)] *)

Definition divides (a b : nat) : Prop := exists q : nat, b = q * a.

Lemma div_ref : forall a : nat, divides a a.
Proof.
intros a; exists 1; auto with arith.
Qed.

Lemma div_divides :
 forall x y : nat, (exists q : _, is_div x y q 0) -> divides y x.
Proof.
intros x y (q, (H1, H2)); exists q; rewrite H2; auto with arith.
Qed.

Lemma divides_div :
 forall x y : nat, 0 < y -> divides y x -> exists q : _, is_div x y q 0.
Proof.
intros x y H'1 (q, H'2); exists q; split; try rewrite H'2; auto with arith.
Qed.

Lemma divides_dec' :
 forall x y : nat,
 {(exists q : _, is_div x y q 0)} + {~ (exists q : _, is_div x y q 0)}.
Proof.
intros x y; case y; auto.
right; red in |- *; intros (q, (H1, H2)); Contradict H1; auto with arith.
intros y'; case (eucl_dev (S y') (Nat.lt_0_succ y') x).
intros q r; case r; auto.
intros H' H'0; left; exists q; split; try rewrite H'0; auto with arith.
intros n H' H'0; right; red in |- *; intros (q1, (H1, H2)); absurd (0 = S n);
 auto with arith.
apply div_unic_r with (a := x) (b := S y') (q1 := q1) (q2 := q); split;
 auto with arith.
Qed.

Lemma divides_dec : forall x y : nat, {divides x y} + {~ divides x y}.
Proof.
intros x y; case x; case y; auto.
left; exists 0; auto.
intros n; right; red in |- *; intros (q, H').
rewrite (Nat.mul_comm q 0) in H'; discriminate.
intros n; left; exists 0; auto.
intros x' y'; case (divides_dec' (S x') (S y')); auto.
intros H'; left; apply div_divides; auto.
intros H'; right; red in |- *; intros (q1, H1); case H'; auto.
exists q1; split; try rewrite H1; auto with arith.
Qed.

Lemma all_divides_O : forall n : nat, divides n 0.
Proof.
intros n; exists 0; auto.
Qed.

Lemma SO_divides_all : forall n : nat, divides 1 n.
Proof.
intros n; exists n; auto with arith.
Qed.

Lemma divides_plus1 :
 forall a b c : nat, divides a b -> divides a c -> divides a (b + c).
Proof.
intros a b c (q1, H1) (q2, H2); exists (q1 + q2); rewrite H1; rewrite H2;
 auto with arith.
Qed.

Lemma divides_plus2 :
 forall a b c : nat, divides a b -> divides a (b + c) -> divides a c.
Proof.
intros a b c (q1, H1) (q2, H2); exists (q2 - q1).
rewrite Nat.mul_sub_distr_r.
rewrite <- H1.
rewrite <- H2.
rewrite Nat.add_comm.
rewrite Nat.add_sub.
reflexivity.
Qed.

Theorem divides_le : forall a b : nat, b <> 0 -> divides a b -> a <= b.
Proof.
intros a b; case b.
intros H'; case H'; auto.
intros n H (q1, H1).
generalize H; rewrite H1; case q1; simpl in |- *; auto with arith.
intros H2; case H2; auto.
Qed.

Lemma divides_antisym : forall a b : nat, divides a b -> divides b a -> a = b.
Proof.
intros a b; case a; case b; auto.
intros b' (q1, H1) H2; rewrite H1; auto with arith.
intros a' H1 (q2, H2); rewrite H2; auto with arith.
intros b' a' H' H'0; apply Nat.le_antisymm; apply divides_le; auto.
Qed.

Lemma not_lt_div : forall a b : nat, 0 < b -> b < a -> ~ divides a b.
Proof.
intros a b H'1 H'2; red in |- *; intros H'3; Contradict H'2; auto with arith.
apply Nat.le_ngt; apply divides_le; auto.
apply sym_not_eq; auto with arith.
Qed.

Theorem divides_mult :
 forall a b c d : nat, divides a c -> divides b d -> divides (a * b) (c * d).
Proof.
intros a b c d (q1, H) (q2, H0); exists (q1 * q2); rewrite H; rewrite H0;
 ring.
Qed.

Theorem divides_mult1 :
 forall a b c : nat, divides a b -> divides (c * a) (c * b).
Proof.
intros a b c (r, H); exists r; rewrite H; ring.
Qed.

Theorem divides_mult2 :
 forall a b c : nat, 0 < c -> divides (c * a) (c * b) -> divides a b.
Proof.
intros a b c H (r, H1); exists r.
apply eq_mult with c; auto with arith.
apply Nat.neq_0_lt_0; auto.
rewrite H1; ring.
Qed.

Theorem divides_trans :
 forall a b c : nat, divides a b -> divides b c -> divides a c.
Proof.
intros a b c (q1, H1) (q2, H2); exists (q1 * q2); rewrite H2; rewrite H1;
 ring.
Qed.

Theorem divides_power :
 forall a b c : nat, a <= b -> divides (power c a) (power c b).
Proof.
intros a b c; exists (power c (b - a)).
rewrite power_mult.
rewrite (Nat.sub_add _ _ H).
reflexivity.
Qed.
#[export] Hint Resolve divides_power: arith.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y P Pprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ Pprime A /\ (wd_ P Pprime /\ (col_ A B Pprime /\ col_ A B P))))) -> col_ Pprime P A)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions sub.


Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import HoareDef.
Require Import ProofMode.
Require Import STB.

Set Implicit Arguments.

Definition CannonRA: URA.t := Auth.t (Excl.t unit).
Definition Ready: CannonRA := Auth.black (M:=(Excl.t _)) (Some tt).
Definition Ball: CannonRA := Auth.white (M:=(Excl.t _)) (Some tt).
Definition Fired: CannonRA := Auth.excl (M:=(Excl.t _)) (Some tt) (Some tt).

Lemma ReadyBall: Ready ⋅ Ball = Fired.
Proof.
  ur. rewrite URA.unit_idl. ss.
Qed.

Lemma FiredReady: ~ URA.wf (Fired ⋅ Ready).
Proof.
  ur. ss.
Qed.

Lemma FiredBall: ~ URA.wf (Fired ⋅ Ball).
Proof.
  ur. ii. des. ur in H. red in H. des. ur in H. destruct ctx; ss.
Qed.

Lemma BallReady_wf: URA.wf (Ball ⋅ Ready).
Proof.
  ur. split.
  { eexists. rewrite ! URA.unit_id. ss. }
  { ur. ss. }
Qed.


Require Import Coq.Bool.Bool.
Require Import Equivalence.
Require Import ExtLib.Core.RelDec.

Class Lte T := { lte : T -> T -> Prop }.
Definition neg_lte {T} {L:Lte T} (x:T) (y:T) : Prop := not (lte x y).

Definition lt {T} {L:Lte T} x y := lte x y /\ ~lte y x.
Definition neg_lt {T} {L:Lte T} x y := not (lt x y).

Instance lt_RelDec {T} {L:Lte T} {RD:RelDec lte} : RelDec lt :=
  { rel_dec x y := (rel_dec x y && negb (rel_dec y x))%bool }.

Instance lt_RelDecCorrect {T} {L:Lte T} {RD:RelDec lte} {RDC:RelDec_Correct RD}
  : RelDec_Correct lt_RelDec.
Proof. constructor.
  intros ; constructor ; intros.
  unfold rel_dec in H. simpl in H. apply andb_true_iff in H. destruct H.
    unfold lt. constructor. apply rel_dec_correct. auto.
    apply neg_rel_dec_correct. simpl in H0.
    apply negb_true_iff in H0. auto.
  unfold lt in H. destruct H. unfold rel_dec. simpl. apply andb_true_iff.
    constructor. apply rel_dec_correct. auto.
    apply negb_true_iff. apply neg_rel_dec_correct. auto.
Qed.

Class LteWF T :=
{ lteWFLte :> Lte T
; lteWFPreOrder :> PreOrder lte
}.

Instance LteWF_Build {T} {L:Lte T} {PO:PreOrder lte} : LteWF T :=
  { lteWFLte := L ; lteWFPreOrder := PO }.

Definition lte_dec {T} {L:Lte T} {R:RelDec lte} := rel_dec.
Definition neg_lte_dec {T} {L:Lte T} {R:RelDec lte} x y := negb (lte_dec x y).

Definition lt_dec {T} {L:Lte T} {R:RelDec lte} := rel_dec.
Definition neg_lt_dec {T} {L:Lte T} {R:RelDec lte} x y := negb (lt_dec x y).

Section dec_p.
  Context {T} {L:Lte T} {RD:RelDec lte} {DC:RelDec_Correct RD}.

  Definition lte_dec_p (x:T) (y:T) : {lte x y} + {~lte x y} := rel_dec_p x y.
  Definition neg_lte_dec_p (x:T) (y:T) : {~lte x y} + {lte x y} := neg_rel_dec_p x y.
  Definition lt_dec_p (x:T) (y:T) : {lt x y} + {~lt x y} := rel_dec_p x y.
  Definition neg_lt_dec_p (x:T) (y:T) : {~lt x y} + {lt x y} := neg_rel_dec_p x y.
End dec_p.

Module LteNotation.
  Notation "x <=! y"       := (lte_dec x y)
    (at level 35, no associativity).
  Notation "x <=! y <=! z" := (lte_dec x y /\ lte_dec y z)
    (at level 35, y at next level, no associativity).
  Notation "x >=! y"       := (lte_dec y x)
    (at level 35, no associativity, only parsing).
  Notation "x >=! y >=! z" := (lte_dec z y /\ lte_dec y x)
    (at level 35, y at next level, no associativity).

  Notation "x <! y"       := (lt_dec x y)
    (at level 35, no associativity).
  Notation "x <! y <! z"  := (lt_dec x y /\ lt_dec y z)
    (at level 35, y at next level, no associativity).
  Notation "x >! y"       := (lt_dec y x)
    (at level 35, no associativity, only parsing).
  Notation "x >! y >! z"  := (lt_dec z y /\ lt_dec y x)
    (at level 35, y at next level, no associativity).

  Notation "x <=? y"       := (lte_dec_p y x)
    (at level 35, no associativity).
  Notation "x <=? y <=? z" := (lte_dec_p x y /\ lte_dec_p y z)
    (at level 35, y at next level, no associativity).
  Notation "x >=? y"       := (lte_dec_p y x)
    (at level 35, no associativity, only parsing).
  Notation "x >=? y >=? z" := (lte_dec_p z y /\ lte_dec_p y x)
    (at level 35, y at next level, no associativity, only parsing).

  Notation "x <? y"       := (lt_dec_p y x)
    (at level 35, no associativity).
  Notation "x <? y <? z"  := (lt_dec_p x y /\ lt_dec_p y z)
    (at level 35, y at next level, no associativity).
  Notation "x >? y"       := (lt_dec_p y x)
    (at level 35, no associativity, only parsing).
  Notation "x >? y >? z"  := (lt_dec_p z y /\ lt_dec_p y x)
    (at level 35, y at next level, no associativity, only parsing).

  Notation "x <=. y"       := (lte x y)
    (at level 70, no associativity).
  Notation "x <=. y <=. z" := (lte x y /\ lte y z)
    (at level 70, y at next level, no associativity).
  Notation "x >=. y"       := (lte y x)
    (at level 70, no associativity, only parsing).
  Notation "x >=. y >=. z" := (lte z y /\ lte y x)
    (at level 70, y at next level, no associativity, only parsing).

  Notation "x <. y"       := (lt x y)
    (at level 70, no associativity).
  Notation "x <. y <. z" := (lt x y /\ lt y z)
    (at level 70, y at next level, no associativity).
  Notation "x >. y"       := (lt y x)
    (at level 70, no associativity, only parsing).
  Notation "x >. y >. z" := (lt z y /\ lt y x)
    (at level 70, y at next level, no associativity, only parsing).
End LteNotation.


From isla Require Import opsem.

Definition a8018c : isla_trace :=
  WriteReg "R1" [] (RegVal_Base (Val_Bits (BV 64%N 0x5040%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


(*******************************************************)
(*                                                     *)
(*  Proof of cross adequacy between the two encodings  *)
(*            of Strong Late Bisimilarity.             *)
(*                                                     *)
(*******************************************************)
(*                                                     *)
(* File   : xadequacy.v                                *)
(* Author : Ivan Scagnetto (scagnett@dimi.uniud.it),   *)
(*          Dipartimento di Matematica e Informatica,  *)
(*          University of Udine                        *)
(* Date   : July 1998                                  *)
(*                                                     *)
(*******************************************************)
(*                                                     *)
(* This file is part of "Pi-calculus in (Co)Inductive  *)
(* Type Theory", a joint work with Furio Honsell and   *)
(* Marino Miculan (accepted for publication on TCS).   *)
(* If you are interested you can find more information *)
(* (and a gzipped PostScript version of the article)   *)
(* at the following URL:                               *)
(* http://www.dimi.uniud.it/~scagnett/pi-calculus.html *)
(*                                                     *)
(*******************************************************)

Require Export picalcth.

Section picalc_xadeq.

(*****************************************************************)
(* Monotonicity of the operator of the Strong Late Bisimilarity. *)
(*****************************************************************)

Lemma Op_StBisim_monotone :
 forall R1 R2 : proc -> proc -> Prop,
 Inclus R1 R2 -> Inclus (Op_StBisim R1) (Op_StBisim R2).

Proof.

unfold Inclus in |- *.
intros.
inversion H0.
apply op_sb.
split.

intro.
cut
 ((forall p0 : proc,
   ftrans p1 a p0 -> exists q1 : proc, ftrans p2 a q1 /\ R1 p0 q1) /\
  (forall q1 : proc,
   ftrans p2 a q1 -> exists p0 : proc, ftrans p1 a p0 /\ R1 p0 q1)).
intro. elim H2. intros. clear H2. split. intros.
cut (exists q1 : proc, ftrans p2 a q1 /\ R1 p0 q1).
intro.
elim H5. intros. clear H5.
exists x.
split. tauto. elim H6.
intros. clear H6.
auto. auto. intros.
cut (exists p0 : proc, ftrans p1 a p0 /\ R1 p0 q1).
intro.
elim H5. intros. clear H5.
exists x.
split. tauto. elim H6.
intros. clear H6.
auto. auto. elim H1. intros. auto.

split.

intro.
cut
 ((forall p0 : name -> proc,
   btrans p1 (In x) p0 ->
   exists q1 : name -> proc,
     btrans p2 (In x) q1 /\ (forall y : name, R1 (p0 y) (q1 y))) /\
  (forall q1 : name -> proc,
   btrans p2 (In x) q1 ->
   exists p0 : name -> proc,
     btrans p1 (In x) p0 /\ (forall y : name, R1 (p0 y) (q1 y)))).
intro. elim H2. intros. clear H2. split. intros.
cut
 (exists q1 : name -> proc,
    btrans p2 (In x) q1 /\ (forall y : name, R1 (p0 y) (q1 y))).
intro.
elim H5. intros. clear H5.
exists x0.
split. tauto. elim H6.
intros. clear H6.
auto. auto. intros.
cut
 (exists p0 : name -> proc,
    btrans p1 (In x) p0 /\ (forall y : name, R1 (p0 y) (q1 y))).
intro.
elim H5. intros. clear H5.
exists x0.
split. tauto. elim H6.
intros. clear H6.
auto. auto. elim H1. intros. elim H3. intros. auto.

intro.
cut
 ((forall p0 : name -> proc,
   btrans p1 (bOut x) p0 ->
   exists q1 : name -> proc,
     btrans p2 (bOut x) q1 /\
     (forall y : name, notin y (nu p0) -> notin y (nu q1) -> R1 (p0 y) (q1 y))) /\
  (forall q1 : name -> proc,
   btrans p2 (bOut x) q1 ->
   exists p0 : name -> proc,
     btrans p1 (bOut x) p0 /\
     (forall y : name, notin y (nu p0) -> notin y (nu q1) -> R1 (p0 y) (q1 y)))).
intros. elim H2. intros. clear H2. split. intros.
cut
 (exists q1 : name -> proc,
    btrans p2 (bOut x) q1 /\
    (forall y : name, notin y (nu p0) -> notin y (nu q1) -> R1 (p0 y) (q1 y))).
intro.
elim H5. intros. clear H5.
exists x0.
split. tauto. elim H6.
intros. clear H6.
auto. auto. intros.
cut
 (exists p0 : name -> proc,
    btrans p1 (bOut x) p0 /\
    (forall y : name, notin y (nu p0) -> notin y (nu q1) -> R1 (p0 y) (q1 y))).
intro.
elim H5. intros. clear H5.
exists x0.
split. tauto. elim H6.
intros. clear H6.
auto. auto. elim H1. intros. elim H3. intros. auto.

Qed.

(****************************)
(* Internal Cross Adequacy.  *)
(****************************)

Lemma Soundness : forall p1 p2 : proc, StBisim p1 p2 -> StBisim' p1 p2.

Proof.

intros.
apply Co_Ind with StBisim.
unfold Inclus in |- *.
intros.
inversion H0.
apply op_sb.
auto. auto.

Qed.

Lemma Completeness : forall p1 p2 : proc, StBisim' p1 p2 -> StBisim p1 p2.

Proof.

intros. elim H. unfold Inclus in |- *. do 2 intro.  generalize p1 p2.
cofix. intros. case (H0 p0 p3 H1). intros.

apply sb. split. intro.
cut
 ((forall p1 : proc,
   ftrans p0 a p1 -> exists q1 : proc, ftrans p3 a q1 /\ R p1 q1) /\
  (forall q1 : proc,
   ftrans p3 a q1 -> exists p1 : proc, ftrans p0 a p1 /\ R p1 q1)).
intro. elim H3. intros. clear H3. split. intros. cut (exists q1 : proc, ftrans p3 a q1 /\ R p4 q1).
intro. elim H6. intros. clear H6. exists x. split. tauto. apply Completeness. tauto. auto. intros.
cut (exists p1 : proc, ftrans p0 a p1 /\ R p1 q1). intro. elim H6. intros. clear H6. exists x. split. tauto.
apply Completeness. tauto. auto. elim H2. intros. auto.

split.
intro.
cut
 ((forall p1 : name -> proc,
   btrans p0 (In x) p1 ->
   exists q1 : name -> proc,
     btrans p3 (In x) q1 /\ (forall y : name, R (p1 y) (q1 y))) /\
  (forall q1 : name -> proc,
   btrans p3 (In x) q1 ->
   exists p1 : name -> proc,
     btrans p0 (In x) p1 /\ (forall y : name, R (p1 y) (q1 y)))).
intro. elim H3. intros. clear H3. split. intros.
cut
 (exists q1 : name -> proc,
    btrans p3 (In x) q1 /\ (forall y : name, R (p4 y) (q1 y))).
intro. elim H6. intros. clear H6. exists x0. split. tauto. intro. apply Completeness. elim H7. intros. auto.
auto. intros.
cut
 (exists p1 : name -> proc,
    btrans p0 (In x) p1 /\ (forall y : name, R (p1 y) (q1 y))).
intro. elim H6. intros. clear H6. exists x0. split. tauto. intro. apply Completeness. elim H7. intros. auto.
auto. elim H2. intros. elim H4. intros. auto.

intro.
cut
 ((forall p1 : name -> proc,
   btrans p0 (bOut x) p1 ->
   exists q1 : name -> proc,
     btrans p3 (bOut x) q1 /\
     (forall y : name, notin y (nu p1) -> notin y (nu q1) -> R (p1 y) (q1 y))) /\
  (forall q1 : name -> proc,
   btrans p3 (bOut x) q1 ->
   exists p1 : name -> proc,
     btrans p0 (bOut x) p1 /\
     (forall y : name, notin y (nu p1) -> notin y (nu q1) -> R (p1 y) (q1 y)))).
intro. elim H3. intros. clear H3. split. intros.
cut
 (exists q1 : name -> proc,
    btrans p3 (bOut x) q1 /\
    (forall y : name, notin y (nu p4) -> notin y (nu q1) -> R (p4 y) (q1 y))).
intro. elim H6. intros. clear H6. exists x0. split. tauto. intros. apply Completeness. elim H7. intros. auto.
auto. intros.
cut
 (exists p1 : name -> proc,
    btrans p0 (bOut x) p1 /\
    (forall y : name, notin y (nu p1) -> notin y (nu q1) -> R (p1 y) (q1 y))).
intro. elim H6. intros. clear H6. exists x0. split. tauto. intros. apply Completeness. elim H7. intros. auto.
auto. elim H2. intros. elim H4. intros. auto.

Qed.

End picalc_xadeq.


Require Import Coq.Lists.List.
Require Import Program.
Require Import Omega.

Require Import def.

(* Lemmas for priority_of_task *)

Lemma existent_task_priority:
  forall (t:task) (tset:taskset),
    In t tset -> exists (n:nat), priority_of_tid t.(task_id) tset = Some n.
Proof.
  intros t tset.
  induction tset.
  - intros IN. inversion IN.
  - intros IN.
    inversion IN.
    + exists 0. simpl. subst.
      rewrite (Nat.eqb_refl (task_id t)). eauto.
    + apply IHtset in H.
      destruct H.
      simpl.
      destruct (task_id a =? task_id t).
      * eauto.
      * rewrite H. eauto.
Qed.

Lemma priority_less_than_length:
  forall (t:task) (tset:taskset) (n:nat),
    priority_of_tid t.(task_id) tset = Some n ->
    n < length tset.
Proof.
  intros t tset.
  induction tset; intros n PR.
  - inversion PR.
  - simpl in PR.
    destruct (task_id a =? task_id t).
    + inversion PR. simpl. omega.
    + destruct (priority_of_tid (task_id t) tset).
      * destruct n; inversion PR.
        simpl.
        apply lt_n_S.
        apply IHtset.
        eauto.
      * inversion PR.
Qed.

Lemma priority_tid_unique:
  forall (tid1 tid2:nat) (tset:taskset) (n:nat),
    valid_tset tset ->
    priority_of_tid tid1 tset = Some n ->
    priority_of_tid tid2 tset = Some n ->
    tid1 = tid2.
Proof.
  intros tid1 tid2 tset.
  induction tset.
  - intros. inversion H0.
  - intros.
    simpl in *.
    destruct (task_id a =? tid1) eqn:EQ1;
      destruct (task_id a =? tid2) eqn:EQ2.
    + apply beq_nat_true in EQ1.
      apply beq_nat_true in EQ2.
      omega.
    + inversion H0. subst.
      destruct (priority_of_tid tid2 tset).
      * inversion H1.
      * inversion H1.
    + inversion H1; subst.
      destruct (priority_of_tid tid1 tset).
      * inversion H0.
      * inversion H0.
    + destruct (priority_of_tid tid1 tset);
        destruct (priority_of_tid tid2 tset).
      * destruct n.
        ++ inversion H0.
        ++ inversion H0; inversion H1; subst.
           eapply IHtset; eauto.
           eapply valid_tset_shrink; eauto.
      * inversion H1.
      * inversion H0.
      * inversion H0.
Qed.

Lemma priority_unique:
  forall (t1 t2:task) (tset:taskset) (n:nat),
    valid_tset tset ->
    In t1 tset -> In t2 tset ->
    priority_of_tid t1.(task_id) tset = Some n ->
    priority_of_tid t2.(task_id) tset = Some n ->
    t1 = t2.
Proof.
  intros t1 t2 tset.
  induction tset; intros n VALID IN1 IN2 PR1 PR2.
  - inversion PR1.
  - destruct (Nat.eq_dec (task_id t1) (task_id a)) eqn:DEC1;
      destruct (Nat.eq_dec (task_id t2) (task_id a)) eqn:DEC2.
    + assert (EQ12: t1 = t2).
      { eapply VALID in IN1. eapply IN1 in IN2.
        destruct IN2 as [NEQ | EQ]; eauto.
        exfalso. apply NEQ. rewrite e. rewrite e0. reflexivity. }
      eauto.
    + simpl in PR1, PR2.
      rewrite e in PR1. rewrite Nat.eqb_refl in PR1.
      destruct (task_id a =? task_id t2) eqn:EQid.
      * apply beq_nat_true in EQid.
        exfalso. apply n0. rewrite EQid. reflexivity.
      * inversion PR1. subst.
        destruct (priority_of_tid (task_id t2) tset).
        ++ inversion PR2.
        ++ inversion PR2.
    + simpl in PR1, PR2.
      rewrite e in PR2. rewrite Nat.eqb_refl in PR2.
      destruct (task_id a =? task_id t1) eqn:EQid.
      * apply beq_nat_true in EQid.
        exfalso. apply n0. rewrite EQid. reflexivity.
      * inversion PR2. subst.
        destruct (priority_of_tid (task_id t1) tset).
        ++ inversion PR1.
        ++ inversion PR1.
    + destruct n.
      { inversion PR1.
        destruct (task_id a =? task_id t1) eqn:EQid.
        - apply beq_nat_true in EQid.
          exfalso. apply n0. eauto.
        - destruct (priority_of_tid (task_id t1) tset); inversion H0.
      }
      apply IHtset with (n:=n).
      * eapply valid_tset_shrink; eauto.
      * inversion IN1; eauto. exfalso. subst. eauto.
      * inversion IN2; eauto. exfalso. subst. eauto.
      * simpl in PR1.
        destruct (task_id a =? task_id t1) eqn:EQid.
        ++ inversion PR1.
        ++ destruct (priority_of_tid (task_id t1) tset); inversion PR1; eauto.
      * simpl in PR2.
        destruct (task_id a =? task_id t2) eqn:EQid.
        ++ inversion PR2.
        ++ destruct (priority_of_tid (task_id t2) tset); inversion PR2; eauto.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Limits.Limit.
Require Import Archetypal.Discr.Discr.
Require Import Cat.Terminal.
Require Import
        Basic_Cons.Terminal
        Basic_Cons.Product
        Basic_Cons.Equalizer
        Basic_Cons.PullBack
.

(** In this module we show that terminal objects, products, equalizers and
    pullbacks are limits. The corresponding duals are dually colimits. *)

Section Limits.
  Context {C : Category}.

  Section Terminal.

    Definition Terminal_Producing_Func_fun (x : Empty) : C
      :=
        match x with
        end
    .

    Context (L : Limit (Discr_Func Terminal_Producing_Func_fun)).

    Program Definition Terminal_as_Limit_Cone
            (c : C)
      :
        Cone (Discr_Func Terminal_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => c;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Terminal_as_Limit_Cone_morph
            {c : C}
            (f : (c –≻ L)%morphism)
      :
        Cone_Morph _ (Terminal_as_Limit_Cone c) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}
    .

    Program Definition Terminal_as_Limit : (𝟙_ C)%object :=
      {|
        terminal := L;
        t_morph :=
          fun c =>
            Trans (LRKE_morph_ex L (Terminal_as_Limit_Cone c)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros c f g.
      apply (
          f_equal
            (fun w : (Terminal_as_Limit_Cone c –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Terminal_as_Limit_Cone_morph f)
                (Terminal_as_Limit_Cone_morph g)
            )
        ).
    Qed.

  End Terminal.

  Section Product.
    Context (a b : C).

    Definition Product_Producing_Func_fun (x : bool) : C
      :=
        match x with
        | true => a
        | false => b
        end
    .

    Context (L : Limit (Discr_Func Product_Producing_Func_fun)).

    Program Definition Product_as_Limit_Cone
            {p : C}
            (h : (p –≻ a)%morphism)
            (h' : (p –≻ b)%morphism)
      :
        Cone (Discr_Func Product_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => h'
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Product_as_Limit_Cone_morph
            {p : C}
            (h : (p –≻ a)%morphism)
            (h' : (p –≻ b)%morphism)
            (f : (p –≻ L)%morphism)
            (H1 : (Trans L true ∘ f)%morphism = h)
            (H2 : (Trans L false ∘ f)%morphism = h')
      :
        Cone_Morph _ (Product_as_Limit_Cone h h') (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}
    .

    Program Definition Product_as_Limit : (a × b)%object :=
      {|
        product := L;
        Pi_1 := Trans (cone_edge L) true;
        Pi_2 := Trans (cone_edge L) false;
        Prod_morph_ex :=
          fun p h h' =>
            Trans (LRKE_morph_ex L (Product_as_Limit_Cone h h')) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros p h h'.
      cbn.
      set (H :=
             f_equal
               (fun w
                    :
                      (Product_as_Limit_Cone h h'
                 ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                 –≻ Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w true)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h'.
      set (H :=
             f_equal
               (fun w
                    :
                      ((Product_as_Limit_Cone h h')
                         ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                         –≻ Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w false)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' f g H1 H2 H3 H4.
      apply (
          f_equal
            (fun w : (Product_as_Limit_Cone h h' –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Product_as_Limit_Cone_morph _ _ _ H1 H2)
                (Product_as_Limit_Cone_morph _ _ _ H3 H4)
            )
        ).
    Qed.

  End Product.

  Section Equalizer.
    Context {a b : C} (f g : (a –≻ b)%morphism).

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Equalizer_Producing_Cat : Category
      :=
        {|
          Obj := bool;
          Hom :=
            fun x y =>
              match (x, y) with
              | (true, true) => unit
              | (true, false) => bool
              | (false, true) => Empty
              | (false, false) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y; destruct z; auto.
    Defined.

    Next Obligation.
    Proof.
      destruct x; constructor.
    Defined.

    Program Definition Equalizer_Producing_Func :
      (Equalizer_Producing_Cat –≻ C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | true => a
              | false => b
              end;
          FA := fun x y h => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y.
      exact id.
      destruct h.
      {
        exact f.
      }
      {
        exact g.
      }
      destruct h.
      exact id.
    Defined.

    Context (L : Limit Equalizer_Producing_Func).

    Program Definition Equalizer_as_Limit_Cone
            {p : C}
            {h : (p –≻ a)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h)%morphism)
      :
        Cone Equalizer_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition Equalizer_as_Limit_Cone_morph
            {p : C}
            {h : (p –≻ a)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h)%morphism)
            (k : (p –≻ L)%morphism)
            (H2 : (Trans L true ∘ k)%morphism = h)
      :
        Cone_Morph _ (Equalizer_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h H1 k H2.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L true false false).
      rewrite assoc.
      rewrite H1; rewrite <- H2.
      trivial.
    Qed.

    Program Definition Equalizer_as_Limit : Equalizer f g :=
      {|
        equalizer := L;
        equalizer_morph := Trans L true;
        equalizer_morph_ex :=
          fun e eqm H =>
            Trans (LRKE_morph_ex L (Equalizer_as_Limit_Cone H)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L true false false).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L true false true) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm eqmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((Equalizer_as_Limit_Cone eqmc)
                      ∘ Functor_To_1_Cat Equalizer_Producing_Cat
                      –≻ Equalizer_Producing_Func)%nattrans
             => Trans w true)
            (cone_morph_com (LRKE_morph_ex L (Equalizer_as_Limit_Cone eqmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm H1 h h' H2 H3.
      apply (
          f_equal
            (fun w : (Equalizer_as_Limit_Cone H1 –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Equalizer_as_Limit_Cone_morph _ _ H2)
                (Equalizer_as_Limit_Cone_morph _ _ H3)
            )
        ).
    Qed.

  End Equalizer.

  Section PullBack.
    Context
      {a b c : C}
      (f : (a –≻ c)%morphism)
      (g : (b –≻ c)%morphism)
    .

    Inductive PBType :=
    | PB_A
    | PB_B
    | PB_C
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : PBType |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [|- unit] => constructor end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition PullBack_Producing_Cat : Category
      :=
        {|
          Obj := PBType;
          Hom :=
            fun x y =>
              match (x, y) with
              | (PB_A, PB_A) => unit
              | (PB_A, PB_B) => Empty
              | (PB_A, PB_C) => unit
              | (PB_B, PB_A) => Empty
              | (PB_B, PB_B) => unit
              | (PB_B, PB_C) => unit
              | (PB_C, PB_A) => Empty
              | (PB_C, PB_B) => Empty
              | (PB_C, PB_C) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}
    .

    Program Definition PullBack_Producing_Func :
      (PullBack_Producing_Cat –≻ C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | PB_A => a
              | PB_B => b
              | PB_C => c
              end;
          FA := fun x y h => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y; auto; try exact id.
    Defined.

    Context (L : Limit PullBack_Producing_Func).

    Program Definition PullBack_as_Limit_Cone
            {p : C}
            {h : (p –≻ a)%morphism}
            {h' : (p –≻ b)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h')%morphism)
      :
        Cone PullBack_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | PB_A => h
                  | PB_B => h'
                  | PB_C => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition PullBack_as_Limit_Cone_morph
            {p : C}
            {h : (p –≻ a)%morphism}
            {h' : (p –≻ b)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h')%morphism)
            (k : (p –≻ L)%morphism)
            (H2 : (Trans L PB_A ∘ k)%morphism = h)
            (H3 : (Trans L PB_B ∘ k)%morphism = h')
      :
        Cone_Morph _ (PullBack_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' H1 k H2 H3.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_B PB_C tt).
      rewrite assoc.
      rewrite H1; rewrite <- H3.
      trivial.
    Qed.

    Program Definition PullBack_as_Limit : PullBack f g :=
      {|
        pullback := L;
        pullback_morph_1 := Trans L PB_A;
        pullback_morph_2 := Trans L PB_B;
        pullback_morph_ex :=
          fun e pm1 pm2 pmc =>
            Trans (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L PB_B PB_C tt).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_A PB_C tt) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      –≻ PullBack_Producing_Func)%nattrans
             => Trans w PB_A)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      –≻ PullBack_Producing_Func)%nattrans
             => Trans w PB_B)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 H1 h h' H2 H3 H4 H5.
      apply (
          f_equal
            (fun w : (PullBack_as_Limit_Cone H1 –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (PullBack_as_Limit_Cone_morph _ _ H2 H3)
                (PullBack_as_Limit_Cone_morph _ _ H4 H5)
            )
        ).
    Qed.

  End PullBack.

End Limits.


From iVM Require Import Lens DSet.

Unset Suggest Proof Using.

(** ** Restriction lenses *)

Import DSetNotations.

Section restriction_section.

  Context {A : Type} {F : A -> Type}.

  Definition restr u : Type := forall (a: A), a ∈ u -> F a.

  Local Notation S := (forall a, F a).

  #[refine] Instance fullLens : Lens S (restr Ω) :=
  {
    proj f a _ := f a;
    update _ g a := g a I;
  }.
  Proof.
    all: unfold restr; try reflexivity.
    cbn. intros f g.
    extensionality a.
    extensionality t.
    destruct t. reflexivity.
  Defined.

  Proposition fullLens_is_all : fullLens ≃ sndMixer.
  Proof. easy. Qed.

  #[refine] Instance subsetLens {u v} (Huv: u ⊆ v) : Lens (restr v) (restr u) :=
  {
    proj f a Ha := f a (Huv a Ha);
    update f g a Hv := match decide (a ∈ u) with
                       | left Hu => g a Hu
                       | _ => f a Hv
                       end;
  }.
  Proof.
    - abstract (intros f g;
                extensionality a;
                extensionality Ha;
                decided Ha;
                reflexivity).
    - abstract (intros f;
                extensionality a;
                extensionality Hv;
                destruct (decide _) as [Hu|_];
                [ f_equal; apply is_true_unique
                | reflexivity ]).
    - abstract (intros f g g';
                extensionality a;
                extensionality Hv;
                destruct (decide _);
                reflexivity).
  Defined.

  Instance restrLens u : Lens S (restr u) :=
    subsetLens full_terminal ∘ fullLens.

  Proposition emptyLens_is_void : restrLens ∅ ≃ fstMixer.
  Proof. intros f g. now extensionality a. Qed.

  (** By construction *)
  Instance full_sublens u : (restrLens u | fullLens).
  Proof.
    apply sublens_comp'.
  Qed.

  Global Instance restrLens_proper_sub :
    Proper (@subset A ==> @Submixer S) restrLens.
  Proof.
    intros u v Huv.
    intros f g h. extensionality a. cbn.
    destruct (decide (a ∈ u)) as [Hu|Hu];
      destruct (decide (a ∈ v)) as [Hv|Hv];
      try reflexivity.
    exfalso.
    apply Hv, Huv, Hu.
  Qed.

  (* TODO: Useful? *)
  Instance submixer_subset {u v} (Huv: u ⊆ v) : (restrLens u | restrLens v).
  Proof.
    (* Does not work in 8.12: [rewrite Huv.]
       cf. Coq issue #4175. *)
    apply restrLens_proper_sub. exact Huv.
  Qed.

  Instance separate_independent u v (Huv: u # v) :
    Independent (restrLens u) (restrLens v).
  Proof.
    intros f g h. extensionality a. cbn.
    destruct (decide (a ∈ v)) as [Hv|Hv];
      destruct (decide (a ∈ u)) as [Hu|Hu];
      try reflexivity.
    exfalso.
    apply (Huv a).
    split; assumption.
  Qed.

  (** ** Point lenses, [restrLens !{a}] simplified *)

  Context {H_eqdec: EqDec A}.

  #[refine] Instance pointLens' {a u} (Ha: a ∈ u) : Lens (restr u) (F a) :=
  {
    proj f := f a Ha;
    update f x a' Hu := match decide (a = a') with
                        | left H => rew H in x
                        | _ => f a' Hu
                        end;
  }.
  Proof.
    - abstract (intros f x;
                decided (@eq_refl _ a);
                revert H;
                apply EqDec.UIP_K;
                reflexivity).
    - intros f;
        extensionality a';
        extensionality Hu;
        destruct (decide (a = a')) as [H|H];
        [ subst a; cbn; f_equal; apply is_true_unique
        | reflexivity ].
    - abstract (intros f x x';
                extensionality a';
                extensionality Hu;
                destruct (decide (a = a')) as [H|H];
                reflexivity).
  Defined.

  Instance pointLens a : Lens S (F a) := pointLens' full_spec ∘ fullLens.

  Instance pointLens_sublens {a u} (Ha: a ∈ u) : (pointLens a | restrLens u).
  Proof.
    intros f g h. extensionality a'. cbn.
    destruct (decide (a = a')) as [H|H].
    - subst a. decided Ha. reflexivity.
    - destruct (decide _); reflexivity.
  Qed.

  Instance pointLens_independent {a a'} (Ha: a <> a') :
    Independent (pointLens a) (pointLens a').
  Proof.
    intros f x x'. cbn.
    extensionality a''.
    destruct (decide (a' = a'')) as [He'|He'];
      destruct (decide (a = a'')) as [He|He];
      congruence.
  Qed.

End restriction_section.