Require Export D.

(** **** Exercise: 2 stars, optional (seq_assoc)  *)
Theorem seq_assoc : forall c1 c2 c3,
  cequiv ((c1;;c2);;c3) (c1;;(c2;;c3)).
Proof.
  intros. split; intros.
  Case "->". inversion H; subst. inversion H2; subst.
  apply E_Seq with st'1. assumption. apply E_Seq with st'0; assumption.
  Case "<-". inversion H; subst. inversion H5; subst. apply E_Seq with st'1. apply E_Seq with st'0; assumption. assumption.
  Qed.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics HoTT.Types.
Require Import HFiber.
Require Import Truncations.
Require Import Spaces.BAut.

Local Open Scope trunc_scope.
Local Open Scope path_scope.

(** * Rigid types *)

Class IsRigid (A : Type) :=
  path_aut_rigid : forall f g : A <~> A, f == g.

(** Assuming funext, rigidity is equivalent to contractibility of [A <~> A]. *)

Global Instance contr_aut_rigid `{Funext} (A : Type) `{IsRigid A}
  : Contr (A <~> A).
Proof.
  exists equiv_idmap.
  intros f; apply path_equiv, path_arrow, path_aut_rigid.
Defined.

(** Assuming univalence, rigidity is equivalent to contractibility of [BAut A]. *)

Global Instance contr_baut_rigid `{Univalence} {A : Type} `{IsRigid A}
  : Contr (BAut A).
Proof.
  refine (contr_change_center (point (BAut A))).
  refine (contr_trunc_conn (Tr 0)).
  intros Z W; baut_reduce.
  refine (istrunc_equiv_istrunc (n := -1) (A <~> A)
                      (path_baut (point (BAut A)) (point (BAut A)))).
Defined.

Definition rigid_contr_Baut `{Univalence} {A : Type} `{Contr (BAut A)}
  : IsRigid A.
Proof.
  unfold IsRigid.
  equiv_intro ((path_baut (point (BAut A)) (point (BAut A)))^-1) f.
  equiv_intro ((path_baut (point (BAut A)) (point (BAut A)))^-1) g.
  apply ap10, ap, ap, path_contr.
Defined.

(** ** HProps are rigid *)

Global Instance rigid_ishprop
       (A : Type) `{IsHProp A} : IsRigid A.
Proof.
  intros f g x; apply path_ishprop.
Defined.

(** ** Equivalences of BAut *)

(** Under a truncatedness/connectedness assumption, multiplying by a rigid type doesn't change the automorphism oo-group. *)

(** A lemma: a "monoid homomorphism up to homotopy" between endomorphism monoids restricts to automorphism groups. *)
Definition aut_homomorphism_end `{Funext} {X Y : Type}
           (M : (X -> X) -> (Y -> Y))
           (Mid : M idmap == idmap)
           (MC : forall f g, M (g o f) == M g o M f)
  : (X <~> X) -> (Y <~> Y).
Proof.
  assert (MS : forall f g, g o f == idmap -> (M g) o (M f) == idmap).
  { intros g f s x.
    transitivity (M (f o g) x).
    + symmetry. refine (MC g f x).
    + transitivity (M idmap x).
      * apply ap10, ap, path_arrow.
        intros y; apply s.
      * apply Mid. }
  assert (ME : (forall f, IsEquiv f -> IsEquiv (M f))).
  { intros f ?.
    refine (isequiv_adjointify (M f) (M f^-1) _ _);
      apply MS; [ apply eisretr | apply eissect ]. }
  exact (fun f => (Build_Equiv _ _ (M f) (ME f _))).
Defined.

Definition baut_prod_rigid_equiv `{Univalence}
           (X A : Type) (n : trunc_index)
           `{IsTrunc n.+1 X} `{IsRigid A} `{IsConnected n.+1 A}
  : BAut X <~> BAut (X * A).
