(********************************************************************************
* Formalization of lambda ex						        *
*									        *
* Flavio L. C. de Moura & Daniel L. Ventura, & Washington R. Segundo, 2015	*
*********************************************************************************)

Set Implicit Arguments.
Require Import Recdef. (*no caso de usarmos Function*)
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV LambdaES_Tac.
Require Import Rewriting_Defs Rewriting_Lib.
Require Import Equation_C Lambda Lambda_Ex LambdaESLab_Defs LambdaESLab_Lib.

(** The extended reduction system is related to the lex-calculus
through a function that computes all the labelled substitutions. *)

Fixpoint xc (t: pterm) : pterm :=
  match t with
    | pterm_app t1 t2 => pterm_app (xc t1) (xc t2)
    | pterm_abs t1 => pterm_abs (xc t1)
    | pterm_sub t1 t2 => pterm_sub (xc t1) (xc t2)
    | pterm_sub' t1 t2 => (xc t1)^^(t2)
    | _ => t
  end.

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

Lemma var_gen_fv: forall E x, x = var_gen(E) <-> x \notin E.

Proof.
introv.
split.
intro Ha.
rewrite Ha.
apply var_gen_spec.

intro Hb.
destruct E.
Admitted.

(* versao de xc com a propriedade de regularidade lc => lc com Recdef*)

Function xc2 (t: pterm) {measure pterm_size t}: pterm :=
  match t with
    | pterm_app t1 t2 => pterm_app (xc2 t1) (xc2 t2)
    | pterm_abs t1 => let x := var_gen (fv t1)  in
                          pterm_abs (close (xc2 (t1^x)) x)
    | pterm_sub t1 t2 => let x := var_gen (fv t1)  in
                          pterm_sub (close (xc2 (t1^x)) x) (xc2 t2)
    | pterm_sub' t1 t2 => (xc2 t1)^^(t2)
    | _ => t
  end.

Proof.
intros. simpl.
auto with arith.

intros. simpl.
auto with arith.

intros. simpl.
unfold open.
rewrite <- pterm_size_open_var.
auto with arith.

intros. simpl.
auto with arith.

intros. simpl.
unfold open.
rewrite <- pterm_size_open_var.
auto with arith.

intros. simpl.
auto with arith.
Defined.

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

(* versao de xc com a propriedade de regularidade lc => lc a la Chargueraud
   porque nao definimos o caso: termo indefinido ?*)
(*
Definition xc2_body (xc_2: pterm -> pterm) (t: pterm): pterm :=
  match t with
    | pterm_app t1 t2 => pterm_app (xc_2 t1) (xc_2 t2)
    | pterm_abs t1 => let x := var_gen (fv t1)  in
                          pterm_abs (close (xc_2 (t1^x)) x)
    | pterm_sub t1 t2 => let x := var_gen (fv t1)  in
                          pterm_sub (close (xc_2 (t1^x)) x) (xc_2 t2)
    | pterm_sub' t1 t2 => (xc_2 t1)^^(t2)
    | _ => t
  end.

Definition xc_2 := fixmu xc_2_body pterm_size. *)

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

(** fv is compatible with open. TO BE MOVED: LambdaES_Defs. *)
Lemma fv_open: forall t u, fv(t ^^ u) << fv(t) \u fv(u).
Proof.
  unfold open.
  intros.
  generalize 0.
  induction t.
    intros.
    case n.
    simpl.
    case_nat.
    apply subset_union_weak_r.
    simpl.
    apply subset_union_weak_l.
    intros.
    simpl.
    case_nat.
    apply subset_union_weak_r.
    simpl.
    apply subset_union_weak_l.
    intros. simpl.
    apply subset_union_weak_l.
    intros.
    simpl.
    apply subset_trans with (F := fv ({n ~> u}t1) \u (fv t2 \u fv u)).
    apply subset_union_trans_r.
    apply IHt2.
Admitted.

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

Lemma xc_fv: forall t, fv (xc t) << fv(t).
Proof.
  induction t.
  simpl; reflexivity.
  simpl; reflexivity.
  simpl.
  rewrite IHt1.
  rewrite IHt2; reflexivity.
  assumption.
  simpl.
  rewrite IHt1.
  rewrite IHt2; reflexivity.
  simpl.
  apply subset_trans with (F := fv(xc(t1)) \u fv(t2)).
  apply fv_open.
  apply subset_union_trans_l. assumption.
Qed.

(*
Lemma xc_open_distr: forall t u, xc (t ^^ u) = (xc(t))^^ (xc(u)).
Proof.
  intros. unfold open. generalize 0 u. clear u.
  induction t.
  intro. simpl. case_nat; reflexivity.

  Focus 5.
  intros.
  simpl.
  unfold open.
  rewrite IHt1.
  assert ()
  rewrite <- IHt1 with (u := t2).

Lemma xc_open_term: forall t u, term u -> xc (t ^^ u) = (xc(t))^^ u.
Proof.
  intros. unfold open. generalize 0.
  generalize u H. clear u H.
  induction t.
  Focus 6.

  intro. simpl.
*)

Lemma term_open_term: forall x t, term t -> t^x = t.
Proof.
  unfold open.
  intros.
  generalize x 0; clear x.
  induction H.

  intros.
  simpl; reflexivity.

  intros.
  simpl.
  rewrite IHterm1.
  rewrite IHterm2; reflexivity.

  intros.
  simpl.
  pick_fresh z.
  assert (Q: ({S n ~> pterm_fvar x}t1)^z = t1^z).
  simpl.
Admitted.

Lemma xc_open: forall t x, x \notin fv(t) -> xc (t ^ x) = (xc t)^x.
Proof.
  intros. unfold open. generalize 0.
  induction t.
  unfold open.
  intro. unfold open_rec.
  case_nat.
  fold open_rec.
  simpl xc.
  unfold open_rec.
  case_nat. reflexivity.
  fold open_rec.
  simpl. case_nat. reflexivity.
  intro. simpl. reflexivity.

  intro. simpl.
  rewrite IHt1.
  rewrite IHt2. reflexivity.

  simpl fv in H.
  apply notin_union in H.
  destruct H; assumption.
  simpl fv in H.
  apply notin_union in H.
  destruct H; assumption.

  Focus 3.
  intros.
  simpl.

Admitted.

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

(* Igualdade sintática para pré-termos*)

Lemma eq_abs: forall t u, t = u -> pterm_abs t = pterm_abs u.
Proof.
 intros t u.
 apply f_equal.
Qed.

Lemma eq_pterm_abs: forall t u L,  (forall x, x \notin L -> t^x = u^x) -> pterm_abs t = pterm_abs u.
Proof.
 intros t u L Ha.
 apply eq_abs.
 pick_fresh z.
 apply notin_union in Fr. destruct Fr as [Hb Hc].
 apply notin_union in Hb. destruct Hb as [Hba Hbb].
 apply open_var_inj with (x := z).
 trivial. trivial.
 apply Ha. trivial.
Qed.

Lemma eq_sub: forall t u v w, (t = v) -> (u = w) -> t[u] = (v[w]).
Proof.
 intros t u v w Ha Hb.
 assert (pterm_sub t = pterm_sub v) as Hc.
 apply f_equal. trivial.
 rewrite Hc.
 apply f_equal. trivial.
Qed.

Lemma eq_pterm_sub: forall t u t' u' L, (forall x, x \notin L -> t^x = t'^x) -> u = u' -> (t[u]) = (t'[u']).
Proof.
 intros t u t' u' L Ha Hb.
 apply eq_sub.
 pick_fresh z.
 apply notin_union in Fr. destruct Fr as [Hc Hd].
 apply notin_union in Hc. destruct Hc as [He Hf].
 apply notin_union in He. destruct He as [Hg Hh].
 apply notin_union in Hg. destruct Hg as [Hi Hj].
 apply open_var_inj with (x := z).
 trivial. trivial.
 apply Ha. trivial.
 trivial.
Qed.

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

(*comutatividade para open_rec*)

Lemma open_rec_subs_comut: forall t u v j, {j~>u}(t[[v]]) = ({(S j)~>u}t[[{j~>u}v]]).
Proof.
 simpl. trivial.
Qed.

Lemma open_rec_xc_comut: forall t u, xc t ^^ u = xc(t[[u]]).
Proof.
 simpl. trivial.
Qed.

Lemma open_rec_xc2_comut: forall t u, xc2 t ^^ u = xc2(t[[u]]).
Proof.
  introv.
  apply eq_sym.
  rewrite xc2_equation.
  trivial.
Qed.

Lemma notin_set_subset: forall E F x, E << F -> x \notin F -> x \notin E.
Proof.
 introv Hs Hx.
Admitted.

Lemma open_xc2: forall t, exists L, forall x, x \notin L -> xc2 (t ^ x) = xc2 t ^ x.
Proof.
 unfold open.
 generalize 0.
 introv.
 exists (fv t).
 introv Hx.

 induction t.

 simpl.
 destruct (n === n0) as []eqn:He1. (*reducao para if then else*)
 rewrite xc2_equation. trivial.
 rewrite xc2_equation. trivial.

 simpl.
 rewrite xc2_equation. trivial.

 simpl in Hx.
 apply notin_union in Hx.
 destruct Hx as [Hxl Hxr].
 simpl.
 rewrite xc2_equation.
 apply eq_sym.
 rewrite xc2_equation.
 simpl.
 rewrite IHt1.
 rewrite IHt2.
 trivial. trivial. trivial.

 simpl in Hx.
 simpl.
 rewrite xc2_equation.
 apply eq_sym.
 rewrite xc2_equation.
 simpl.
 apply eq_abs.
 (*assert (x = var_gen (fv t)) as Ht.
 apply var_gen_fv.
 trivial.
 rewrite <- Ht.*)
 unfold open.
 apply eq_sym.
 rewrite IHt. (*problema com generalize, n, 0 e Sn*)
 rewrite <- close_open_term with (x:= x).
 pick_fresh z.
 (*apply notin_union in Fr.*)
 assert (z = var_gen (fv ({1 ~> pterm_fvar x}t))) as Hz.
 apply var_gen_fv.
 apply notin_set_subset with (F := (fv t \u {{x}})).
 apply fv_open_subset.
 rewrite  union_comm. trivial.
 rewrite <- Hz.
 unfold open.
 rewrite subst_com.
 unfold open  in IHt.
 rewrite IHt.
Admitted.

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

Lemma xc_term_term: forall t, term t -> xc t = t.
Proof.
 (* intros t H.
  induction H.

  simpl; reflexivity.

  simpl.
  rewrite IHterm1.
  rewrite IHterm2; reflexivity.

  simpl.
  apply eq_pterm_abs with (L := L).
  intros x Ha.
  rewrite <- H0.
  rewrite xc_open_2 with (L := L).
  trivial. trivial.
  apply H. trivial. trivial.

  simpl.
  apply eq_pterm_sub with (L := L).
  intros x Ha.
  rewrite <- H0.
  rewrite xc_open_2 with (L := L).
  trivial. trivial.
  apply H. trivial. trivial. trivial.

  (*
  simpl.
  pick_fresh z.
  apply notin_union in Fr.
  destruct Fr.
  assert (Q: (xc t1)^z = t1^z).
  assert (U: xc(t1^z) = xc(t1)^z).
  apply xc_open; assumption.
  rewrite <- U.
  apply H0; assumption.
  apply open_var_inj with (x := z) in Q.
  rewrite Q; reflexivity.
Admitted.*)
 Qed.*)
Admitted.

Lemma term_lab_term: forall t, term t -> lab_term t.
Proof.
 introv Ha.
 induction Ha.

 apply lab_term_var.
 apply lab_term_app. trivial. trivial.
 apply lab_term_abs with (L:= L). trivial.
 apply lab_term_sub with (L:=L). trivial. trivial.
Qed.

Lemma xc2_reg: forall t, lab_term t -> term (xc2 t).
Proof.
 introv Ha.
 induction Ha.

 rewrite xc2_equation.
 apply term_var.

 rewrite xc2_equation.
 apply term_app. trivial. trivial.

 rewrite xc2_equation.
 apply body_to_term_abs.
 apply close_var_body.
 pick_fresh z.
 assert (z = var_gen(fv t1)) as Ha.
 apply var_gen_fv.
 apply notin_union_r2 with (E:= L). trivial.
 rewrite <- Ha.
 apply H0.
 apply notin_union_r1 with (F:= (fv t1)). trivial.

 rewrite xc2_equation.
 apply body_to_subs.
 apply close_var_body.
 pick_fresh z.
 assert (z = var_gen(fv t1)) as Hb.
 apply var_gen_fv.
 apply notin_union_r2 with (E:= L).
 apply notin_union_r1 with (F:= (fv t2)). trivial.
 rewrite <- Hb.
 apply H0.
 apply notin_union_r1 with (F:= fv t1).
 apply notin_union_r1 with (F:= fv t2). trivial.
 trivial.

 rewrite xc2_equation.
 apply body_open_term.
 unfold body.
 exists L.
 introv Ha.
 pick_fresh z.

