Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ.
From Circom.CircomLib Require Import Bitify Comparators.
From Circom.BigInt.Proof Require Import BigAdd BigLessThan BigSub.
From Circom.BigInt.Definition Require Import BigAdd BigLessThan BigSub.
From Circom.BigInt.Definition Require Import BigAddModP.
(* Circuit:
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module BigAddModP.

Module B := Bitify.
Module D := DSL.
Module Cmp := Comparators.
Module RZU := ReprZUnsigned.
Module RZ := RZU.RZ.
Module R := Repr.
Module Add := BigAdd.BigAdd.
Module Sub := BigSub.BigSub.
Module Lt := BigLessThan.BigLessThan.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Section _BigAddModP.
Context {n k: nat}.

Definition cons (a b p out: F^k) :=
  exists (add: @Add.t n k) (lt: @Lt.t n (S k)) (sub: @Sub.t n (S k)),
  D.iter (fun i _cons => _cons /\
    add.(Add.a)[i] = a[i] /\
    add.(Add.b)[i] = b[i]) k True /\
  D.iter (fun i _cons => _cons /\
    lt.(Lt.a)[i] = add.(Add.out)[i] /\
    lt.(Lt.b)[i] = p[i]) k True /\
  lt.(Lt.a)[k] = add.(Add.out)[k] /\
  lt.(Lt.b)[k] = 0 /\
  D.iter (fun i _cons => _cons /\
    sub.(Sub.a)[i] = add.(Add.out)[i] /\
    sub.(Sub.b)[i] = (1 - lt.(Lt.out)) * p[i]) k True /\
  sub.(Sub.a)[k] = add.(Add.out)[k] /\
  sub.(Sub.b)[k] = 0 /\
  sub.(Sub.out)[k] = 0 /\
  D.iter (fun i _cons => _cons /\
    out[i] = sub.(Sub.out)[i]) k True.

Record t := { a: F^k; b: F^k; p: F^k; out: F^k; _cons: cons a b p out }.
Local Notation "[| xs |]" := (RZ.as_le n xs).

Local Notation "xs !! i" := (List.nth i xs _) (at level 10).

Ltac pose_as_le_nonneg := repeat match goal with
| [ |- context[RZ.as_le ?n ?xs ] ] =>
  let t := type of (RZU.as_le_nonneg n xs) in
  lazymatch goal with
  (* already posed *)
  | [ _: t |- _] => fail
  | _ =>
    let Hnonneg := fresh "_Hnonneg" in
    pose proof (RZU.as_le_nonneg n xs) as Hnonneg
    ;move Hnonneg at top
  end
| _ => fail
end.

Ltac rewrite_length :=
  repeat match goal with
  | [ H: length ?xs = ?l |- context[length ?xs] ] =>
    rewrite H
  end; simplify.

Ltac lrewrite :=
  repeat match goal with
  | [ H: ?x = _ |- context[?x] ] => rewrite H
  end.
Ltac rrewrite :=
  repeat match goal with
  | [ H: _ = ?x |- context[?x] ] => rewrite H
  end.

Lemma scale_0: forall l, List.map (fun pi => 0 * pi) l = List.repeat (0:F) (length l).
Proof.
  induction l as [ | x l]; simpl; auto.
  simplify. f_equal. auto.
Qed.

Lemma as_le_0: forall i, [| List.repeat (0:F) i|] = 0%Z.
Proof.
  induction i; simpl; auto.
  rewrite IHi. simplify.
Qed.

Lemma as_le_msb_0: forall xs l,
  length xs = S l ->
  xs |: (n) ->
  [| xs |] <= 2^(n*l)-1 ->
  [| xs |] = [| xs[:l] |].
Proof.
  intros.
  unwrap_C.
  pose proof (RZ.as_le_split_last' n l xs).
  specialize (H2 H).
  rewrite H2.
  destruct (dec (xs ! l = 0)).
  rewrite e. simplify.
  remember (RZ.ToZ.to_Z (xs ! l)) as y.
  assert (y <> 0)%Z. subst. apply F.to_Z_nonzero. auto.
  assert (0 <= y). subst. apply F.to_Z_range. lia.
  assert (0 <= [|xs [:l]|]). pose_as_le_nonneg. lia.
  assert ([|xs [:l]|] <= 2 ^ (n * l) - 1).
    eapply RZU.repr_le_ub.
    applys_eq RZ.repr_trivial. rewrite firstn_length_le; lia.
    apply Forall_firstn. auto.
  exfalso. nia.
Qed.

Lemma scale_binary_range: forall s xs,
  xs |: (n) ->
  binary s ->
  List.map (fun x => s * x) xs |: (n).
Proof.
  induction xs; simpl; intros; constructor;
  inversion H; subst; clear H.
  destruct H0; subst; simplify.
  rewrite F.to_Z_0. lia.
  apply IHxs; auto.
Qed.

Lemma scale_binary0: forall (s: F) xs l,
  s = 0 ->
  l = length xs ->
  List.map (fun x => s * x) xs = List.repeat 0 l.
Proof.
  induction xs; intros; subst; simpl in *; simplify.
  reflexivity.
  f_equal. auto.
Qed.

Lemma scale_binary1: forall (s: F) xs l,
  s = 1 ->
  l = length xs ->
  List.map (fun x => s * x) xs = xs.
Proof.
  induction xs; intros; subst; simpl in *; simplify.
  reflexivity.
  f_equal. erewrite IHxs; eauto.
Qed.

Lemma Zmod_once: forall a b c,
  0 <= a < c ->
  0 <= b < c ->
  c <= a + b ->
  ((a + b) mod c = (a + b) - c)%Z.
Proof.
  intros a b c. intros.
  rewrite Zmod_eq by lia.
  assert ((a+b)/c < 2). apply Zdiv_lt_upper_bound. lia. lia.
  assert (1 <= (a+b)/c). apply Zdiv_le_lower_bound; lia.
  nia.
Qed.

#[local]Hint Extern 10 => match goal with
  | [ |- context[ length (firstn _ _) ] ] =>
    rewrite firstn_length_le by lia
  end : core.
#[local]Hint Extern 10 (eq (F.F q) _ _) => fqsatz : core.
#[local]Hint Extern 10 F => exact F.zero: core.

Theorem soundness: forall (c: t),
  (* pre-conditions *)
  0 < n ->
  0 < k ->
  n + 2 <= C.k ->
  'c.(a) |: (n) ->
  'c.(b) |: (n) ->
  'c.(p) |: (n) ->
  [|'c.(a)|] <= [|'c.(p)|] - 1 ->
  [|'c.(b)|] <= [|'c.(p)|] - 1 ->
  (* post-conditions *)
  [|'c.(out)|] = ([|'c.(a)|] + [|'c.(b)|]) mod [|'c.(p)|] /\
  'c.(out) |: (n).
Proof with (lia || eauto).
  unwrap_C.
  intros c Hn Hk Hnk Ha Hb Hp Hap Hbp.
  destruct c as [a b p out [add [lt [sub prog]]]].
  destruct prog as [Padd [Plt [Plt_ak [Plt_bk [Psub [Psub_ak [Psub_bk [Psub_outk Pout]]]]]]]].
  simpl in *.
  lift_to_list.
  pose_lengths.
  rem_iter.
  assert (0 < 2^n). { apply Zpow_facts.Zpower_gt_0... }
  assert (0 <= [|' a|] + [|' b|]) by (pose_as_le_nonneg; lia).
  assert ([|'p|] <= 2^(n*k)-1). {
    eapply RZU.repr_le_ub with (xs:='p).
    unfold RZU.RZ.repr_le. intuition.
  }

  (* add *)
  pose (Iadd := fun (i:nat) _cons => _cons ->
    'add.(Add.a)[:i] = 'a[:i] /\
    'add.(Add.b)[:i] = 'b[:i]).
  assert (Hadd: Iadd k (D.iter f2 k True)) by connection Iadd.
  pose proof (Add.soundness add) as Sadd.
  destruct Hadd as [Hadd_a Hadd_b]...
  firstn_all. rewrite Hadd_a, Hadd_b in *. clear Hadd_a Hadd_b.
  destruct Sadd as [Sadd_out Sadd_out_range]...
  subst f2. clear Padd Iadd.

  (* less than *)
  pose (Ilt := fun (i:nat) _cons => _cons ->
    'lt.(Lt.a)[:i] = 'add.(Add.out)[:i] /\
    'lt.(Lt.b)[:i] = 'p[:i]).
  assert (Hlt: Ilt k (D.iter f1 k True)) by connection Ilt.
  destruct Hlt as [Hlt_a Hlt_b]... clear Ilt.
  pose proof (Lt.soundness lt) as Slt.
  destruct Slt as [Slt_bin Slt]; try lia;
  try (applys_eq (@Forall_firstn_and_last F);
    rewrite_length;
    fold_default; lrewrite; unfold_default;
    try apply Forall_firstn)...
  apply Forall_nth... rewrite F.to_Z_0...
  assert (Hlt_a': 'lt.(Lt.a) = 'add.(Add.out)). {
    applys_eq (@list_tail_congruence F)...
    fold_default...
  }
  rewrite Hlt_a', Sadd_out in *. clear Hlt_a Hlt_a'.
  assert (Hlt_b': [|' Lt.b lt |] = [|'p|]). {
    erewrite RZ.as_le_split_last with (ws:='Lt.b lt) (i:=k).
    rewrite Hlt_b, Plt_bk.
    firstn_all. simplify.
    applys_eq RZ.repr_trivial...
    eapply Forall_firstn_and_last; rewrite_length;
    fold_default; lrewrite; unfold_default.
    apply Forall_firstn... rewrite F.to_Z_0...
  }
  move Hlt_b' before Hlt_b.

  (* sub *)
  (* sub.a = add.out *)
  pose (Isub_a := fun (i: nat) _cons => _cons ->
    'Sub.a sub [:i] = 'Add.out add [:i]).
  assert (Hsub_a: Isub_a k (D.iter f0 k True)) by connection Isub_a.
  specialize (Hsub_a Psub).
  assert (Hsub_a': 'sub.(Sub.a) = 'add.(Add.out)). {
    applys_eq (@list_tail_congruence F)... fold_default...
  }
  clear Hsub_a Isub_a Psub_ak.
  (* [|sub.b|] = [|p|] *)
  pose (Isub_b := fun (i: nat) _cons => _cons ->
    'Sub.b sub [:i] = List.map (fun pi => (1-Lt.out lt) * pi) ('p)[:i]).
  assert (Hsub_b: Isub_b k (D.iter f0 k True)). {
    apply D.iter_inv; unfold Isub_b.
    - easy.
    - intros i _cons IH Hi Hstep. subst f0. lift_to_list. intuition.
      applys_eq (@firstn_congruence F)...
      rewrite map_nth. fold_default...
  }
  specialize (Hsub_b Psub). clear Isub_b.
  rewrite Hlt_b' in *.

  (* out *)
  pose (Iout := fun (i: nat) _cons => _cons ->
    'out [:i] = 'Sub.out sub [:i]).
  assert (Hout: Iout k (D.iter f k True)) by connection Iout.
  specialize (Hout Pout). clear Pout Iout.
  firstn_all.

  destruct (Sub.soundness_ite sub) as [H_sub_out_bin [H_sub_out H_sub]]; try lia.
    rewrite Hsub_a'. auto.
    eapply Forall_firstn_and_last; rewrite_length.
    rewrite Hsub_b. rewrite firstn_map. firstn_all.
    apply scale_binary_range...
    eapply one_minus_binary; eauto.
    fold_default. rewrite Psub_bk. autorewrite with F_to_Z...

  rewrite Hsub_a', Sadd_out in *.
  destruct (dec ([|' a|] + [|' b|] < [|' p|])).
  - rewrite Zmod_small...
    assert (Hsub_b': 'Sub.b sub = List.repeat 0 (S k)). {

      erewrite <- firstn_split_last with (l:=' Sub.b sub) (n:=k)...
      cbn [List.repeat]. rewrite repeat_cons.
      apply app_congruence_iff; intuition.
      rewrite firstn_length_le, repeat_length...
      replace (1 - lt.(Lt.out)) with (0:F) in Hsub_b by fqsatz.
      rewrite Hsub_b, scale_0. rewrite_length.
      rewrite firstn_all2... rewrite repeat_length...
      fold_default. f_equal...
    }
    rewrite Hsub_b', as_le_0 in *.
    destruct (dec ([|' a|] + [|' b|] >= 0)); try lia.
    intuition;
    rewrite Hout.
    rewrite <- as_le_msb_0...
    apply Forall_firstn...
  - rewrite Zmod_once...
    rewrite Hout.
    assert (Hsub_bk: [|'sub.(Sub.b)|] = [|'sub.(Sub.b)[:k]|]). {
      erewrite RZ.as_le_split_last with (i:=k).
      lrewrite. simplify.
      applys_eq RZ.repr_trivial...
      eapply Forall_firstn_and_last; rewrite_length; lrewrite...
      apply Forall_firstn. apply scale_binary_range... eapply one_minus_binary...
      fold_default. lrewrite. autorewrite with F_to_Z...
    }
    assert (Hsub_outk: [|'sub.(Sub.out)|] = [|'sub.(Sub.out)[:k]|]). {
      erewrite RZ.as_le_split_last with (i:=k).
      lrewrite. simplify.
      applys_eq RZ.repr_trivial...
    }
    destruct (Slt_bin) as [Hlt_out | Hlt_out]; rewrite Hlt_out in *.
    split_dec.
    erewrite scale_binary1 with (l:=k) in Hsub_b; try fqsatz...
    rewrite firstn_all2 with (l:='p) in Hsub_b...
    rewrite Hsub_bk, Hsub_b, <- Hsub_outk in *.
    intuition.
    apply Forall_firstn...
    erewrite scale_binary1 with (l:=k) in Hsub_b; try fqsatz...
    rewrite firstn_all2 with (l:='p) in Hsub_b...
    rewrite Hsub_bk, Hsub_b, <- Hsub_outk in *.
    lia.
    exfalso.
    erewrite scale_binary0 with (l:=k) in Hsub_b; try fqsatz...
    assert ([|' a|] + [|' b|] < [|' p|]). apply Slt...
    lia.
    Unshelve. all:auto.
Qed.

End _BigAddModP.
End BigAddModP.


(* Full safety for STLC *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)
(* subtyping (in addition to nano2.v) *)
(* singleton types (in addtion to nano4-1.v *)

(* TODO: proper subtyping in nano4-1 and here,
phrase singleton type lookup through stp,
dependent application *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
  | TVar   : id -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : list vl -> tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint length {X: Type} (l : list X): nat :=
  match l with
    | [] => 0
    | _::l' => 1 + length l'
  end.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
           has_type env ttrue TBool
| t_false: forall env,
           has_type env tfalse TBool
| t_varx: forall x env T1,
           index x env = Some T1 ->
           has_type env (tvar x) (TVar x)
| t_var: forall x env T1,
           index x env = Some T1 ->
           has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
           has_type env f (TFun T1 T2) ->
           has_type env x T1 ->
           has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
           has_type (T1::(TFun T1 T2)::env) y T2 ->
           has_type env (tabs y) (TFun T1 T2)
.

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall v t vs ts,
    val_type (v::vs) v t ->
    wf_env vs ts ->
    wf_env (cons v vs) (cons t ts)

with val_type : venv -> vl -> ty -> Prop :=
| v_bool: forall venv b,
    val_type venv (vbool b) TBool
| v_abs: forall env venv tenv y T1 T2,
    wf_env venv tenv ->
    has_type (T1::(TFun T1 T2)::tenv) y T2 ->
    val_type env (vabs venv y) (TFun T1 T2)
| v_var: forall env x v,
    index x env = Some v ->
    val_type env v (TVar x)
.

Inductive stp: venv -> ty -> venv -> ty -> Prop :=
| stp_bool: forall G1 G2,
    stp G1 TBool G2 TBool
| stp_fun: forall G1 G2 T1 T2 T3 T4,
    stp G2 T3 G1 T1 ->
    stp G1 T2 G2 T4 ->
    stp G1 (TFun T1 T2) G2 (TFun T3 T4)
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v

Could use do-notation to clean up syntax.
 *)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vbool _)) => Some None
                | Some (Some (vabs env2 ey)) =>
                  teval n (vx::(vabs env2 ey)::env2) ey
              end
          end
      end
  end.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
Hint Constructors val_type.
Hint Constructors wf_env.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma valtp_extend : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1::vs) v T.
Proof. intros. induction H; eauto. eapply index_extend in H. eauto. Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
Qed.

Inductive res_type: venv -> option vl -> ty -> Prop :=
| not_stuck: forall venv v T,
      val_type venv v T ->
      res_type venv (Some v) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stp H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros. inversion H; inversion H0; subst T2; subst; eauto.
  inversion H9. inversion H9.
  admit. (* fun *)
  inversion H8. inversion H10.
Qed.

Lemma invert_abs: forall venv vf vx T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stp venv T1 (vx::vf::env) T3 /\
    stp (vx::vf::env) T4 venv T2.
Proof.
  intros. inversion H. repeat eexists; repeat eauto. admit. admit.
Qed.

(* if not a timeout, then result not stuck and well-typed *)

Theorem full_safety : forall n e tenv venv res T,
  teval n venv e = Some res -> has_type tenv e T -> wf_env venv tenv ->
  res_type venv res T.

Proof.
  intros n. induction n.
  (* 0 *)   intros. inversion H.
  (* S n *) intros. destruct e; inversion H; inversion H0.

  Case "True".  eapply not_stuck. eapply v_bool.
  Case "False". eapply not_stuck. eapply v_bool.

  Case "VarX".
    destruct (index_safe_ex venv0 tenv0 T1 i) as [v [I V]]; eauto.

    rewrite I. eapply not_stuck. eapply v_var. eauto.

  Case "Var".
    destruct (index_safe_ex venv0 tenv0 T i) as [v [I V]]; eauto.

    rewrite I. eapply not_stuck. eapply V.

  Case "App".
    remember (teval n venv0 e1) as tf.
    remember (teval n venv0 e2) as tx.
    subst T.

    destruct tx as [rx|]; try solve by inversion.
    assert (res_type venv0 rx T1) as HRX. SCase "HRX". subst. eapply IHn; eauto.
    inversion HRX as [? vx].

    destruct tf as [rf|]; subst rx; try solve by inversion.
    assert (res_type venv0 rf (TFun T1 T2)) as HRF. SCase "HRF". subst. eapply IHn; eauto.
    inversion HRF as [? vf].

    destruct (invert_abs venv0 vf vx T1 T2) as
        [env1 [tenv [y0 [T3 [T4 [EF [WF [HTY [STX STY]]]]]]]]]. eauto.
    (* now we know it's a closure, and we have has_type evidence *)

    assert (res_type (vx::vf::env1) res T4) as HRY.
      SCase "HRY".
        subst. eapply IHn. eauto. eauto.
        (* wf_env f x *) econstructor. eapply valtp_widen; eauto.
        (* wf_env f   *) econstructor. eapply v_abs; eauto.
        eauto.

    inversion HRY as [? vy].

    eapply not_stuck. eapply valtp_widen; eauto.

  Case "Abs". intros. inversion H. inversion H0.
    eapply not_stuck. eapply v_abs; eauto.
Qed.

End STLC.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import prime fintype paths finfun ssralg bigops finset.
Require Import groups morphisms normal commutators.
Require Import cyclic center pgroups sylow gprod schurzass hall.
Require Import coprime_act nilpotent.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

Section coprime_comm.
Variable T : finGroupType.

(* same as the following but with weaker assumptions
Lemma comm_center_prod: forall (A G: group T),
  A \subset 'N(G) -> coprime #|[~: G, A]| #|A| -> solvable [~: G, A] ->
  G = [~: G, A] * 'C_G(A) :> set _.
Proof.
move=> A G AsubNG coprime solv.
apply/eqP; rewrite eqEsubset; apply/andP; split.
- apply: sub_gmul; rewrite /=; first by apply:commg_norml.
  - by apply: (subset_trans _ (commg_norml G A)); rewrite /centraliser; apply: subsetIl.
  - rewrite coprime_quotient_cent //=.
    - by rewrite subsetI; apply/andP; split; last by apply: quotient_cents2r.
    - apply/andP; rewrite //=; split; last by apply:commg_norml.
      by rewrite commGC commg_subr //.
    - by rewrite commGC; apply: commg_norml.
- rewrite -{3}mulGid; apply:imset2S; last by apply: subsetIl.
  by rewrite commGC commg_subr //.
Qed.
*)

Lemma comm_center_prod : forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> solvable G ->
  G :=: [~: G, A] * 'C_G(A).
Proof.
move=> A G AsubNG coprime solv.
apply/eqP; rewrite eqEsubset andbC -{3}mulGid imset2S ?subsetIl //; last first.
  by rewrite commGC commg_subr.
rewrite -quotientSK ?commg_norml // coprime_quotient_cent_weak //=; last first.
- by rewrite commGC commg_norml.
- by rewrite [_ <| G]andbC commg_norml commGC commg_subr.
by rewrite subsetI andbC quotient_cents2r /=.
Qed.

Lemma commGAA:   forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> solvable G ->
  [~: G, A] = [~: G, A, A].
Proof.
move=> A G AsubNG coGA solG.
apply/eqP; rewrite eqEsubset; apply/andP; split; last first.
  by rewrite commSg // commg_subl.
rewrite {1}(comm_center_prod AsubNG coGA solG) commMG.
- by rewrite (commG1P (subsetIr _ _)) //= mulg1.
- by rewrite subIset // commg_norml.
by rewrite subIset // orbC cent_sub.
Qed.

Lemma comm_center_triv:   forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> abelian G ->
 [~: G, A] :&: 'C_G(A) = 1.
Proof.
move => A G norm co abel.
have mulGC : @commutative (subg_of G) mulg.
  by case=> x Gx [y Gy]; apply: val_inj; rewrite /= (centsP abel).
pose gTG := Ring.AdditiveGroup (@mulgA _) mulGC (@mul1g _) (@mulVg _).
have Gval: forall u : gTG, sgval u \in G by exact: valP.
have valM: forall a b : gTG, sgval (a + b)%R = sgval a * sgval b by [].
pose f x y : gTG := subg G (conjg x y).
pose phi y := sgval (\sum_(x \in A) f y x)%R.
have morphic_phi: {in G &, {morph phi : x y / x * y}}.
  move => x y xin yin; rewrite /phi -valM -big_split //=.
  congr (sgval _); apply: eq_bigr => z Az.
  have xz: x ^ z \in G by rewrite memJ_norm //; apply (subsetP norm).
  have yz: y ^ z \in G by rewrite memJ_norm //; apply (subsetP norm).
  by rewrite /f conjMg; apply: val_inj; rewrite /= !subgK //; apply: groupM.
have phia : forall a y, a \in A -> phi (conjg y a) = phi y.
  move=> a y ain; rewrite /phi; apply: sym_eq.
  rewrite (reindex (fun x => a * x))  /=; last first.
    - exists (fun x => a^-1 * x); move => b abin; rewrite //=; first by rewrite mulKg //.
      by rewrite mulKVg //.
    - rewrite (eq_bigl (fun x => x \in A)); last by move => x; rewrite //=; apply: groupMl.
      by congr (sgval _); apply: eq_bigr => x xin; rewrite /f conjgM //.
pose Mphi := Morphism  morphic_phi.
have kerphi: forall c, c \in [~: G, A] -> c \in 'ker Mphi.
  move=>c; move/generatedP; apply {c}.
  apply/subsetP; move=> c; case/imset2P=> x a xin ain -> {c}.
  have xinv : x^-1 \in G by apply:groupVr.
  have xconja: x ^ a \in G by rewrite memJ_norm //; apply: (subsetP norm).
  apply/morphpreP; split; rewrite/commg //=; first by apply: groupM.
  by apply/set1P; rewrite morphic_phi // phia // (morphV Mphi) //; apply: mulVg.
have centr : forall v, v \in 'C_G(A) -> phi v = v^+ #|A|.
  move=> v; rewrite inE; case/andP=> inG; move/centP=> inC.
  pose cphi y := sgval (\sum_(x \in A) (subg G y : gTG))%R.
  have phiv: phi v = cphi v.
    congr (sgval _); apply: eq_bigr => x; rewrite /f => xin.
    by congr subg; rewrite /conjg -{2}(mulKg x v); congr (_ * _); apply: inC.
  rewrite phiv /cphi sumr_const.
  by elim: {+}#|_| => [  | n indh]; first done; rewrite //= subgK // expgS indh.
have v1: forall v, v \in G ->  v ^+ #|A| = 1 -> v = 1.
  move => v vin; move/eqP; rewrite -order_dvd => div.
  have ov1: #[ v ] = 1%nat.
    rewrite /coprime in co; apply/eqP.
    by rewrite -dvdn1 -(eqP co) dvdn_gcd order_dvd_g.
  rewrite -(expg1 v) -ov1; apply: order_expn1.
  apply/eqP; rewrite eqEsubset; apply/andP; split.
  - apply/subsetP => x; case/setIP=> inco incen; move: (incen).
    rewrite inE; case/andP=> inG ince; apply/set1P; apply: v1; first done.
    by rewrite -centr; last done; apply: (mker (kerphi x inco)).
  - by apply/subsetP => x; move/set1P ->; apply/setIP; split; apply: group1.
Qed.

Theorem comm_center_dir_prod: forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> abelian G ->
  G :=: [~: G, A] \x 'C_G(A).
move=> A G AsubNG coprime abel.
have trI: [~: G, A] :&: 'C_G(A) = 1 by apply: comm_center_triv.
rewrite dprodE //.
- apply: comm_center_prod => //.
  apply: nilpotent_sol; exact: abelian_nil.
apply: subset_trans (centS (subsetIl _ _)); apply: subset_trans abel.
by rewrite commg_subl.
Qed.

Definition stabn (A:{set T}) (G G1:{group T}):=
  (G1 <| G) && (A \subset 'N(G1)) && (A/G1 \subset 'C(G/G1)).

Definition stabn_seq A G s:= path (stabn A) G s && (last (unit_group T) (G::s) == (unit_group T)).

Theorem stabn_seq_cent: forall (A G: {group T}) s,
coprime #|G| #|A| -> solvable G -> stabn_seq A G s -> A \subset 'C(G).
Proof.
move => A G s; rewrite /stabn_seq; move: G.
elim: s => [G1 _ _|G1 t indh G cop solv] /=; first by move/eqP->; rewrite cents1.
rewrite /=. case/andP. case/andP. case /andP. case /andP.
move=> G1nG AnG1 subC ph lh.
have subC1: A \subset 'C(G1).
  apply: indh; last by apply/andP; split.
  - by have G1sG := normal_sub G1nG; rewrite -(LaGrange G1sG) coprime_mull in cop; case/andP: cop.
  - by apply: (solvableS (normal_sub G1nG)).
have lem: G \subset G1 * 'C_G(A).
  rewrite -quotientSK; last by apply:normal_norm.
  rewrite coprime_quotient_cent_weak; last done; last done; last done; last done.
  by rewrite subsetI; apply/andP; split; first done; rewrite centsC.
have lem2: G1 * 'C_G(A) \subset 'C(A).
  apply: mul_subG; first by rewrite centsC. by apply: subsetIr.
by rewrite centsC; apply: (subset_trans lem lem2).
Qed.

(* B+G Prop 1.09 *)
Theorem faithful_cent_fix_nil : forall A G: {group T},
    A \subset 'N(G) -> coprime #|G| #|A| -> nilpotent G ->
  'C_G('C_G(A)) \subset 'C(A) -> G \subset 'C(A).
Proof.
move=> A G subN co nil subC.
suff AsubCNC: A \subset 'C('N_G('C_G(A))).
  apply/setIidPl; symmetry; apply: nilpotent_sub_norm; rewrite ?subsetIl //.
  by rewrite subsetI subsetIl centsC AsubCNC.
suff stab: stabn_seq A 'N_G('C_G(A)) [:: 'C_G(A)%G ; 1%G].
apply: stabn_seq_cent _ _ stab.
  by rewrite -(LaGrange (subsetIl G 'N('C_G(A)))) coprime_mull in co; case/andP: co.
  by apply: nilpotent_sol; apply: (nilpotentS _ nil); rewrite subsetIl.
apply/andP; split; last done.
have AsubNC: A \subset 'N('C_G(A)) by rewrite normsI ?norms_cent ?normG.
rewrite /stabn /= andbT; apply/andP; split.
  rewrite /stabn AsubNC /(_ <| _) subsetIr subsetI subsetIl /= normG /=.
  apply: quotient_cents2r.
  rewrite gen_subG; apply/subsetP=> ax; case/imset2P=> a x Aa Nx ->{ax}.
  case/setIP: Nx => Gx Nx.
  have subCG: 'C_G('C_G(A)) \subset 'C_G(A) by rewrite subsetI subC subsetIl //.
  apply: (subsetP subCG); rewrite inE commgEr groupMr // memJ_norm ?(subsetP subN, groupV) // Gx.
  apply/centP=> y Cy.
  rewrite /commute -mulgA (conjgCV x y) 2!mulgA; congr (_ * _).
  have Cyx: y ^ x^-1 \in 'C_G(A) by rewrite -mem_conjg (normP Nx).
  have Cfixa: forall z, z \in 'C_G(A) -> z ^ a = z.
    by move=> z; case/setIP=> _ Cz; rewrite conjgE (centP Cz) ?mulKg.
  by rewrite -{2}(Cfixa y Cy) -(Cfixa _ Cyx) -!conjMg -conjgC.
rewrite /(_ <| _) sub1G norm1 !subsetT /= quotient_cents2r //.
by rewrite (sameP trivgP commG1P) centsC subsetIr.
Qed.

Lemma not_dvdn_partn1: forall n p,
  0 < n -> prime p -> ~ (p %| n) -> n`_p = 1%N.
Proof.
move=> n p npos pr; move/negP=> nd.
by rewrite p_part lognE npos pr //= (negbET nd).
Qed.

Lemma divp_pgroup_p: forall G: {group T}, forall p d, 1 < d -> prime p ->
  p.-group G -> d %| #|G| -> pdiv d = p.
Proof.
move=> G p d lt1d pr; move/pgroupP=> pG dG; apply/eqP; apply: pG.
  exact: prime_pdiv.
exact: dvdn_trans (dvdn_pdiv _) dG.
Qed.

Lemma card_pgroup_p: forall (G : {group T}) p,
  prime p -> p.-group G -> #|G| = #|G|`_p.
Proof. by move=> G p _ pG; rewrite part_pnat. Qed.

Lemma dvdn_sub_primes: forall d n: nat, 0 < n ->
  d %| n -> {subset primes d <= primes n}.
Proof.
move=> d n lt0n dvd m; rewrite !mem_primes lt0n; case/and3P=> -> _ /= dvm.
exact: dvdn_trans dvd.

Qed.

Lemma pgroup_coprime: forall A H : {group T}, forall p : nat, prime p ->
  p.-group A ->  ~ p %| #|H| -> coprime #|A| #|H|.
Proof.
move=> A H p pr; case/p_natP=> // k ->; move/negP; rewrite -prime_coprime //.
exact: coprime_expl.
Qed.

Lemma pgroup_quotient_normal_inv : forall A G H : {group T}, forall p : nat,
  prime p -> p.-group A -> A \subset G -> H <| G -> ~ p %| #|H| ->
  forall x, x \in 'N(H) -> x \in G -> coset H x \in 'N(A / H) ->
  x \in 'N_G(A) * H.
Proof.
move=> A G H p pr pg AsubG normH pndvdn x Nx Gx xbin.
suff exz: exists2 z, z \in A * H & A :^ x :=: A :^ z.
  case exz=> z; case/imset2P=> a y ain yin  ->.
  rewrite //= conjsgM (conjsgE _ a) rcoset_id // lcoset_id ?groupVr // => eqyx.
  rewrite -(mulgKV y x) mem_imset2 //.
  have yinG: y \in G by apply: (subsetP (normal_sub normH) _ yin).
  rewrite inE groupM ?groupVr //=.
  by apply/normP; rewrite conjsgM eqyx conjsgK.
rewrite -norm_mulgenEl; last by apply: (subset_trans AsubG (normal_norm normH)).
suff sylowA: p.-Sylow(A <*> H) A.
  apply: (Sylow_trans sylowA).
  suff xnormAH : x \in 'N(A <*> H) by rewrite /= -(normP xnormAH) pHallJ2.
  have nAH : A \subset 'N(H) by apply: subset_trans (normal_norm normH).
  rewrite mulgenC norm_mulgenEr // -quotientK //.
  by rewrite (subsetP (morphpre_norm _ _)) ?mem_morphpre.
rewrite pHallE sub_gen ?subsetUl //= norm_mulgenEl; last by apply: (subset_trans AsubG (normal_norm normH)).
have co: coprime #|A| #|H| by apply: (pgroup_coprime pr).
rewrite coprime_cardMg // partn_mul ?ltn_0mul ?ltn_0group //=.
rewrite (@not_dvdn_partn1 #|H|); rewrite //=; last by apply: ltn_0group.
by rewrite muln1; apply/eqP; apply: card_pgroup_p.
Qed.

Lemma pgroup_quotient_normal : forall A G H: {group T}, forall p:nat, prime p ->
    p.-group A -> A \subset G -> H <| G -> ~ p %| #|H| ->
  'N_G(A) / H = 'N_(G / H)(A / H).
move => A G H p pr pgroupA AsubG normH co.
apply/eqP; rewrite eqEsubset subsetI morphimS ?subsetIl //= morphim_norms ?morphimS ?subsetIr //=.
apply/subsetP=> xb; case/setIP; rewrite quotientE; case /morphimP=> x Nx Gx -> xbin.
rewrite -quotient_mulg; apply/imsetP; exists x; rewrite // inE Nx /=.
apply: (pgroup_quotient_normal_inv pr); rewrite //.
Qed.

Lemma pgroup_quotient_central : forall A G H: {group T}, forall p:nat, prime p ->
    p.-group A -> A \subset G -> H <| G -> ~ p %| #|H| ->
  'C_G(A) / H = 'C_(G / H)(A / H).
Proof.
move => A G H p pr pgroupA AsubG normH pndivn.
apply/eqP; rewrite eqEsubset subsetI morphimS ?subsetIl //=.
rewrite morphim_cents ?morphimS ?subsetIr //=.
apply/subsetP=> xb; case/setIP.
rewrite quotientE; case /morphimP=> x Nx Gx -> xbin.
rewrite -quotient_mulg; apply/imsetP; exists x; rewrite // inE Nx /=.
have nHA: A \subset 'N(H) by apply: subset_trans AsubG _; case/andP: normH.
suff subC: coset H @*^-1 'C_(G / H)(A / H) :&: 'N_G(A) \subset 'C_G(A).
  apply: (subsetP (mulSg _ subC)); rewrite group_modr ?in_setI; rewrite ?Nx //=.
  - rewrite inE in_setI xbin -andbA /=; apply/andP; split.
    by apply/imsetP; exists x; rewrite ?in_setI ?Nx.
    by apply: (pgroup_quotient_normal_inv pr); rewrite //; apply: (subsetP (cent_sub _)).
  - have lem: H \subset coset H @*^-1 ('C_G(A) / H).
      by rewrite morphimK ?ker_coset ?mulG_subl ?(subset_trans (subsetIl _ _)) ?normal_norm.
    apply: (subset_trans lem); apply: morphpreS.
    by rewrite subsetI morphimS ?subsetIl ?morphim_cents ?subsetIr.
rewrite subsetI {1}subIset ?subsetIl ?orbT {x Nx Gx xbin}//=.
have co: coprime #|H| #|A| by rewrite coprime_sym; apply: (pgroup_coprime pr).
rewrite (sameP commG1P trivgP) -(coprime_TIg co).
rewrite subsetI commg_subr /= {2}setIA subsetIr andbT.
apply: subset_trans (commSg _ (subsetIl _ _)) _.
by rewrite -quotient_cents2 ?subsetIl // cosetpreK subsetIr.
Qed.

End coprime_comm.


(* generated by Ott 0.31, locally-nameless lngen from: ../spec/rules.ott *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition i : Set := nat.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top *)
 | t_arrow (A:typ) (B:typ) (*r function types *)
 | t_and (A:typ) (B:typ) (*r intersection *)
 | t_rcd (l:i) (A:typ) (*r record *).

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_top : exp (*r top *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (A:typ) (e:exp) (B:typ) (*r abstractions *)
 | e_fixpoint (e:exp) (A:typ) (*r fixpoint *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_merge (e1:exp) (e2:exp) (*r merge *)
 | e_anno (e:exp) (A:typ) (*r annotation *)
 | e_rcd (l:i) (e:exp) (*r record *)
 | e_proj (e:exp) (l:i) (*r projection *).

Inductive vl : Set :=  (*r value or projection label *)
 | vl_exp (v:exp)
 | vl_la (l:i).

Definition ctx : Set := list ( atom * typ ).

Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (open_exp_wrt_exp_rec (S k) e_5 e) B
  | (e_fixpoint e A) => e_fixpoint (open_exp_wrt_exp_rec (S k) e_5 e) A
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
  | (e_rcd l e) => e_rcd l (open_exp_wrt_exp_rec k e_5 e)
  | (e_proj e l) => e_proj (open_exp_wrt_exp_rec k e_5 e) l
end.

Definition open_vl_wrt_exp_rec (k:nat) (e5:exp) (vl5:vl) : vl :=
  match vl5 with
  | (vl_exp v) => vl_exp (open_exp_wrt_exp_rec k e5 v)
  | (vl_la l) => vl_la l
end.

Definition open_vl_wrt_exp e5 vl5 := open_vl_wrt_exp_rec 0 vl5 e5.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

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

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_top :
     (lc_exp e_top)
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (A:typ) (e:exp) (B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs A e B))
 | lc_e_fixpoint : forall (e:exp) (A:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_fixpoint e A))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_merge : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_merge e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A))
 | lc_e_rcd : forall (l:i) (e:exp),
     (lc_exp e) ->
     (lc_exp (e_rcd l e))
 | lc_e_proj : forall (e:exp) (l:i),
     (lc_exp e) ->
     (lc_exp (e_proj e l)).

(* defns LC_vl *)
Inductive lc_vl : vl -> Prop :=    (* defn lc_vl *)
 | lc_vl_exp : forall (v:exp),
     (lc_exp v) ->
     (lc_vl (vl_exp v))
 | lc_vl_la : forall (l:i),
     (lc_vl (vl_la l)).
(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | e_top => {}
  | (e_lit i5) => {}
  | (e_abs A e B) => (fv_exp e)
  | (e_fixpoint e A) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_merge e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
  | (e_rcd l e) => (fv_exp e)
  | (e_proj e l) => (fv_exp e)
end.

Definition fv_vl (vl5:vl) : vars :=
  match vl5 with
  | (vl_exp v) => (fv_exp v)
  | (vl_la l) => {}
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (subst_exp e_5 x5 e) B
  | (e_fixpoint e A) => e_fixpoint (subst_exp e_5 x5 e) A
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_merge e1 e2) => e_merge (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
  | (e_rcd l e) => e_rcd l (subst_exp e_5 x5 e)
  | (e_proj e l) => e_proj (subst_exp e_5 x5 e) l
end.

Definition subst_vl (e5:exp) (x5:var) (vl5:vl) : vl :=
  match vl5 with
  | (vl_exp v) => vl_exp (subst_exp e5 x5 v)
  | (vl_la l) => vl_la l
end.

(** definitions *)

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | value_unit :
     value e_top
 | value_lit : forall (i5:i),
     value (e_lit i5)
 | value_anno : forall (A:typ) (e:exp) (B:typ),
     lc_exp (e_abs A e B) ->
     value (e_abs A e B)
 | value_merge : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     value (e_merge v1 v2)
 | value_rcd : forall (l:i) (v:exp),
     value v ->
     value (e_rcd l v).

(* defns TopLikeType *)
Inductive topLike : typ -> Prop :=    (* defn topLike *)
 | TL_top :
     topLike t_top
 | TL_and : forall (A B:typ),
     topLike A ->
     topLike B ->
     topLike (t_and A B)
 | TL_arr : forall (A B:typ),
     topLike B ->
     topLike (t_arrow A B)
 | TL_rcd : forall (l:i) (B:typ),
     topLike B ->
     topLike (t_rcd l B).

(* defns SplitType *)
Inductive spl : typ -> typ -> typ -> Prop :=    (* defn spl *)
 | Sp_and : forall (A B:typ),
     spl  (t_and A B)   A   B
 | Sp_arrow : forall (A B C D:typ),
     spl B C D ->
     spl  (t_arrow A B)   (t_arrow A C)   (t_arrow A D)
 | Sp_rcd : forall (l:i) (B C D:typ),
     spl B C D ->
     spl (t_rcd l B) (t_rcd l C) (t_rcd l D).

(* defns OrdinaryType *)
Inductive ord : typ -> Prop :=    (* defn ord *)
 | O_top :
     ord t_top
 | O_int :
     ord t_int
 | O_arrow : forall (A B:typ),
     ord B ->
     ord (t_arrow A B)
 | O_rcd : forall (l:i) (B:typ),
     ord B ->
     ord (t_rcd l B).

(* defns Disjoint *)
Inductive disjoint : typ -> typ -> Prop :=    (* defn disjoint *)
 | D_topL : forall (A:typ),
     disjoint t_top A
 | D_topR : forall (A:typ),
     disjoint A t_top
 | D_andL : forall (A1 A2 B:typ),
     disjoint A1 B ->
     disjoint A2 B ->
     disjoint (t_and A1 A2) B
 | D_andR : forall (A B1 B2:typ),
     disjoint A B1 ->
     disjoint A B2 ->
     disjoint A (t_and B1 B2)
 | D_IntArr : forall (A1 A2:typ),
     disjoint t_int (t_arrow A1 A2)
 | D_ArrInt : forall (A1 A2:typ),
     disjoint (t_arrow A1 A2) t_int
 | D_ArrArr : forall (A1 A2 B1 B2:typ),
     disjoint A2 B2 ->
     disjoint (t_arrow A1 A2) (t_arrow B1 B2)
 | D_rcdEq : forall (l:i) (A B:typ),
     disjoint A B ->
     disjoint (t_rcd l A) (t_rcd l B)
 | D_rcdNeq : forall (l1:i) (A:typ) (l2:i) (B:typ),
      l1  <>  l2  ->
     disjoint (t_rcd l1 A) (t_rcd l2 B)
 | D_IntRcd : forall (l:i) (A:typ),
     disjoint t_int (t_rcd l A)
 | D_RcdInt : forall (l:i) (A:typ),
     disjoint (t_rcd l A) t_int
 | D_ArrRcd : forall (A1 A2:typ) (l:i) (A:typ),
     disjoint (t_arrow A1 A2) (t_rcd l A)
 | D_RcdArr : forall (l:i) (A A1 A2:typ),
     disjoint (t_rcd l A) (t_arrow A1 A2).

(* defns OriginalBCDDeclarativeSubtyping *)
Inductive original_bcd_sub : typ -> typ -> Prop :=    (* defn original_bcd_sub *)
 | OS_refl : forall (A:typ),
     original_bcd_sub A A
 | OS_trans : forall (A C B:typ),
     original_bcd_sub A B ->
     original_bcd_sub B C ->
     original_bcd_sub A C
 | OS_top : forall (A:typ),
     original_bcd_sub A t_top
 | OS_topArr :
     original_bcd_sub t_top (t_arrow t_top t_top)
 | OS_topRcd : forall (l:i),
     original_bcd_sub t_top (t_rcd l t_top)
 | OS_arr : forall (A C B D:typ),
     original_bcd_sub B A ->
     original_bcd_sub C D ->
     original_bcd_sub (t_arrow A C) (t_arrow B D)
 | OS_and : forall (A B C:typ),
     original_bcd_sub A B ->
     original_bcd_sub A C ->
     original_bcd_sub A (t_and B C)
 | OS_andl : forall (A B:typ),
     original_bcd_sub (t_and A B) A
 | OS_andr : forall (A B:typ),
     original_bcd_sub (t_and A B) B
 | OS_distArr : forall (A B C:typ),
     original_bcd_sub (t_and  (t_arrow A B)   (t_arrow A C) ) (t_arrow A (t_and B C))
 | OS_rcd : forall (l:i) (A B:typ),
     original_bcd_sub A B ->
     original_bcd_sub (t_rcd l A) (t_rcd l B)
 | OS_distRcd : forall (l:i) (A B:typ),
     original_bcd_sub (t_and (t_rcd l A) (t_rcd l B)) (t_rcd l (t_and A B)).

(* defns AlgorithmicSubtyping *)
Inductive algo_sub : typ -> typ -> Prop :=    (* defn algo_sub *)
 | S_int :
     algo_sub t_int t_int
 | S_top : forall (A B:typ),
     ord B ->
     topLike B ->
     algo_sub A B
 | S_andl : forall (A B C:typ),
     ord C ->
     algo_sub A C ->
     algo_sub (t_and A B) C
 | S_andr : forall (A B C:typ),
     ord C ->
     algo_sub B C ->
     algo_sub (t_and A B) C
 | S_arr : forall (A C B D:typ),
     ord D ->
     algo_sub B A ->
     algo_sub C D ->
     algo_sub (t_arrow A C) (t_arrow B D)
 | S_rcd : forall (l:i) (C D:typ),
     ord D ->
     algo_sub C D ->
     algo_sub (t_rcd l C) (t_rcd l D)
 | S_and : forall (A D B C:typ),
     spl D B C ->
     algo_sub A B ->
     algo_sub A C ->
     algo_sub A D.

(* defns ModularSubtyping *)
Inductive msub : typ -> typ -> Prop :=    (* defn msub *)
 | MS_int :
     msub t_int t_int
 | MS_top : forall (A B:typ),
     topLike B ->
     msub A B
 | MS_andl : forall (A B C:typ),
     msub A C ->
     msub (t_and A B) C
 | MS_andr : forall (A B C:typ),
     msub B C ->
     msub (t_and A B) C
 | MS_arr : forall (A C B D:typ),
     msub B A ->
     msub C D ->
     msub (t_arrow A C) (t_arrow B D)
 | MS_rcd : forall (l:i) (C D:typ),
     msub C D ->
     msub (t_rcd l C) (t_rcd l D)
 | MS_and : forall (A D B C:typ),
     spl D B C ->
     msub A B ->
     msub A C ->
     msub A D.

(* defns SubSubtyping *)
Inductive subsub : typ -> typ -> Prop :=    (* defn subsub *)
 | SubSub_z : forall (A:typ),
     subsub A A
 | SubSub_arr : forall (A1 A2 B1 B2:typ),
     algo_sub B1 A1 ->
     subsub A2 B2 ->
     subsub (t_arrow A1 A2) (t_arrow B1 B2)
 | SubSub_rcd : forall (l:i) (A B:typ),
     subsub A B ->
     subsub (t_rcd l A) (t_rcd l B)
 | SubSub_top : forall (A:typ),
     ord A ->
     topLike A ->
     subsub t_top A
 | SubSub_split : forall (A B A1 A2 B1 B2:typ),
     spl A A1 A2 ->
     spl B B1 B2 ->
     subsub A1 B1 ->
     subsub A2 B2 ->
     subsub A B.

(* defns ConvertToArrowType *)
Inductive arrTyp : typ -> typ -> Prop :=    (* defn arrTyp *)
 | AT_arr : forall (A B:typ),
     arrTyp (t_arrow A B) (t_arrow A B)
 | AT_topArr :
     arrTyp t_top (t_arrow t_top t_top)
 | AT_andArr : forall (A B A1 B1 A2 B2:typ),
     arrTyp A (t_arrow A1 A2) ->
     arrTyp B (t_arrow B1 B2) ->
     arrTyp (t_and A B) (t_arrow (t_and A1 B1) (t_and A2 B2))
 | AT_rcd : forall (l:i) (A:typ),
     arrTyp (t_rcd l A) (t_rcd l A)
 | AT_topRcd : forall (l:i),
     arrTyp t_top (t_rcd l t_top)
 | AT_andRcd : forall (A B:typ) (l:i) (A2 B2:typ),
     arrTyp A (t_rcd l A2) ->
     arrTyp B (t_rcd l B2) ->
     arrTyp (t_and A B) (t_rcd l (t_and A2 B2)).

(* defns TypedReduction *)
Inductive TypedReduce : exp -> typ -> exp -> Prop :=    (* defn TypedReduce *)
 | TReduce_refl : forall (i5:i),
     TypedReduce (e_lit i5) t_int (e_lit i5)
 | TReduce_top : forall (v:exp) (A:typ),
     lc_exp v ->
     ord A ->
     topLike A ->
     TypedReduce v A e_top
 | TReduce_arrow : forall (A:typ) (e:exp) (B C D:typ),
     lc_exp (e_abs A e B) ->
     ord D ->
      not ( topLike D )  ->
     algo_sub C A ->
     algo_sub B D ->
     TypedReduce (e_abs A e B)  (t_arrow C D)  (e_abs A e D)
 | TReduce_rcd : forall (l:i) (v:exp) (A:typ) (v':exp),
     ord A ->
      not ( topLike A )  ->
     TypedReduce v A v' ->
     TypedReduce (e_rcd l v) (t_rcd l A) (e_rcd l v')
 | TReduce_mergevl : forall (v1 v2:exp) (A:typ) (v1':exp),
     lc_exp v2 ->
     ord A ->
     TypedReduce v1 A v1' ->
     TypedReduce (e_merge v1 v2) A v1'
 | TReduce_mergevr : forall (v1 v2:exp) (A:typ) (v2':exp),
     lc_exp v1 ->
     ord A ->
     TypedReduce v2 A v2' ->
     TypedReduce (e_merge v1 v2) A v2'
 | TReduce_and : forall (v:exp) (A:typ) (v1 v2:exp) (B C:typ),
     spl A B C ->
     TypedReduce v B v1 ->
     TypedReduce v C v2 ->
     TypedReduce v A (e_merge v1 v2).

(* defns ParallelApplication *)
Inductive papp : exp -> vl -> exp -> Prop :=    (* defn papp *)
 | Papp_abs : forall (A:typ) (e:exp) (B:typ) (v v':exp),
     lc_exp (e_abs A e B) ->
     TypedReduce v A v' ->
     papp (e_abs A e B) (vl_exp v) (e_anno  (  (open_exp_wrt_exp  e v' )  )  B)
 | Papp_proj : forall (l:i) (v:exp),
     lc_exp v ->
     papp (e_rcd l v) (vl_la l) v
 | Papp_top : forall (vl5:vl),
     lc_vl vl5 ->
     papp e_top vl5 e_top
 | Papp_merge : forall (v1 v2:exp) (vl5:vl) (e1 e2:exp),
     papp v1 vl5 e1 ->
     papp v2 vl5 e2 ->
     papp (e_merge v1 v2) vl5 (e_merge e1 e2).

(* defns Reduction *)
Inductive step : exp -> exp -> Prop :=    (* defn step *)
 | Step_papp : forall (v1 v2 e:exp),
     value v1 ->
     value v2 ->
     papp v1 (vl_exp v2) e ->
     step (e_app v1 v2) e
 | Step_pproj : forall (v:exp) (l:i) (v':exp),
     value v ->
     papp v (vl_la l) v' ->
     step (e_proj v l) v'
 | Step_annov : forall (v:exp) (A:typ) (v':exp),
     value v ->
     TypedReduce v A v' ->
     step (e_anno v A) v'
 | Step_appl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_app e1 e2) (e_app e1' e2)
 | Step_appr : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_app v1 e2) (e_app v1 e2')
 | Step_merge : forall (e1 e2 e1' e2':exp),
     step e1 e1' ->
     step e2 e2' ->
     step (e_merge e1 e2) (e_merge e1' e2')
 | Step_mergel : forall (e1 v2 e1':exp),
     value v2 ->
     step e1 e1' ->
     step (e_merge e1 v2) (e_merge e1' v2)
 | Step_merger : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_merge v1 e2) (e_merge v1 e2')
 | Step_anno : forall (e:exp) (A:typ) (e':exp),
     step e e' ->
     step (e_anno e A) (e_anno e' A)
 | Step_fix : forall (e:exp) (A:typ),
     lc_exp (e_fixpoint e A) ->
     step (e_fixpoint e A) (e_anno  (open_exp_wrt_exp  e (e_fixpoint e A) )  A)
 | Step_rcd : forall (l:i) (e e':exp),
     step e e' ->
     step (e_rcd l e) (e_rcd l e')
 | Step_proj : forall (e:exp) (l:i) (e':exp),
     step e e' ->
     step (e_proj e l) (e_proj e' l).

(* defns PreValues *)
Inductive prevalue : exp -> Prop :=    (* defn prevalue *)
 | PV_val : forall (v:exp),
     value v ->
     prevalue v
 | PV_anno : forall (e:exp) (A:typ),
     lc_exp e ->
     prevalue (e_anno e A)
 | PV_rcd : forall (l:i) (u:exp),
     prevalue u ->
     prevalue (e_rcd l u)
 | PV_merge : forall (u1 u2:exp),
     prevalue u1 ->
     prevalue u2 ->
     prevalue (e_merge u1 u2).

(* defns PrincipalType *)
Inductive pType : exp -> typ -> Prop :=    (* defn pType *)
 | PT_top :
     pType e_top t_top
 | PT_int : forall (i5:i),
     pType (e_lit i5) t_int
 | PT_lam : forall (A:typ) (e:exp) (B:typ),
     lc_exp (e_abs A e B) ->
     pType  ( (e_abs A e B) )   (t_arrow A B)
 | PT_rcd : forall (l:i) (u:exp) (A:typ),
     pType u A ->
     pType (e_rcd l u) (t_rcd l A)
 | PT_anno : forall (e:exp) (A:typ),
     lc_exp e ->
     pType  ( (e_anno e A) )  A
 | PT_merge : forall (u1 u2:exp) (A B:typ),
     pType u1 A ->
     pType u2 B ->
     pType  ( (e_merge u1 u2) )   (t_and A B) .

(* defns Consistent *)
Inductive consistent : exp -> exp -> Prop :=    (* defn consistent *)
 | C_lit : forall (i5:i),
     consistent (e_lit i5) (e_lit i5)
 | C_abs : forall (A:typ) (e:exp) (B1 B2:typ),
     lc_exp (e_abs A e B1) ->
     consistent (e_abs A e B1) (e_abs A e B2)
 | C_anno : forall (e:exp) (A B:typ),
     lc_exp e ->
     consistent (e_anno e A) (e_anno e B)
 | C_rcd : forall (l:i) (u1 u2:exp),
     consistent u1 u2 ->
     consistent (e_rcd l u1) (e_rcd l u2)
 | C_disjoint : forall (u1 u2:exp) (A B:typ),
     pType u1 A ->
     pType u2 B ->
     disjoint A B ->
     prevalue u1 ->
     prevalue u2 ->
     consistent u1 u2
 | C_mergel : forall (u1 u2 u:exp),
     consistent u1 u ->
     consistent u2 u ->
     consistent (e_merge u1 u2) u
 | C_merger : forall (u u1 u2:exp),
     consistent u u1 ->
     consistent u u2 ->
     consistent u (e_merge u1 u2).

(* defns BidirectionalTyping *)
Inductive Typing : ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | Typ_top : forall (G:ctx),
      uniq  G  ->
     Typing G e_top Inf t_top
 | Typ_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Typing G (e_lit i5) Inf t_int
 | Typ_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Typing G (e_var_f x) Inf A
 | Typ_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B )  ->
     Typing G (e_abs A e B) Inf (t_arrow A B)
 | Typ_app : forall (G:ctx) (e1 e2:exp) (C A B:typ),
     Typing G e1 Inf A ->
     arrTyp A (t_arrow B C) ->
     Typing G e2 Chk B ->
     Typing G (e_app e1 e2) Inf C
 | Typ_proj : forall (G:ctx) (e:exp) (l:i) (C A:typ),
     Typing G e Inf A ->
     arrTyp A (t_rcd l C) ->
     Typing G (e_proj e l) Inf C
 | Typ_rcd : forall (G:ctx) (l:i) (e:exp) (A:typ),
     Typing G e Inf A ->
     Typing G (e_rcd l e) Inf (t_rcd l A)
 | Typ_merge : forall (G:ctx) (e1 e2:exp) (A B:typ),
     Typing G e1 Inf A ->
     Typing G e2 Inf B ->
     disjoint A B ->
     Typing G (e_merge e1 e2) Inf (t_and A B)
 | Typ_anno : forall (G:ctx) (e:exp) (A:typ),
     Typing G e Chk A ->
     Typing G  ( (e_anno e A) )  Inf A
 | Typ_fix : forall (L:vars) (G:ctx) (e:exp) (A:typ),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk A )  ->
     Typing G (e_fixpoint e A) Inf A
 | Typ_mergev : forall (G:ctx) (u1 u2:exp) (A B:typ),
      uniq  G  ->
     Typing  nil  u1 Inf A ->
     Typing  nil  u2 Inf B ->
     consistent u1 u2 ->
     Typing G (e_merge u1 u2) Inf (t_and A B)
 | Typ_sub : forall (G:ctx) (e:exp) (B A:typ),
     Typing G e Inf A ->
     algo_sub A B ->
     Typing G e Chk B.

(** infrastructure *)
Hint Constructors value topLike spl ord disjoint original_bcd_sub algo_sub msub subsub arrTyp TypedReduce papp step prevalue pType consistent Typing lc_exp lc_vl : core.


(* subs library for yalla *)

(* output in Type *)

(** * Substitutions in Linear Logic formulas and proofs *)

Require Import List_more.
Require Import Permutation_Type.
Require Import genperm_Type.

Require Export ll_def.

(** ** Decidable equality on [Atom], through value into [bool] *)
Definition ateq := yalla_ax.ateq.
Definition ateq_eq := yalla_ax.ateq_eq.

(** ** Substitutions *)

(** basic operation for substitution of atoms *)
Definition repl_at x y A := if ateq x y then A else var x.

Lemma repl_at_eq : forall x y A, x = y -> repl_at x y A = A.
Proof.
intros ; subst.
unfold repl_at.
rewrite (proj2 (ateq_eq _ _) (eq_refl _)).
reflexivity.
Qed.

Lemma repl_at_neq : forall x y A, x <> y -> repl_at x y A = var x.
Proof.
intros x y A Hneq.
unfold repl_at.
case_eq (ateq x y) ; intros Heqb ; try reflexivity.
exfalso.
rewrite ateq_eq in Heqb.
apply Hneq ; assumption.
Qed.

(** Substitution in [formula]: substitutes [x] by [C] in [A] *)
Fixpoint subs C x A :=
match A with
| var y     => repl_at y x C
| covar y   => dual (repl_at y x C)
| one       => one
| bot       => bot
| tens A B  => tens (subs C x A) (subs C x B)
| parr A B  => parr (subs C x A) (subs C x B)
| zero      => zero
| top       => top
| aplus A B => aplus (subs C x A) (subs C x B)
| awith A B => awith (subs C x A) (subs C x B)
| oc A      => oc (subs C x A)
| wn A      => wn (subs C x A)
end.

Lemma subs_dual : forall A C x, subs C x (dual A) = dual (subs C x A).
Proof with myeasy.
intros A C x.
induction A ; simpl ; rewrite ?bidual ; simpl ;
  try (rewrite IHA ; myeasy ; fail) ;
  try (rewrite IHA1 ; rewrite IHA2 ; myeasy ; fail)...
Qed.

(** Substitution in proofs *)

Lemma subs_ll {P} : forall A x l,
  ll P l ->
    ll (axupd_pfrag P (existT (fun x => x -> list formula) _
                            (fun a => map (subs A x) (projT2 (pgax P) a))))
       (map (subs A x) l).
Proof with myeeasy.
intros A x l pi.
assert
  (forall l, map (subs A x) (map wn l)
           = map wn (map (subs A x) l))
  as Hmapwn.
{ clear.
  induction l...
  simpl ; rewrite IHl... }
induction pi ; list_simpl ; try (now constructor).
- eapply ex_r ; [ apply ax_exp | apply PCperm_Type_swap ].
- eapply PCperm_Type_map in p.
  eapply ex_r...
- rewrite ? map_app in IHpi ; rewrite Hmapwn in IHpi ; rewrite Hmapwn.
  eapply Permutation_Type_map in p.
  eapply ex_wn_r...
- specialize Hmapwn with l.
  rewrite Hmapwn.
  apply oc_r.
  rewrite <- Hmapwn...
- eapply (cut_r _ (subs A x A0))...
  rewrite <- subs_dual...
- apply (gax_r (axupd_pfrag P (existT (fun x => x -> list formula) _
                      (fun a => map (subs A x) (projT2 (pgax P) a)))) a).
Unshelve. simpl...
Qed.

Lemma subs_ll_axfree {P} : (projT1 (pgax P) -> False) -> forall A x l,
  ll P l -> ll P (map (subs A x) l).
Proof with myeeasy.
intros P_axfree A x l pi.
apply (subs_ll A x) in pi.
eapply stronger_pfrag...
nsplit 5...
simpl ; intros a.
contradiction P_axfree.
Qed.

(** ** Fresh variables and associated properties *)
Section Fresh.

(** Embedding of [nat] into [Atom] *)
Variable a2n : Atom -> nat.
Variable n2a : nat -> Atom.
Hypothesis n2n : forall n, a2n (n2a n) = n.

Lemma a2n_is_n2a : forall a n, a = n2a n -> n = a2n a.
Proof.
intros a n Ha.
rewrite Ha.
rewrite n2n.
reflexivity.
Qed.

(** [nat] bigger than all [nat] associated with [Atom] in [A] *)
Fixpoint nat_fresh_of A :=
match A with
| var x     => S (a2n x)
| covar x   => S (a2n x)
| one       => 0
| bot       => 0
| tens B C  => nat_fresh_of B + nat_fresh_of C
| parr B C  => nat_fresh_of B + nat_fresh_of C
| zero      => 0
| top       => 0
| aplus B C => nat_fresh_of B + nat_fresh_of C
| awith B C => nat_fresh_of B + nat_fresh_of C
| oc B      => nat_fresh_of B
| wn B      => nat_fresh_of B
end.

(** Provide an [Atom] which is fresh for [A] *)
Definition fresh_of A := n2a (nat_fresh_of A).

Lemma subs_fresh_le : forall C A n, nat_fresh_of A <= n -> subs C (n2a n) A = A.
Proof with myeasy.
intros C A n Hle.
induction A ; simpl in Hle ; simpl ;
  try rewrite IHA ;
  try (rewrite IHA2 ; [ rewrite IHA1 | ]) ;
  simpl...
- rewrite repl_at_neq...
  intro Heq.
  apply a2n_is_n2a in Heq ; subst.
  inversion Hle...
- rewrite repl_at_neq...
  intro Heq.
  apply a2n_is_n2a in Heq ; subst.
  inversion Hle...
Qed.

Lemma subs_fresh : forall C A, subs C (fresh_of A) A = A.
Proof.
intros.
apply subs_fresh_le.
reflexivity.
Qed.

Definition nat_fresh_of_list l := list_max (map nat_fresh_of l).

Lemma nat_fresh_of_list_fresh : forall l,
  Forall (fun x => nat_fresh_of x <= nat_fresh_of_list l) l.
Proof with myeasy.
unfold nat_fresh_of_list.
induction l ; constructor ; simpl...
remember (map nat_fresh_of l) as k.
revert IHl ; clear ; induction l ;
  intros IHl' ; inversion IHl' ; subst ; constructor...
intuition.
Qed.

(** Provide an [Atom] which is fresh for all elements of [l] *)
Definition fresh_of_list l := n2a (nat_fresh_of_list l).

Lemma subs_fresh_list_le : forall C l n,
  nat_fresh_of_list l <= n -> map (subs C (n2a n)) l = l.
Proof with myeasy.
unfold nat_fresh_of_list.
intros C l n Hle.
induction l...
simpl in Hle ; simpl.
rewrite subs_fresh_le ; [ rewrite IHl | ]...
Qed.

Lemma subs_fresh_list : forall C l, map (subs C (fresh_of_list l)) l = l.
Proof.
intros.
apply subs_fresh_list_le.
reflexivity.
Qed.

End Fresh.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import Peano_dec.

Require Import ListExt.
Require Import folProof.
Require Import folLogic.
Require Import folProp.

Section Replacement.

Variable L : Language.
Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let var := var L.
Let apply := apply L.
Let equal := equal L.
Let atomic := atomic L.
Let impH := impH L.
Let notH := notH L.
Let forallH := forallH L.
Let orH := orH L.
Let andH := andH L.
Let existH := existH L.
Let iffH := iffH L.
Let ifThenElseH := ifThenElseH L.
Let SysPrf := SysPrf L.

Lemma reduceImp :
 forall (f1 f2 f3 f4 : Formula) (T : System),
 SysPrf T (iffH f1 f3) ->
 SysPrf T (iffH f2 f4) -> SysPrf T (iffH (impH f1 f2) (impH f3 f4)).
Proof.
assert
 (forall (f1 f2 f3 f4 : Formula) (T : System),
  SysPrf T (iffH f1 f3) ->
  SysPrf T (iffH f2 f4) -> SysPrf T (impH (impH f1 f2) (impH f3 f4))).
intros.
repeat apply (impI L).
apply impE with f2.
repeat apply sysWeaken.
apply (iffE1 L).
apply H0.
apply impE with f1.
apply sysWeaken.
apply Axm; right; constructor.
apply impE with f3.
repeat apply sysWeaken.
apply (iffE2 L).
apply H.
apply Axm; right; constructor.
intros.
apply (iffI L).
apply H; auto.
apply H; apply (iffSym L); auto.
Qed.

Lemma reduceNot :
 forall (f1 f2 : Formula) (T : System),
 SysPrf T (iffH f1 f2) -> SysPrf T (iffH (notH f1) (notH f2)).
Proof.
assert
 (forall (f1 f2 : Formula) (T : System),
  SysPrf T (iffH f1 f2) -> SysPrf T (impH (notH f1) (notH f2))).
intros.
apply (cp2 L).
apply (iffE2 L).
apply H.
intros.
apply (iffI L).
apply H.
assumption.
apply H.
apply (iffSym L).
assumption.
Qed.

Lemma impForall :
 forall (f1 f2 : Formula) (v : nat) (T : System),
 ~ In_freeVarSys _ v T ->
 SysPrf T (impH f1 f2) -> SysPrf T (impH (forallH v f1) (forallH v f2)).
Proof.
intros.
apply (impI L).
apply (forallI L).
unfold not in |- *; intros.
induction H1 as (x, H1); induction H1 as (H1, H2).
induction H2 as [x H2| x H2]; [ idtac | induction H2 ].
apply H.
unfold In_freeVarSys in |- *.
exists x.
auto.
apply (In_list_remove2 _ _ _ _ _ H1).
auto.
apply impE with f1.
apply sysWeaken.
apply H0.
eapply forallSimp.
apply Axm; right; constructor.
Qed.

Lemma reduceForall :
 forall (f1 f2 : Formula) (v : nat) (T : System),
 ~ In_freeVarSys _ v T ->
 SysPrf T (iffH f1 f2) -> SysPrf T (iffH (forallH v f1) (forallH v f2)).
Proof.
intros.
apply (iffI L).
apply impForall; auto.
apply (iffE1 L).
apply H0.
apply impForall; auto.
apply (iffE2 L).
apply H0.
Qed.

Lemma reduceOr :
 forall (f1 f2 f3 f4 : Formula) (T : System),
 SysPrf T (iffH f1 f3) ->
 SysPrf T (iffH f2 f4) -> SysPrf T (iffH (orH f1 f2) (orH f3 f4)).
Proof.
assert
 (forall (f1 f2 f3 f4 : Formula) (T : System),
  SysPrf T (iffH f1 f3) ->
  SysPrf T (iffH f2 f4) -> SysPrf T (impH (orH f1 f2) (orH f3 f4))).
intros.
apply (impI L).
apply (orSys L).
apply (orI1 L).
apply impE with f1.
apply sysWeaken.
apply (iffE1 L).
assumption.
apply Axm; right; constructor.
apply (orI2 L).
apply impE with f2.
apply sysWeaken.
apply (iffE1 L).
assumption.
apply Axm; right; constructor.
intros.
apply (iffI L).
apply H; auto.
apply H; apply (iffSym L); auto.
Qed.

Lemma reduceAnd :
 forall (f1 f2 f3 f4 : Formula) (T : System),
 SysPrf T (iffH f1 f3) ->
 SysPrf T (iffH f2 f4) -> SysPrf T (iffH (andH f1 f2) (andH f3 f4)).
Proof.
assert
 (forall (f1 f2 f3 f4 : Formula) (T : System),
  SysPrf T (iffH f1 f3) ->
  SysPrf T (iffH f2 f4) -> SysPrf T (impH (andH f1 f2) (andH f3 f4))).
intros.
apply (impI L).
apply (andI L).
apply impE with f1.
apply sysWeaken.
apply (iffE1 L).
assumption.
eapply (andE1 L).
apply Axm; right; constructor.
apply impE with f2.
apply sysWeaken.
apply (iffE1 L).
assumption.
eapply (andE2 L).
apply Axm; right; constructor.
intros.
apply (iffI L).
apply H; auto.
apply H; apply (iffSym L); auto.
Qed.

Lemma iffExist :
 forall (f1 f2 : Formula) (v : nat) (T : System),
 ~ In_freeVarSys _ v T ->
 SysPrf T (impH f1 f2) -> SysPrf T (impH (existH v f1) (existH v f2)).
Proof.
intros.
unfold existH, fol.existH in |- *.
apply (cp2 L).
apply impForall; auto.
apply (cp2 L).
apply H0.
Qed.

Lemma reduceExist :
 forall (f1 f2 : Formula) (v : nat) (T : System),
 ~ In_freeVarSys _ v T ->
 SysPrf T (iffH f1 f2) -> SysPrf T (iffH (existH v f1) (existH v f2)).
Proof.
intros.
unfold existH, fol.existH in |- *.
apply reduceNot.
apply reduceForall; auto.
apply reduceNot.
apply H0.
Qed.

Lemma reduceIff :
 forall (f1 f2 f3 f4 : Formula) (T : System),
 SysPrf T (iffH f1 f3) ->
 SysPrf T (iffH f2 f4) -> SysPrf T (iffH (iffH f1 f2) (iffH f3 f4)).
Proof.
assert
 (forall (f1 f2 f3 f4 : Formula) (T : System),
  SysPrf T (iffH f1 f3) ->
  SysPrf T (iffH f2 f4) -> SysPrf T (impH (iffH f1 f2) (iffH f3 f4))).
intros.
apply (impI L).
apply (iffTrans L) with f2.
apply (iffTrans L) with f1.
apply sysWeaken.
apply (iffSym L).
apply H.
apply Axm; right; constructor.
apply sysWeaken.
apply H0.
intros.
apply (iffI L).
apply H; auto.
apply H; apply (iffSym L); auto.
Qed.

Lemma reduceIfThenElse :
 forall (f1 f2 f3 f4 f5 f6 : Formula) (T : System),
 SysPrf T (iffH f1 f4) ->
 SysPrf T (iffH f2 f5) ->
 SysPrf T (iffH f3 f6) ->
 SysPrf T (iffH (ifThenElseH f1 f2 f3) (ifThenElseH f4 f5 f6)).
Proof.
intros.
unfold ifThenElseH, fol.ifThenElseH in |- *.
apply reduceAnd; apply reduceImp; auto.
apply reduceNot; auto.
Qed.

Lemma reduceSub :
 forall (T : System) (v : nat) (s : Term) (f g : Formula),
 ~ In_freeVarSys L v T ->
 SysPrf T (iffH f g) ->
 SysPrf T (iffH (substituteFormula L f v s) (substituteFormula L g v s)).
Proof.
assert
 (forall (T : System) (v : nat) (s : Term) (f g : Formula),
  ~ In_freeVarSys L v T ->
  SysPrf T (iffH f g) ->
  SysPrf T (impH (substituteFormula L f v s) (substituteFormula L g v s))).
intros.
rewrite <- (subFormulaImp L).
apply (forallE L).
apply forallI.
assumption.
apply (iffE1 L).
apply H0.
intros.
apply (iffI L).
apply H; auto.
apply H; auto.
apply (iffSym L).
auto.
Qed.

Lemma reduceCloseList :
 forall (l : list nat) (f1 f2 : Formula) (T : System),
 (forall v : nat, In v l -> ~ In_freeVarSys _ v T) ->
 SysPrf T (iffH f1 f2) ->
 SysPrf T (iffH (closeList L l f1) (closeList L l f2)).
Proof.
intro.
induction l as [| a l Hrecl]; simpl in |- *; intros.
apply H0.
apply reduceForall.
apply H.
auto.
apply Hrecl; auto.
Qed.

End Replacement.


(** * Typechecking: A Typechecker for STLC *)

(** The [has_type] relation of the STLC defines what it means for a
    term to belong to a type (in some context).  But it doesn't, by
    itself, tell us how to _check_ whether or not a term is well
    typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- they exactly follow the shape of the term.  This makes it
    straightforward to translate the typing rules into clauses of a
    typechecking _function_ that takes a term and a context and either
    returns the term's type or else signals that the term is not
    typable.  This short chapter constructs such a function and proves
    it correct. *)

Require Import Coq.Bool.Bool.
Require Import Maps.
Require Import Smallstep.
Require Import Stlc.

Module STLCChecker.
Import STLC.

(* ================================================================= *)
(** ** Comparing Types *)

(** First, we need a function to compare two types for equality... *)

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TBool, TBool =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [beq_ty] and the logical
    proposition that its inputs are equal. *)

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - (* T1=TBool *)
    reflexivity.
  - (* T1=TArrow T1_1 T1_2 *)
    rewrite andb_true_iff in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.

(* ================================================================= *)
(** ** The Typechecker *)

(** The typechecker works by walking over the structure of the given
    term, returning either [Some T] or [None].  Each time we make a
    recursive call to find out the types of the subterms, we need to
    pattern-match on the results to make sure that they are not
    [None].  Also, in the [tapp] case, we use pattern matching to
    extract the left- and right-hand sides of the function's arrow
    type (and fail if the type of the function is not [TArrow T11 T12]
    for some [T1] and [T2]). *)

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x => Gamma x
  | tabs x T11 t12 => match type_check (update Gamma x T11) t12 with
                          | Some T12 => Some (TArrow T11 T12)
                          | _ => None
                        end
  | tapp t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (TArrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  | ttrue => Some TBool
  | tfalse => Some TBool
  | tif x t f => match type_check Gamma x with
                     | Some TBool =>
                       match type_check Gamma t, type_check Gamma f with
                         | Some T1, Some T2 =>
                           if beq_ty T1 T2 then Some T1 else None
                         | _,_ => None
                       end
                     | _ => None
                   end
  end.

(* ================================================================= *)
(** ** Properties *)

(** To verify that this typechecking algorithm is correct, we show
    that it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* tvar *) eauto.
  - (* tapp *)
    remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct T1 as [|T11 T12]; try solve_by_invert.
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (beq_ty T11 T2) eqn: Heqb;
    try solve_by_invert.
    apply beq_ty__eq in Heqb.
    inversion H0; subst...
  - (* tabs *)
    rename i into y. rename t into T1.
    remember (update Gamma y T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve_by_invert.
    inversion H0; subst...
  - (* ttrue *) eauto.
  - (* tfalse *) eauto.
  - (* tif *)
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve_by_invert.
    destruct Tc; try solve_by_invert.
    destruct TO1 as [T1|]; try solve_by_invert.
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (beq_ty T1 T2) eqn:Heqb;
    try solve_by_invert.
    apply beq_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  induction Hty; simpl.
  - (* T_Var *) eauto.
  - (* T_Abs *) rewrite IHHty...
  - (* T_App *)
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
  - (* T_True *) eauto.
  - (* T_False *) eauto.
  - (* T_If *) rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (beq_ty_refl T)...
Qed.

End STLCChecker.

(** $Date: 2016-07-13 12:41:41 -0400 (Wed, 13 Jul 2016) $ *)


Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.TheoryOfSequentCalculus.

Local Open Scope logic_base.

Class BasicSequentCalculus (L: Language) (Gamma: Derivable L) := {
  deduction_weaken: forall Phi Psi x, Included _ Phi Psi -> Phi |--- x -> Psi |--- x;
  derivable_assum: forall Phi x, Ensembles.In _ Phi x -> Phi |--- x;
  deduction_subst: forall (Phi Psi: context) y, (forall x, Psi x -> Phi |--- x) -> Union _ Phi Psi |--- y -> Phi |--- y
}.

Class FiniteWitnessedSequentCalculus (L: Language) (Gamma: Derivable L) := {
  derivable_finite_witnessed: forall (Phi: context) (y: expr), Phi |--- y -> exists xs, Forall Phi xs /\ (fun x => In x xs) |--- y
}.

Section DerivableRulesFromSequentCalculus.

Context {L: Language}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}.

Lemma deduction_subst1: forall Phi x y, Phi |--- x -> Phi;; x |--- y -> Phi |--- y.
Proof.
  intros.
  apply deduction_subst with (Singleton _ x); auto.
  intros.
  inversion H1; subst.
  auto.
Qed.

Lemma derivable_trans: forall (Phi Psi: context) y, (forall x, Psi x -> Phi |--- x) -> Psi |--- y -> Phi |--- y.
Proof.
  intros.
  eapply deduction_subst; eauto.
  eapply deduction_weaken; eauto.
  apply right_Included_Union.
Qed.

Lemma deduction_weaken1: forall Phi x y,
  Phi |--- y ->
  Phi;; x |--- y.
Proof.
  intros.
  eapply deduction_weaken; eauto.
  intros ? ?; left; auto.
Qed.

Lemma derivable_assum1: forall (Phi: context) (x: expr), Phi;; x |--- x.
Proof.
  intros.
  apply derivable_assum.
  right; constructor.
Qed.

Lemma contextual_derivable_finite_witnessed {fwSC: FiniteWitnessedSequentCalculus L Gamma}: forall (Phi Psi: context) (y: expr), Union _ Phi Psi |--- y -> exists xs, Forall Psi xs /\ Union _ Phi (fun x => In x xs) |--- y.
Proof.
  apply DeductionWeaken_DerivableFiniteWitnessed_2_ContextualDerivableFiniteWitnessed.
  + hnf; intros; eapply deduction_weaken; eauto.
  + hnf; intros; eapply derivable_finite_witnessed; eauto.
Qed.

End DerivableRulesFromSequentCalculus.

Ltac solve_assum :=
  (first [apply derivable_assum1 | assumption | apply deduction_weaken1; solve_assum] || fail 1000 "Cannot find the conclusion in assumption").


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-03-19 (setoid)
- Adam Koprowski, 2007-04-14

* Semi-ring equipped with two (strict and non-strict) orders.

*)

Require Export SemiRing2.
Require Import Morphisms RelDec SN RelExtras2 NatUtil LogicUtil Max ZUtil
  RelUtil Min Setoid.

(***********************************************************************)
(** ** Semi-rings equipped with orders. *)

Section OrdSemiRingType.

  Variable e: Eqset.
  Variable s : SemiRingType e.

  Notation eqA := (eqA e).
  Notation "x =A= y" := (eqA x y) (at level 70).

  Notation Aplus := (Aplus e s).
  Notation "x + y " := (Aplus x y).

  Notation Amult := (Amult e s).
  Notation "x * y" := (Amult x y).

  Record OrdSemiRingType := mkOrdSemiRingType {
    gt : relation A;
    ge : relation A;

    eq_ge_compat : forall x y, x =A= y -> ge x y;
    ge_refl : reflexive ge;
    ge_trans : transitive ge;
    gt_trans : transitive gt;

    ge_dec : rel_dec ge;
    gt_dec : rel_dec gt;

    ge_gt_compat : forall x y z, ge x y -> gt y z -> gt x z;
    ge_gt_compat2 : forall x y z, gt x y -> ge y z -> gt x z;

    plus_gt_compat : forall m n m' n',
      gt m m' -> gt n n' -> gt (m + n) (m' + n');
    plus_ge_compat : forall m n m' n',
    ge m m' -> ge n n' -> ge (m + n) (m' + n');

    mult_ge_compat : forall m n m' n',
    ge m m' -> ge n n' -> ge (m * n) (m' * n')
  }.

  Hint Resolve ge_refl : arith.

End OrdSemiRingType.

Section OrdSemiRing.

  Variable e: Eqset.

  Variable s: SemiRingType e.

  Variable o : OrdSemiRingType e s.

  Notation eqA := (eqA e).

  Notation sid_theoryA := (sid_theoryA e).

  Notation ge := (ge e s o).
  Notation "x >>= y" := (ge x y) (at level 70).

  Notation ge_refl := (ge_refl e s o).

  Notation ge_trans := (ge_trans e s o).

  Add Setoid A eqA sid_theoryA as A_Setoid.

  Add Relation A ge
    reflexivity proved by ge_refl
    transitivity proved by ge_trans
      as ge_rel.

  Instance ge_mor : Proper (eqA ==> eqA ==> iff) ge.

  Proof.
    intros x y H x0 y0 H0. intuition.
    trans x. apply (eq_ge_compat e s).
    sym. hyp.
    trans x0. hyp. apply (eq_ge_compat e s). hyp.
    trans y. apply eq_ge_compat. hyp.
    trans y0. hyp. apply eq_ge_compat. sym. hyp.
  Qed.

  Notation gt := (gt e s o).
  Notation "x >> y" := (gt x y) (at level 70).

  Notation gt_trans := (gt_trans e s o).

  Add Relation A gt
    transitivity proved by gt_trans
      as gt_rel.

  Instance gt_mor : Proper (eqA ==> eqA ==> iff) gt.

  Proof.
    intros x y H x0 y0 H0.
    intuition. apply ge_gt_compat2 with x0. 2: apply eq_ge_compat; hyp.
    apply ge_gt_compat with x. apply eq_ge_compat. sym. hyp. hyp.
    apply ge_gt_compat2 with y0. 2: apply eq_ge_compat; sym; hyp.
    apply ge_gt_compat with y. apply eq_ge_compat. hyp. hyp.
  Qed.

End OrdSemiRing.

(***********************************************************************)
(** ** Natural numbers semi-rings with natural order. *)

Section NOrdSemiRingT.

  Definition gtN := Peano.gt.
  Definition geN := Peano.ge.

  Lemma eq_ge_compatp : forall x y, x = y -> x >= y.

  Proof.
    intros. subst. apply le_refl.
  Qed.

  Lemma ge_reflN : reflexive geN.

  Proof.
    intro m. unfold geN. auto with arith.
  Qed.

  Lemma ge_transN : transitive geN.

  Proof.
    intros m n p. unfold geN, Peano.ge. eauto with arith.
  Qed.

  Lemma ge_antisymN : antisymmetric geN.

  Proof.
    intros m n. unfold geN, Peano.ge. auto with arith.
  Qed.

  Definition gt_irrefl := Gt.gt_irrefl.

  Definition gt_transN := Gt.gt_trans.

  Definition ge_decN := ge_dec.

  Definition gt_decN := gt_dec.

  Lemma gt_WF : WF gtN.

  Proof.
    apply wf_transp_WF.
    apply well_founded_lt_compat with (fun x:nat => x). auto.
  Qed.

  Lemma ge_gt_compatN : forall x y z, x >= y -> y > z -> x > z.

  Proof.
    intros. apply le_gt_trans with y; hyp.
  Qed.

  Lemma ge_gt_compat2N : forall x y z, x > y -> y >= z -> x > z.

  Proof.
    intros. apply gt_le_trans with y; hyp.
  Qed.

  Lemma plus_gt_compatN : forall m n m' n',
    m > m' -> n > n' -> m + n > m' + n'.

  Proof.
    intros. omega.
  Qed.

  Lemma plus_gt_compat_lN : forall m n m' n',
    m > m' -> n >= n' -> m + n > m' + n'.

  Proof.
    intros. omega.
  Qed.

  Lemma plus_gt_compat_rN : forall m n m' n',
    m >= m' -> n > n' -> m + n > m' + n'.

  Proof.
    intros. omega.
  Qed.

  Lemma plus_ge_compatN : forall m n m' n',
    m >= m' -> n >= n' -> m + n >= m' + n'.

  Proof.
    intros. unfold Peano.ge.
    apply plus_le_compat; hyp.
  Qed.

  Lemma mult_ge_compatN : forall m n m' n',
    m >= m' -> n >= n' -> m * n >= m' * n'.

  Proof.
    intros. unfold Peano.ge.
    apply mult_le_compat; hyp.
  Qed.

End NOrdSemiRingT.

(***********************************************************************)
(** ** BigN natural numbers semi-rings with natural order. *)

Section BigNOrdSemiRingT.

  Open Local Scope bigN_scope.

  Require Import BigNUtil.

  Definition gtbn x y := BigN.lt y x.

  Definition gebn x y := BigN.le y x.

  Definition eqAbn := BigN.eq.

  Lemma eq_ge_compatbn : forall x y, eqAbn x y -> x >= y.

  Proof.
    intros x y. unfold eqAbn, gebn, BigN.eq, BigN.le. omega.
  Qed.

  Definition ge_reflbn := BigN.le_refl.

  Lemma ge_transbn : transitive gebn.

  Proof.
    intros m n p. unfold gebn, BigN.le. omega.
  Qed.

  Lemma gt_transbn : transitive gtbn.

  Proof.
    intros m n p. unfold gtbn, BigN.lt. omega.
  Qed.

  Lemma ge_decbn : forall x y, {gebn x y}+{~gebn x y}.

  Proof.
    intros x y. unfold gebn, BigN.le. destruct (Z_le_dec [y] [x]).
    left. omega. right. omega.
  Qed.

  Lemma gt_decbn : forall x y, {gtbn x y}+{~gtbn x y}.

  Proof.
    intros. unfold gtbn, BigN.lt. destruct (Z_lt_dec [y] [x]).
    left. omega. right. omega.
  Qed.

  Definition gt_WFbn := wf_transp_WF BigN.lt_wf_0.

  Lemma ge_gt_compatbn : forall x y z, gebn x y -> gtbn y z -> gtbn x z.

  Proof.
    intros x y z. unfold gebn, gtbn, BigN.le, BigN.lt. omega.
  Qed.

  Lemma ge_gt_compat2bn : forall x y z, gtbn x y -> gebn y z -> gtbn x z.

  Proof.
    intros x y z. unfold gtbn, BigN.lt, gebn, BigN.le. omega.
  Qed.

  Lemma plus_gt_compatbn :
    forall m n m' n', gtbn m m' -> gtbn n n' -> gtbn (m + n) (m' + n').

  Proof.
    intros m n m' n'. apply BigN.add_lt_mono; hyp.
  Qed.

  Lemma plus_gt_compat_lbn :
    forall m n m' n', gtbn m m' -> gebn n n' -> gtbn (m + n) (m' + n').

  Proof.
    intros. apply BigN.add_lt_le_mono; hyp.
  Qed.

  Lemma plus_gt_compat_rbn :
    forall m n m' n', gebn m m' -> gtbn n n' -> gtbn (m + n) (m' + n').

  Proof.
    intros. apply BigN.add_le_lt_mono; hyp.
  Qed.

  Lemma plus_ge_compatbn :
    forall m n m' n', gebn m m' -> gebn n n' -> gebn (m + n) (m' + n').

  Proof.
    intros. apply BigN.add_le_mono; hyp.
  Qed.

  Lemma mult_ge_compatbn :
    forall m n m' n', gebn m m' -> gebn n n' -> gebn (m * n) (m' * n').

  Proof.
    intros. apply BigN.mul_le_mono; hyp.
  Qed.

  Lemma mult_lt_compat_lrbn : forall i j k l,
    i <= j -> j > 0 -> k < l -> i * k < j * l.

  Proof.
    intros. case (bigN_le_gt_dec j i); intro.
    assert (i==j). apply BigN.le_antisymm; hyp. rewrite H2.
    rewrite <- (BigN.mul_lt_mono_pos_l _ _ _ H0). hyp.
    apply BigN.mul_lt_mono; hyp.
  Qed.

  Close Scope bigN_scope.

End BigNOrdSemiRingT.

(***********************************************************************)
(** ** Arctic ordered semi-ring. *)

Section ArticOrdSemiRingT.

  Open Scope nat_scope.

  Definition gtr m n :=
    match m, n with
    | MinusInf, _ => False
    | Pos _, MinusInf => True
    | Pos m, Pos n => m > n
    end.

  Definition ger m n := gtr m n \/ m = n.

  Lemma eq_ge_compatr : forall x y, x = y -> ger x y.

  Proof.
    unfold ger. intuition.
  Qed.

  Lemma gt_irreflr : irreflexive gtr.

  Proof.
    intros x xx. destruct x.
    unfold gtr in xx. omega.
    auto.
  Qed.

  Lemma gt_transr : transitive gtr.

  Proof.
    intros x y z xy yz.
    destruct x; destruct y; destruct z; try solve [ auto | contr ].
    simpl in *.
    omega.
  Qed.

  Lemma gt_asymr : forall x y, gtr x y -> ~gtr y x.

  Proof.
    intros x y xy.
    destruct x; destruct y; simpl in *; try solve [auto | omega].
  Qed.

  Lemma gt_decr : rel_dec gtr.

  Proof.
    unfold rel_dec. intros.
    unfold gtr.
    destruct x; destruct y; simpl; auto.
    destruct (NatUtil.gt_dec n n0) ; auto.
  Defined.

  Lemma gt_WFr : WF gtr.

  Proof.
    apply wf_transp_WF.
    apply well_founded_lt_compat with
      (fun x =>
        match x with
        | Pos x => x + 1
        | MinusInf => 0
        end).
    intros. destruct x; destruct y;
      solve [auto with arith | elimtype False; auto].
  Qed.

  Lemma ge_reflr : reflexive ger.

  Proof.
    intro m. right. trivial.
  Qed.

  Lemma ge_transr : transitive ger.

  Proof.
    intros x y z xy yz. destruct xy. destruct yz.
    left. apply (gt_transr x y z); hyp.
    subst y. left. hyp.
    subst x. hyp.
  Qed.

  Lemma ge_antisymr : antisymmetric ger.

  Proof.
    intros x y xy yx. destruct xy. destruct yx.
    absurd (gtr y x). apply gt_asymr. hyp. hyp.
    auto. hyp.
  Qed.

  Lemma ge_decr : rel_dec ger.

  Proof.
    intros x y. destruct (gt_decr x y).
    left. left. hyp.
    destruct (eqA_decr x y).
    left. right. hyp.
    right. intro xy. destruct xy; auto.
  Defined.

  Notation "x >>= y" := (ger x y) (at level 70).
  Notation "x >> y" := (gtr x y) (at level 70).

  Lemma ge_gt_eqr : forall x y, x >>= y -> x >> y \/ x = y.

  Proof.
    destruct 1; auto.
  Qed.

  Lemma ge_gt_compatr : forall x y z, x >>= y -> y >> z -> x >> z.

  Proof.
    intros. destruct y. destruct x. destruct z.
    unfold gtr, ger in *. destruct H.
    simpl in H. omega.
    injection H. intro. subst n0. hyp.
    auto.
    elimtype False. destruct H. auto. discr.
    elimtype False. destruct H. auto. subst x.  auto.
  Qed.

  Lemma ge_gt_compat2r : forall x y z, x >> y -> y >>= z -> x >> z.

  Proof.
    unfold ger, gtr. destruct x; destruct y; destruct z; simpl; intuition.
    inversion H1. subst. hyp. discr.
  Qed.

  Lemma pos_ordr : forall m n,
    Pos m >>= Pos n -> Peano.ge m n.

  Proof.
    intros. inversion H; simpl in H0. omega.
    injection H0. omega.
  Qed.

  Notation "x + y" := (Aplusr x y).
  Notation "x * y" := (Amultr x y).

  Lemma plus_inf_decr : forall m n,
    { exists p, (m = Pos p \/ n = Pos p) /\ m + n = Pos p} +
    { m + n = MinusInf /\ m = MinusInf /\ n = MinusInf }.

  Proof.
    intros. destruct m.
    left. destruct n.
    exists (max n0 n). split.
    apply max_case; auto. trivial.
    exists n0. auto.
    destruct n.
    left. exists n. auto.
    right. auto.
  Qed.

  Lemma mult_inf_decr : forall m n,
    { exists mi, exists ni,
      m = Pos mi /\ n = Pos ni /\ m * n = Pos (mi + ni) } +
    { m * n = MinusInf /\ (m = MinusInf \/ n = MinusInf) }.

  Proof.
    intros. destruct m. destruct n.
    left. exists n0. exists n. repeat split.
    right. auto.
    right. auto.
  Qed.

  Lemma ge_impl_pos_ger : forall m n, (m >= n)%nat -> Pos m >>= Pos n.

  Proof.
    intros. destruct (lt_eq_lt_dec m n) as [[m_n | m_n] | m_n].
    elimtype False. omega.
    subst m. right. refl.
    left. trivial.
  Qed.

  Lemma pos_ge_impl_ger : forall m n, Pos m >>= Pos n -> (m >= n)%nat.

  Proof.
    intros. destruct H. auto with arith.
    injection H. intro. subst m. auto with arith.
  Qed.

  Ltac arctic_ord :=
    match goal with
    | H: MinusInf >> Pos _ |- _ =>
        contr
    | H: MinusInf >>= Pos _ |- _ =>
        destruct H; [ contr | discr ]
    | H: Pos ?m >>= Pos ?n |- _ =>
        assert ((m >= n)%nat);
          [ apply pos_ge_impl_ger; hyp
          | clear H; arctic_ord
          ]
    | |- Pos _ >>= MinusInf => left; simpl; trivial
    | |- Pos ?m >>= Pos ?n => apply ge_impl_pos_ger
    | _ => try solve [contr | discr]
    end.

  Lemma plus_gt_compatr : forall m n m' n',
    m >> m' -> n >> n' -> m + n >> m' + n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; arctic_ord.
    apply max_gt_compat; hyp.
    unfold Peano.gt. apply lt_max_intro_l. hyp.
    unfold Peano.gt. apply lt_max_intro_r. hyp.
  Qed.

  Lemma plus_ge_compatr : forall m n m' n',
    m >>= m' -> n >>= n' -> m + n >>= m' + n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; arctic_ord.
    apply max_ge_compat; hyp.
    unfold Peano.ge. apply le_max_intro_l. hyp.
    unfold Peano.ge. apply le_max_intro_r. hyp.
  Qed.

  Lemma mult_ge_compatr : forall m n m' n',
    m >>= m' -> n >>= n' -> m * n >>= m' * n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; arctic_ord.
    omega.
  Qed.

  Lemma not_minusInf_ge_A1 : forall a, a <> MinusInf -> a >>= A1r.

  Proof.
    intros. destruct a. destruct n.
    right. refl.
    left. simpl. omega.
    tauto.
  Qed.

  Lemma ge_A1_not_minusInf : forall a, a >>= A1r -> a <> MinusInf.

  Proof.
    intros. destruct a.
    discr.
    destruct H. contr. discr.
  Qed.

Close Scope nat_scope.

End ArticOrdSemiRingT.

(***********************************************************************)
(** ** Arctic below-zero ordered semi-ring. *)

Section ArticBZOrdSemiRingT.

  Local Open Scope Z_scope.

  Definition gtrbz m n :=
    match m, n with
    | MinusInfBZ, _ => False
    | Fin _, MinusInfBZ => True
    | Fin m, Fin n => m > n
    end.

  Definition gerbz m n := gtrbz m n \/ m = n.

  Definition is_above_zero v :=
    match v with
      | MinusInfBZ => false
      | Fin z => is_not_neg z
    end.

  Lemma is_above_zero_ok :
    forall v, is_above_zero v = true <-> gerbz v (Fin 0).

  Proof.
    intro. destruct v; simpl; intuition.
    destruct z. right. refl. left. simpl. auto with zarith. discr.
    rewrite is_not_neg_ok. destruct H. simpl in H. auto with zarith.
    inversion H. auto with zarith.
    destruct H. simpl in H. contr. discr.
  Qed.

  Lemma eq_ge_compatrbz : forall x y, x = y -> gerbz x y.

  Proof.
    unfold gerbz. intuition.
  Qed.

  Lemma ge_reflrbz : reflexive gerbz.

  Proof.
    intro m. right. trivial.
  Qed.

  Lemma gt_transrbz : transitive gtrbz.

  Proof.
    intros m n p mn np.
    destruct m; auto.
    destruct n.
    destruct p; auto.
    simpl in *. omega.
    simpl in *. tauto.
  Qed.

  Lemma gt_irreflrbz : irreflexive gtrbz.

  Proof.
    intros x xx. destruct x.
    unfold gtrbz in xx. omega.
    auto.
  Qed.

  Lemma gt_asymrbz : forall m n, gtrbz m n -> ~gtrbz n m.

  Proof.
    intros. destruct m; destruct n; try tauto.
    simpl in *. omega.
  Qed.

  Lemma ge_transrbz : transitive gerbz.

  Proof.
    intros m n p mn np.
    destruct mn.
    destruct np.
    left. apply (gt_transrbz m n p); hyp.
    rewrite <- H0. left. trivial.
    rewrite H. trivial.
  Qed.

  Lemma ge_antisymrbz : antisymmetric gerbz.

  Proof.
    intros m n mn nm. destruct mn; auto. destruct nm; auto.
    absurd (gtrbz n m). apply gt_asymrbz. hyp. hyp.
  Qed.

  Lemma gt_decrbz : rel_dec gtrbz.

  Proof.
    intros x y.
    destruct x; destruct y; simpl; auto.
    destruct (Z_lt_dec z0 z); [left | right]; omega.
  Defined.

  Lemma ge_decrbz : rel_dec gerbz.

  Proof.
    intros x y.
    destruct (gt_decrbz x y).
    left. left. trivial.
    destruct (eqA_decrbz x y).
    left. right. trivial.
    right. intro xy. destruct xy; auto.
  Defined.

  Notation "x + y" := (Aplusrbz x y).
  Notation "x * y" := (Amultrbz x y).
  Notation "x >> y" := (gtrbz x y) (at level 70).
  Notation "x >>= y" := (gerbz x y) (at level 70).

  Lemma ge_gt_eqrbz : forall x y, x >>= y -> x >> y \/ x = y.

  Proof.
    destruct 1; auto.
  Qed.

  Lemma ge_gt_compatrbz : forall x y z, x >>= y -> y >> z -> x >> z.

  Proof.
    intros. destruct y. destruct x. destruct z.
    unfold gtrbz, gerbz in *. destruct H.
    simpl in H. omega.
    injection H. intro. subst z0. hyp.
    auto.
    elimtype False. destruct H. auto. discr.
    elimtype False. destruct H. auto. subst x.  auto.
  Qed.

  Lemma ge_gt_compat2rbz : forall x y z, x >> y -> y >>= z -> x >> z.

  Proof.
    unfold gerbz, gtrbz. destruct x as [x|]; destruct y as [y|];
      try destruct z as [z|]; simpl; intuition.
    inversion H1. subst. hyp. discr.
  Qed.

  Lemma fin_ge_Zgerbz : forall m n,
    Fin m >>= Fin n -> (m >= n)%Z.

  Proof.
    intros. inversion H; simpl in H0. omega.
    injection H0. omega.
  Qed.

  Lemma plus_inf_dec : forall m n,
    { exists p, (m = Fin p \/ n = Fin p) /\ m + n = Fin p} +
    { m + n = MinusInfBZ /\ m = MinusInfBZ /\ n = MinusInfBZ }.

  Proof.
    intros. destruct m.
    left. destruct n.
    exists (Zmax z z0). split.
    apply Zmax_case; auto. trivial.
    exists z. auto.
    destruct n.
    left. exists z. auto.
    right. auto.
  Qed.

  Lemma mult_inf_dec : forall m n,
    {exists mi, exists ni, m = Fin mi /\ n = Fin ni /\ m * n = Fin (mi + ni)}
    + {m * n = MinusInfBZ /\ (m = MinusInfBZ \/ n = MinusInfBZ)}.

  Proof.
    intros. destruct m. destruct n.
    left. exists z. exists z0. repeat split.
    right. auto.
    right. auto.
  Qed.

  Lemma minusInf_ge_min : forall a, a >>= MinusInfBZ.

  Proof.
    intros. destruct a. left. simpl. trivial.
    right. refl.
  Qed.

  Lemma ge_impl_fin_ge : forall m n, (m >= n)%Z -> Fin m >>= Fin n.

  Proof.
    intros. destruct (Z_le_lt_eq_dec n m). omega.
    left. simpl. omega.
    subst n. right. refl.
  Qed.

  Lemma fin_ge_impl_ge : forall m n, Fin m >>= Fin n -> (m >= n)%Z.

  Proof.
    intros. destruct H.
    simpl in H. omega.
    injection H. intro. subst m. omega.
  Qed.

  Ltac arctic_ord :=
    match goal with
    | H: MinusInfBZ >> Fin _ |- _ =>
        contr
    | H: MinusInfBZ >>= Fin _ |- _ =>
        destruct H; [ contr | discr ]
    | H: Fin ?m >>= Fin ?n |- _ =>
        assert ((m >= n)%Z);
          [ apply fin_ge_impl_ge; hyp
          | clear H; arctic_ord
          ]
    | |- Fin _ >>= MinusInfBZ => left; simpl; trivial
    | |- Fin ?m >>= Fin ?n => apply ge_impl_fin_ge
    | _ => try solve [contr | discr]
    end.

  Lemma plus_gt_compatrbz : forall m n m' n',
    m >> m' -> n >> n' -> m + n >> m' + n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; arctic_ord; simpl in *.
    apply Zmax_gt_compat; hyp.
    apply Zlt_gt. apply elim_lt_Zmax_l. omega.
    apply Zlt_gt. apply elim_lt_Zmax_r. omega.
  Qed.

  Lemma plus_ge_compatrbz : forall m n m' n',
    m >>= m' -> n >>= n' -> m + n >>= m' + n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; arctic_ord.
    apply Zmax_ge_compat; hyp.
    apply Zle_ge. apply elim_Zmax_l. omega.
    apply Zle_ge. apply elim_Zmax_r. omega.
  Qed.

  Lemma mult_ge_compatrbz : forall m n m' n',
    m >>= m' -> n >>= n' -> m * n >>= m' * n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; arctic_ord.
    omega.
  Qed.

  Lemma arctic_plus_ge_monotone : forall (a b c : Arbz),
    a >>= c -> Aplusrbz a b >>= c.

  Proof.
    intros. destruct c.
    destruct a. destruct b. simpl. arctic_ord.
    apply Zle_ge. apply elim_Zmax_l. omega.
    trivial.
    arctic_ord.
    apply minusInf_ge_min.
  Qed.

  Lemma ge_A1_not_minusInfrbz : forall a, a >>= A1rbz -> a <> MinusInfBZ.

  Proof.
    intros. destruct a.
    discr.
    destruct H. contr. discr.
  Qed.

End ArticBZOrdSemiRingT.

(***********************************************************************)
(** ** Tropical ordered semi-ring. *)

Section TropicalOrdSemiRingT.

  Local Open Scope nat_scope.

  Definition gtt m n :=
    match m, n with
    | PlusInf, PlusInf => False
    | PlusInf, _ => True
    | TPos _, PlusInf => False
    | TPos m, TPos n => m > n
    end.

  Definition get m n := gtt m n \/ m = n.

  Lemma eq_ge_compatt : forall x y, x = y -> get x y.

  Proof.
    unfold get. intuition.
  Qed.

  Lemma gt_irreflt : irreflexive gtt.

  Proof.
    intros x xx. destruct x.
    unfold gtt in xx. omega.
    auto.
  Qed.

  Lemma gt_transt : transitive gtt.

  Proof.
    intros x y z xy yz.
    destruct x; destruct y; destruct z; try solve [ auto | contr ].
    apply Arith.Gt.gt_trans with n0; auto.
  Qed.

  Lemma gt_asymt : forall x y, gtt x y -> ~gtt y x.

  Proof.
    intros x y xy.
    destruct x; destruct y; simpl in *; try solve [auto | omega].
  Qed.

  Lemma gt_dect : rel_dec gtt.

  Proof.
    unfold rel_dec. intros.
    destruct x; destruct y; simpl; auto.
    destruct (NatUtil.gt_dec n n0); auto.
  Defined.

  Lemma gt_Fin_WF x : Acc (transp gtt) (TPos x).
  Proof.
    induction x using lt_wf_ind; apply Acc_intro; destruct y;
      auto || contr.
  Qed.

  Hint Resolve gt_Fin_WF.

  Lemma gt_WFt : WF gtt.

  Proof with auto; try contr.
    apply wf_transp_WF. intro x.
    destruct x...
    apply Acc_intro. intros. destruct y...
  Qed.

  Lemma ge_reflt : reflexive get.

  Proof.
    intro m. right. trivial.
  Qed.

  Lemma ge_transt : transitive get.

  Proof.
    intros x y z xy yz. destruct xy. destruct yz.
    left. apply (gt_transt x y z); hyp.
    subst y. left. hyp.
    subst x. hyp.
  Qed.

  Lemma ge_antisym : antisymmetric get.

  Proof.
    intros x y xy yx. destruct xy. destruct yx.
    absurd (gtt y x). apply gt_asymt. hyp. hyp.
    auto. hyp.
  Qed.

  Lemma ge_dect : rel_dec get.

  Proof.
    intros x y. destruct (gt_dect x y).
    left. left. hyp.
    destruct (eqA_dect x y).
    left. right. hyp.
    right. intro xy. destruct xy; auto.
  Defined.

  Notation "x + y" := (Aplust x y).
  Notation "x * y" := (Amultt x y).
  Notation "x >>= y" := (get x y) (at level 70).
  Notation "x >> y" := (gtt x y) (at level 70).

  Lemma ge_gt_eq : forall x y, x >>= y -> x >> y \/ x = y.

  Proof.
    destruct 1; auto.
  Qed.

  Lemma ge_gt_compatt : forall x y z, x >>= y -> y >> z -> x >> z.

  Proof with simpl; intuition.
    intros.
    destruct y; destruct x; destruct z; auto...
    destruct H. simpl in *. omega. injection H. intros. subst...
    destruct H. contr. discr.
  Qed.

  Lemma ge_gt_compat2t : forall x y z, x >> y -> y >>= z -> x >> z.

  Proof.
    unfold get, gtt. destruct x; destruct y; destruct z; simpl; intuition;
    try discr.
    inversion H1. subst. hyp.
  Qed.

  Lemma pos_ord : forall m n,
    TPos m >>= TPos n -> Peano.ge m n.

  Proof.
    intros. inversion H; simpl in H0. omega.
    injection H0. omega.
  Qed.

  Lemma plus_inf_dect : forall m n,
    { exists p, (m = TPos p \/ n = TPos p) /\ m + n = TPos p} +
    { m + n = PlusInf /\ m = PlusInf /\ n = PlusInf }.

  Proof.
    intros. destruct m.
    left. destruct n.
    exists (min n0 n). split.
    apply min_case; auto. trivial.
    exists n0. auto.
    destruct n.
    left. exists n. auto.
    right. auto.
  Qed.

  Lemma mult_inf_dect : forall m n,
    { exists mi, exists ni,
      m = TPos mi /\ n = TPos ni /\ m * n = TPos (mi + ni) } +
    { m * n = PlusInf /\ (m = PlusInf \/ n = PlusInf) }.

  Proof.
    intros. destruct m. destruct n.
    left. exists n0. exists n. repeat split.
    right. auto.
    right. auto.
  Qed.

  Lemma ge_impl_pos_ge : forall m n, (m >= n)%nat -> TPos m >>= TPos n.

  Proof.
    intros. destruct (lt_eq_lt_dec m n) as [[m_n | m_n] | m_n].
    elimtype False. omega.
    subst m. right. refl.
    left. trivial.
  Qed.

  Lemma pos_ge_impl_ge : forall m n, TPos m >>= TPos n -> (m >= n)%nat.

  Proof.
    intros. destruct H. auto with arith.
    injection H. intro. subst m. auto with arith.
  Qed.

  Ltac tropical_ord :=
    match goal with
    | H: _ >> PlusInf |- _ => contr
    | H: TPos _ >>= PlusInf |- _ =>
        destruct H; [ contr | discr ]
    | H: TPos ?m >>= TPos ?n |- _ =>
        assert ((m >= n)%nat);
          [ apply pos_ge_impl_ge; hyp
          | clear H; tropical_ord
          ]
    | |- PlusInf >>= TPos _ => left; simpl; trivial
    | |- TPos ?m >>= TPos ?n => apply ge_impl_pos_ge
    | _ => try solve [contr | discr]
    end.

  Lemma plus_gt_compatt : forall m n m' n',
    m >> m' -> n >> n' -> m + n >> m' + n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; tropical_ord.
    apply min_gt_compat; hyp.
    unfold Peano.gt. apply lt_min_intro_l. hyp.
    unfold Peano.gt. apply lt_min_intro_r. hyp.
  Qed.

  Lemma plus_ge_compatt : forall m n m' n',
    m >>= m' -> n >>= n' -> m + n >>= m' + n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; tropical_ord.
    apply min_ge_compat; hyp.
    unfold Peano.ge. apply le_min_intro_l. hyp.
    unfold Peano.ge. apply le_min_intro_r. hyp.
  Qed.

  Lemma mult_ge_compatt : forall m n m' n',
    m >>= m' -> n >>= n' -> m * n >>= m' * n'.

  Proof.
    intros.
    destruct m; destruct n; destruct m'; destruct n';
      simpl; trivial; tropical_ord.
    omega.
  Qed.

  Lemma not_minusInf_ge_A1t : forall a, a <> PlusInf -> a >>= A1t.

  Proof.
    intros. destruct a. destruct n.
    right. refl.
    left. simpl. omega.
    tauto.
  Qed.

  Lemma tropical_plus_inf_max : forall x, x <> PlusInf -> PlusInf >> x.
  Proof.
    intros. destruct x. simpl. auto.
    elimtype False. apply H. trivial.
  Qed.

End TropicalOrdSemiRingT.

(***********************************************************************)
(** ** Semi-ring of booleans with order True > False. *)

Section BOrdSemiRingT.

  Local Open Scope bool.

  Definition gtb x y :=
    match x, y with
    | true, false => True
    | _, _ => False
    end.

  Definition geb x y :=
    match x, y with
    | false, true => False
    | _, _ => True
    end.

  Lemma eq_ge_compatb : forall x y, x = y -> geb x y.

  Proof.
    unfold geb. destruct x; destruct y; auto. discr.
  Qed.

  Notation "x + y" := (Aplusb x y).
  Notation "x * y" := (Amultb x y).
  Notation "x >> y" := (gtb x y) (at level 70).
  Notation "x >>= y" := (geb x y) (at level 70).

  Lemma ge_reflb : reflexive geb.

  Proof.
    intro m. unfold geb. destruct m; auto.
  Qed.

  Lemma ge_transb : transitive geb.

  Proof.
    intros m n p. unfold geb.
    destruct m; destruct n; destruct p; auto.
  Qed.

  Lemma ge_antisymb : antisymmetric geb.

  Proof.
    intros m n. unfold geb.
    destruct m; destruct n; tauto.
  Qed.

  Lemma gt_irreflb : irreflexive gtb.

  Proof.
    intros x. unfold gtb. destruct x; tauto.
  Qed.

  Lemma gt_transb : transitive gtb.

  Proof.
    intros x y z.
    destruct x; destruct y; destruct z; tauto.
  Qed.

  Lemma ge_decb : rel_dec geb.

  Proof.
    intros x y. destruct x; destruct y; simpl; tauto.
  Qed.

  Lemma gt_decb : rel_dec gtb.

  Proof.
    intros x y. destruct x; destruct y; simpl; tauto.
  Qed.

  (* open nat_scope to be able to use [well_founded_lt_compat] *)
  Local Open Scope nat_scope.

  Lemma gt_WFb : WF gtb.

  Proof.
    apply wf_transp_WF.
    apply well_founded_lt_compat with
      (fun x =>
        match x with
        | false => 0
        | true => 1
        end).
    destruct x; destruct y; unfold transp, gtb;
      solve [tauto | auto with arith].
  Qed.

  Close Scope nat_scope.

  Lemma ge_gt_compatb : forall x y z, x >>= y -> y >> z -> x >> z.

  Proof.
    destruct x; destruct y; destruct z; simpl; tauto.
  Qed.

  Lemma ge_gt_compat2b : forall x y z, x >> y -> y >>= z -> x >> z.

  Proof.
    destruct x; destruct y; destruct z; simpl; tauto.
  Qed.

  Lemma plus_gt_compatb : forall m n m' n',
    m >> m' -> n >> n' -> m + n >> m' + n'.

  Proof.
    destruct m; destruct m'; destruct n; destruct n'; simpl; tauto.
  Qed.

  Lemma plus_ge_compatb : forall m n m' n',
    m >>= m' -> n >>= n' -> m + n >>= m' + n'.

  Proof.
    destruct m; destruct m'; destruct n; destruct n'; simpl; tauto.
  Qed.

  Lemma mult_ge_compatb : forall m n m' n',
    m >>= m' -> n >>= n' -> m * n >>= m' * n'.

  Proof.
    destruct m; destruct m'; destruct n; destruct n'; simpl; tauto.
  Qed.

End BOrdSemiRingT.