Proof.
  refine (Build_Equiv _ _ (baut_prod_r X A) _).
  apply isequiv_surj_emb.
  { apply BuildIsSurjection; intros Z.
    baut_reduce.
    refine (tr (point _ ; _)).
    apply path_sigma_hprop; reflexivity. }
  { apply isembedding_isequiv_ap.
    intros Z W.
    pose (L := fun e : Z <~> W => equiv_functor_prod_r (B := A) e).
    refine (isequiv_commsq
             L (ap (baut_prod_r X A))
             (path_baut Z W)
             (path_baut (baut_prod_r X A Z) (baut_prod_r X A W))
             (fun e => (ap_baut_prod_r X A e)^)).
    refine ((isconnected_elim (Tr (-1)) (A := A) _ _).1).
    { apply contr_inhabited_hprop;
        [ exact _ | refine (merely_isconnected n A) ]. }
    intros a0.
    baut_reduce.
    pose (M := fun f:X*A -> X*A => fun x => fst (f (x,a0))).
    assert (MH : forall (a:A) (f:X*A -> X*A) (x:X),
               fst (f (x,a)) = fst (f (x,a0))).
    { refine (conn_map_elim (Tr n) (unit_name a0) _ _).
      intros; reflexivity. }
    assert (MC : forall (f g :X*A -> X*A), M (g o f) == M g o M f).
    { intros f g x; unfold M.
      transitivity (fst (g (fst (f (x,a0)), snd (f (x,a0))))).
      - reflexivity.
      - apply MH. }
    pose (M' := aut_homomorphism_end M (fun x => 1) MC).
    assert (Mker : forall f, M' f == 1%equiv -> f == 1%equiv).
    { unfold M', M; cbn. intros f p.
      pose (fh := fun x a => (MH a f x) @ p x).
      pose (g := fun x a => snd (f (x,a))).
      assert (ge : forall x, IsEquiv (g x)).
      { apply isequiv_from_functor_sigma.
        refine (isequiv_commsq' _ f
                  (equiv_sigma_prod0 X A) (equiv_sigma_prod0 X A) _).
        intros [x a]; cbn.
        apply path_prod; [ apply fh | reflexivity ]. }
      intros [x a].
      pose (gisid := path_aut_rigid (Build_Equiv _ _ (g x) (ge x)) 1).
      apply path_prod.
      - apply fh.
      - apply gisid. }
    assert (Minj : forall f g, M' f == M' g -> f == g).
    { intros f g p z.
      apply moveL_equiv_M.
      revert z.
      refine (Mker (g^-1 oE f) _).
      intros x.
      refine (MC f g^-1 x @ _).
      change ((M' g)^-1 (M f x) = x).
      apply moveR_equiv_V, p. }
    refine (isequiv_adjointify L M' _ _);
      intros e;
      apply path_equiv, path_arrow;
      try apply Minj;
      intros x; reflexivity. }
Defined.


(** Coq coding by choukh, Mar 2021 **)

Require Import ZFC.Lib.Essential.

Declare Scope Topology_scope.
Delimit Scope Topology_scope with topo.
Open Scope Topology_scope.

(* 拓扑空间 *)
Record TopologicalSpace : Type := constr {
  (* 全集 *)
  X : set;
  (* 开集条件 *)
  is_open : set → Prop;
  (* 全集开 *)
  is_open_univ : is_open X;
  (* 空集开 *)
  is_open_empty : is_open ∅;
  (* 有限交开 *)
  is_open_inter : ∀ A B ∈ 𝒫 X, is_open A → is_open B → is_open (A ∩ B);
  (* 任意并开 *)
  is_open_union : ∀ 𝒜 ∈ 𝒫 𝒫 X, (∀A ∈ 𝒜, is_open A) → is_open (⋃ 𝒜)
}.

Module Type AbstractTopology.
Parameter Space : TopologicalSpace.
End AbstractTopology.

Module Topology (Abstract : AbstractTopology).
Definition S := Abstract.Space.

(* 开集族 *)
Definition Opens := {A ∊ 𝒫 S.(X) | S.(is_open) }.
Notation τ := Opens.

(* 邻域系 *)
Definition Neighbours := λ x, {A ∊ τ | x ∈ A}.
Notation U := Neighbours.

(* 闭包 *)
Definition Closure := λ A, {x ∊ S.(X) | ∀B ∈ U x, A ∩ B ≠ ∅ }.
Notation "A ⁻" := (Closure A) (at level 60).

(* 空集的闭包是空集 *)
Theorem closure_of_empty : ∅⁻ = ∅.
Proof.
  ext Hx; [exfalso|exfalso0].
  apply SepE in Hx as [H1 H2].
  assert (S.(X) ∈ U x). {
    apply SepI. apply SepI. apply all_in_its_power.
    apply is_open_univ. apply H1.
  }
  apply (H2 _ H).
  ext y Hy.
  apply BInterE in Hy as []. exfalso0. exfalso0.
Qed.

(* 闭包运算保持子集关系 *)
Theorem closure_preserve_sub : ∀ A B, A ⊆ B → A⁻ ⊆ B⁻.
Proof with eauto.
  intros A B Hsub x Hx.
  apply SepE in Hx as [Hx H].
  apply SepI... intros C HC. apply H in HC.
  apply EmptyNE in HC as [a Ha]. apply BInterE in Ha as [H1 H2].
  apply EmptyNI. exists a. apply BInterI... apply Hsub...
Qed.

End Topology.

Module Test.
Definition TrivialSpace :=
  constr ∅ (λ _, True) I I (λ _ _ _ _ _ _, I) (λ _ _ _ , I).

Module Trivial <: AbstractTopology.
Definition Space := TrivialSpace.
End Trivial.

Include Topology Trivial.

Fact opens_eq : τ = {∅,}.
Proof with auto.
  ext Hx.
  - apply SepE1 in Hx. simpl in Hx.
    apply only_empty_in_power_empty in Hx. subst...
  - apply SingE in Hx. subst.
    apply SepI. simpl. apply all_in_its_power. apply I.
Qed.

End Test.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-01-16 22:29:57 -0500 (Wed, 16 Jan 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

From Coq Require Import Lia.
(* Require Omega.   (* needed for using the [omega] tactic *) *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  (* Case "b = true". *)
    reflexivity.
  (* Case "b = false". *)
    rewrite <- H. reflexivity.  Qed.

(* From Poly.v *)

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  induction n as [| n'].
  (* Case "n = 0". *)
  apply le_n.
  (* Case "n = S n'". *)
  apply le_S. apply IHn'.
Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H as [| m'].
  (* Case "H = n <= n". *)
  apply le_n.
  (* Case "H = n <= S m'". *)
  apply le_S in IHle. apply IHle.
Qed.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
Proof.
  intros. generalize dependent m.
  induction n as [| n'];
    intros.
  (* Case "n = 0". *)
  apply O_le_n.
  (* Case "n = S n'". *)
  destruct m. inversion H.
    simpl in H. apply n_le_m__Sn_le_Sm. apply IHn'. apply H.
Qed.

Lemma ble_nat_true_iff : forall n m : nat,
  ble_nat n m = true <-> n <= m.
Proof.
  intros n m. split. apply ble_nat_true.
  generalize dependent m. induction n; intros m H. reflexivity.
    simpl. destruct m. inversion H.
    apply le_S_n in H. apply IHn. assumption.
Qed.

Theorem false_beq_nat : forall n m : nat,
     n <> m ->
     beq_nat n m = false.
Proof.
  intros. generalize dependent m.
  induction n;
    intros;
      unfold not in H;
        destruct m;
          simpl.
  destruct H. reflexivity.
  reflexivity.
  reflexivity.
  apply IHn. unfold not.
  intros H'. apply H.
  rewrite H'. reflexivity.
Qed.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

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

(* Implicit Arguments multi [[X]]. *)
Set Implicit Arugments.

(* Tactic Notation "multi_cases" tactic(first) ident(c) := *)
(*   first; *)
(*   [ Case_aux c "multi_refl" | Case_aux c "multi_step" ]. *)

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.

Definition beq_id id1 id2 :=
  match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (beq_id x2 x1)...
Qed.

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


Require Import Ashley.Set.
Require Import Ashley.Category.
Require Import Ashley.SetFunction.
Require Import Ashley.Topology.

Definition Presheaf {A} {open : set (set A)} (top : topology open) {O} {M} (cat : Category O M) :=
 ContraFunctor (inclusion_category open) cat.
(*
Class Sheaf {A} {open : set (set A)} (top : topology open) {O} {M} (cat : Category O M) `{Presheaf top cat} : Type :=
*)

Definition topology_union {A} {open : set (set A)} {top : topology open} (u : stype open) (v : stype open) : stype open.
apply (sval (set A) open (union (val open u) (val open v))).
apply top_union.
apply (ins open u).
apply (ins open v).
Defined.

Category A
O = stype open, objects are pairs
M o1 o2 = Prop

Class SetSheaf {A} {open : set (set A)} (top : topology open) (B : Type) `{Presheaf top (subset_category B)} : Type :=
{
  sheaf_locality:
forall u v : stype open,
forall s t : comapO (topology_union u v),
(
(comapM (sval u) (sval (union u v)) (u <= union u v) s = comapM (sval u) (sval (union u v)) (u <= union u v) t)
 /\
(comapM (sval v) (sval (union u v) )(v <= union u v) s = comapM (sval v) (sval (union u v)) (v <= union u v) t)
) -> s = t
(*
uv := union u v

comapM (u <= uv) : M (comapO uv) (comapO u)

s = t;
  sheaf_condition:
    forall (o1, o2 :O) (m : M o1 o2),

comapM m : comapO o2 -> comapO o1
comapO o1 : set S
comapO o2 : set S
*)
}.


Require Import Reals.
Require Import Flocq.Core.Core.
Require Import Gappa_tactic.

Definition rnd := rounding_float rndNE 53 (-1074).

Goal
  forall a_ b_ a b : R,
  a = rnd a_ ->
  b = rnd b_ ->
  (Rabs (rnd (a + b) - (a + b)) <= powerRZ 2 (-50) * Rabs (a + b))%R.
Proof.
unfold rnd.
gappa.
Qed.


Require Import Program.Basics.
Require Import Profunctor.
Require Import Util.FunExt.

Open Scope program_scope.

Definition Fun (A B : Type) : Type := A -> B.

Instance Profunctor_fun : Profunctor Fun :=
{ dimap A A' B B' f g ab := g ∘ ab ∘ f
}.

Instance ProfunctorDec_fun : ProfunctorDec Fun.
Proof.
  split; auto.
Qed.

Instance Cartesian_fun : Cartesian Fun :=
{ first  A B C f := fun ac => let (a, c) := ac in pair (f a) c
; second  A B C f := fun ca => let (c, a) := ca in pair c (f a)
}.

Instance CartesianDec_fun : CartesianDec Fun.
Proof.
  split; intros; apply functional_extensionality; intros; destruct x.
  - now destruct u.
  - now destruct p.
Qed.


Require Import Category.
Require Import Category3.

(* given a Category we define the data necessary to create a Category3 *)

Definition A3_ (A:Type) (c:Category A) : Type := A.
Arguments A3_ {A} _.

Definition source3_    (A:Type) (c:Category A) (x: A3_ c) : A3_ c := source c x.
Definition target3_    (A:Type) (c:Category A) (x: A3_ c) : A3_ c := target c x.
Definition compose3_   (A:Type) (c:Category A) (x y: A3_ c) : option (A3_ c) :=
    compose c x y.

Arguments source3_  {A} _ _.
Arguments target3_  {A} _ _.
Arguments compose3_ {A} _ _ _.

Definition proof_ss3_  (A:Type) (c:Category A) : forall (f:A3_ c),
    source3_ c (source3_ c f) = source3_ c f.
Proof. apply (proof_ss c). Qed.

Definition proof_ts3_  (A:Type) (c:Category A) : forall (f:A3_ c),
    target3_ c (source3_ c f) = source3_ c f.
Proof. apply (proof_ts c). Qed.

Definition proof_tt3_  (A:Type) (c:Category A) : forall (f:A3_ c),
    target3_ c (target3_ c f) = target3_ c f.
Proof. apply (proof_tt c). Qed.

Definition proof_st3_  (A:Type) (c:Category A) : forall (f:A3_ c),
    source3_ c (target3_ c f) = target3_ c f.
Proof. apply (proof_st c). Qed.

Definition proof_dom3_  (A:Type) (c:Category A) : forall (f g:A3_ c),
    target3_ c f = source3_ c g <-> compose3_ c f g <> None.
Proof. apply (proof_dom c). Qed.

Definition proof_src3_  (A:Type) (c:Category A) : forall (f g h:A3_ c),
    compose3_ c f g = Some h -> source3_ c h = source3_ c f.
Proof. apply (proof_src c). Qed.

Definition proof_tgt3_  (A:Type) (c:Category A) : forall (f g h:A3_ c),
    compose3_ c f g = Some h -> target3_ c h = target3_ c g.
Proof. apply (proof_tgt c). Qed.

Definition proof_idl3_  (A:Type) (c:Category A) : forall (a f:A3_ c),
    a = source3_ c f -> compose3_ c a f = Some f.
Proof. apply (proof_idl c). Qed.

Definition proof_idr3_  (A:Type) (c:Category A) : forall (a f:A3_ c),
    a = target3_ c f -> compose3_ c f a = Some f.
Proof. apply (proof_idr c). Qed.

Definition proof_asc3_  (A:Type) (c:Category A) : forall (f g h fg gh:A3_ c),
    compose3_ c f g  = Some fg ->
    compose3_ c g h  = Some gh ->
    compose3_ c f gh = compose3_ c fg h.
Proof. apply (proof_asc c). Qed.

Definition toCategory3 (A:Type) (c:Category A) : Category3 := category3
    (A3_                c)
    (source3_           c)
    (target3_           c)
    (compose3_          c)
    (proof_ss3_     A   c)
    (proof_ts3_     A   c)
    (proof_tt3_     A   c)
    (proof_st3_     A   c)
    (proof_dom3_    A   c)
    (proof_src3_    A   c)
    (proof_tgt3_    A   c)
    (proof_idl3_    A   c)
    (proof_idr3_    A   c)
    (proof_asc3_    A   c).

Arguments toCategory3 {A} _.


(** ** destruct

destruct term というのは指定した term の場合分けを行う tactic です。
term は inductive な型の値でなければなりません。
inductive な型の値はその型のコンストラクタのいずれかで生成されているので、
それぞれのコンストラクタの場合分けします。

コンストラクタで場合分けする、というのはつまり match 式です。
ですから、destruct は証明項に match を構築する tactic といえます。

*)

(** *** case term

まず、(destruct term ではなく) case term という tactic を試します。
case term は destruct term の派生形のひとつで、
destruct term よりも単純な証明項を生成します。

また、case term は SSReflect の case とは異なります。
SSReflect の case は引数をとらずに case. としたり、: tactical をつけて case: という
形なので、Coq 本体の case term とは区別できます。

例として bool 型の二重否定の除去の証明を使います。
(なお、難しい話を知っているひとに注意しておきますが、
これは bool の話であり、命題の話ではないので、直観主義論理でも問題なく証明できます。)

ここでは、negb 関数を使いますが、これは bool の否定を行う関数です。

*)

Goal forall b, negb (negb b) = b.
Proof.
(**
<<
1 subgoal
______________________________________(1/1)
forall b : bool, negb (negb b) = b
>>
最初は、Goal に与えた命題がそのまま証明すべき命題として提示されています。
*)
  Show Proof.
(**
<<
?Goal
>>
もちろん、この最初の時点の証明項は ?Goal です。
*)
  intro b.
(**
<<
1 subgoal
b : bool
______________________________________(1/1)
negb (negb b) = b
>>
Coq の case では引数に term を指定する必要があります。
ここでは b を指定したいのですが、
そのためには前提に b がある（外側で b が束縛されている）必要があります。
そのため、intro で b を前提に動かします。
*)
  Show Proof.
(**
<<
(fun b : bool => ?Goal)
>>
*)
  case b.
(**
<<
2 subgoals
b : bool
______________________________________(1/2)
negb (negb true) = true
______________________________________(2/2)
negb (negb false) = false
>>
case b により、b で場合分けを行います。
b は bool なので true か false のどちらかであり、
それぞれの場合についての命題の証明が必要だと提示されています。
*)
  Show Proof.
(**
<<
(fun b : bool =>
 if b as b0 return (negb (negb b0) = b0) then ?Goal else ?Goal0)
>>
if が表示されてしまったので、Display all low-level contents を有効にして
Show Proof をやりなおしましょう。
<<
(fun b : bool =>
 match b as b0 return (@eq bool (negb (negb b0)) b0) with
 | true => ?Goal@{b:=b}
 | false => ?Goal0@{b:=b}
 end)
>>
case b をやる前には ?Goal だったところに match 式が埋められています。
つまり、case b が match 式を構築したことがわかります。
この match 式は match b as ... と書かれているので、b で分岐します。
true の場合と false の場合それぞれ分岐の中身は ?Goal@{b:=b} と ?Goal0@{b:=b} と
書かれており、これらは subgoal がふたつあることに対応しています。

match 式の as b0 return (negb (negb b0) = b0) の部分は、
この match 式自身の型および各分岐の型を示しています。
b0 を match 対象の b に置き換えた場合が match 式自身の型であり、
b0 を true や false に置き換えた場合が各分岐の型になります。

実際、b0 を b にすれば、negb (negb b) = b という case b とする前の命題になりますし、
b0 を true, false にすれば negb (negb true) = true, negb (negb false) = false という
case b とした後の命題になっています。

というわけで、あとは場合分けした結果の negb (negb true) = true
と negb (negb false) = false の
証明を行えば証明項を完成できます。

negb (negb true) と negb (negb false) には変数が含まれておらず、実際に計算を進めれば
true と false になります。
つまり、命題はすでに reflexivity で証明できるようになっています。
*)
    reflexivity.
  reflexivity.
  Show Proof.
(**
<<
(fun b : bool =>
 if b as b0 return (negb (negb b0) = b0) then eq_refl else eq_refl)
>>

Display all low-level contents を有効にすると以下のようになります。

<<
(fun b : bool =>
 match b as b0 return (@eq bool (negb (negb b0)) b0) with
 | true => @eq_refl bool true
 | false => @eq_refl bool false
 end)
>>

証明項をみると、?Goal@{b:=b} と ?Goal0@{b:=b} だったところに
reflexivity が構築した @eq_refl bool true と @eq_refl bool false が
入っていることがわかります。
*)
Qed.


Class Var_env : Type := {
  Var : Type;
  var_eq: forall v1 v2: Var, {v1 = v2} + {v1 <> v2}
}.

Section Logic.

Context {venv: Var_env}.

Inductive Term: Type :=
  | andp : Term -> Term -> Term
  | orp : Term -> Term -> Term
  | impp : Term -> Term -> Term
  | falsep : Term
  | varp : Var -> Term.

Notation "x && y" := (andp x y) (at level 40, left associativity) : IPC_scope.
Notation "x || y" := (orp x y) (at level 50, left associativity) : IPC_scope.
Notation "x --> y" := (impp x y) (at level 55, right associativity) : IPC_scope.
Notation "'FF'" := falsep : IPC_scope.

Local Open Scope IPC_scope.

Definition term_eq: forall t1 t2: Term, {t1 = t2} + {t1 <> t2}.
Proof.
  induction t1; intros.
  + destruct t2; try solve [right; congruence].
    destruct (IHt1_1 t2_1), (IHt1_2 t2_2); [left | right | right | right]; congruence.
  + destruct t2; try solve [right; congruence].
    destruct (IHt1_1 t2_1), (IHt1_2 t2_2); [left | right | right | right]; congruence.
  + destruct t2; try solve [right; congruence].
    destruct (IHt1_1 t2_1), (IHt1_2 t2_2); [left | right | right | right]; congruence.
  + destruct t2; try solve [right; congruence].
    left; auto.
  + destruct t2; try solve [right; congruence].
    destruct (var_eq v v0); [left | right]; congruence.
Defined.

Definition Context := Term -> bool.

Definition EmptyContext : Context := fun _ => false.

Definition ExtendContext (ctx: Context) (t: Term) : Context :=
  fun t0 => if term_eq t0 t then true else ctx t0.

Notation "ctx ;; t" := (ExtendContext ctx t) (at level 65, left associativity) : IPC_scope.

Class Semantic : Type := mk_sem {
  ModelType : Type;
  satisfy : ModelType -> Term -> Prop
}.

Definition valid {sem: Semantic} (t: Term) : Prop :=
  forall M, @satisfy sem M t.

Definition sem_conseq {sem: Semantic} (ctx : Context) (t: Term) : Prop :=
  forall M, (forall t0, ctx t0 = true -> @satisfy sem M t0) -> @satisfy sem M t.

Notation "M  |=  t" := (satisfy M t) (at level 60, no associativity) : IPC_scope.

Notation "|==  t" := (valid t) (at level 61, no associativity) : IPC_scope.

Notation "ctx  |==  t" := (sem_conseq ctx t) (at level 60, no associativity) : IPC_scope.

Class ProofTheory : Type := mk_pt {
  derivable : Context -> Term -> Prop
}.

Notation "ctx  |--  t" := (derivable ctx t) (at level 60, no associativity) : IPC_scope.

Definition provable {pt: ProofTheory} t := EmptyContext |-- t.

Notation "|--  t" := (provable t) (at level 61, no associativity) : IPC_scope.

Definition sound (sem: Semantic) (pt: ProofTheory) : Prop :=
  forall ctx t, ctx |-- t -> ctx |== t.

Definition weak_complete (sem: Semantic) (pt: ProofTheory) : Prop :=
  forall t, |== t -> |-- t.

Definition strong_complete (sem: Semantic) (pt: ProofTheory) : Prop :=
  forall ctx t, ctx |== t -> ctx |-- t.

End Logic.

Module IPC_Notation.
Notation "x && y" := (andp x y) (at level 40, left associativity) : IPC_scope.
Notation "x || y" := (orp x y) (at level 50, left associativity) : IPC_scope.
Notation "x --> y" := (impp x y) (at level 55, right associativity) : IPC_scope.
Notation "'FF'" := falsep : IPC_scope.
End IPC_Notation.

Module LogicNotation.
Notation "ctx ;; t" := (ExtendContext ctx t) (at level 65, left associativity) : IPC_scope.
Notation "M  |=  t" := (satisfy M t) (at level 60, no associativity) : IPC_scope.
Notation "|==  t" := (valid t) (at level 61, no associativity) : IPC_scope.
Notation "ctx  |==  t" := (sem_conseq ctx t) (at level 60, no associativity) : IPC_scope.
Notation "ctx  |--  t" := (derivable ctx t) (at level 60, no associativity) : IPC_scope.
Notation "|--  t" := (provable t) (at level 61, no associativity) : IPC_scope.
End LogicNotation.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Wellfounded Relations.

Require Import base homogeneous wf bar arity HWF.

Set Implicit Arguments.

Local Notation "A ⊆ B" := (∀x y, A x y -> B x y).

Local Notation "A ∩ B" := (fun x y => A x y /\ B x y).
Local Notation "A ∪ B" := (fun x y => A x y \/ B x y).

(** Symbols for copy/paste: ∩ ∪ ⊆ ⊇ ⊔ ⊓ ⊑ ≡  ⋅ ↑ ↓ ⇑ ⇓ ∀ ∃ *)

Local Notation "R ↓ x" := (fun a b => R a b /\ R b x).

Section hwf_binary.

  Variable (X : Type).
  Implicit Type (R S : X -> X -> Prop).

  Inductive hwf R : Prop :=
    | in_hwf_0 : (forall a b, ~ R a b) -> hwf R
    | in_hwf_1 : (forall x, hwf (R↓x)) -> hwf R.

  Fact hwf_anti R S : S ⊆ R -> hwf R -> hwf S.
  Proof.
    intros H1 H2; revert H2 S H1.
    induction 1 as [ R HR | R HR IHR ]; intros S H1.
    * constructor 1; intros a b H; apply (HR a b); auto.
    * constructor 2; intros x.
      apply (IHR x); intros ? ? []; split; auto.
  Qed.

  Section hwf_Ramsey.

    Let new R l :=
      match rev l with
        | a::b::_ => R b a
        | _ => False
      end.

    Let wen (S : list X -> Prop) a b := S (a::b::nil).

    Let wen_new R a b : wen (new R) a b <-> R a b.
    Proof. cbv; tauto. Qed.

    Let hwf_HWF R : hwf R -> HWF (new R).
    Proof.
      induction 1 as [ R HR | R HR IHR ].
      * constructor 1.
        intros l; rewrite <- (rev_involutive l); generalize (rev l); clear l.
        intros l; unfold new; rewrite rev_involutive; revert l.
        intros [|?[|?[|]]]; simpl; auto.
      * constructor 2; intros x.
        generalize (IHR x); apply HWF_anti.
        intros l; unfold new; rewrite rev_app_distr; simpl.
        destruct (rev l) as [|?[|?[|]]]; simpl; tauto.
    Qed.

    Let HWF_hwf T : HWF T -> kary 2 (fun l => T (rev l)) -> hwf (wen T).
    Proof.
      induction 1 as [ T HT | T HT IHT ]; intros Ha.
      * constructor 1; intros ? ?; apply HT.
      * constructor 2; intros x; red in Ha; simpl in Ha.
        eapply hwf_anti.
        2: apply (IHT x).
        + intros a b; cbv.
          rewrite (Ha x b (a::nil)); tauto.
        + intros a b l; simpl.
          rewrite Ha, (Ha x a (b::nil)), (Ha x a (b::l)).
          tauto.
    Qed.

    Let hwf_HWF_eq R : hwf R <-> HWF (new R).
    Proof.
      split.
      * apply hwf_HWF.
      * intros H.
        eapply hwf_anti.
        2: apply HWF_hwf with (1 := H).
        intros a b; apply wen_new.
        unfold kary, new.
        intros a b l; repeat rewrite rev_involutive; tauto.
    Qed.

    (* This is an instance of Berardi's thm *)

    Theorem hwf_Ramsey R S : hwf R -> hwf S -> hwf (R∪S).
    Proof.
      do 3 rewrite hwf_HWF_eq; intros H1 H2.
      eapply HWF_anti.
      2: apply HWF_Ramsey with (3 := H1) (4 := H2).
      * intros l; unfold new; destruct (rev l) as [|?[|]]; tauto.
      * do 2 (constructor 2; intros ?); constructor 1.
        intros ? ?; unfold new; repeat (rewrite rev_app_distr; simpl); tauto.
      * do 2 (constructor 2; intros ?); constructor 1.
        intros ? ?; unfold new; repeat (rewrite rev_app_distr; simpl); tauto.
    Qed.

  End hwf_Ramsey.

  Section wf_hwf.

    Variable R : X -> X -> Prop.

    Hypothesis R_ldec : ∀ x y, R x y \/ ~ R x y.

    Fact Acc_hwf x : Acc R x -> hwf (R↓x).
    Proof.
      induction 1 as [ x Hx IHx ].
      constructor 2; intros y.
      destruct (R_ldec y x) as [ H | H ].
      + generalize (IHx _ H); apply hwf_anti; cbv; tauto.
      + constructor 1; tauto.
    Qed.

    Theorem well_founded_hwf : well_founded R -> hwf R.
    Proof. intros H; constructor 2; intros x; apply Acc_hwf, H. Qed.

  End wf_hwf.

  Fact rel_reduce_transitive R : transitive _ R -> forall x, transitive _ (R↓x).
  Proof. intros H a x y z H1 H2; specialize (H x y); firstorder. Qed.

  Fact rel_reduce_mono R S : R ⊆ S -> ∀x, R↓x ⊆ S↓x.
  Proof. cbv; firstorder. Qed.

  Theorem hwf_well_founded R : hwf R -> transitive _ R -> well_founded R.
  Proof.
    induction 1 as [ R HR | R HR IHR ]; intros H1 a; constructor; intros b Hb.
    + destruct (HR _ _ Hb).
    + specialize (IHR _ (rel_reduce_transitive H1 a) b).
      induction IHR as [ b Hb' IHb ].
      constructor 1; intros c Hc.
      apply IHb; auto.
      apply H1 with (1 := Hc); auto.
  Qed.

  Fixpoint list_rel_reduce R l :=
    match l with
      | nil  => R
      | x::l => (R⇓l)↓x
    end
  where "R ⇓ l" := (list_rel_reduce R l).

  Fact list_rel_reduce_app R l m : R⇓(l++m) = R⇓m⇓l.
  Proof. induction l; simpl; auto; rewrite IHl; auto. Qed.

  Fact list_rel_reduce_mono R S : R ⊆ S -> ∀l, R⇓l ⊆ S⇓l.
  Proof.
    intros H l; revert R S H; induction l; simpl; intros R S H; auto.
    apply rel_reduce_mono, IHl; auto.
  Qed.

  Fact list_rel_reduce_spec R l x y : (R⇓l) x y <-> R x y /\ Forall (R y) l /\ homogeneous R l.
  Proof.
    revert x y; induction l as [ | a l IHl ]; intros x y; simpl.
    + repeat split; try tauto; constructor.
    + do 2 rewrite IHl.
      repeat rewrite homogeneous_inv.
      repeat rewrite Forall_cons_inv.
      tauto.
  Qed.

  Section hwf_homogeneous.

    Let hwf_bar_rec R : hwf R -> ∀ l S, S⇓l ⊆ R -> bar (fun x => ~ homogeneous S x) l.
    Proof.
      induction 1 as [ R HR | R HR IHR ]; intros l S HS.
      * apply in_bar_1; intros a.
        apply in_bar_1; intros b.
        apply in_bar_0; intros H.
        apply (HR b a), HS.
        rewrite list_rel_reduce_spec.
        rewrite homogeneous_inv, homogeneous_inv, Forall_cons_inv in H.
        tauto.
      * apply in_bar_1; intros x.
        apply (IHR x).
        simpl; intros ? ? []; split; auto.
    Qed.

    Let bar_hwf S l : bar (fun x => ~ homogeneous S x) l -> hwf (S⇓l).
    Proof.
      induction 1 as [ l Hl | l Hl IHl ].
      * constructor 1; intros x y Hxy.
        rewrite list_rel_reduce_spec in Hxy.
        apply Hl; tauto.
      * constructor 2; intros; apply IHl.
    Qed.

    Theorem hwf_bar_lift_eq R l : hwf (R⇓l) <-> bar (fun x => ~ homogeneous R x) l.
    Proof.
      split; auto.
      intros H; apply hwf_bar_rec with (R := R⇓l); auto.
    Qed.

  End hwf_homogeneous.

  Corollary hwf_bar_eq R : hwf R <-> bar (fun x => ~ homogeneous R x) nil.
  Proof. apply hwf_bar_lift_eq with (l := nil). Qed.

  (* This is the definition in Berardi's paper *)

  Definition Hwf R := well_founded (extends⬇(homogeneous R)).

  Section well_founded_Hwf.

    Variable (R : X -> X -> Prop).

    Let P y := forall l (Hl : homogeneous R (y::l)), Acc (extends⬇(homogeneous R)) (exist _ _ Hl).

    Let HP : IND R P.
    Proof.
      intros y Hy; unfold P in *; intros l Hl.
      constructor; auto.
      intros (p&Hp) (z & ?); simpl in *; subst.
      apply Hy; auto.
      revert Hp; apply homogeneous_two_inv.
    Qed.

    Theorem well_founded_Hwf : well_founded R -> Hwf R.
    Proof.
      rewrite well_founded_all_wf; intros HR.
      assert (forall x, P x) as Hx.
      { intros x; apply (HR x), HP. }
      intros (l & Hl); constructor; auto.
      intros (m & Hm) (y & ?); simpl in *; subst; apply Hx; auto.
    Qed.

  End well_founded_Hwf.

  Section Hwf_wf.

    Variable (R : X -> X -> Prop).

    (* This proof comes from Berardi's paper ... is there
       a direct proof than doesn't uses wf/IND ? *)

    Theorem Hwf_well_founded : Hwf R -> transitive _ R -> well_founded R.
    Proof.
      rewrite well_founded_all_wf; intros H HR x P HP.
      set (Y l := homogeneous R l /\ match l with nil  => True | y::l => P y end).
      assert (IND_st (homogeneous R) extends Y) as HY.
      { intros [ | y l ] H1 H2; split; simpl; auto.
        apply HP.
        intros z Hz.
        apply (H2 (z::y::l)).
        constructor; auto.
        apply homogeneous_inv, proj1 in H1; constructor; auto.
        revert H1; apply Forall_impl; intro; apply HR; auto.
        exists z; auto. }
      red in H.
      rewrite IND_st_IND in HY.
      specialize (H (exist _ _ (homogeneous_sg R x))).
      rewrite <- wf_eq_Acc in H.
      apply (H _ HY).
    Qed.

  End Hwf_wf.

  Section Hwf_hwf.

    (** We show the equivalence between Berardi's definition and
        the direct inductive charaterization. We use the bar
        inductive characterization for a wery short proof *)

    Variable (R : X -> X -> Prop).

    (* hwf is always stronger than Hwf *)

    Theorem hwf_Hwf : hwf R -> Hwf R.
    Proof.
      rewrite hwf_bar_eq, bar_nil.
      + intros H (l & Hl); apply (bar_Acc _ (H l)).
      + intros x m H1; contradict H1.
        rewrite homogeneous_inv in H1; tauto.
    Qed.

    Hypothesis R_dec : forall x y, R x y \/ ~ R x y.

    (* For logically decidable relations, Hwf is equivalent to hwf *)

    Hint Resolve homogeneous_dec.

    Theorem Hwf_hwf : Hwf R -> hwf R.
    Proof.
      rewrite hwf_bar_eq; intro.
      apply Acc_bar with (l := exist _ _ (in_homogeneous_0 R)); auto.
    Qed.

    Hint Resolve hwf_Hwf Hwf_hwf.

    Theorem Hwf_hwf_eq : Hwf R <-> hwf R.
    Proof. split; auto. Qed.

  End Hwf_hwf.

  (* hwf implies no increasing sequence *)

  Fact hwf_seq R : hwf R -> ∀f, (∀ i j, i < j -> R (f j) (f i)) -> False.
  Proof.
    induction 1 as [ R HR | R HR IHR ]; intros f Hf.
    * apply (HR (f 1) (f 0)), Hf; auto.
    * apply (IHR (f 0) (fun n => f (S n))).
      intros i j Hij; split; apply Hf; omega.
  Qed.

  Corollary hwf_irr R : hwf R -> ∀x, ~ R x x.
  Proof. intros HR x Hx; apply (hwf_seq HR (fun _ => x)); auto. Qed.

  Fact Acc_seq R a : Acc (fun x y => R y x) a -> ∀f, f 0 = a -> (∀i, R (f i) (f (S i))) -> False.
  Proof.
    induction 1 as [ a Ha IHa ]; intros f H1 H2.
    apply (IHa (f 1)) with (f0 := fun n => f (S n)); auto.
    subst; apply H2.
  Qed.

  Fact wf_seq R : well_founded (fun x y => R y x) -> ∀f, (∀i, R (f i) (f (S i))) -> False.
  Proof. intros HR f Hf; apply (@Acc_seq _ _ (HR (f 0)) f); auto. Qed.

  Section Hwf_Ramsey.

    (* Hence very short proof of Berardi's thm for decidable relations *)

    Variables (R S : X -> X -> Prop)
              (HR : forall x y, R x y \/ ~ R x y)
              (HS : forall x y, S x y \/ ~ S x y).

    Theorem Hwf_Ramsey : Hwf R -> Hwf S -> Hwf (R∪S).
    Proof.
      repeat rewrite Hwf_hwf_eq; auto.
      + apply hwf_Ramsey.
      + intros x y; destruct (HR x y); destruct (HS x y); tauto.
    Qed.

  End Hwf_Ramsey.

End hwf_binary.

Check hwf_Hwf.
Check Hwf_well_founded.
Check hwf_well_founded.
Check hwf_Hwf.
Check Hwf_hwf.
Check well_founded_Hwf.
Check well_founded_hwf.

Check hwf_Ramsey.
Check Hwf_Ramsey.

(* gt = fun x y => y < x is homogeneous well-founded *)

Theorem hwf_lt : hwf lt.
Proof.
  apply well_founded_hwf.
  + intros; omega.
  + apply lt_wf.
Qed.


(* Coq representation of compiler/cmm/CmmType.hs *)
Require Import Eqdep.

Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.

Require Import GHC.CmmType.
Require Import GHC.Int.

Definition isIntWidth (w:Width) : Prop :=
  match w with
  | W8
  | W16
  | W32
  | W64 => True
  | _ => False
  end.

Definition isFloatWidth (w:Width) : Prop :=
  match w with
  | W32
  | W64 => True
  | _ => False
  end.

Definition isCoreCmmType (t:CmmType) : Prop :=
  match t with
  | CT_CmmType c w => match c with
                      | BitsCat
                      | GcPtrCat => isIntWidth w
                      | FloatCat => isFloatWidth w
                      | VecCat _ _ => False
                      end
  end.

Definition CC_CmmType := sig isCoreCmmType.

Definition CC_cmmBits (w : {w' : Width | isIntWidth w'}) : CC_CmmType :=
  match w with
  | exist width pf => exist _ (cmmBits width) pf
  end.

Definition CC_cmmFloat (w : {w' : Width | isFloatWidth w'}) : CC_CmmType :=
  match w with
  | exist width pf => exist _ (cmmFloat width) pf
  end.

Definition b64 : CC_CmmType := CC_cmmBits (exist _ W64 I).
Definition bWord : CC_CmmType := CC_cmmBits (exist _ W64 I). (* Need DynFlags here *)

(* Semantics *)

Module Wordsize_16.
  Definition wordsize := 16%nat.
  Remark wordsize_not_zero: wordsize <> 0%nat.
  Proof. unfold wordsize; congruence. Qed.
End Wordsize_16.

Strategy opaque [Wordsize_16.wordsize].

Module Int16 := Make(Wordsize_16).

Strategy 0 [Wordsize_16.wordsize].

Notation short := Int16.int.

Notation long := Int64.int.

Definition CC_CmmTypeDenote (ct:CC_CmmType): Type :=
  match ct with
  | exist t pf => match t with
                  | CT_CmmType BitsCat w => match w with
                                            | W8 => byte
                                            | W16 => short
                                            | W32 => int
                                            | W64 => long
                                            | _ => unit
                                            end
                  | CT_CmmType FloatCat w => match w with
                                             | W32 => float32
                                             | W64 => float
                                             | _ => unit
                                             end
                  | CT_CmmType GcPtrCat _ => long
                  | CT_CmmType (VecCat _ _) _ => unit
                  end
  end.

(* We want to make use of CC_CmmType proof here so we don't have to return
a bogus unit type *)


(** * Equational reasoning for Riesz Spaces *)
Require Import CMorphisms.
Require Import RL.hmr.Rterm.

Require Import Reals.
Require Import Lra.

Local Open Scope R_scope.

(** ** Basic definitions needed for equational reasoning *)
(** Context *)
Inductive Rcontext : Type :=
| R_hole : Rcontext
| R_TC : Rterm -> Rcontext
| R_varC : nat -> Rcontext
| R_zeroC : Rcontext
| R_minC : Rcontext -> Rcontext -> Rcontext
| R_maxC : Rcontext -> Rcontext -> Rcontext
| R_plusC : Rcontext -> Rcontext -> Rcontext
| R_mulC : R -> Rcontext -> Rcontext
| R_oneC
| R_diamondC : Rcontext -> Rcontext.

Fixpoint evalRcontext (c : Rcontext) (t : Rterm) : Rterm :=
  match c with
  | R_hole => t
  | R_TC t' => t'
  | R_varC n => R_var n
  | R_zeroC => R_zero
  | R_minC c1 c2 => R_min (evalRcontext c1 t) (evalRcontext c2 t)
  | R_maxC c1 c2 => R_max (evalRcontext c1 t) (evalRcontext c2 t)
  | R_plusC c1 c2 => R_plus (evalRcontext c1 t) (evalRcontext c2 t)
  | R_mulC x c => R_mul x (evalRcontext c t)
  | R_oneC => R_one
  | R_diamondC c => R_diamond (evalRcontext c t)
  end.

(** ** Equational Reasoning *)
Inductive R_eqMALG : Rterm -> Rterm -> Type :=
(** equational rules *)
| R_refl t : R_eqMALG t t
| R_trans t1 t2 t3 : R_eqMALG t1 t2 -> R_eqMALG t2 t3 -> R_eqMALG t1 t3
| R_ctxt c t1 t2 : R_eqMALG t1 t2 -> R_eqMALG (evalRcontext c t1) (evalRcontext c t2)
| R_sym t1 t2 : R_eqMALG t1 t2 -> R_eqMALG t2 t1
| R_subs_r t1 t2 n t : R_eqMALG t1 t2 -> R_eqMALG (Rsubs t1 n t) (Rsubs t2 n t)
(** vector space axioms *)
| R_asso_plus t1 t2 t3 : R_eqMALG (t1 +R (t2 +R t3)) ((t1 +R t2) +R t3)
| R_commu_plus t1 t2 : R_eqMALG (t1 +R t2) (t2 +R t1)
| R_neutral_plus t : R_eqMALG (t +R R_zero) t
| R_opp_plus t : R_eqMALG (t -R t) R_zero
| R_mul_1 t  : R_eqMALG (1 *R t) t
| R_mul_assoc x y t : R_eqMALG (x *R (y *R t)) ((x * y) *R t)
| R_mul_distri_term x t1 t2 : R_eqMALG (x *R (t1 +R t2)) ((x *R t1) +R (x *R t2))
| R_mul_distri_coeff x y t : R_eqMALG ((x + y) *R t) ((x *R t) +R (y *R t))
(** lattice axioms *)
| R_asso_max t1 t2 t3 : R_eqMALG (R_max t1 (R_max t2 t3)) (R_max (R_max t1 t2) t3)
| R_commu_max t1 t2 : R_eqMALG (R_max t1 t2) (R_max t2 t1)
| R_abso_max t1 t2 : R_eqMALG (R_max t1 (R_min t1 t2)) t1
| R_asso_min t1 t2 t3 : R_eqMALG (R_min t1 (R_min t2 t3)) (R_min (R_min t1 t2) t3)
| R_commu_min t1 t2 : R_eqMALG (R_min t1 t2) (R_min t2 t1)
| R_abso_min t1 t2 : R_eqMALG (R_min t1 (R_max t1 t2)) t1
(** modal axioms *)
| R_diamond_linear t1 t2 : R_eqMALG (<R> (t1 +R t2)) ((<R> t1) +R (<R> t2))
| R_diamond_mul r t : R_eqMALG (<R> (r *R t)) (r *R <R> t)
| R_diamond_one : R_eqMALG ((<R> R_one) /\R R_one) (<R> R_one)
| R_diamond_pos t : R_eqMALG (R_zero /\R <R> (t \/R R_zero)) R_zero
| R_one_pos : R_eqMALG (R_zero /\R R_one) R_zero
(** compability axiom *)
| R_compa_R_plus_ax t1 t2 t3 : R_eqMALG (R_min (R_plus (R_min t1 t2) t3) (R_plus t2 t3)) (R_plus (R_min t1 t2) t3)
| R_compa_mul_ax r t : 0 <= r -> R_eqMALG (R_min R_zero (R_mul r (R_max t R_zero))) R_zero.

Notation "A =R= B" := (R_eqMALG A B) (at level 90, no associativity).
Notation "A <R= B" := (R_eqMALG (R_min A B) A) (at level 90, no associativity).

(** *** =R= is an equivalence relation **)

Instance R_eqMALG_Equivalence : Equivalence R_eqMALG | 10 := {
  Equivalence_Reflexive := R_refl ;
  Equivalence_Symmetric := R_sym ;
  Equivalence_Transitive := R_trans }.

(** *** Proofs of a equalities *)

Hint Constructors R_eqMALG : core.

Lemma cong_S : forall A B, A = B -> A =R= B.
Proof.
  intros A B eq.
  subst.
  reflexivity.
Qed.
Hint Resolve cong_S : core.

Lemma plus_left : forall A B C, A =R= C -> A +R B =R= C +R B.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_plusC R_hole (R_TC B))).
  apply eq.
Qed.

Lemma plus_right : forall A B C, B =R= C -> A +R B =R= A +R C.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_plusC (R_TC A) R_hole)).
  apply eq.
Qed.

Lemma plus_cong : forall A B C D, A =R= B -> C =R= D -> A +R C =R= B +R D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A +R D); [apply plus_right | apply plus_left]; assumption.
Qed.

Global Instance plus_cong_instance : Proper (R_eqMALG ==> R_eqMALG ==> R_eqMALG) R_plus | 10.
Proof. repeat intro; now apply plus_cong. Qed.

Lemma max_left : forall A B C, A =R= C -> A \/R B =R= C \/R B.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_maxC R_hole (R_TC B))).
  apply eq.
Qed.

Lemma max_right : forall A B C, B =R= C -> A \/R B =R= A \/R C.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_maxC (R_TC A) R_hole)).
  apply eq.
Qed.

Lemma max_cong : forall A B C D, A =R= B -> C =R= D -> A \/R C =R= B \/R D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A \/R D); [apply max_right | apply max_left]; assumption.
Qed.

Global Instance max_cong_instance : Proper (R_eqMALG ==> R_eqMALG ==> R_eqMALG) R_max | 10.
Proof. repeat intro; now apply max_cong. Qed.

Lemma min_left : forall A B C, A =R= C -> A /\R B =R= C /\R B.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_minC R_hole (R_TC B))).
  apply eq.
Qed.

Lemma min_right : forall A B C, B =R= C -> A /\R B =R= A /\R C.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_minC (R_TC A) R_hole)).
  apply eq.
Qed.

Lemma R_mul_left : forall x y A , x = y -> R_mul x A =R= R_mul y A.
Proof.
  intros x y A eq.
  rewrite eq.
  auto.
Qed.

Lemma min_cong : forall A B C D, A =R= B -> C =R= D -> A /\R C =R= B /\R D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A /\R D); [apply min_right | apply min_left]; assumption.
Qed.

Global Instance min_cong_instance : Proper (R_eqMALG ==> R_eqMALG ==> R_eqMALG) R_min | 10.
Proof. repeat intro; now apply min_cong. Qed.

Lemma R_mul_right : forall x A B , A =R= B -> R_mul x A =R= R_mul x B.
Proof.
  intros x A B eq.
  apply (@R_ctxt (R_mulC x R_hole)).
  apply eq.
Qed.

Global Instance R_mul_right_instance x : Proper (R_eqMALG ==> R_eqMALG) (R_mul x) | 10.
Proof. repeat intro; now apply R_mul_right. Qed.

Lemma minus_cong : forall A B , A =R= B -> -R A =R= -R B.
Proof.
  intros A B eq.
  apply (@R_ctxt (R_mulC (-1) R_hole)).
  assumption.
Qed.

Global Instance minus_cong_instance : Proper (R_eqMALG ==> R_eqMALG) (R_mul (-1)) | 10.
Proof. repeat intro; now apply minus_cong. Qed.

Lemma diamond_cong : forall A B, A =R= B -> (<R> A =R= <R> B).
Proof.
  intros A B eq.
  apply (@R_ctxt (R_diamondC R_hole)).
  apply eq.
Qed.

Global Instance diamond_cong_instance : Proper (R_eqMALG ==> R_eqMALG) R_diamond | 10.
Proof. repeat intro; now apply diamond_cong. Qed.

Hint Resolve plus_left plus_right max_left max_right min_left min_right minus_cong R_mul_left R_mul_right diamond_cong : core.

Lemma evalContext_cong : forall c t1 t2, t1 =R= t2 -> evalRcontext c t1 =R= evalRcontext c t2.
Proof.
  induction c; simpl; auto.
  all:intros t1 t2 eq; specialize (IHc1 t1 t2 eq); specialize (IHc2 t1 t2 eq); rewrite IHc1 ; now rewrite IHc2.
Qed.

Global Instance evalContext_cong_instance c : Proper (R_eqMALG ==> R_eqMALG) (evalRcontext c) | 10.
Proof. repeat intro; now apply evalContext_cong. Qed.

Lemma leq_compa_plus : forall A B C, (A /\R B) +R C <R= B +R C.
Proof.
  intros A B C.
  auto.
Qed.

Hint Resolve leq_compa_plus : Rsem_solver.

Lemma minus_distri : forall A B, -R (A +R B) =R= (-R A) +R (-R B).
Proof.
  intros A B.
  auto.
Qed.

Hint Resolve minus_distri : Rsem_solver.

Lemma minus_R_zero : R_zero =R= -R R_zero.
Proof.
  rewrite <- (R_neutral_plus ((-1) *R R_zero)).
  rewrite R_commu_plus.
  auto.
Qed.

Lemma minus_minus : forall A , -R (-R A) =R= A.
Proof with auto.
  intro A.
  rewrite<- R_neutral_plus.
  rewrite<- (R_opp_plus A).
  rewrite (R_commu_plus A (-R A)).
  rewrite R_asso_plus.
  rewrite (R_commu_plus (-R (-R A)) (-R A)).
  rewrite R_opp_plus.
  now rewrite R_commu_plus.
Qed.

Hint Resolve minus_R_zero : Rsem_solver.
Hint Resolve minus_minus : Rsem_solver.

Lemma leq_antisym : forall A B, A <R= B -> B <R= A -> A =R= B.
Proof with auto.
  intros A B eq1 eq2.
  apply R_trans with (B /\R A)...
  apply R_trans with (A /\R B)...
Qed.

Lemma leq_cong_l : forall A A' B, A =R= A' -> A' <R= B -> A <R= B.
Proof with auto.
  intros A A' B eq leq.
  apply R_trans with (A' /\R B)...
  apply R_trans with A'...
Qed.

Lemma leq_cong_r : forall A B B', B =R= B' -> A <R= B' -> A <R= B.
Proof with auto.
  intros A B B' eq leq.
  apply R_trans with (A /\R B')...
Qed.

Lemma leq_R_trans : forall A B C, A <R= B -> B <R= C -> A <R= C.
Proof with auto.
  intros A B C leq1 leq2.
  apply R_trans with ((A /\R B) /\R C)...
  apply R_trans with (A /\R (B /\R C))...
  apply R_trans with (A /\R B)...
Qed.

Lemma leq_plus : forall A B C, A <R= B -> (A +R C) <R= (B +R C).
Proof with auto.
  intros A B C leq.
  apply leq_cong_l with ((A /\R B) +R C)...
Qed.

Hint Resolve leq_plus : Rsem_solver.

Lemma min_max : forall A B , (A /\R B) =R= A -> (A \/R B) =R= B.
Proof with auto.
  intros A B eq.
  apply R_trans with ((A /\R B) \/R B)...
  apply R_trans with ((B /\R A) \/R B)...
  apply R_trans with (B \/R (B /\R A))...
Qed.

Lemma max_min : forall A B , (A \/R B) =R= A -> (A /\R B) =R= B.
Proof with auto.
  intros A B eq.
  apply R_trans with ((A \/R B) /\R B)...
  apply R_trans with ((B \/R A) /\R B)...
  apply R_trans with (B /\R (B \/R A))...
Qed.

Hint Resolve max_min min_max : Rsem_solver.

Lemma leq_refl_cong : forall A B, ((A /\R A) /\R B) =R= A /\R B.
Proof with auto with *.
  intros A B.
  apply R_trans with (A /\R (A /\R B))...
Qed.

Lemma leq_refl : forall A , A /\R A =R= A.
Proof with auto.
  intro A.
  apply R_trans with (A /\R (A /\R (A \/R A)))...
  apply R_trans with ((A /\R A) /\R (A \/R A))...
  apply R_trans with (A /\R (A \/R A)); auto using leq_refl_cong.
Qed.

Hint Resolve leq_refl : Rsem_solver.

Lemma leq_min : forall A B C, A <R= B -> A <R= C -> A <R= (B /\R C).
Proof with auto.
  intros A B C leq1 leq2.
  apply R_trans with ((A /\R B) /\R C)...
  apply R_trans with (A /\R C)...
Qed.

Lemma leq_max : forall A B , A <R= (A \/R B).
Proof with auto.
  intros A B.
  auto.
Qed.

Lemma min_leq : forall A B, (A /\R B) <R= A.
Proof with auto with *.
  intros A B.
  apply R_trans with (A /\R (A /\R B))...
Qed.

Lemma max_leq : forall A B C, A <R= C -> B <R= C -> (A \/R B) <R= C.
Proof with auto with *.
  intros A B C leq1 leq2.
  apply R_trans with (C /\R (A \/R B))...
  apply max_min.
  apply R_trans with ((A \/R B) \/R C)...
  apply R_trans with (A \/R (B \/R C))...
  apply R_trans with (A \/R C)...
Qed.

Hint Resolve leq_max min_leq min_leq max_leq : Rsem_solver.

Lemma leq_plus_left : forall A B C, A <R= B -R C -> A +R C <R= B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_r with (B +R (-R C) +R C)...
  apply R_trans with (B +R ((-R C) +R C))...
  apply R_trans with (B +R (C -R C))...
  apply R_trans with (B +R R_zero)...
Qed.

Lemma leq_plus_right : forall A B C, A -R B <R= C -> A <R= C +R B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_l with ( A -R B +R B)...
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (B -R B))...
  apply R_trans with (A +R ((-R B) +R B))...
Qed.

Lemma leq_minus_left : forall A B C, A <R= B +R C -> A -R C <R= B.
Proof with auto.
  intros A B C leq.
  apply leq_plus_left...
  apply R_trans with (A /\R (B +R C)); auto using minus_minus.
Qed.

Lemma leq_minus_right : forall A B C , A +R C <R= B -> A <R= B -R C.
Proof with auto.
  intros A B C leq.
  apply leq_plus_right.
  apply R_trans with ((A +R C) /\R B); auto using minus_minus.
  apply R_trans with (A +R C); auto using minus_minus.
Qed.

Lemma max_plus : forall A B C, ((A \/R B) +R C) =R= (A +R C) \/R (B +R C).
Proof with auto.
  intros A B C.
  apply leq_antisym.
  - apply leq_plus_left.
    apply max_leq.
    + apply leq_minus_right...
    + apply leq_minus_right...
      apply R_trans with ((B +R C) /\R ((B +R C) \/R (A +R C)))...
  - apply max_leq; auto using leq_plus.
    apply leq_plus_right.
    apply leq_cong_l with B.
      * apply R_trans with (B +R (C -R C))...
        apply R_trans with (B +R R_zero)...
      * apply leq_cong_r with (B \/R A)...
Qed.

Hint Resolve max_plus : Rsem_solver.

Lemma minus_reverse_leq : forall A B, B <R= A -> (-R A) <R= (-R B).
Proof with auto.
  intros A B leq.
  apply leq_cong_r with (-R B +R R_zero)...
  apply leq_cong_r with (R_zero -R B)...
  apply leq_minus_right.
  apply leq_cong_l with (B -R A)...
  apply leq_minus_left.
  apply leq_cong_r with (A +R R_zero)...
  apply leq_cong_r with A...
Qed.

Hint Resolve minus_reverse_leq : Rsem_solver.

Lemma minus_min_max : forall A B, -R (A /\R B) =R= (-R A) \/R (-R B).
Proof with auto with Rsem_solver.
  intros A B.
  apply leq_antisym.
  - apply leq_cong_r with (-R (-R ((-R A) \/R (-R B))))...
    apply minus_reverse_leq.
    apply leq_min.
    + apply leq_cong_r with (-R (-R A))...
    + apply leq_cong_r with (-R (-R B))...
      apply leq_cong_l with (-R (-R B \/R -R A))...
  - apply max_leq.
    + apply minus_reverse_leq...
    + apply leq_cong_r with (-R (B /\R A))...
Qed.

Lemma min_leq_max : forall A B, A /\R B <R= A \/R B.
Proof with auto with Rsem_solver.
  intros A B.
  apply leq_R_trans with A...
Qed.

Hint Resolve minus_min_max min_leq_max : Rsem_solver.

Lemma minus_inj : forall A B, -R A =R= -R B -> A =R= B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (-R (-R A))...
  apply R_trans with (-R (-R B))...
Qed.

Lemma leq_plus_cong : forall A B C D, A <R= B -> C <R= D -> A +R C <R= B +R D.
Proof with auto with Rsem_solver.
  intros A B C D leq1 leq2.
  apply leq_R_trans with (B +R C)...
  apply leq_cong_l with (C +R B)...
  apply leq_cong_r with (D +R B)...
Qed.

Hint Resolve leq_plus_cong : Rsem_solver.

Lemma cond_leq : forall A B, R_zero <R= (A -R B) -> B <R= A.
Proof with auto with Rsem_solver.
  intros A B Hleq.
  apply leq_cong_r with ((A -R B) +R B).
  { apply R_trans with (A +R R_zero)...
    apply R_trans with (A +R (B -R B))...
    apply R_trans with (A +R ((-R B) +R B))... }
  apply leq_cong_l with (R_zero +R B)...
  apply R_trans with (B +R R_zero)...
Qed.

Lemma cond_leq_inv : forall A B, B <R= A -> R_zero <R= (A -R B).
Proof with auto with Rsem_solver.
  intros A B Hleq.
  apply leq_cong_l with (B -R B)...
Qed.

Lemma eq_minus : forall A B, A =R= B -> A -R B =R= R_zero.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (B -R B)...
Qed.

Hint Resolve eq_minus : Rsem_solver.

Lemma minus_eq : forall A B, A -R B =R= R_zero -> A =R= B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (B -R B))...
  apply R_trans with (A +R ((-R B) +R B))...
  apply R_trans with (A -R B +R B)...
  apply R_trans with (R_zero +R B)...
  apply R_trans with (B +R R_zero)...
Qed.

Lemma R_minus_mul : forall r A, -R (r *R A) =R= r *R (-R A).
Proof with auto with Rsem_solver.
  intros r A.
  rewrite R_mul_assoc.
  replace (-1 * r) with (r * -1) by lra.
  rewrite R_mul_assoc.
  reflexivity.
Qed.

Hint Resolve R_minus_mul : Rsem_solver.

Lemma R_mul_compa : forall r A B, (0 <= r) -> A <R= B -> (r *R A) <R= (r *R B).
Proof with auto with Rsem_solver.
  intros r A B Hleqr HleqAB.
  apply cond_leq.
  apply leq_cong_r with ((r *R ((B -R A) \/R R_zero))).
  { apply R_trans with ((r *R B) +R (r *R (-R A)))...
    apply R_trans with (r *R (B -R A))...
    apply R_mul_right.
    apply R_sym.
    apply R_trans with (R_zero \/R (B -R A))...
    apply min_max.
    apply cond_leq_inv...
  }
  apply R_compa_mul_ax...
Qed.

Hint Resolve R_mul_compa : Rsem_solver.

Lemma R_mul_0 :  forall r, r *R R_zero =R= R_zero.
Proof with auto with Rsem_solver.
  intro r.
  transitivity (r *R (R_zero +R R_zero))...
  transitivity (r *R R_zero +R r *R R_zero)...
  transitivity (r *R R_zero +R r *R (-R R_zero))...
  transitivity (r *R R_zero +R (-R (r *R R_zero)))...
Qed.

Hint Resolve R_mul_0 : Rsem_solver.

Lemma no_div_R_zero : forall r A, r <> 0 -> r *R A =R= R_zero -> A =R= R_zero.
Proof with auto with Rsem_solver.
  intros r A Hr eq.
  transitivity (1 *R A)...
  transitivity ((/ r * r) *R A)...
  { apply R_mul_left.
    symmetry.
    apply Rinv_l... }
  apply R_trans with ((/ r) *R (r *R A))...
  apply R_trans with ((/ r) *R R_zero)...
Qed.

Lemma R_mul_distri_minus : forall k A B, (k *R A) -R (k *R B) =R= k *R (A -R B).
Proof with auto with Rsem_solver.
  intros k A B.
  apply R_trans with ((k *R A) +R (k *R (-R B)))...
Qed.

Lemma minus_max_min : forall A B, -R (A \/R B) =R= (-R A) /\R (-R B).
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with (-R (A \/R (-R (-R B))))...
  apply R_trans with (-R ((-R (-R A)) \/R (-R (-R B))))...
  apply R_trans with (-R (-R ((-R A) /\R (-R B))))...
Qed.

Hint Resolve R_mul_distri_minus minus_max_min : Rsem_solver.

Lemma R_zero_leq_pos : forall A , R_zero <R= R_pos A.
Proof with auto with Rsem_solver.
  intro A.
  apply leq_cong_r with (R_zero \/R A)...
Qed.

Lemma R_zero_leq_neg : forall A , R_zero <R= R_neg A.
Proof with auto with Rsem_solver.
  intro A.
  apply leq_cong_r with (R_zero \/R (-R A))...
Qed.

Hint Resolve R_zero_leq_pos R_zero_leq_neg : Rsem_solver.

Lemma eq_minus_right : forall A B C, A +R C =R= B -> A =R= B -R C.
Proof with auto with Rsem_solver.
  intros A B C eq.
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (C -R C))...
  apply R_trans with ((A +R C) -R C)...