Admitted.

Lemma xc2_term_term: forall t, term t -> xc2 t = t.
Proof.
 intros t Ha.
 induction Ha.

 rewrite xc2_equation.
 trivial.

 rewrite xc2_equation.
 rewrite IHHa1.
 rewrite IHHa2.
 trivial.

 rewrite xc2_equation.
 pick_fresh z.
 apply notin_union in Fr.
 destruct Fr as [Hb Hc].
 assert (z=var_gen (fv t1)) as Hd.
 apply var_gen_fv. trivial.
 rewrite <- Hd.
 rewrite H0.
 rewrite <- close_open_term.
 trivial. trivial. trivial.

 rewrite xc2_equation.
 pick_fresh z.
 apply notin_union in Fr.
 destruct Fr as [Hb Hc].
 apply notin_union in Hb.
 destruct Hb as [Hd He].
 assert (z=var_gen (fv t1)) as Hf.
 apply var_gen_fv.
 trivial.
 rewrite <- Hf.
 rewrite H0.
 rewrite <- close_open_term.
 rewrite IHHa.
 trivial. trivial. trivial.
Qed.

 Lemma xc_bswap: forall t, bswap(xc(t)) = xc(bswap(t)).
Proof.
  intro.
  unfold bswap.
   generalize 0.
  induction t.
  intro.
  assert (xc (pterm_bvar n) = pterm_bvar n).
  simpl xc; reflexivity.
  rewrite H.
  case (n0 === n).
  intro. rewrite e.
  simpl bswap_rec at 2. case_nat.
  simpl bswap_rec. case_nat.
  simpl xc; reflexivity.
  intro.
  case (S n0 === n).
  intro Hn0. rewrite <- Hn0.
  simpl bswap_rec.
  case_nat.
  simpl xc; reflexivity.
  case_nat.
  simpl; reflexivity.
  intro Hn0.
  unfold bswap_rec.
  case_nat.
  case_nat.
  contradiction.
  simpl xc; reflexivity.
  intro n.
  simpl bswap_rec. simpl; reflexivity.
  intro n.
  simpl bswap_rec.
  simpl xc at 3.
  fequal. apply IHt1. apply IHt2.
  intro n.
  simpl bswap_rec.
  simpl xc at 2.
  fequal. apply IHt.
  intro n.
  simpl bswap_rec.
  simpl xc at 3.
  fequal. apply IHt1. apply IHt2.
  intro n.
  simpl bswap_rec.
  simpl xc.
  rewrite <- IHt1.
Admitted.

 Lemma xc2_bswap: forall t, bswap(xc2(t)) = xc2(bswap(t)).
Proof.
 introv.
Admitted. (*precisamos desse caso geral ou de um mais especifico ?*)

Lemma xc_idempotent: forall t, xc(xc(t)) = t.
Proof.
  induction t.
  simpl; reflexivity.
  simpl; reflexivity.
  simpl. rewrite IHt1. rewrite IHt2; reflexivity.
  simpl. rewrite IHt; reflexivity.
  simpl. rewrite IHt1. rewrite IHt2; reflexivity.
  simpl.

Lemma xc_equations: forall t t', t =~e t' ->  xc t = xc t'.
Proof.
  intros t t' He.
  elim He.
  intros.
  elim H.
  intros.
  elim H0.
  intros; reflexivity.
  intros. simpl.
  unfold open. simpl.

  destruct H.
  induction H; trivial.
  induction t.
  induction n.
  simpl. simpl.
  Admitted.

   Lemma xc2_equations: forall t t', t =~e t' ->  xc2 t = xc2 t'.
Proof.
  introv He.
  destruct He as [t1|t2].
  destruct H.
  destruct H.

  trivial.

  rewrite xc2_equation.
  unfold open.
  apply eq_sym.
  rewrite xc2_equation.
  SearchAbout bswap.

  elim Hb.
  introv. trivial.
  introv Hc Hd.
  rewrite xc2_equation.
  rewrite xc2_equation.
  apply eq_sym.
  rewrite xc2_equation.
  unfold open. simpl.

  destruct H.
  induction H; trivial.
  induction t.
  induction n.
  simpl. simpl.
Admitted.

  Lemma xc_ex_equal: forall t t', t -->[ex] t' -> xc t = xc t'.
Proof.
  intros t t' Hex.
  destruct Hex.
  destruct H.
  destruct H.
  destruct H0.
  destruct H0.
  induction H0.
  assert (xc(t) = xc (pterm_bvar 0 [[t0]])).
  apply xc_equations; assumption.
  simpl in H2. unfold open in H2. simpl in H2.
  (*rewrite H.*)
Admitted.

  Lemma xc2_ex_equal: forall t t', lab_term t -> t -->[ex] t' -> xc2 t = xc2 t'.
Proof.
  introv Ht Hex.

  inversion Hex as [t1 Ha].
  inversion Ha as [t2 Hb].
  destruct Hb as [Hb Hc].
  destruct Hc as [Hc Hd].

  induction Ht.

  case Hc.

Admitted.

  (*
Lemma SN_lab_1 : forall S t u', lab_term S t -> ((U_lab t) -->lex u') ->
                 exists u, lab_term S u /\ (t -->[lex] u) /\ u' = U_lab u .
Proof.
 intros.
 case H0; clear H0. intros t0 H'.
 case H'; clear H'. intros u0 H'.
 destruct H'. destruct H1.
 induction H1. induction H1. destruct H1.
 exists (t0[[u]]). split.
 skip. split.

(*
 unfold body in H1. case H1; clear H1.
 intros L H1. apply lab_term_sub' with (L := L); intros;
 try apply term_to_lab_term; trivial.
 apply H1; trivial. skip. skip. split. skip. simpl.
 *)

 Admitted.

Lemma SN_lab_2 : forall S t, lab_term S t -> SN lab_lex t -> SN lex (U_lab t).
Proof.
 intros.
Admitted.

(** In order to prove the Perpetuality Theorem, IE Property is considered as a hypothesis, but in a future work the a formalization of this point needs to be done. A sofisticated approach with the extention of the lex grammar is used in D. Kesner's paper, and our intent is following the same steps of the pencil and paper proof.
*)

*)

Hypothesis IE_property : forall t u lv, body t -> term u->
                         SN lex u -> SN lex ((t ^^ u) // lv) -> SN lex ((t[u]) // lv).


Require Import Coq.Strings.String.
Require Import MirrorSolve.SMT.

Require Import MirrorSolve.FirstOrder.

Section SMTSig.
  Set Universe Polymorphism.
  Variable (sig: signature).

  Inductive packed_sfun :=
  | PSF: forall args r, sig.(sig_funs) args r -> packed_sfun
  | PSR : forall args, sig.(sig_sorts) -> sig.(sig_rels) args -> packed_sfun
  | PSL : forall X args r,
    (forall (x: X), sig.(sig_funs) args r) ->
    packed_sfun.

  Record smt_sig := MkSMTSig {
    sorts : list (sig.(sig_sorts) * smt_sort) ;
    funs : list (packed_sfun * smt_fun) ;
  }.
End SMTSig.

Register MkSMTSig as ms.smt.mk_smt_sig.
Register PSF as ms.smt.psf.
Register PSR as ms.smt.psr.
Register PSL as ms.smt.psl.


Require oeuf.Common.
Require Vector.

(* 2 deep total lookups *)
Inductive vecvec (A : Type) : forall (n :nat), Vector.t nat n -> Type :=
| empty :
    vecvec A O (Vector.nil nat)
| full :
    forall len (v : Vector.t A len)
           n (lens : Vector.t nat n) (vv : vecvec A n lens),
      vecvec A (S n) (Vector.cons nat len n lens).

(* Operation copied from Vectors *)
(* use this instead of destructing a vector *)
(* just destruct the index instead *)
Definition caseS {A} (* type parameter *)
           (P : forall {n}, Vector.t A (S n) -> Type) (* Property of nonempty vectors *)
           (H : forall h {n} t, @P n (Vector.cons A h _ t)) (* Proof that property holds on cons *)
           {n} (* implicit bound *)
           (v: Vector.t A (S n)) (* actual vector *)
  : P v := (* Property on that vector *)
match v with
| Vector.cons _ h _ t => H h t
| _ => fun devil => False_ind (@IDProp) devil
end.

(* like caseS, but for 2 dimensions *)
(*

Definition vvcaseS {A}
           (P : forall {n}, t A (S n) -> Type)

(* Operation copied from Vectors *)
Definition nth {A} :=
fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A :=
match p in Fin.t m' return t A m' -> A with
 |Fin.F1 => caseS (fun n v' => A) (fun h n t => h)
 |Fin.FS p' => fun v => (caseS (fun n v' => Fin.t n -> A)
   (fun h n t p0 => nth_fix t p0) v) p'
end v'.

(* TODO: how do I write this? *)
Fixpoint lookup
         (A : Type)
         (n : nat)
         (lens : Vector.t nat n)
         (vv : vecvec A n lens)
         (idx1 : Fin.t n)
         (idx2 : Fin.t (Vector.nth lens idx1)) : nat :=
  match vv with
  | empty _ O (Vector.nil nat) =>
    match idx1 as Fin.t O with end
  | full _ len v n lens vv' => O
  end.
  inversion vv.
  - subst n. inversion idx1.
  - subst n.

    eapply Eqdep_dec.inj_pair2_eq_dec in H2;
      try eapply PeanoNat.Nat.eq_dec.

    subst lens.

*)


Require Import String.
Import List.
Import ListNotations.

Require Import Utilities.

Require Import Input_Properties.
Require Import Flood_Properties.
Require Import Flood_Box.

Require Import List_Properties.

Require Import extract_port_buffer_message_properties.
Require Import execute_flood_aux_properties.