Qed.

Lemma eq_plus_right : forall A B C, A -R C =R= B -> A =R= B +R C.
Proof with auto with Rsem_solver.
  intros A B C eq.
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (C -R C))...
  apply R_trans with (A +R ((-R C) +R C))...
  apply R_trans with ((A -R C) +R C)...
Qed.

Lemma decomp_pos_neg : forall A, A =R= (R_pos A) -R (R_neg A).
Proof with auto with Rsem_solver.
  intros A.
  apply eq_minus_right.
  apply R_trans with (A \/R (A -R A))...
  apply R_trans with ((A +R R_zero) \/R (A -R A))...
  apply R_trans with ((R_zero +R A) \/R (A -R A))...
  apply R_trans with ((A -R A) \/R (R_zero +R A))...
  apply R_trans with (((-R A) +R A) \/R (R_zero +R A))...
  apply R_trans with (R_neg A +R A)...
Qed.

Hint Resolve decomp_pos_neg : Rsem_solver.

Lemma pos_neg : forall A, R_pos A =R= A +R (R_neg A).
Proof.
  intros A.
  apply R_trans with ((R_pos A -R R_neg A) +R R_neg A); auto using eq_plus_right with Rsem_solver.
Qed.

Lemma neg_pos : forall A , R_neg A =R= (R_pos A) -R A.
Proof with auto with Rsem_solver.
  intros A.
  apply eq_minus_right...
  apply R_trans with (A +R R_neg A); auto using eq_plus_right with Rsem_solver.
Qed.

Hint Resolve pos_neg neg_pos : Rsem_solver.

Lemma min_plus : forall A B C, (A /\R B) +R C =R= (A +R C) /\R (B +R C).
Proof with auto with Rsem_solver.
  intros A B C.
  apply R_trans with (-R (-R ((A +R C) /\R (B +R C))))...
  apply R_trans with (-R ((-R (A +R C)) \/R (-R (B +R C))))...
  apply R_trans with (-R (((-R A) -R C) \/R ((-R (B +R C)))))...
  apply R_trans with (-R (((-R A) -R C) \/R (((-R B) -R C))))...
  apply R_trans with (-R (((-R A) \/R ((-R B))) -R C))...
  apply R_trans with ((-R (((-R A) \/R ((-R B))))) -R (-R C))...
  apply R_trans with ((-R (((-R A) \/R ((-R B))))) +R C)...
  apply R_trans with (((-R (-R A)) /\R ((-R (-R B)))) +R C)...
  apply R_trans with ((A /\R ((-R (-R B)))) +R C)...
Qed.

Hint Resolve min_plus : Rsem_solver.

Lemma min_pos_neg : forall A, (R_pos A) /\R (R_neg A) =R= R_zero.
Proof with auto with Rsem_solver.
  intros A.
  apply R_trans with ((A +R (R_neg A)) /\R (R_neg A))...
  apply R_trans with ((A +R (R_neg A)) /\R (R_neg A +R R_zero))...
  apply R_trans with ((A +R (R_neg A)) /\R (R_zero +R R_neg A))...
  apply R_trans with ((A /\R R_zero) +R R_neg A)...
  apply R_trans with ( (-R (-R (A /\R R_zero))) +R R_neg A)...
  apply R_trans with ( (-R ((-R A) \/R (-R R_zero))) +R R_neg A)...
  apply R_trans with ( (-R (R_neg A)) +R R_neg A)...
  apply R_trans with (R_neg A -R R_neg A)...