Lemma fail_on_add_diff_message_implies_fails_before:
  forall buf buf' i i' j j' m m' c c',
  extract_port_buffer (add_message_to_all buf i' m' c') j i j' m c = (buf', None) ->
  (i', m', c') <> (i, m, c) ->
  exists buf'', extract_port_buffer buf j i j' m c = (buf'', None).
Proof.
  intros buf.
  induction buf;
  intros buf' i i' j j' m m' c c';
  intros H_extract_add H_ne.
  - simpl.
    exists [].
    reflexivity.
  - simpl in H_extract_add |- *.
    destruct j.
    + destruct (triple_and (Nat.eqb i i') (m =? m')%string (Nat.eqb c c')) eqn:and_eq.
      * apply tuple_nat_string_nat_not_eq_implies_or in H_ne.
        destruct H_ne.
        -- apply PeanoNat.Nat.eqb_neq in H.
           destruct (Nat.eqb i i') eqn:rem.
           ++ rewrite PeanoNat.Nat.eqb_sym in H.
              rewrite rem in H.
              discriminate.
           ++ unfold triple_and in and_eq.
              discriminate.
        -- destruct H.
           ++ apply eqb_neq in H.
              rewrite eqb_sym in H.
              rewrite H in and_eq.
              unfold triple_and in and_eq.
              destruct (Nat.eqb i i');
              discriminate.
           ++ apply PeanoNat.Nat.eqb_neq in H.
              destruct (Nat.eqb c c') eqn:rem.
              ** rewrite PeanoNat.Nat.eqb_sym in H.
                 rewrite rem in H.
                 discriminate.
              ** unfold triple_and in and_eq.
                 discriminate.
      * destruct (extract_message a i j' m c).
        inversion H_extract_add.
        exists (i0 :: buf).
        reflexivity.
    + destruct (extract_port_buffer (add_message_to_all buf i' m' c') j i j' m c) eqn:extract.
      inversion H_extract_add.
      subst. clear H_extract_add.
      assert (exists buf'' : In_transit_buffer, extract_port_buffer buf j i j' m c = (buf'', None))
        as H_extract_is_none
        by (eapply IHbuf;
            eassumption).
      destruct H_extract_is_none as [buf'' H_extract_is_none].
      exists (a :: buf'').
      rewrite H_extract_is_none.
      reflexivity.
Qed.

Lemma fail_on_extract_message_diff_message_implies_fails_before:
  forall port_buf port_buf' port_buf'' i i' j j' m m' c c' res,
  extract_message port_buf i' j' m' c' = (port_buf', res) ->
  extract_message port_buf' i j m c = (port_buf'', None) ->
  (i', m', c') <> (i, m, c) ->
  exists some_port_buf, extract_message port_buf i j m c = (some_port_buf, None).
Proof.
  intros port_buf.
  induction port_buf;
  intros port_buf' port_buf'' i i' j j' m m' c c' res;
  intros H_extract_first H_extract H_ne.
  - exists [].
    simpl.
    reflexivity.
  - simpl in H_extract_first |- *.
    destruct a.
    destruct p.
    destruct (triple_and (Nat.eqb i' n0) (m' =? s)%string (Nat.eqb c' n)) eqn:and_first.
    + destruct (triple_and (Nat.eqb i n0) (m =? s)%string (Nat.eqb c n)) eqn:and_second.
      * unfold triple_and in and_first, and_second.
        destruct (Nat.eqb i' n0) eqn:H_i'n0;
        destruct ((m' =? s)%string) eqn:H_m's;
        destruct (Nat.eqb c' n) eqn:H_c'n;
        destruct (Nat.eqb i n0) eqn:H_in0;
        destruct ((m =? s)%string) eqn:H_ms;
        destruct (Nat.eqb c n) eqn:H_cn;
          try discriminate.
        clear and_first. clear and_second.
        apply EqNat.beq_nat_true in H_i'n0.
        apply EqNat.beq_nat_true in H_in0.
        apply eqb_eq in H_m's.
        apply eqb_eq in H_ms.
        apply EqNat.beq_nat_true in H_c'n.
        apply EqNat.beq_nat_true in H_cn.
        subst.
        contradiction.
      * inversion H_extract_first.
        subst. clear H_extract_first.
        rewrite H_extract.
        exists ((n0, s, n) :: port_buf'').
        reflexivity.
    + destruct (extract_message port_buf i' j' m' c') eqn:extract_first.
      inversion H_extract_first.
      subst. clear H_extract_first.
      destruct (triple_and (Nat.eqb i n0) (m =? s)%string (Nat.eqb c n)) eqn:and_second;
      simpl in H_extract;
      rewrite and_second in H_extract.
      * inversion H_extract.
      * destruct (extract_message i0 i j m c) eqn:extract_second.
        inversion H_extract.
        subst. clear H_extract.
        assert (exists some_port_buf, extract_message port_buf i j m c = (some_port_buf, None))
          as H_must_fail
          by (eapply IHport_buf;
              eassumption).
        destruct H_must_fail as [some_port_buf H_must_fail].
        rewrite H_must_fail.
        exists ((n0, s, n) :: some_port_buf).
        reflexivity.
Qed.

Lemma fail_on_extract_port_buffer_same_port_implies_fail_before:
  forall buf buf' buf'' i i' j' jp jp' m m' c c' p,
  extract_port_buffer buf j' i' jp' m' c' = (buf', Some p) ->
  extract_port_buffer buf' j' i jp m c = (buf'', None) ->
  (i', m', c') <> (i, m, c) ->
  exists some_buf, extract_port_buffer buf j' i jp m c = (some_buf, None).
Proof.
  intros buf.
  induction buf;
  intros buf' buf'' i i' j' jp jp' m m' c c' p;
  intros H_extract_some H_extract_none H_diff;
  simpl in H_extract_some |- * .
  - inversion H_extract_some.
  - destruct j'.
    + destruct (extract_message a i' jp' m' c') eqn:extract_mes_some.
      inversion H_extract_some.
      subst. clear H_extract_some.
      simpl in H_extract_none.
      destruct (extract_message i0 i jp m c) eqn:extract_mes_none.
      inversion H_extract_none.
      subst. clear H_extract_none.
      assert (exists some_port_buf, extract_message a i jp m c = (some_port_buf, None))
        as H_res_none
        by (eapply fail_on_extract_message_diff_message_implies_fails_before;
            eassumption).
      destruct H_res_none as [some_port_buf H_res_none].
      rewrite H_res_none.
      exists (some_port_buf :: buf).
      reflexivity.
    + destruct (extract_port_buffer buf j' i' jp' m' c') eqn:extract_some.
      inversion H_extract_some.
      subst. clear H_extract_some.
      simpl in H_extract_none.
      destruct (extract_port_buffer i0 j' i jp m c) eqn:extract_none.
      inversion H_extract_none.
      subst. clear H_extract_none.
      assert (exists some_buf, extract_port_buffer buf j' i jp m c = (some_buf, None))
        as H_res_none
        by (eapply IHbuf;
            eassumption).
      destruct H_res_none as [some_buf H_res_none].
      rewrite H_res_none.
      exists (a :: some_buf).
      reflexivity.
Qed.

Lemma fail_on_extract_port_buffer_diff_port_implies_fail_before:
  forall buf buf' buf'' i i' j j' jp jp' m m' c c' p,
  extract_port_buffer buf j' i' jp' m' c' = (buf', Some p) ->
  extract_port_buffer buf' j i jp m c = (buf'', None) ->
  j <> j' ->
  exists some_buf, extract_port_buffer buf j i jp m c = (some_buf, None).
Proof.
  intros buf.
  induction buf;
  intros buf' buf'' i i' j j' jp jp' m m' c c' p;
  intros H_extract_first H_extract_fail H_ne;
  simpl in H_extract_first |- *.
  - inversion H_extract_first.
  - destruct j'.
    + destruct (extract_message a i' jp' m' c') eqn:extract_mes_first.
      inversion H_extract_first.
      subst. clear H_extract_first.
      simpl in H_extract_fail.
      destruct j.
      * contradiction.
      * destruct (extract_port_buffer buf j i jp m c) eqn:extract_second.
        inversion H_extract_fail.
        subst. clear H_extract_fail.
        exists (a :: i1).
        reflexivity.
    + destruct (extract_port_buffer buf j' i' jp' m' c') eqn:extract_first.
      inversion H_extract_first.
      subst. clear H_extract_first.
      simpl in H_extract_fail.
      destruct j.
      * destruct (extract_message a i jp m c) eqn:extract_mes_second.
        inversion H_extract_fail.
        subst. clear H_extract_fail.
        exists (i1 :: buf).
        reflexivity.
      * destruct (extract_port_buffer i0 j i jp m c) eqn:extract_second.
        inversion H_extract_fail.
        subst. clear H_extract_fail.
        assert (exists some_buf, extract_port_buffer buf j i jp m c = (some_buf, None))
          as H_must_fail
          by (eapply IHbuf;
              try apply PeanoNat.Nat.succ_inj_wd_neg;
              eassumption).
        destruct H_must_fail as [some_buf H_must_fail].
        rewrite H_must_fail.
        exists (a :: some_buf).
        reflexivity.
Qed.

Lemma fail_on_extract_diff_message_implies_fails_before:
  forall buf buf' buf'' i i' j jp j' jp' m m' c c' res,
  extract_port_buffer buf j' i' jp' m' c' = (buf', res) ->
  extract_port_buffer buf' j i jp m c = (buf'', None) ->
  (i', j', m', c') <> (i, j, m, c) ->
  exists some_buf, extract_port_buffer buf j i jp m c = (some_buf, None).
Proof.
  intros buf buf' buf'' i i' j jp j' jp' m m' c c' res.
  intros H_extract_prev H_extract_fail H_ne.
  destruct res.
  - assert (j < Datatypes.length buf \/ Datatypes.length buf <= j)
      as H_out_of_bounds_or_not
      by (apply PeanoNat.Nat.lt_ge_cases).
    destruct H_out_of_bounds_or_not as [H_in_bounds | H_out_bounds].
    + assert (j = j' \/ j <> j')
        as H_j_eq_dec
        by (apply nat_eq_dec).
      destruct H_j_eq_dec as [H_j_eq | H_j_not_eq].
      * subst.
        eapply fail_on_extract_port_buffer_same_port_implies_fail_before;
          try eassumption.
        unfold not.
        intros H_eq.
        inversion H_eq.
        subst.
        apply H_ne.
        reflexivity.
      * eapply fail_on_extract_port_buffer_diff_port_implies_fail_before;
        eassumption.
    + apply extract_port_buffer_out_of_bounds_implies_none
        with buf i j jp m c
        in H_out_bounds.
      exists buf.
      assumption.
  - apply extract_port_buffer_none_action_same_buffer in H_extract_prev.
    subst.
    exists buf''.
    assumption.
Qed.

Definition input_message_then_fail_extract_implies_earlier_deliver_def
  (inp : inputs) : Prop :=
  forall t1 n i j m c trace buf buf',
  nth_error inp t1 = Some (Send i (m, c)) ->
  execute_flood_rec inp (Flood_Box_init n) = (trace, buf) ->
  extract_port_buffer buf j i j m c = (buf', None) ->
  j < n ->
  exists t2, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)).

Lemma input_message_then_fail_extract_implies_earlier_deliver:
  forall inp,
  input_message_then_fail_extract_implies_earlier_deliver_def inp.
Proof.
  apply rev_ind;
  unfold input_message_then_fail_extract_implies_earlier_deliver_def.
  - intros.
    nth_error_empty.
  - intros action inp.
    intros IHinp.
    intros t1 n i j m c trace buf buf'.
    intros H_inp_send H_exec H_extract_fail H_jle.
    apply concat_inp_concats_trace_split in H_exec.
    destruct H_exec as [buf_inter H_exec].
    destruct H_exec as [trace_head H_exec].
    destruct H_exec as [trace_tail H_exec].
    destruct H_exec as [H_trace_concat H_exec].
    destruct H_exec as [H_exec_inp H_exec_send].
    apply nth_index_in_concat in H_inp_send.
    destruct H_inp_send as [H_inp_send | H_inp_send_tail].
    + destruct action;
      simpl in H_exec_send.
      * destruct p.
        inversion H_exec_send.
        subst. clear H_exec_send.
        assert ((n0, s, n1) = (i, m, c) \/ (n0, s, n1) <> (i, m, c))
          as H_same_or_diff_send_params
          by (apply tuple_nat_string_nat_eq_dec).
        destruct H_same_or_diff_send_params as [H_same_params | H_diff_params].
        -- inversion H_same_params.
           subst. clear H_same_params.
           assert (n = Datatypes.length buf_inter)
             as H_buf_length
             by (rewrite <- length_of_flood_init_is_param with (n := n);
                 eapply execute_inp_preserves_buffer_length;
                 eassumption).
           subst.
           assert (exists buf' res,
                    extract_port_buffer (add_message_to_all buf_inter i m c) j i j m c
                      = (buf', Some res))
             as H_extract_not_fail
             by (apply extract_from_buffer_with_message_just_added_cannot_fail;
                 assumption).
           destruct H_extract_not_fail as [buf'' H_extract_not_fail].
           destruct H_extract_not_fail as [res H_extract_not_fail].
           rewrite H_extract_not_fail in H_extract_fail.
           inversion H_extract_fail.
        -- assert (exists buf', extract_port_buffer buf_inter j i j m c = (buf', None))
             as H_extract_smaller_fail
             by (eapply fail_on_add_diff_message_implies_fails_before;
                 eassumption).
           destruct H_extract_smaller_fail as [some_buf H_extract_smaller_fail].
           assert (exists t2 : nat, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
           as H_deliver_in_inp
           by (eapply IHinp;
               eassumption).
           destruct H_deliver_in_inp as [t2 H_deliver_in_inp].
           destruct H_deliver_in_inp as [H_le H_deliver_in_inp].
           exists t2.
           split.
           ++ assumption.
           ++ apply nth_succes_larger.
              assumption.
      * destruct p.
        assert ((n0, n1, s, n2) = (i, j, m, c) \/ (n0, n1, s, n2) <> (i, j, m, c))
          as H_same_or_diff_deliver_params
          by (apply tuple_nat_nat_string_nat_eq_dec).
        destruct H_same_or_diff_deliver_params as [H_same_params | H_diff_params].
        -- inversion H_same_params.
           subst. clear H_same_params.
           exists (Datatypes.length inp).
           split.
           ++ apply nth_error_Some.
              unfold not.
              intros H_none.
              rewrite H_none in H_inp_send.
              discriminate.
           ++ rewrite nth_error_app2.
              ** rewrite PeanoNat.Nat.sub_diag.
                 simpl.
                 reflexivity.
              ** apply PeanoNat.Nat.le_refl.
        -- destruct (extract_port_buffer buf_inter n1 n0 n1 s n2) eqn:del_extract.
           destruct o;
           try (do 3 destruct p);
           inversion H_exec_send;
           subst; clear H_exec_send;
           assert (exists buf', extract_port_buffer buf_inter j i j m c = (buf', None))
             as H_extract_smaller_fail
             by (eapply fail_on_extract_diff_message_implies_fails_before;
                 eassumption);
           destruct H_extract_smaller_fail as [some_buf H_extract_smaller_fail];
           assert (exists t2 : nat, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
           as H_deliver_in_inp
           by (eapply IHinp;
               eassumption);
           destruct H_deliver_in_inp as [t2 H_deliver_in_inp];
           destruct H_deliver_in_inp as [H_le H_deliver_in_inp];
           exists t2;
           split;
           try (apply nth_succes_larger);
           assumption.
    + destruct H_inp_send_tail as [offset H_inp_send_tail].
      destruct H_inp_send_tail as [H_offset H_inp_send_tail].
      destruct offset;
      simpl in H_inp_send_tail.
      * inversion H_inp_send_tail.
        subst. clear H_inp_send_tail.
        simpl in H_exec_send.
        inversion H_exec_send.
        subst. clear H_exec_send.
        assert (n = Datatypes.length buf_inter)
          as H_buf_length
          by (rewrite <- length_of_flood_init_is_param with (n := n);
              eapply execute_inp_preserves_buffer_length;
              eassumption).
        subst.
        assert (exists buf' res,
                 extract_port_buffer (add_message_to_all buf_inter i m c) j i j m c
                   = (buf', Some res))
          as H_extract_not_fail
          by (apply extract_from_buffer_with_message_just_added_cannot_fail;
              assumption).
        destruct H_extract_not_fail as [buf'' H_extract_not_fail].
        destruct H_extract_not_fail as [res H_extract_not_fail].
        rewrite H_extract_not_fail in H_extract_fail.
        inversion H_extract_fail.
      * nth_error_empty.
Qed.

Definition send_then_deliver_inp_implies_input_output_pair_in_trace_def
  (inp : inputs) : Prop :=
  forall t1 t1' t2 n i j m c trace buf,
  nth_error inp t1 = Some (Send i (m, c)) ->
  nth_error inp t2 = Some (Deliver i j (m, c)) ->
  t1 < t2 ->
  no_late_specific_send inp t1 i m c ->
  execute_flood_rec inp (Flood_Box_init n) = (trace, buf) ->
  nth_error trace t1' = Some (Flood_Input i (m, c)) ->
  j < n ->
  exists t2', t1' < t2' /\ nth_error trace t2' = Some (Flood_Output i j (m, c)).

Lemma send_then_deliver_inp_implies_input_output_pair_in_trace:
  forall inp,
  send_then_deliver_inp_implies_input_output_pair_in_trace_def inp.
Proof.
  apply rev_ind;
  unfold send_then_deliver_inp_implies_input_output_pair_in_trace_def.
  - intros.
    nth_error_empty.
  - intros action inp.
    intros IHinp.
    intros t1 t1' t2 n i j m c trace buf'.
    intros H_inp_send H_inp_deliver H_t_le H_inp_no_late_send H_exec H_trace_input H_port_exists.
    apply concat_inp_concats_trace_split in H_exec.
    destruct H_exec as [buf H_exec].
    destruct H_exec as [trace_head H_exec].
    destruct H_exec as [trace_tail H_exec].
    destruct H_exec as [trace_concat H_exec].
    destruct H_exec as [exec_inp exec_action].
    apply nth_index_in_concat in H_inp_send.
    destruct H_inp_send as [H_inp_send_head | H_inp_send_tail].
    + apply nth_index_in_concat in H_inp_deliver.
      destruct H_inp_deliver as [H_inp_deliver_head | H_inp_deliver_tail].
      * rewrite trace_concat in H_trace_input.
        assert (exists t2' : nat, t1' < t2' /\
                  nth_error trace_head t2' = Some (Flood_Output i j (m, c)))
          as H_output_in_head
          by (eapply IHinp;
              try eapply no_late_specific_send_implies_shorter;
              try eapply send_in_inp_head_implies_send_in_trace_head;
              eassumption).
        destruct H_output_in_head as [t2' H_output_in_head].
        destruct H_output_in_head as [H_le_prime H_output_in_head].
        exists t2'.
        split.
        -- assumption.
        -- rewrite trace_concat.
           eapply nth_succes_larger.
           eassumption.
      * destruct H_inp_deliver_tail as [offset H_inp_deliver_tail].
        destruct H_inp_deliver_tail as [H_offset H_inp_deliver_tail].
        destruct offset;
        simpl in H_inp_deliver_tail.
        -- inversion H_inp_deliver_tail.
           subst. clear H_inp_deliver_tail.
           simpl in H_t_le.
           simpl in exec_action.
           destruct (extract_port_buffer buf j i j m c) eqn:extract.
           destruct o.
           ++ do 3 destruct p.
              inversion exec_action.
              subst. clear exec_action.
              apply extract_port_buffer_success_same_output in extract.
              destruct extract as [H_eq1 H_eq].
              destruct H_eq as [H_j_eq H_eq].
              destruct H_eq as [H_m_eq H_c_eq].
              subst.
              exists (S (Datatypes.length trace_head)).
              split.
              ** apply nth_error_concat_not_in_tail_implies_head in H_trace_input.
                 --- apply PeanoNat.Nat.lt_lt_succ_r.
                     apply nth_error_Some.
                     unfold not.
                     intros H_none.
                     rewrite H_none in H_trace_input.
                     inversion H_trace_input.
                 --- unfold not.
                     intros H_in.
                     inversion H_in;  (* fix name, to be constant - match goal? *)
                     inversion H;
                     inversion H0.
              ** rewrite nth_error_app2.
                 --- rewrite <- Minus.minus_Sn_m.
                     +++ rewrite PeanoNat.Nat.sub_diag.
                         simpl.
                         reflexivity.
                     +++ apply PeanoNat.Nat.le_refl.
                 --- apply PeanoNat.Nat.le_succ_diag_r.
           ++ inversion exec_action.
              subst. clear exec_action.
              assert (exists t2, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
                as H_earlier_deliver
                by (eapply input_message_then_fail_extract_implies_earlier_deliver;
                    eassumption).
              destruct H_earlier_deliver as [t2 H_earlier_deliver].
              destruct H_earlier_deliver as [H_t1_le_t2 H_inp_deliver].
              assert (exists t2' : nat, t1' < t2' /\
                        nth_error trace_head t2' = Some (Flood_Output i j (m, c)))
                as H_output_in_head
                by (eapply IHinp;
                    try eassumption;
                    try eapply no_late_specific_send_implies_shorter;
                    try eapply nth_different_tail_smaller;
                    try eassumption;
                    discriminate).
              destruct H_output_in_head as [t2' H_output_in_head].
              destruct H_output_in_head as [H_le H_output_in_head].
              exists t2'.
              split.
              ** assumption.
              ** eapply nth_succes_larger.
                 eassumption.
        --  nth_error_empty.
    + destruct H_inp_send_tail as [offset H_inp_send_tail].
      destruct H_inp_send_tail as [H_offset H_inp_send_tail].
      destruct offset;
      simpl in H_inp_send_tail.
      * inversion H_inp_send_tail.
        simpl in H_offset.
        subst. clear H_inp_send_tail.
        apply nth_different_tail_smaller in H_inp_deliver.
        -- apply PeanoNat.Nat.lt_le_incl in H_t_le.
           apply nth_error_None in H_t_le.
           rewrite H_inp_deliver in H_t_le.
           inversion H_t_le.
        -- unfold not.
           intros H_err.
           inversion H_err.
      * nth_error_empty.
Qed.

Theorem Flood_Box_Liveness:
  forall inp n trace,
  user_contract inp ->
  input_liveness inp n ->
  execute_flood inp n = trace ->
  flood_liveness trace n.
Proof.
  intros inp n trace.
  intros H_contract H_live_inp H_exec.
  unfold flood_liveness.
  intros i m c t1.
  intros H_nth j H_in.
  unfold execute_flood in H_exec.
  destruct (execute_flood_rec inp (Flood_Box_init n)) eqn:exec_rec.
  simpl in H_exec.
  subst.
  assert (exists t1', nth_error inp t1' = Some (Send i (m, c))/\
                      no_late_specific_send inp t1' i m c)
    as H_inp_send
    by (eapply input_in_trace_implies_late_send_in_inp;
        eassumption).
  destruct H_inp_send as [t1' H_inp_send].
  destruct H_inp_send as [H_inp_send H_inp_late_non_send].
  unfold input_liveness in H_live_inp.
  assert (exists t2 : nat, t1' < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
    as H_deliver_inp
    by (eapply H_live_inp;
        eassumption).
  destruct H_deliver_inp as [t2 H_deliver_inp].
  destruct H_deliver_inp as [H_t_le H_deliver_inp].
  eapply send_then_deliver_inp_implies_input_output_pair_in_trace;
  eassumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O B C Bprime Cprime X Y B0 : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ B0 O /\ (wd_ C Bprime /\ (wd_ Y C /\ (wd_ X C /\ (wd_ Y B /\ (wd_ X B /\ (wd_ B Bprime /\ (wd_ B B0 /\ (wd_ B Cprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y B0 /\ (col_ C C Bprime /\ col_ O C Bprime)))))))))))))))))))))) -> col_ O B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D A1 A2 A3 B1 B2 B3 C1 C2 C3 D1 D2 D3 O P Q R : Universe, ((wd_ A B /\ (wd_ B D /\ (wd_ A D /\ (wd_ C1 C2 /\ (wd_ C2 C3 /\ (wd_ C B /\ (wd_ C D /\ (wd_ A1 A2 /\ (wd_ A2 A3 /\ (wd_ A C /\ (wd_ D1 D2 /\ (wd_ D2 D3 /\ (wd_ B1 B2 /\ (wd_ B2 B3 /\ (wd_ P Q /\ (wd_ Q R /\ (col_ A B C /\ (col_ A D C /\ (col_ B O D /\ (col_ A O C /\ col_ D2 D1 D3)))))))))))))))))))) -> col_ C B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


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

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Basic Category Theory: epic, monic, iso                          *)
(*                                                                           *)
(*          Amokrane Saibi,  May 1994                                        *)
(*                                                                           *)
(*****************************************************************************)

Require Export Dual.

Set Implicit Arguments.
Unset Strict Implicit.

Section epic_monic_def.

Variables (C : Category) (a b : C).

(* epic *)

Definition Epic_law (f : a --> b) :=
  forall (c : C) (g h : b --> c), f o g =_S f o h -> g =_S h.

Structure > Epic : Type :=
  {Epic_mor : a --> b; Prf_isEpic :> Epic_law Epic_mor}.

(* monic *)

Definition Monic_law (f : b --> a) :=
  forall (c : C) (g h : c --> b), g o f =_S h o f -> g =_S h.

Structure > Monic : Type :=
  {Monic_mor : b --> a; Prf_isMonic :> Monic_law Monic_mor}.

End epic_monic_def.

(* iso *)

Section iso_def.

Variable C : Category.

Definition RIso_law (a b : C) (f : a --> b) (f1 : b --> a) := f1 o f =_S Id b.

Variable a b : C.

Definition AreIsos (f : a --> b) (f1 : b --> a) :=
  RIso_law f f1 /\ RIso_law f1 f.

Structure > Iso : Type :=
  {Iso_mor : a --> b; Inv_iso : b --> a; Prf_Iso :> AreIsos Iso_mor Inv_iso}.

Lemma Idl_inv : forall i : Iso, RIso_law (Iso_mor i) (Inv_iso i).
Proof.
simple induction i; unfold AreIsos in |- *; intros f g p; elim p; auto.
Qed.

Lemma Idr_inv : forall i : Iso, RIso_law (Inv_iso i) (Iso_mor i).
Proof.
simple induction i; unfold AreIsos in |- *; intros f g p; elim p; auto.
Qed.

Lemma Inv_iso_unique :
 forall f g : Iso, Iso_mor f =_S Iso_mor g -> Inv_iso f =_S Inv_iso g.
Proof.
intros f g H.
apply Trans with ((Inv_iso f o Iso_mor f) o Inv_iso g).
apply Trans with (Inv_iso f o Iso_mor f o Inv_iso g).
apply Trans with (Inv_iso f o Id a).
apply Idr.
apply Comp_l.
apply Trans with (Iso_mor g o Inv_iso g).
apply Sym; apply (Idr_inv g).
apply Comp_r; apply Sym; trivial.
apply Ass.
apply Trans with (Id b o Inv_iso g).
apply Comp_r; apply (Idl_inv f).
apply Idl.
Qed.

Lemma RightInv_epic :
 forall (h : a --> b) (h1 : b --> a), RIso_law h h1 -> Epic_law h.
Proof.
intros h h1 H.
unfold Epic_law in |- *; intros c f g H1.
apply Trans with (Id b o f).
apply Idl1.
apply Trans with (Id b o g).
apply Trans with ((h1 o h) o f).
apply Comp_r; apply Sym; trivial.
apply Trans with ((h1 o h) o g).
apply Trans with (h1 o h o f).
apply Ass1.
apply Trans with (h1 o h o g).
apply Comp_l; trivial.
apply Ass.
apply Comp_r; trivial.
apply Idl.
Qed.

End iso_def.

Coercion RightInv_epic : RIso_law >-> Epic_law.

(* initial *)

Section initial_def.

Variable C : Category.

Definition IsInitial (a : C) (h : forall b : C, a --> b) :=
  forall (b : C) (f : a --> b), f =_S h b.

Structure > Initial : Type :=
  {Initial_ob : C;
   MorI : forall b : C, Initial_ob --> b;
   Prf_isInitial :> IsInitial MorI}.

Definition At_most_1mor (a b : C) := forall f g : a --> b, f =_S g.

Lemma UniqueI : forall (i : Initial) (b : C), At_most_1mor (Initial_ob i) b.
Proof.
intros i b; red in |- *; intros f g.
apply Trans with (MorI i b).
apply (Prf_isInitial (i:=i)).
apply Sym; apply (Prf_isInitial (i:=i)).
Qed.

Lemma I_unic : forall i1 i2 : Initial, Iso (Initial_ob i1) (Initial_ob i2).
Proof.
intros i1 i2.
apply
 (Build_Iso (Iso_mor:=MorI i1 (Initial_ob i2))
    (Inv_iso:=MorI i2 (Initial_ob i1))); unfold AreIsos in |- *;
 unfold RIso_law in |- *; split.
apply (UniqueI (i:=i2) (b:=Initial_ob i2)).
apply (UniqueI (i:=i1) (b:=Initial_ob i1)).
Defined.

End initial_def.

(* terminal *)

Section terminal_def.

Variable C : Category.

Definition IsTerminal (b : C) (h : forall a : C, a --> b) :=
  forall (a : C) (f : a --> b), f =_S h a.

Structure > Terminal : Type :=
  {Terminal_ob : C;
   MorT : forall a : C, a --> Terminal_ob;
   Prf_isTerminal :> IsTerminal MorT}.

Lemma UniqueT : forall (t : Terminal) (a : C), At_most_1mor a (Terminal_ob t).
Proof.
intros t a; red in |- *; intros f g.
apply Trans with (MorT t a).
apply (Prf_isTerminal (t:=t)).
apply Sym; apply (Prf_isTerminal (t:=t)).
Qed.

End terminal_def.

Lemma Initial_dual :
 forall (C : Category) (a : C) (h : forall b : C, a --> b),
 IsInitial h -> IsTerminal (C:=Dual C) h.
Proof.
auto.
Qed.

Coercion Initial_dual : IsInitial >-> IsTerminal.

Definition IsTerminal' (C : Category) (b : C) (h : forall a : C, a --> b) :=
  IsInitial (C:=Dual C) h.


(* mell_mset example file for yalla library *)
(* v 1.0   Olivier Laurent *)

(** * Example of a concrete use of the yalla library: multi-set based MELL *)

Require Import Injective.
Require Import nattree.
Require Import fmsetlist_Type.
Require Import List_more.
Require Import List_Type_more.
Require Import Permutation_more.
Require Import Permutation_Type_more.

Import FMSetNotations.

(** ** 0. load the [ll] library *)

Require ll_cut.
Require fmformulas.

(** ** 1. define formulas *)

Inductive formula : Set :=
| var : formulas.Atom -> formula
| covar : formulas.Atom -> formula
| one : formula
| bot : formula
| tens : formula -> formula -> formula
| parr : formula -> formula -> formula
| oc : formula -> formula
| wn : formula -> formula.

Fixpoint dual A :=
match A with
| var x     => covar x
| covar x   => var x
| one       => bot
| bot       => one
| tens A B  => parr (dual B) (dual A)
| parr A B  => tens (dual B) (dual A)
| oc A      => wn (dual A)
| wn A      => oc (dual A)
end.

(** ** 2. define embedding into [formulas.formula] *)

Fixpoint mell2ll A :=
match A with
| var x    => formulas.var x
| covar x  => formulas.covar x
| one      => formulas.one
| bot      => formulas.bot
| tens A B => formulas.tens (mell2ll A) (mell2ll B)
| parr A B => formulas.parr (mell2ll A) (mell2ll B)
| oc A     => formulas.oc (mell2ll A)
| wn A     => formulas.wn (mell2ll A)
end.

Lemma mell2ll_inj : injective mell2ll.
Proof with try reflexivity.
intros A.
induction A ; intros B Heq ;
  destruct B ; inversion Heq ;
  try apply IHA in H0 ;
  try apply IHA1 in H0 ;
  try apply IHA2 in H1 ; subst...
Qed.

Instance border_formula : BOrder.
Proof.
eapply (@border_inj _ border_nat).
eapply comp_inj ; [ eapply comp_inj | ].
- apply nattree2nat_inj.
- eapply section_inj.
  apply fmformulas.form_nattree_section.
- apply mell2ll_inj.
Defined.

Lemma mell2ll_dual : forall A,
  formulas.dual (mell2ll A) = mell2ll (dual A).
Proof.
induction A ; simpl ;
  rewrite ? IHA ;
  rewrite ? IHA1 ;
  rewrite ? IHA2 ;
  reflexivity.
Qed.

Lemma mell2ll_map_wn : forall l,
  map mell2ll (map wn l) = map formulas.wn (map mell2ll l).
Proof with try reflexivity.
induction l...
simpl ; rewrite IHl...
Qed.

Lemma mell2ll_map_wn_inv : forall l1 l2,
  Permutation_Type (map formulas.wn l1) (map mell2ll l2) -> { pl : _ &
    prod (prod (l1 = map mell2ll (fst pl)) (l2 = map wn (snd pl)))
         (Permutation_Type (fst pl) (snd pl)) }.
Proof with try assumption ; try reflexivity.
induction l1 ; intros l2 Heq ;
  destruct l2.
- exists (nil, nil) ; split ; [ split | ]...
- apply Permutation_Type_nil in Heq.
  inversion Heq.
- symmetry in Heq.
  apply Permutation_Type_nil in Heq.
  inversion Heq.
- assert (HP := Heq).
  symmetry in Heq.
  apply Permutation_Type_vs_cons_inv in Heq.
  destruct Heq as ((l0 & l3) & Heq).
  destruct l0.
  + simpl in Heq ; inversion Heq ; subst.
    simpl in HP.
    rewrite H0 in HP.
    apply Permutation_Type_cons_inv in HP.
    apply IHl1 in HP.
    destruct HP as ((l1' & l2') & (Heq1 & Heq2) & HP) ; subst.
    destruct f ; inversion H0.
    exists (f :: l1', f :: l2') ; split ; [ split | ]...
    apply Permutation_Type_cons...
  + inversion Heq.
    simpl in HP ; rewrite H1 in HP.
    rewrite app_comm_cons in HP.
    apply Permutation_Type_cons_app_inv in HP.
    symmetry in H1.
    decomp_map_Type H1 ; subst ; simpl in HP.
    replace (mell2ll f :: map mell2ll l4 ++ map mell2ll l6)
      with (map mell2ll ((f :: l4) ++ l6))
      in HP by (list_simpl ; reflexivity).
    apply IHl1 in HP.
    destruct HP as ((l1' & l2') & (Heq1 & Heq2) & HP).
    simpl in Heq1 ; simpl in Heq2 ; subst ; simpl in H1 ; simpl in HP.
    destruct x ; inversion H1.
    decomp_map_Type Heq2 ; subst.
    exists (x :: l1', x0 :: l1 ++ x :: l2) ; split ; [ split | ]...
    * list_simpl...
    * rewrite app_comm_cons.
      apply Permutation_Type_cons_app...
Qed.

(** *** 2bis. sequents *)

Instance fmset_formula : FinMultiset (SortedList _) formula :=
  FMConstr_slist border_formula.

(** ** 3. define proofs *)

Inductive mell : SortedList border_formula -> Prop :=
| ax_r : forall X, mell (add (covar X) (add (var X) empty))
| one_r : mell (add one empty)
| bot_r : forall m, mell m -> mell (add bot m)
| tens_r : forall A B m1 m2,
              mell (add A m1) -> mell (add B m2) ->
              mell (add (tens A B) (sum m1 m2))
| parr_r : forall A B m,
              mell (add A (add B m)) ->
              mell (add (parr A B) m)
| oc_r : forall A m,
              mell (add A (fmmap wn m)) ->
              mell (add (oc A) (fmmap wn m))
| de_r : forall A m,
              mell (add A m) -> mell (add (wn A) m)
| wk_r : forall A m,
              mell m -> mell (add (wn A) m)
| co_r : forall A m,
              mell (add (wn A) (add (wn A) m)) ->
              mell (add (wn A) m).

(** ** 4. characterize corresponding [ll] fragment *)

(*
Definition mell_fragment A := exists B, A = mell2ll B.

Lemma mell_is_fragment : ll_prop.fragment mell_fragment.
Proof.
intros A HfA B Hsf.
induction Hsf ;
  try (apply IHHsf ;
       destruct HfA as [B0 HfA] ;
       destruct B0 ; inversion HfA ; subst ;
       eexists ; reflexivity).
assumption.
Qed.
*)

(** cut / axioms / mix0 / mix2 / permutation *)
Definition pfrag_mell := ll_def.mk_pfrag false ll_def.NoAxioms false false true.
(*                                       cut   axioms          mix0  mix2  perm  *)

(** ** 5. prove equivalence of proof predicates *)

Lemma mell2mellfrag : forall m,
  mell m -> inhabited (ll_def.ll pfrag_mell (map mell2ll (elts m))).
Proof with try reflexivity ; try eassumption.
intros m pi.
induction pi ; simpl ; rewrite ? map_app ;
  try (destruct IHpi as [IHpi]) ;
  try (destruct IHpi1 as [IHpi1]) ;
  try (destruct IHpi2 as [IHpi2]) ;
  constructor.
- apply (ll_def.ex_r _ (map mell2ll (covar X :: var X :: nil))).
  + apply ll_def.ax_r.
  + symmetry.
    destruct (Compare_dec.leb
           (cpair 2 (pcpair (cpair (fmformulas.a2n X) (pcpair 0 0)) 0))
           (cpair 1 (pcpair (cpair (fmformulas.a2n X) (pcpair 0 0)) 0)))...
    apply Permutation_Type_swap.
- apply ll_def.one_r.
- eapply ll_def.ex_r.
  + apply ll_def.bot_r...
  + change (formulas.bot :: map mell2ll (elts m))
      with (map mell2ll (bot :: elts m)).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add bot m) = elts (add bot m))
      as Helt by reflexivity.
    rewrite Helt.
    symmetry ; apply elts_add.
- eapply ll_def.ex_r.
  + apply ll_def.tens_r.
    * assert (Helt := Permutation_Type_map mell2ll (elts_add A m1)).
      apply (ll_def.ex_r _ _ _ IHpi1) in Helt.
      simpl in Helt...
    * assert (Helt := Permutation_Type_map mell2ll (elts_add B m2)).
      apply (ll_def.ex_r _ _ _ IHpi2) in Helt.
      simpl in Helt...
  + rewrite <- map_app.
    change (formulas.tens (mell2ll A) (mell2ll B)
              :: map mell2ll (proj1_sig m2 ++ proj1_sig m1))
      with (map mell2ll (tens A B :: elts m2 ++ elts m1)).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add (tens A B) (sum m1 m2))
              = elts (add (tens A B) (sum m1 m2)))
      as Helt by reflexivity.
    rewrite Helt.
    etransitivity ; [ apply Permutation_Type_cons ;
                      [ reflexivity | apply Permutation_Type_app_comm ] | ].
    etransitivity ; [ apply Permutation_Type_cons ;
                      [ reflexivity | symmetry ; apply elts_sum ] | ].
    symmetry ; apply elts_add.
- eapply ll_def.ex_r.
  + apply ll_def.parr_r.
    assert (Permutation_Type (elts (add A (add B m))) (A :: B :: elts m))
      as Helt.
    { etransitivity ; [ apply elts_add | ].
      apply Permutation_Type_cons...
      apply elts_add. }
    apply (Permutation_Type_map mell2ll) in Helt.
    apply (ll_def.ex_r _ _ _ IHpi) in Helt.
    simpl in Helt...
  + change (formulas.parr (mell2ll A) (mell2ll B) :: map mell2ll (proj1_sig m))
      with (map mell2ll (parr A B :: elts m)).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add (parr A B) m) = elts (add (parr A B) m))
      as Helt by reflexivity.
    rewrite Helt.
    symmetry ; apply elts_add.
- eapply ll_def.ex_r.
  + apply ll_def.oc_r.
    assert (Permutation_Type (elts (add A (fmmap wn m))) (A :: map wn (elts m)))
      as Helt.
    { etransitivity ; [ apply elts_add | ].
      apply Permutation_Type_cons...
      apply elts_fmmap. }
    apply (Permutation_Type_map  mell2ll) in Helt.
    apply (ll_def.ex_r _ _ _ IHpi) in Helt.
    eapply ll_def.ex_r ; [ apply Helt | ].
    simpl.
    apply Permutation_Type_cons...
    rewrite mell2ll_map_wn.
    apply Permutation_Type_map.
    reflexivity.
  + rewrite <- mell2ll_map_wn.
    change (formulas.oc (mell2ll A) :: map mell2ll (map wn (proj1_sig m)))
      with (map mell2ll (oc A :: map wn (elts m))).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add (oc A) (fmmap wn m))
              = elts (add (oc A) (fmmap wn m)))
      as Helt by reflexivity.
    rewrite Helt.
    symmetry.
    etransitivity ; [ apply elts_add | ].
    apply Permutation_Type_cons...
    apply elts_fmmap.
- eapply ll_def.ex_r.
  + apply ll_def.de_r.
    assert (Helt := Permutation_Type_map mell2ll (elts_add A m)).
    apply (ll_def.ex_r _ _ _ IHpi) in Helt.
    simpl in Helt...
  + change (formulas.wn (mell2ll A) :: map mell2ll (proj1_sig m))
      with (map mell2ll (wn A :: elts m)).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add (wn A) m) = elts (add (wn A) m))
      as Helt by reflexivity.
    rewrite Helt.
    symmetry ; apply elts_add.
- eapply ll_def.ex_r.
  + apply (ll_def.wk_r _ (mell2ll A))...
  + change (formulas.wn (mell2ll A) :: map mell2ll (elts m))
      with (map mell2ll (wn A :: elts m)).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add (wn A) m) = elts (add (wn A) m))
      as Helt by reflexivity.
    rewrite Helt.
    symmetry ; apply elts_add.
- eapply ll_def.ex_r.
  + apply (ll_def.co_r _ (mell2ll A)).
    simpl.
    assert (Permutation_Type (elts (add (wn A) (add (wn A) m)))
                             (wn A :: wn A :: elts m))
      as Helt.
    { etransitivity ; [ apply elts_add | ].
      apply Permutation_Type_cons...
      apply elts_add. }
    apply (Permutation_Type_map mell2ll) in Helt.
    apply (ll_def.ex_r _ _ _ IHpi) in Helt.
    simpl in Helt...
  + change (formulas.wn (mell2ll A) :: map mell2ll (proj1_sig m))
      with (map mell2ll (wn A :: elts m)).
    apply Permutation_Type_map.
    rewrite <- (@insert_add border_formula).
    assert (proj1_sig (fmslist_add (wn A) m) = elts (add (wn A) m))
      as Helt by reflexivity.
    rewrite Helt.
    symmetry ; apply elts_add.
Qed.

Lemma mellfrag2mell : forall m,
  ll_def.ll pfrag_mell (map mell2ll (elts m)) -> mell m.
Proof with try eassumption ; try reflexivity.
intros m pi.
remember (map mell2ll (elts m)) as l.
assert (HP := Permutation_Type_refl l).
rewrite Heql in HP at 2 ; clear Heql.
revert m HP ; induction pi ; intros m HP ; subst ;
  try (now inversion f) ;
  try (now (apply Permutation_Type_image in HP ;
            destruct HP as [Z Heq] ;
            destruct Z ; inversion Heq)).
- apply Permutation_Type_length_2_inv in HP.
  destruct HP as [ HP | HP ] ; symmetry in HP ; decomp_map HP ; subst.
  + destruct l1 ; inversion HP4.
    destruct x ; inversion HP1 ; subst.
    destruct x0 ; inversion HP3 ; subst.
    apply (f_equal (fold_right add empty)) in HP.
    rewrite retract in HP ; subst.
    apply ax_r.
  + destruct l1 ; inversion HP4.
    destruct x ; inversion HP1 ; subst.
    destruct x0 ; inversion HP3 ; subst.
    apply (f_equal (fold_right add empty)) in HP.
    rewrite retract in HP ; subst.
    simpl.
    assert (add (var a0) (add (covar a0) empty)
          = add (covar a0) (add (var a0) empty))
      as Hswap by apply add_swap.
    unfold add in Hswap.
    simpl in Hswap.
    rewrite Hswap.
    apply ax_r.
- apply IHpi.
  simpl in p.
  etransitivity...
- apply IHpi.
  etransitivity...
  apply Permutation_Type_app_head.
  apply Permutation_Type_app_tail.
  apply Permutation_Type_map...
- apply Permutation_Type_length_1_inv in HP.
  remember (elts m) as l.
  destruct l ; inversion HP.
  destruct l ; inversion H1.
  destruct f ; inversion H0 ; subst.
  apply (f_equal (fold_right add empty)) in Heql.
  rewrite retract in Heql ; subst.
  apply one_r.
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l1 & l2) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  rewrite list2fm_elt.
  apply bot_r.
  apply IHpi.
  etransitivity ; [ | apply elts_fmmap ].
  unfold fmmap.
  etransitivity ; [ | symmetry ; apply elts_perm ].
  etransitivity ; [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ;
   [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  list_simpl in HP2.
  symmetry in HP2.
  apply Permutation_Type_cons_app_inv in HP2.
  rewrite map_app...
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l3 & l4) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ;
    [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  list_simpl in HP2.
  symmetry in HP2.
  apply Permutation_Type_cons_app_inv in HP2.
  rewrite <- map_app in HP2.
  apply Permutation_Type_map_inv in HP2.
  destruct HP2 as [l Heq HP].
  rewrite list2fm_elt.
  apply list2fm_perm in HP ; simpl in HP.
  rewrite HP.
  decomp_map Heq ; subst.
  rewrite list2fm_app.
  rewrite sum_comm.
  apply tens_r.
  + apply IHpi1.
    eapply Permutation_Type_trans ; [ | apply elts_fmmap ].
    unfold fmmap.
    eapply Permutation_Type_trans ; [ | symmetry ; apply elts_perm ].
    change (mell2ll x1 :: map mell2ll l9) with (map mell2ll (x1 :: l9)).
    apply Permutation_Type_map.
    symmetry.
    etransitivity.
    * apply elts_add.
    * apply Permutation_Type_cons...
      apply elts_perm.
  + apply IHpi2.
    eapply Permutation_Type_trans ; [ | apply elts_fmmap ].
    unfold fmmap.
    eapply Permutation_Type_trans ; [ | symmetry ; apply elts_perm ].
    change (mell2ll x2 :: map mell2ll l8) with (map mell2ll (x2 :: l8)).
    apply Permutation_Type_map.
    symmetry.
    etransitivity.
    * apply elts_add.
    * apply Permutation_Type_cons...
      apply elts_perm.
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l1 & l2) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  rewrite list2fm_elt.
  apply parr_r.
  apply IHpi.
  etransitivity ; [ | apply elts_fmmap ].
  unfold fmmap.
  etransitivity ; [ | symmetry ; apply elts_perm ].
  rewrite <- 2 list2fm_elt.
  etransitivity ; [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply Permutation_Type_map ;
                                             apply elts_perm ].
  list_simpl in HP2.
  symmetry in HP2.
  apply Permutation_Type_cons_app_inv in HP2.
  list_simpl.
  apply Permutation_Type_cons_app.
  apply Permutation_Type_cons_app...
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l1 & l2) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  rewrite list2fm_elt.
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply Permutation_Type_map ;
                                             apply elts_perm ].
  list_simpl in HP2.
  symmetry in HP2.
  apply Permutation_Type_cons_app_inv in HP2.
  rewrite <- map_app in HP2.
  apply mell2ll_map_wn_inv in HP2.
  destruct HP2 as ((l1' & l2') & (Heq1 & Heq2) & HP) ; subst.
  rewrite Heq2.
  rewrite list2fm_map.
  apply oc_r.
  apply IHpi.
  etransitivity ; [ | apply elts_fmmap ].
  unfold fmmap.
  etransitivity ; [ | symmetry ; apply elts_perm ].
  etransitivity ; [ | symmetry ; apply Permutation_Type_map ; apply elts_add ].
  simpl ; apply Permutation_Type_cons...
  rewrite <- mell2ll_map_wn.
  apply Permutation_Type_map.
  change (proj1_sig (list2fm (map wn (proj1_sig (list2fm l2')))))
    with (elts (list2fm (map wn (elts (list2fm l2'))))).
  etransitivity ; [ | symmetry ; apply elts_perm ].
  apply Permutation_Type_map.
  etransitivity ; [ | symmetry ; apply elts_perm ]...
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l1 & l2) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  rewrite list2fm_elt.
  apply de_r.
  apply IHpi.
  etransitivity ; [ | apply elts_fmmap ].
  unfold fmmap.
  etransitivity ; [ | symmetry ; apply elts_perm ].
  rewrite <- list2fm_elt.
  etransitivity ; [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply Permutation_Type_map ;
                                             apply elts_perm ].
  list_simpl in HP2.
  symmetry in HP2.
  apply Permutation_Type_cons_app_inv in HP2.
  list_simpl.
  apply Permutation_Type_cons_app...
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l1 & l2) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  rewrite list2fm_elt.
  apply wk_r.
  apply IHpi.
  etransitivity ; [ | apply elts_fmmap ].
  unfold fmmap.
  etransitivity ; [ | symmetry ; apply elts_perm ].
  etransitivity ; [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply Permutation_Type_map ;
                                             apply elts_perm ].
  list_simpl in HP2.
  symmetry in HP2.
  apply Permutation_Type_cons_app_inv in HP2.
  rewrite map_app...
- symmetry in HP.
  assert (HP2 := HP).
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l1 & l2) & HP).
  symmetry in HP.
  decomp_map HP ; subst.
  destruct x ; inversion HP4 ; subst.
  apply (f_equal list2fm) in HP.
  rewrite list2fm_retract in HP ; subst.
  rewrite list2fm_elt.
  apply co_r.
  apply IHpi.
  etransitivity ; [ | apply elts_fmmap ].
  unfold fmmap.
  etransitivity ; [ | symmetry ; apply elts_perm ].
  rewrite <- 2 list2fm_elt.
  etransitivity ; [ | symmetry ; apply Permutation_Type_map ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | apply elts_fmmap ].
  unfold fmmap in HP2.
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply elts_perm ].
  eapply Permutation_Type_trans in HP2 ; [ | symmetry ; apply Permutation_Type_map ;
                                             apply elts_perm ].
  list_simpl in HP2.
  list_simpl.
  apply Permutation_Type_cons_app.
  symmetry.
  etransitivity ; [ apply HP2 | ]...
- inversion a.
Qed.

(** ** 6. import properties *)

(** *** axiom expansion *)

Lemma ax_gen_r : forall A, mell (add (dual A) (add A empty)).
Proof.
intro A.
apply mellfrag2mell.
eapply ll_def.ex_r ; [ apply (ll_def.ax_exp (mell2ll (dual A))) | ].
rewrite <- mell2ll_dual.
rewrite formulas.bidual.
rewrite mell2ll_dual.
change (mell2ll (dual A) :: mell2ll A :: nil)
  with (map mell2ll (dual A :: A :: nil)).
apply Permutation_Type_map.
etransitivity ; [ | symmetry ; apply elts_add ].
reflexivity.
Qed.

(** *** cut admissibility *)

Lemma cut_r : forall A m1 m2,
  mell (add A m1) -> mell (add (dual A) m2) -> mell (sum m1 m2).
Proof with try eassumption.
intros A m1 m2 pi1 pi2.
apply mell2mellfrag in pi1 ; destruct pi1 as [pi1].
apply mell2mellfrag in pi2 ; destruct pi2 as [pi2].
apply mellfrag2mell.
eapply ll_def.ex_r ; [ | apply Permutation_Type_map ; symmetry ; apply elts_sum ].
rewrite map_app.
eapply ll_cut.cut_r_axfree...
- intros a ; destruct a.
- assert (Permutation_Type (map mell2ll (elts (add (dual A) m2)))
                           (map mell2ll (dual A :: elts m2)))
  as Helt2 by (apply Permutation_Type_map ; apply elts_add).
  simpl in Helt2 ; rewrite <- mell2ll_dual in Helt2.
  eapply ll_def.ex_r ; [ | apply Helt2 ]...
- assert (Permutation_Type (map mell2ll (elts (add A m1)))
                           (map mell2ll (A :: elts m1)))
  as Helt by (apply Permutation_Type_map ; apply elts_add).
  eapply ll_def.ex_r ; [ | apply Helt ]...
Qed.


Require Import VST.progs.io.
Require Import VST.progs.io_specs.
Require Import VST.floyd.proofauto.

Local Open Scope itree_scope.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition putchar_spec := DECLARE _putchar putchar_spec.
Definition getchar_spec := DECLARE _getchar getchar_spec.

Definition getchar_blocking_spec :=
 DECLARE _getchar_blocking
  WITH k : byte -> IO_itree
  PRE [ ]
    PROP ()
    PARAMS ()
    GLOBALS ()
    SEP (ITREE (r <- read stdin;; k r))
  POST [ tint ]
   EX i : byte,
    PROP ()
    LOCAL (temp ret_temp (Vubyte i))
    SEP (ITREE (k i)).

Definition putchar_blocking_spec :=
 DECLARE _putchar_blocking
  WITH c : byte, k : IO_itree
  PRE [ tint ]
    PROP ()
    PARAMS (Vubyte c)
    GLOBALS ()
    SEP (ITREE (r <- write stdout c ;; k))
  POST [ tint ]
    PROP ()
    LOCAL (temp ret_temp (Vubyte c))
    SEP (ITREE k).

Lemma div_10_dec : forall n, 0 < n ->
  (Z.to_nat (n / 10) < Z.to_nat n)%nat.
Proof.
  intros.
  change 10 with (Z.of_nat 10).
  rewrite <- (Z2Nat.id n) by lia.
  rewrite <- Nat2Z.inj_div by discriminate.
  rewrite !Nat2Z.id.
  apply Nat2Z.inj_lt.
  rewrite Nat2Z.inj_div, Z2Nat.id by lia; simpl.
  apply Z.div_lt; auto; lia.
Qed.

Program Fixpoint chars_of_Z (n : Z) { measure (Z.to_nat n) } : list byte :=
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Next Obligation.
Proof.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous.
  eapply Z.lt_le_trans, Z_mult_div_ge with (b := 10); lia.
Defined.

(* The function computed by print_intr *)
Program Fixpoint intr n { measure (Z.to_nat n) } : list byte :=
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Next Obligation.
Proof.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous; lia.
Defined.

Definition print_intr_spec :=
 DECLARE _print_intr
  WITH i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i))
    GLOBALS ()
    SEP (ITREE (write_list stdout (intr i) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (ITREE tr).

Definition print_int_spec :=
 DECLARE _print_int
  WITH i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i))
    GLOBALS ()
    SEP (ITREE (write_list stdout (chars_of_Z i) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (ITREE tr).

Definition read_sum n d : IO_itree :=
   ITree.iter (fun '(n, d) =>
       if zlt n 1000 then if zlt d 10 then
         write_list stdout (chars_of_Z (n + d));; write stdout (Byte.repr newline);;
              c <- read stdin;;
              Ret (inl (n + d, Byte.unsigned c - char0)) (* loop again with these parameters *)
       else Ret (inr tt) else Ret (inr tt)) (* inr to end the loop *)
     (n, d).

Definition main_itree := c <- read stdin;; read_sum 0 (Byte.unsigned c - char0).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog main_itree gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs := ltac:(with_library prog [putchar_spec; getchar_spec;
  print_intr_spec; print_int_spec; getchar_blocking_spec; putchar_blocking_spec; main_spec]).

Lemma divu_repr : forall x y,
  0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
  Int.divu (Int.repr x) (Int.repr y) = Int.repr (x / y).
Proof.
  intros; unfold Int.divu.
  rewrite !Int.unsigned_repr; auto.
Qed.

Opaque Nat.div Nat.modulo.

Lemma intr_eq : forall n, intr n =
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Proof.
  intros.
  unfold intr at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold intr.
  destruct n; reflexivity.
Qed.

Lemma body_getchar_blocking: semax_body Vprog Gprog f_getchar_blocking getchar_blocking_spec.
Proof.
  start_function.
  forward.
  forward_while (EX i : int, PROP (-1 <= Int.signed i <= two_p 8 - 1) LOCAL (temp _r (Vint i))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- read stdin;; k r) else k (Byte.repr (Int.signed i))))).
  - Exists (Int.neg (Int.repr 1)); entailer!!.
    { simpl; lia. }
    rewrite if_true; auto.
  - entailer!!.
  - subst; rewrite Int.signed_repr by rep_lia.
    rewrite if_true by auto.
    forward_call k.
    Intros i.
    forward.
    Exists i; entailer!!.
  - assert (Int.signed i <> -1).
    { intro X.
      apply f_equal with (f := Int.repr) in X.
      rewrite Int.repr_signed in X; auto. }
    rewrite if_false by auto.
    forward.
    Exists (Byte.repr (Int.signed i)); entailer!.
    unfold Vubyte; rewrite Byte.unsigned_repr, Int.repr_signed; auto.
    split; try lia.
    etransitivity; [apply H|].
    simpl; rep_lia.
Qed.

Lemma body_putchar_blocking: semax_body Vprog Gprog f_putchar_blocking putchar_blocking_spec.
Proof.
  start_function.
  forward.
  forward_while (EX i : int, PROP (Int.signed i = -1 \/ Int.signed i = Byte.unsigned c) LOCAL (temp _r (Vint i); temp _c (Vubyte c))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- write stdout c;; k) else k))).
  - Exists (Int.neg (Int.repr 1)); entailer!!.
    rewrite if_true; auto.
  - entailer!.
  - subst; rewrite Int.signed_repr by rep_lia.
    rewrite if_true by auto.
    forward_call (c, k).
    Intros i.
    forward.
    Exists i; entailer!!.
  - assert (Int.signed i <> -1).
    { intro X.
      apply f_equal with (f := Int.repr) in X.
      rewrite Int.repr_signed in X; auto. }
    rewrite if_false by auto.
    destruct H; [contradiction | subst].
    forward.
    entailer!!.
    unfold Vubyte.
    rewrite <- H, Int.repr_signed; auto.
Qed.

Lemma body_print_intr: semax_body Vprog Gprog f_print_intr print_intr_spec.
Proof.
  start_function.
  forward_if (PROP () LOCAL () SEP (ITREE tr)).
  - forward.
    forward.
    rewrite modu_repr, divu_repr by (lia || computable).
    rewrite intr_eq.
    destruct (Z.leb_spec i 0); try lia.
    rewrite write_list_app, bind_bind.
    forward_call (i / 10, write_list stdout [Byte.repr (i mod 10 + char0)];; tr).
    { split; [apply Z.div_pos; lia | apply Z.div_le_upper_bound; lia]. }
    simpl write_list.
    forward_call (Byte.repr (i mod 10 + char0), tr).
    { entailer!!.
      unfold Vubyte; rewrite Byte.unsigned_repr; auto.
      pose proof (Z_mod_lt i 10); unfold char0; rep_lia. }
    { rewrite <- sepcon_emp at 1; apply sepcon_derives; [|cancel].
      rewrite bind_ret'; auto. }
    entailer!!.
  - forward.
    subst; entailer!!.
    simpl.
    rewrite bind_ret_l; auto.
Qed.

Lemma chars_of_Z_eq : forall n, chars_of_Z n =
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Proof.
  intros.
  unfold chars_of_Z at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold chars_of_Z.
  destruct (_ <=? _); reflexivity.
Qed.

Lemma chars_of_Z_intr : forall n, 0 < n ->
  chars_of_Z n = intr n.
Proof.
  induction n using (well_founded_induction (Zwf.Zwf_well_founded 0)); intro.
  rewrite chars_of_Z_eq, intr_eq.
  destruct (n <=? 0) eqn: Hn; [apply Zle_bool_imp_le in Hn; lia|].
  simpl.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  destruct (n / 10 <=? 0) eqn: Hdiv.
  - apply Zle_bool_imp_le in Hdiv.
    assert (0 <= n / 10).
    { apply Z.div_pos; lia. }
    assert (n / 10 = 0) as Hz by lia.
    rewrite Hz; simpl.
    apply Z.div_small_iff in Hz as [|]; try lia.
    rewrite Zmod_small; auto.
  - apply Z.leb_nle in Hdiv.
    rewrite H; auto; try lia.
    split; try lia.
    apply Z.div_lt; auto; lia.
Qed.

Lemma body_print_int: semax_body Vprog Gprog f_print_int print_int_spec.
Proof.
  start_function.
  forward_if (PROP () LOCAL () SEP (ITREE tr)).
  - subst.
    forward_call (Byte.repr char0, tr).
    { rewrite chars_of_Z_eq; simpl.
      erewrite <- sepcon_emp at 1; apply sepcon_derives; [|cancel].
      rewrite bind_ret'; apply derives_refl. }
    entailer!!.
  - forward_call (i, tr).
    { rewrite chars_of_Z_intr by lia; cancel. }
    entailer!!.
Qed.

Lemma read_sum_eq : forall n d, read_sum n d ≈
  (if zlt n 1000 then if zlt d 10 then
     write_list stdout (chars_of_Z (n + d));; write stdout (Byte.repr newline);;
     c <- read stdin;; read_sum (n + d) (Byte.unsigned c - char0)
   else Ret tt else Ret tt).
Proof.
  intros.
  unfold read_sum; rewrite unfold_iter.
  unfold ITree.iter.
  if_tac; [|rewrite bind_ret_l; reflexivity].
  if_tac; [|rewrite bind_ret_l; reflexivity].
  repeat setoid_rewrite bind_bind.
  setoid_rewrite bind_ret_l.
  setoid_rewrite tau_eutt.
  reflexivity.
Qed.

Lemma signed_char_unsigned : forall c, Byte.unsigned c <= two_p 8 - 1.
Proof.
  intros.
  pose proof (Byte.unsigned_range c).
  unfold Byte.modulus, two_power_nat in H; simpl in *; lia.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  unfold main_pre.
  sep_apply (has_ext_ITREE(E := @IO_event nat)).
  forward.
  unfold main_itree.
  rewrite <- !seq_assoc. (* Without this, forward_call gives a type error! *)
  forward_call (fun c => read_sum 0 (Byte.unsigned c - char0)).
  Intros c.
  forward.
  rewrite zero_ext_inrange by (pose proof (signed_char_unsigned c); rewrite Int.unsigned_repr; rep_lia).
  set (Inv := EX n : Z, EX c : byte,
    PROP (0 <= n < 1009)
    LOCAL (temp _c (Vubyte c); temp _n (Vint (Int.repr n)))
    SEP (ITREE (read_sum n (Byte.unsigned c - char0)))).
  unfold Swhile; forward_loop Inv break: Inv.
  { Exists 0 c; entailer!!. }
  subst Inv.
  clear dependent c; Intros n c.
  forward_if.
  forward.
  forward_if.
  { forward.
    Exists n c; entailer!!. }
  forward.
  destruct (zlt (Byte.unsigned c) char0).
  { rewrite Int.unsigned_repr_eq in H1.
    rewrite <- Z_mod_plus_full with (b := 1), Zmod_small in H1; unfold char0 in *; rep_lia. }
  rewrite Int.unsigned_repr in H1 by (unfold char0 in *; rep_lia).
  rewrite read_sum_eq.
  rewrite if_true by auto.
  destruct (zlt _ _); [|unfold char0 in *; lia].
  forward_call (n + (Byte.unsigned c - char0),
    write stdout (Byte.repr newline);; c' <- read stdin;; read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  forward_call (Byte.repr newline, c' <- read stdin;; read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  forward_call (fun c' => read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  Intros c'.
  forward.
  rewrite zero_ext_inrange by (pose proof (signed_char_unsigned c'); rewrite Int.unsigned_repr; rep_lia).
  Exists (n + (Byte.unsigned c - char0)) c'; entailer!!.
  { forward.
    Exists n c; entailer!!. }
  subst Inv.
  Intros n c'.
  forward.
Qed.

Definition ext_link := ext_link_prog prog.

#[export] Instance Espec : OracleKind := IO_Espec ext_link.

Lemma prog_correct:
  semax_prog prog main_itree Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons_ext.
{ simpl; Intro i.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons_ext.
{ simpl; Intro i'.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons body_getchar_blocking.
semax_func_cons body_putchar_blocking.
semax_func_cons body_print_intr.
semax_func_cons body_print_int.
semax_func_cons body_main.
Qed.

Require Import VST.veric.SequentialClight.
Require Import VST.progs.io_dry.

Lemma init_mem_exists : { m | Genv.init_mem prog = Some m }.
Proof.
  unfold Genv.init_mem; simpl.
Ltac alloc_block m n := match n with
  | O => idtac
  | S ?n' => let m' := fresh "m" in let Hm' := fresh "Hm" in
    destruct (dry_mem_lemmas.drop_alloc m) as [m' Hm']; alloc_block m' n'
  end.
try first [
  (* This version works in Coq 8.15, CompCert 3.10 *)
  alloc_block Mem.empty 62%nat;
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end;
  reflexivity
 |
  (* This version worked in Coq 8.13, CompCert 3.9 *)
  alloc_block Mem.empty 60%nat;
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end;
  reflexivity
].
Qed.

Definition init_mem := proj1_sig init_mem_exists.

Definition main_block_exists : {b | Genv.find_symbol (Genv.globalenv prog) (AST.prog_main prog) = Some b}.
Proof.
  eexists; simpl.
  unfold Genv.find_symbol; simpl; reflexivity.
Qed.

Definition main_block := proj1_sig main_block_exists.

Axiom (Jsub: forall ef se lv m t v m' (EFI : ef_inline ef = true) m1
       (EFC : Events.external_call ef se lv m t v m'), juicy_mem.mem_sub m m1 ->
       exists m1' (EFC1 : Events.external_call ef se lv m1 t v m1'),
         juicy_mem.mem_sub m' m1' /\ proj1_sig (Clight_core.inline_external_call_mem_events _ _ _ _ _ _ _ EFI EFC1) =
         proj1_sig (Clight_core.inline_external_call_mem_events _ _ _ _ _ _ _ EFI EFC)).

Theorem prog_ext_correct : exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
  forall n, @step_lemmas.dry_safeN _ _ _ _ semax.genv_symb_injective (Clight_core.cl_core_sem (globalenv prog))
             (io_dry_spec ext_link) {| genv_genv := Genv.globalenv prog; genv_cenv := prog_comp_env prog |} n
            main_itree q init_mem.
Proof.
  edestruct whole_program_sequential_safety_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - repeat intro; hnf.
    apply I.
  - apply Jsub.
  - apply add_funspecs_frame.
  - apply juicy_dry_specs.
  - apply dry_spec_mem.
  - intros; apply I.
  - apply CSHL_Sound.semax_prog_sound, prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    split; auto.
Qed.

Require Import VST.progs.os_combine.
Require Import VST.progs.io_combine.
Require Import VST.progs.io_os_specs.
Require Import VST.progs.io_os_connection.

(* correctness down to OS traces, with relationship between syscall events and actual external reads/writes *)
Theorem prog_OS_correct : forall {H : io_os_specs.ThreadsConfigurationOps},
  exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
     forall n s0, s0.(io_log) = [] -> s0.(console) = {| cons_buf := []; rpos := 0 |} ->
    exists traces, OS_safeN_trace prog n Traces.TEnd traces main_itree s0 q init_mem /\
     forall t s, traces (t, s) -> exists z', consume_trace main_itree z' t /\ t = trace_of_ostrace s.(io_log) /\
      valid_trace_user s.(io_log).
Proof.
  intros.
  edestruct IO_OS_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - apply Jsub.
  - apply prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    auto.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export type_sys.
Require Import dest_close.

Lemma cequivc_eqindomain {p} :
  forall lib,
  forall(a b : @CTerm p),
  forall (eqa: per),
  term_equality_symmetric eqa ->
  term_equality_transitive eqa ->
  term_equality_respecting lib eqa ->
  cequivc lib a b -> eqindomain eqa a b.
Proof.  intros. unfold eqindomain.
 unfold term_equality_symmetric in H.
 unfold term_equality_transitive in H0.
 unfold term_equality_respecting in H1.
 split; try split; intro.
 assert (eqa a b). apply H1; auto. sp. spcast. auto.
 assert (eqa b a). apply H; auto. eapply H0; eauto.
 assert (eqa b a). apply H1; auto. sp. spcast. apply cequivc_sym. auto.
 assert (eqa a b). apply H; auto. eapply H0; eauto.
 apply H1; auto. sp. spcast. auto.
Qed.

Lemma eqindomain_sym {p} :
  forall(a b : @CTerm p),
  forall (eqa: per),
  term_equality_symmetric eqa ->
  eqindomain eqa a b -> eqindomain eqa b a.
Proof.  intros. unfold eqindomain.
 unfold term_equality_symmetric in H.
 split; try split; intro. apply H0; auto. apply H0; auto.
 assert (eqa a b). apply H0; auto. apply H0; auto. apply H. auto.

Qed.

Lemma eqindomain_trans {p} :
  forall(a b c: @CTerm p),
  forall (eqa: per),
  term_equality_transitive eqa ->
  eqindomain eqa a b -> eqindomain eqa b c -> eqindomain eqa a c.
Proof.  unfold eqindomain. intros.
 unfold term_equality_symmetric in H. sp. rw H3; auto.
 assert (eqa b c). apply H1; rw <- H4; auto.
 eapply H; eauto.
Qed.

Lemma eqindomain_combine {p} :
  forall(a1 a2 b1 b2 : @CTerm p),
  forall (eqa: per),
  term_equality_symmetric eqa ->
  term_equality_transitive eqa ->
  eqindomain eqa a1 b1 -> eqindomain eqa a2 b2 -> eqa a1 a2 -> eqa b1 b2.
Proof.  intros. unfold eqindomain.
 unfold term_equality_symmetric in H.
 unfold term_equality_transitive in H0.
 assert (eqa a1 b1). apply H1. eapply H0; eauto.
 assert (eqa a2 b2). apply H2. eapply H0; eauto.
 eapply H0; eauto.

Qed.

Lemma eq_term_equals_eqindomain {p} :

  forall (eq1 eq2: per),
  eq1 <=2=> eq2 ->
  forall(a b : @CTerm p),
  eqindomain eq1 a b <=> eqindomain eq2 a b.
Proof.  intros. unfold eqindomain.
 repeat (rw H). sp.

Qed.

Lemma close_type_system_eq {p} :
  forall lib (ts : cts(p)),
  forall T T' (eq : per) A B a1 a2 b1 b2 eqa,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_equality a1 a2 A)
    -> computes_to_valc lib T' (mkc_equality b1 b2 B)
    -> close lib ts A B eqa
    -> eqindomain eqa a1 b1
    -> eqindomain eqa a2 b2
    -> (forall t t' : CTerm,
          eq t t' <=>
             ccomputes_to_valc lib t mkc_axiom
             # ccomputes_to_valc lib t' mkc_axiom
             # eqa a1 a2)
    -> per_eq lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A B eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 eos1 eos2 eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr.

    * SSCase "CL_eq".
      clear per.
      allunfold @per_eq; sp.
      unfold eq_term_equals; sp.
      spcast; allrw.
      ccomputes_to_eqval.
      unfold type_sys_props in IHX1; sp.
      implies_ts_or_eq A B0 B h.
      apply IHX0 in h.
      unfold eq_term_equals in h.
      rw h; split; sp.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    allunfold @per_eq; exrepd;
    ccomputes_to_eqval;
    apply CL_eq; unfold per_eq.

    (* 1 *)
    exists A B0 a1 a2 b0 b3 eqa0; sp; spcast; sp.
    allrw <-; sp.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_eq; allunfold @per_eq; sp;
    ccomputes_to_eqval.

    duplicate c1 as c0.
    apply cequivc_mkc_equality with (t' := T3) in c0; sp.
    exists A T'0 a1 a2 a' b' eqa; sp; spcast; sp; try (complete (right; spcast; sp)).
    allunfold @type_sys_props; sp.
    pose proof (cequivc_eqindomain lib a1 a' eqa). apply H0; auto; apply IHX1.
    pose proof (cequivc_eqindomain lib a2 b' eqa). apply H0; auto; apply IHX1.

    duplicate c2 as c0.
    apply cequivc_mkc_equality with (t' := T3) in c0; sp.
    exists B T'0 b1 b2 a' b' eqa; sp; spcast; sp; try (complete (right; spcast; sp)).
    allunfold @type_sys_props; sp.
    pose proof (cequivc_eqindomain lib b1 a' eqa). apply H0; auto; apply IHX1.
    pose proof (cequivc_eqindomain lib b2 b' eqa). apply H0; auto; apply IHX1.
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    rw eqiff; split; sp. eapply eqindomain_combine; eauto.
    pose proof (eqindomain_combine b1 b2 a1 a2 eqa) as xx; apply xx; auto; apply eqindomain_sym; auto.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    allrw; discover; sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    allrw; discover; sp.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    allrw; discover; sp; spcast.
    apply @cequivc_axiom with (t := t); sp.

  + SCase "type_gsymmetric".
    repdors; subst; split; sp; dclose_lr;
    apply CL_eq;
    clear per;
    allunfold @per_eq; exrepd;
    ccomputes_to_eqval;
    unfold per_eq;
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
    try (assert (close lib ts A A0 eqa0)
                as k by (generalize (tygs A A0 eqa0); intro i; autodimp i h; rw <- i in c3; sp));
    try (assert (close lib ts B A0 eqa0)
                as k by (generalize (tygs B A0 eqa0); intro i; autodimp i h; rw <- i in c3; sp));
    try (assert (eq_term_equals eqa eqa0)
                as eqt by (apply uv with (T3 := A0); sp));
    try (assert (eq_term_equals eqa eqa0)
                as eqt by (apply uv with (T3 := B0); sp)).

    (* 1 *)
    exists B0 A b0 b3 a1 a2 eqa0.
    assert (term_equality_symmetric eqa0).
     unfold term_equality_symmetric; intros; rw <- eqt; apply tes; rw eqt; auto.
    assert (forall a b : CTerm, eqindomain eqa a b <=> eqindomain eqa0 a b) as sameeq.
    apply eq_term_equals_eqindomain; auto.

    sp; spcast; sp.
    generalize (tygs A B0 eqa0); intro i; autodimp i h; rw <- i; sp.
    apply eqindomain_sym; auto.
    apply eqindomain_sym; auto.

    rw t; repeat (rw <- eqt).
    split; sp.
    pose proof (eqindomain_combine a1 a2 b0 b3 eqa) as xx; apply xx; auto;
    rw sameeq; auto.
    pose proof (eqindomain_combine b0 b3 a1 a2 eqa) as xx; apply xx; auto;
    apply eqindomain_sym; auto; rw sameeq; auto.

    (* 2 *)
    exists A A0 a1 a2 a0 a3 eqa0.
    assert (term_equality_symmetric eqa0).
     unfold term_equality_symmetric; intros; rw <- eqt; apply tes; rw eqt; auto.
    assert (forall a b : CTerm, eqindomain eqa a b <=> eqindomain eqa0 a b) as sameeq.
    apply eq_term_equals_eqindomain; auto.
     sp; spcast; sp.
    apply eqindomain_sym; auto.
    apply eqindomain_sym; auto.

    rw t; repeat (rw <- eqt).
    split; sp.
    pose proof (eqindomain_combine a0 a3 a1 a2 eqa) as xx; apply xx; auto;
    rw sameeq; auto.
    pose proof (eqindomain_combine a1 a2 a0 a3 eqa) as xx; apply xx; auto;
    apply eqindomain_sym; auto; rw sameeq; auto.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_eq lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_eq lib (close lib ts) T' T4 eq2));

    clear per;
    allunfold @per_eq; exrepd;
    ccomputes_to_eqval;
    applydup @type_sys_props_ts_refl in IHX1; repnd;
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.

    (* 1 *)
    assert (close lib ts A A1 eqa1) as eqta1 by (generalize (tymt A A1 A eqa1 eqa); sp).
    assert (eq_term_equals eqa eqa1) as eqt1 by (apply uv with (T3 := A1); sp).
    assert (eq_term_equals eqa eqa0) as eqt2 by (apply uv with (T3 := B0); sp).
    assert (close lib ts A1 B0 eqa0) as eqta2 by (generalize (tymt A A1 B0 eqa1 eqa0); sp).
    assert (forall a b : CTerm, eqindomain eqa a b <=> eqindomain eqa0 a b) as sameeq1.
    apply eq_term_equals_eqindomain; auto.
    assert (forall a b : CTerm, eqindomain eqa a b <=> eqindomain eqa1 a b) as sameeq2.
    apply eq_term_equals_eqindomain; auto.

    dands; apply CL_eq; unfold per_eq.

    exists A1 B0 a4 a5 b0 b3 eqa0.
    allrw <- sameeq1.
    allrw <- sameeq2.
    sp; spcast; sp.
    eapply eqindomain_trans; eauto.
    eapply eqindomain_trans; eauto.

    rw t0.
    allrw <-; sp.

    exists A1 B0 a4 a5 b0 b3 eqa0.
    allrw <- sameeq1.
    allrw <- sameeq2.
    sp; spcast; sp.
    eapply eqindomain_trans; eauto.
    eapply eqindomain_trans; eauto.

    rw t.
    allrw <-; sp.

    rw eqiff; split; intros; sp.
    pose proof (eqindomain_combine a1 a2 a4 a5 eqa) as xx; apply xx; auto;
    apply eqindomain_sym; auto.
    pose proof (eqindomain_combine a4 a5 a1 a2 eqa) as xx; apply xx; auto.

    (* 2 *)
    assert (close lib ts B A1 eqa1) as eqta1 by (generalize (tymt B A1 B eqa1 eqa); sp).
    assert (eq_term_equals eqa eqa1) as eqt1 by (apply uv with (T3 := A1); sp).
    assert (eq_term_equals eqa eqa0) as eqt2 by (apply uv with (T3 := B0); sp).
    assert (close lib ts A1 B0 eqa1) as cl by (generalize (tymt B A1 B0 eqa1 eqa0); intro i; autodimp i h; sp).
    assert (forall a b : CTerm, eqindomain eqa a b <=> eqindomain eqa0 a b) as sameeq1.
    apply eq_term_equals_eqindomain; auto.
    assert (forall a b : CTerm, eqindomain eqa a b <=> eqindomain eqa1 a b) as sameeq2.
    apply eq_term_equals_eqindomain; auto.

    dands; apply CL_eq; unfold per_eq.

    exists A1 B0 a4 a5 b0 b3 eqa1.
    allrw <- sameeq1.
    allrw <- sameeq2.
    sp; spcast; sp.
    eapply eqindomain_trans; eauto.
    eapply eqindomain_trans; eauto.

    exists A1 B0 a4 a5 b0 b3 eqa1.
    allrw <- sameeq1.
    allrw <- sameeq2.
    sp; spcast; sp.
    eapply eqindomain_trans; eauto.
    eapply eqindomain_trans; eauto.

    rw t; repeat (rw <- eqt1); repeat (rw <- eqt2); split; sp.
    pose proof (eqindomain_combine b1 b2 a4 a5 eqa) as xx; apply xx; auto;
    apply eqindomain_sym; auto.
    pose proof (eqindomain_combine a4 a5 b1 b2 eqa) as xx; apply xx; auto.

Qed.