Qed.

Hint Resolve min_pos_neg : Rsem_solver.

Lemma cond_R_zero_leq_max : forall A B,
    (A \/R B) =R= (R_pos A \/R R_pos B) -> R_zero <R= A \/R B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with ((A \/R B) /\R R_zero)...
  apply max_min.
  apply R_trans with ((A \/R B) \/R (R_zero \/R R_zero))...
  apply R_trans with (A \/R (B \/R (R_zero \/R R_zero)))...
  apply R_trans with (A \/R (R_pos B \/R R_zero))...
  apply R_trans with (A \/R (R_zero \/R R_pos B))...
  apply R_trans with (R_pos A \/R R_pos B)...
Qed.

Lemma cond_eq_pos : forall A B,
    R_zero <R= A \/R B -> (A \/R B) =R= (R_pos A \/R R_pos B).
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (A \/R (R_zero \/R R_pos B))...
  apply R_trans with (A \/R (R_pos B \/R R_zero))...
  apply R_trans with (A \/R (B \/R (R_zero \/R R_zero)))...
  apply R_trans with ((A \/R B) \/R (R_zero \/R R_zero))...
  apply R_trans with (A \/R B \/R R_zero)...
  apply R_trans with (R_zero \/R (A \/R B))...
Qed.

Lemma max_pos : forall A B, A \/R B =R= (R_pos (A -R B)) +R B.
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with ((A +R R_zero) \/R B)...
  apply R_trans with ((A +R (B -R B)) \/R B)...
  apply R_trans with ((A +R ((-R B) +R B)) \/R B)...
  apply R_trans with ((A +R (-R B) +R B) \/R B)...
  apply R_trans with ((A +R (-R B) +R B) \/R (B +R R_zero))...
  apply R_trans with ((A +R (-R B) +R B) \/R (R_zero +R B))...
Qed.

Hint Resolve max_pos : Rsem_solver.

Lemma min_pos : forall A B, A /\R B =R= A -R (R_pos (A -R B)).
Proof with auto with Rsem_solver.
  intros A B.
  apply eq_minus_right.
  apply R_trans with ((R_pos (A -R B)) +R (A /\R B))...
  apply R_sym.
  apply eq_plus_right.
  apply R_trans with (A +R ((-R A) \/R (-R B)))...
  apply R_trans with (((-R A) \/R (-R B)) +R A)...
  apply R_trans with (((-R A) +R A) \/R ((-R B) +R A))...
  apply R_trans with ((A -R A) \/R ((-R B) +R A))...
  apply R_trans with (R_zero \/R ((-R B) +R A))...
  apply R_trans with (R_zero \/R (A -R B))...
Qed.

Hint Resolve min_pos : Rsem_solver.

Lemma min_max_plus : forall A B, (A \/R B) +R (A /\R B) =R= A +R B.
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with (((R_pos (A -R B)) +R B) +R (A /\R B))...
  apply R_trans with (((R_pos (A -R B)) +R B) +R (A -R (R_pos (A -R B))))...
  apply R_trans with ((B +R (R_pos (A -R B))) +R (A -R (R_pos (A -R B))))...
  apply R_trans with (B +R ((R_pos (A -R B)) +R (A -R (R_pos (A -R B)))))...
  apply R_trans with (B +R ((R_pos (A -R B)) +R ((-R (R_pos (A -R B))) +R A)))...
  apply R_trans with (B +R ((R_pos (A -R B)) +R (-R (R_pos (A -R B))) +R A))...
  apply R_trans with (B +R (R_zero +R A))...
  apply R_trans with (B +R (A +R R_zero))...
  apply R_trans with (B +R A)...
Qed.

Hint Resolve min_max_plus : Rsem_solver.

Lemma max_distri_min : forall A B C, (A /\R B) \/R C =R= (A \/R C) /\R (B \/R C).
Proof with auto with Rsem_solver.
  intros A B C.
  remember ((A \/R C) /\R (B \/R C)) as m.
  apply leq_antisym.
  - apply leq_cong_r with (A \/R C /\R B \/R C)...
    apply leq_min.
    + apply max_leq.
      * apply leq_R_trans with A...
      * apply leq_cong_r with (C \/R A)...
    + apply max_leq...
      * apply leq_R_trans with B...
        apply leq_cong_l with (B /\R A)...
      * apply leq_cong_r with (C \/R B)...
  - apply leq_cong_r with ((A /\R B) -R ((-R C) +R ((A /\R B) /\R C)))...
    + apply R_trans with ((A /\R B) +R ((-R (-R C)) -R ((A /\R B) /\R C)))...
      apply R_trans with ((A /\R B) +R (C -R ((A /\R B) /\R C)))...
      apply R_trans with (((A /\R B) +R C) -R ((A /\R B) /\R C)); auto using eq_minus_right with Rsem_solver.
    + apply leq_minus_right...
      apply leq_min...
      * apply leq_cong_l with ((m +R ((A /\R B) /\R C)) -R C)...
        ** apply R_trans with (m +R (((A /\R B) /\R C) -R C))...
        ** apply leq_cong_r with ((A +R C) -R C); auto using eq_minus_right with Rsem_solver.
           apply leq_plus.
           apply leq_cong_r with ((A \/R C) +R (A /\R C))...
           apply leq_R_trans with (m +R (A /\R C))...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A /\R (B /\R C))...
               apply leq_cong_l with (A /\R (C /\R B))...
               apply leq_cong_l with (A /\R C /\R B)...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A \/R C /\R B \/R C)...
      * apply leq_cong_l with (m +R ((A /\R B /\R C) -R C))...
        apply leq_cong_l with ((m +R (A /\R B /\R C)) -R C)...
        apply leq_cong_r with (B +R R_zero)...
        apply leq_cong_r with (B +R (C -R C))...
        apply leq_cong_r with ((B +R C) -R C)...
        apply leq_plus...
        apply leq_cong_r with ((B \/R C) +R (B /\R C))...
        apply leq_plus_cong...
        apply leq_cong_l with (A \/R C /\R B \/R C)...
        ** apply leq_cong_l with (B \/R C /\R A \/R C)...
        ** apply leq_cong_l with (A /\R (B /\R C))...
           apply leq_cong_l with ((B /\R C) /\R A)...
Qed.

Hint Resolve max_distri_min : Rsem_solver.

Lemma min_distri_max : forall A B C, (A \/R B) /\R C =R= (A /\R C) \/R (B /\R C).
Proof with auto with Rsem_solver.
  intros A B C.
  apply R_trans with (-R (-R (A \/R B /\R C)))...
  apply R_trans with (-R ((-R (A \/R B) \/R (-R C))))...
  apply R_trans with (-R (((-R A) /\R (-R B)) \/R (-R C)))...
  apply R_trans with (-R (((-R A) \/R (-R C)) /\R ((-R B) \/R (-R C))))...
  apply R_trans with ((-R ((-R A) \/R (-R C))) \/R (-R ((-R B) \/R (-R C))))...
  apply R_trans with (((-R (-R A)) /\R (-R (-R C))) \/R (-R ((-R B) \/R (-R C))))...
  apply R_trans with (((-R (-R A)) /\R (-R (-R C))) \/R ((-R (-R B)) /\R (-R (-R C))))...
  apply R_trans with ((A /\R (-R (-R C))) \/R ((-R (-R B)) /\R (-R (-R C))))...
  apply R_trans with ((A /\R C) \/R ((-R (-R B)) /\R (-R (-R C))))...
  apply R_trans with ((A /\R C) \/R (B /\R (-R (-R C))))...
Qed.

Hint Resolve min_distri_max : Rsem_solver.

Lemma decomp_max_pos_neg : forall A B, A \/R B =R= ((R_pos A) \/R (R_pos B)) -R ((R_neg A) /\R (R_neg B)).
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with (R_pos (A \/R B) -R (R_neg (A \/R B)))...
  apply R_trans with ((R_pos A \/R R_pos B) -R (R_neg (A \/R B))).
  - apply (@R_ctxt (R_plusC R_hole (R_mulC (-1) (R_TC (R_neg (A \/R B)))))).
    apply R_trans with (A \/R B \/R (R_zero \/R R_zero))...
    apply R_trans with (A \/R (B \/R R_pos R_zero))...
    apply R_trans with (A \/R (R_pos B \/R R_zero))...
    apply R_trans with (A \/R (R_zero \/R R_pos B))...
  - apply R_trans with ((R_pos A \/R R_pos B) -R (((-R A) /\R (-R B)) \/R R_zero))...
Qed.

Hint Resolve decomp_max_pos_neg : Rsem_solver.

Lemma cond_R_zero_leq_max_2 : forall A B, (R_neg A) /\R (R_neg B) =R= R_zero -> R_zero <R= A \/R B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply cond_R_zero_leq_max...
  apply R_trans with ((R_pos A \/R R_pos B) +R R_zero)...
  apply R_trans with ((R_pos A \/R R_pos B) -R R_zero)...
  apply R_trans with ((R_pos A \/R R_pos B) -R (R_neg A /\R R_neg B))...
Qed.

Lemma cond_min_R_neg_eq_R_zero : forall A B, R_zero <R= A \/R B -> (R_neg A) /\R (R_neg B) =R= R_zero.
Proof with auto with Rsem_solver.
  intros A B leq.
  apply R_trans with (((R_pos A) \/R (R_pos B)) -R (A \/R B)); auto using eq_minus_right, cond_eq_pos with Rsem_solver.
  apply eq_minus_right...
  apply R_trans with ((A \/R B) +R (R_neg A /\R R_neg B)); auto using eq_plus_right with Rsem_solver.
Qed.

Lemma R_zero_leq_abs : forall A, R_zero <R= R_abs A.
Proof with auto with Rsem_solver.
  intro A.
  apply cond_R_zero_leq_max_2.
  apply R_trans with ((R_neg A) /\R (R_pos A))...
  apply R_trans with ((R_pos A) /\R (R_neg A))...
Qed.

Hint Resolve R_zero_leq_abs : Rsem_solver.


Require Import List Specif TheoryList.

Set Implicit Arguments.

Ltac magic_solver := repeat progress (simpl; intuition eauto; subst).

Section sumbool.
  Variables A1 B1 A2 B2 : Prop.

  Definition sumbool_and (b1 : {A1} + {B1}) (b2 : {A2} + {B2})
    : {A1 /\ A2} + {B1 \/ B2}.
    intros.
    refine (if b1
      then if b2
	then left _ _
	else right _ _
      else right _ _); tauto.
  Defined.

  Definition sumbool_or (b1 : {A1} + {B1}) (b2 : {A2} + {B2})
    : {A1 \/ A2} + {B1 /\ B2}.
    intros.
    refine (if b1
      then left _ _
      else if b2
	then left _ _
	else right _ _); magic_solver.
  Defined.

  Definition reduce : (A1 -> A2) -> (B1 -> B2)
    -> {A1} + {B1} -> {A2} + {B2}.
    destruct 3; auto.
  Defined.
End sumbool.

About sumbool_and.
About sumbool_or.

Infix "&&" := sumbool_and (left associativity, at level 50).
Infix "||" := sumbool_or (left associativity, at level 51).

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).

About reduce.

Notation "'Reduce'" := (reduce _ _).

Hint Extern 1 False => discriminate.

Definition nat_eq_dec : forall (x y : nat), {x = y} + {x <> y}.
  refine (fix nat_eq_dec (x y : nat) {struct x} : {x = y} + {x <> y} :=
    match x return {x = y} + {x <> y} with
      | O =>
	match y return {O = y} + {O <> y} with
	  | O => Yes
	  | S _ => No
	end
      | S x' =>
	match y return {S x' = y} + {S x' <> y} with
	  | O => No
	  | S y' => Reduce (nat_eq_dec x' y')
	end
    end); magic_solver.
Defined.

Hint Extern 2 (_ = _) => congruence.

Definition list_nat_eq_dec : forall (x y : list nat), {x = y} + {x <> y}.
  refine (fix list_nat_eq_dec (x y : list nat) {struct x} : {x = y} + {x <> y} :=
    match x return {x = y} + {x <> y} with
      | nil =>
	match y return {nil = y} + {nil <> y} with
	  | nil => Yes
	  | _ :: _ => No
	end
      | hx :: tx =>
	match y return {hx :: tx = y} + {hx :: tx <> y} with
	  | nil => No
	  | hy :: ty => Reduce (nat_eq_dec hx hy && list_nat_eq_dec tx ty)
	end
    end); magic_solver.
Defined.

Hint Extern 2 False =>
  match goal with
    | [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst
  end.

Definition list_nat_In_dec : forall (n : nat) (ls : list nat), {In n ls} + {~In n ls}.
  refine (fix list_nat_In_dec (n : nat) (ls : list nat) {struct ls} : {In n ls} + {~In n ls} :=
    match ls return {In n ls} + {~In n ls} with
      | nil => No
      | n' :: ls' => Reduce (nat_eq_dec n n' || list_nat_In_dec n ls')
    end); magic_solver.
Defined.

Section sumor_and.
  Variables A1 A2 : Set.
  Variable P1 : A1 -> Prop.
  Variable P2 : A2 -> Prop.
  Variables Q1 Q2 : Prop.

  Definition sumor_and (b1 : sig P1 + {Q1}) (b2 : sig P2 + {Q2})
    : {x : A1 * A2 | P1 (fst x) /\ P2 (snd x)} + {Q1 \/ Q2}.
    intros.
    refine (match b1 with
	      | inleft (exist x1 _) =>
		match b2 with
		  | inleft (exist x2 _) => inleft _ (exist _ (x1, x2) _)
		  | inright _ => inright _ _
		end
	      | inright _ => inright _ _
	    end); magic_solver.
  Defined.
End sumor_and.

Section sumor_or.
  Variable A : Set.
  Variables P1 P2 : A -> Prop.
  Variables Q1 Q2 : Prop.

  Definition sumor_or (b1 : sig P1 + {Q1}) (b2 : sig P2 + {Q2})
    : {x : A | P1 x \/ P2 x} + {Q1 /\ Q2}.
    intros.
    refine (match b1 with
	      | inleft (exist x _) => inleft _ (exist _ x _)
	      | inright _ =>
		match b2 with
		  | inleft (exist x _) => inleft _ (exist _ x _)
		  | inright _ => inright _ _
		end
	    end); magic_solver.
  Defined.

  Definition reduceSumor : (forall x, P1 x -> P2 x) -> (Q1 -> Q2)
    -> sig P1 + {Q1} -> sig P2 + {Q2}.
    intros H1 H2 s.
    refine (match s with
	      | inleft (exist x _) => inleft _ (exist _ x _)
	      | inright _ => inright _ _
	    end); auto.
  Defined.
End sumor_or.

Infix "&&&" := sumor_and (left associativity, at level 50).
Infix "|||" := sumor_or (left associativity, at level 51).

Section sumor_consider.
  Variable A : Set.
  Variable P1 P2 : Prop.
  Variable P3 : A -> Prop.

  Definition consider : forall (x : A), (P1 -> P3 x)
    -> {P1} + {P2}
    -> sig P3 + {P2}.
    intros x H s.
    refine (if s
      then inleft _ (exist _ x _)
      else inright _ _); magic_solver.
  Defined.
End sumor_consider.

Notation "'This' x" := (inleft _ (exist _ x _)) (at level 30).
Notation "'Nobody'" := (inright _ _).
Notation "'Use'" := (reduceSumor _ _ _).
Notation "'Consider' x 'for' p 'when' y" := (consider p x _ y) (at level 30).

Definition assoc : forall (x : nat) (ls : list (nat * nat)),
  {y : nat | In (x, y) ls} + {forall y, ~In (x, y) ls}.
  refine (fix assoc (x : nat) (ls : list (nat * nat)) {struct ls}
    : {y : nat | In (x, y) ls} + {forall y, ~In (x, y) ls} :=
    match ls return {y : nat | In (x, y) ls} + {forall y, ~In (x, y) ls} with
      | nil => Nobody
      | (x', y) :: ls' =>
	Use (Consider y for (fun y' => In (x, y') ((x', y) :: ls')) when nat_eq_dec x x'
	  ||| assoc x ls')
    end); magic_solver.
Defined.

Section sumbool_monad.
  Variables P1 P2 Q1 Q2 : Prop.

  Definition sumbool_bind : {P1} + {P2}
    -> (P1 -> {Q1} + {Q2})
    -> (P2 -> Q2)
    -> {Q1} + {Q2}.
    destruct 1; eauto.
  Defined.
End sumbool_monad.

About sumbool_bind.

Notation "pf <-- m1 ; m2" := (sumbool_bind m1 (fun pf => m2) _)
  (right associativity, at level 30).

Hint Extern 1 False =>
  match goal with
    | [ H : AllS _ (_ :: _) |- _ ] => inversion H; clear H; subst
  end.

Section AllS_dec.
  Variable A : Set.
  Variable P : A -> Prop.
  Variable P_dec : forall (x : A), {P x} + {~P x}.

  Definition AllS_dec : forall (ls : list A), {AllS P ls} + {~AllS P ls}.
    refine (fix AllS_dec (ls : list A) : {AllS P ls} + {~AllS P ls} :=
      match ls return {AllS P ls} + {~AllS P ls} with
	| nil => Yes
	| x :: ls' =>
	  Hx <-- P_dec x;
  	  Hls' <-- AllS_dec ls';
	  Yes
      end); intuition.
  Defined.
End AllS_dec.

Section sumor_monad.
  Variables A1 A2 : Set.
  Variable P1 : A1 -> Prop.
  Variable P2 : A2 -> Prop.
  Variables Q1 Q2 : Prop.

  Definition sumor_bind : sig P1 + {Q1}
    -> (forall (x : A1), P1 x -> sig P2 + {Q2})
    -> (Q1 -> Q2)
    -> sig P2 + {Q2}.
    destruct 1; eauto.
    destruct s; eauto.
  Defined.
End sumor_monad.

Section sumbool_monad_sumor.
  Variables P1 P2 Q2 : Prop.
  Variable Q1 : Set.

  Definition sumbool_bind_sumor : {P1} + {P2}
    -> (P1 -> Q1 + {Q2})
    -> (P2 -> Q2)
    -> Q1 + {Q2}.
    destruct 1; eauto.
  Defined.
End sumbool_monad_sumor.

About sumor_bind.
About sumbool_bind_sumor.

Notation "x 'by' pf <- m1 ; m2" := (sumor_bind m1 (fun x pf => m2) _)
  (right associativity, at level 30).
Notation "pf <-- m1 ;; m2" := (sumbool_bind_sumor m1 (fun pf => m2) _)
  (right associativity, at level 30).

Inductive ty : Set :=
  | Nat : ty
  | Bool : ty.

Inductive exp : Set :=
  | Const : nat -> exp
  | Plus : exp -> exp -> exp
  | BConst : bool -> exp
  | Eq : exp -> exp -> exp.

Inductive hasType : exp -> ty -> Prop :=
  | HT_Const : forall n,
    hasType (Const n) Nat
  | HT_Plus : forall e1 e2,
    hasType e1 Nat
    -> hasType e2 Nat
    -> hasType (Plus e1 e2) Nat
  | HT_BConst : forall b,
    hasType (BConst b) Bool
  | HT_Eq : forall e1 e2,
    hasType e1 Nat
    -> hasType e2 Nat
    -> hasType (Eq e1 e2) Bool.

Hint Constructors hasType.

Ltac ics H := inversion H; clear H; subst.

Ltac my_inversion :=
  match goal with
    | [ H : hasType (Const _) _ |- _ ] => ics H
    | [ H : hasType (Plus _ _) _ |- _ ] => ics H
    | [ H : hasType (BConst _) _ |- _ ] => ics H
    | [ H : hasType (Eq _ _) _ |- _ ] => ics H
  end.

Hint Extern 1 (_ = _) => repeat my_inversion.
Hint Extern 1 False => repeat my_inversion.

Definition ty_eq_dec : forall (t1 t2 : ty), {t1 = t2} + {t1 <> t2}.
  decide equality.
Defined.

Theorem hasType_unique : forall e t1,
  hasType e t1
  -> forall t2, hasType e t2
    -> t1 = t2.
  induction 1; magic_solver.
Qed.

Hint Resolve hasType_unique.

Definition hasType_dec : forall (e : exp),
  {t : ty | hasType e t} + {forall t, ~hasType e t}.
  refine (fix hasType_dec (e : exp)
    : {t : ty | hasType e t} + {forall t, ~hasType e t} :=
    match e return {t : ty | hasType e t} + {forall t, ~hasType e t} with
      | Const _ => This Nat
      | Plus e1 e2 =>
	t1 by Ht1 <- hasType_dec e1;
        Heq1 <-- ty_eq_dec t1 Nat;;
        t2 by Ht2 <- hasType_dec e2;
        Heq2 <-- ty_eq_dec t2 Nat;;
        This Nat
      | BConst _ => This Bool
      | Eq e1 e2 =>
	t1 by Ht1 <- hasType_dec e1;
        Heq1 <-- ty_eq_dec t1 Nat;;
        t2 by Ht2 <- hasType_dec e2;
        Heq2 <-- ty_eq_dec t2 Nat;;
        This Bool
    end); clear hasType_dec; magic_solver.
Defined.

Recursive Extraction hasType_dec.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal38.

Set Printing Depth 1000.
Definition lfind_eval  z y:=
append y z.

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Nil).

Compute lfind_eval  (Cons Zero Nil) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)))) (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons Zero (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Nil) (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ (Succ Zero)) Nil))))) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero Nil)))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)) (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Nil).

Compute lfind_eval  (Cons Zero Nil) (Cons Zero (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Nil) (Cons Zero Nil).

Compute lfind_eval  (Nil) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Nil) (Nil).

Compute lfind_eval  (Nil) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Nil) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Nil).

Compute lfind_eval  (Nil) (Nil).