(* 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.


From Coq.Unicode Require Import Utf8.
From Coq.Program Require Import Tactics.
From Categories.Essentials Require Import Notations Facts_Tactics Quotient.
From Coq.Logic Require Import PropExtensionality.
From Categories Require Import
     Category.Main Functor.Main Adjunction.Main NatTrans.Main.
From Coq.Classes Require Import RelationClasses.
From cat_monotone Require Import PreOrder.

Record PO := {
  PO_type :> Type;
  PO_car :> PO_type → PO_type → Prop;
  PO_PO : PreOrder PO_car;
  PO_antisymm : ∀ x y, PO_car x y → PO_car y x → x = y }.

Existing Instance PO_PO.

Record PO_morphism (po po' : PO) := {
  POM_mor :> po → po';
  POM_mono x y : po x y → po' (POM_mor x) (POM_mor y) }.

Arguments POM_mor {_ _} _ _.

Lemma POM_morphism_eq (po po' : PO) (f g : PO_morphism po po') :
  (∀ x, f x = g x) → f = g.
Proof.
  intros Hfg.
  assert (POM_mor f = POM_mor g) by (FunExt; auto).
  destruct f as [f Hfmono]; destruct g as [g Hgmono];
    cbn in *; subst.
  PIR; trivial.
Qed.

Program Definition POM_id (po : PO) : PO_morphism po po :=
  {| POM_mor x := x |}.

Program Definition POM_comp (po po' po'' : PO)
  (f : PO_morphism po po') (g : PO_morphism po' po'') : PO_morphism po po'' :=
  {| POM_mor x := g (f x) |}.
Next Obligation.
Proof.
  repeat apply POM_mono; trivial.
Qed.

Program Definition PO_cat : Category :=
  {| Obj := PO;
    Hom := PO_morphism;
    compose := POM_comp;
    id := POM_id |}.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.

(** partial order to preorder *)
Definition preorder_of_partial_order (po : PO) : PreOrd :=
{| PRO_type := po; PRO_car := po |}.

Program Definition preorder_of_partial_order_morphism (po po' : PO)
           (f : PO_morphism po po')
  : PRO_morphism (preorder_of_partial_order po) (preorder_of_partial_order po') :=
{| PROM_mor := f; PROM_mono := POM_mono _ _ f |}.

Program Definition preorder_of_partial_order_func : Functor PO_cat PreOrd_cat :=
{| FO := preorder_of_partial_order; FA := preorder_of_partial_order_morphism |}.

Next Obligation.
Proof. apply PROM_morphism_eq; simpl; trivial. Qed.

(** preorder to partial order *)

Definition antisymm_rel_base (pro : PreOrd) (x y : pro) : Prop :=
  pro x y ∧ pro y x.

Program Definition antisymm_rel (pro : PreOrd) : EquiRel pro :=
  {| EQR_rel := antisymm_rel_base pro |}.
Next Obligation.
Proof.
  unfold antisymm_rel_base.
  split.
  - intros ?; split; reflexivity.
  - intros ???; tauto.
  - intros ??? [? ?] [? ?]; split; etransitivity; eauto.
Qed.

Definition partial_order_of_preorder_relation
  (pro : PreOrd) (x y : quotient (antisymm_rel pro)) : Prop :=
  pro (representative x) (representative y).

Lemma partial_order_of_preorder_relation_refl pro x :
  partial_order_of_preorder_relation pro x x.
Proof. unfold partial_order_of_preorder_relation; reflexivity. Qed.

Lemma partial_order_of_preorder_relation_trans pro x y z :
  partial_order_of_preorder_relation pro x y →
  partial_order_of_preorder_relation pro y z →
  partial_order_of_preorder_relation pro x z.
Proof. unfold partial_order_of_preorder_relation; etransitivity; eauto. Qed.

Lemma partial_order_of_preorder_relation_antisymm pro x y :
  partial_order_of_preorder_relation pro x y →
  partial_order_of_preorder_relation pro y x →
  x = y.
Proof.
  unfold partial_order_of_preorder_relation.
  intros Hxy Hyx.
  apply (uniquely_represented _ _ _ (representative x) (representative y));
  [apply representative_represented; fail|
   apply representative_represented; fail|].
  split; trivial.
 Qed.

Instance: ∀ pro, PreOrder (partial_order_of_preorder_relation pro).
Proof.
  intros; split.
  - intros ?; apply partial_order_of_preorder_relation_refl.
  - intros ???; apply partial_order_of_preorder_relation_trans.
Qed.

Program Definition partial_order_of_preorder (pro : PreOrd) : PO :=
{| PO_type := quotient (antisymm_rel pro);
   PO_car := partial_order_of_preorder_relation pro;
   PO_antisymm := partial_order_of_preorder_relation_antisymm pro|}.

Local Obligation Tactic := idtac.

Program Definition partial_order_of_preorder_morphism (pro pro' : PreOrd)
           (f : PRO_morphism pro pro')
  : PO_morphism (partial_order_of_preorder pro) (partial_order_of_preorder pro')
  := {| POM_mor := λ x, class_of (antisymm_rel pro') (f (representative x))|}.

Next Obligation.
Proof.
  intros pro pro' f x y Hxy; simpl in *.
  unfold partial_order_of_preorder_relation in *.
  etransitivity;
    [apply (representative_of_class_of
              (antisymm_rel pro') (f (representative x)))|].
  etransitivity;
    [|apply (representative_of_class_of
              (antisymm_rel pro') (f (representative y)))].
  apply (PROM_mono _ _ f); trivial.
Qed.

Program Definition partial_order_of_preorder_func : Functor PreOrd_cat PO_cat :=
{| FO := partial_order_of_preorder; FA := partial_order_of_preorder_morphism |}.

Next Obligation.
Proof.
  intros x.
  apply POM_morphism_eq; simpl; intros ?.
  apply class_of_representative.
Qed.
Next Obligation.
Proof.
  intros pro pro' por'' f g.
  apply POM_morphism_eq; simpl; intros ?.
  apply class_of_inj; split.
  - apply (PROM_mono _ _ g).
    etransitivity;
      [|apply (representative_of_class_of
                 (antisymm_rel pro') (f (representative x)))].
    reflexivity.
  - apply (PROM_mono _ _ g).
    etransitivity;
      [apply (representative_of_class_of
                 (antisymm_rel pro') (f (representative x)))|].
    reflexivity.
Qed.

(** properties of inclusion functor and back *)

Lemma preorder_of_partial_order_func_full :
  Full_Func preorder_of_partial_order_func.
Proof.
  intros po po' f; simpl in *.
  exists ({| POM_mor := f; POM_mono := (PROM_mono _ _ f) |}).
  apply PROM_morphism_eq; trivial.
Qed.

Lemma preorder_of_partial_order_func_faithful :
  Faithful_Func preorder_of_partial_order_func.
Proof.
  intros po po' f g Hfg; simpl in *.
  apply POM_morphism_eq.
  intros x.
  apply (equal_f (f_equal PROM_mor Hfg) x).
Qed.

Program Definition preorder_partial_order_adj_unit_map (pro : PreOrd) :
  PRO_morphism pro (preorder_of_partial_order (partial_order_of_preorder pro)) :=
{| PROM_mor := λ x, class_of (antisymm_rel pro) x  |}.

Next Obligation.
Proof.
  intros pro x y Hxy; simpl.
  unfold partial_order_of_preorder_relation.
  etransitivity;
      [apply (representative_of_class_of (antisymm_rel pro) x)|].
  etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) y)].
  trivial.
Qed.

Program Definition preorder_partial_order_adj_unit :
  NatTrans (Functor_id PreOrd_cat)
           (preorder_of_partial_order_func ∘ partial_order_of_preorder_func) :=
{| Trans := preorder_partial_order_adj_unit_map |}.

Next Obligation.
Proof.
  intros pro pro' f; simpl in *.
  apply PROM_morphism_eq; intros x; simpl.
  apply class_of_inj; split; apply (PROM_mono _ _ f).
  - etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) x)]; reflexivity.
  - etransitivity;
    [apply (representative_of_class_of (antisymm_rel pro) x)|]; reflexivity.
Qed.

Next Obligation.
Proof.
  intros pro pro' f; simpl in *.
  apply PROM_morphism_eq; intros x; simpl.
  apply class_of_inj; split; apply (PROM_mono _ _ f).
  - etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) x)]; reflexivity.
  - etransitivity;
    [apply (representative_of_class_of (antisymm_rel pro) x)|]; reflexivity.
Qed.

Program Definition preorder_partial_order_adj_morph_ex (pro : PreOrd) (po : PO)
        ( f : PRO_morphism pro (preorder_of_partial_order po)) :
  PO_morphism (partial_order_of_preorder pro) po :=
{| POM_mor := λ x, f (representative x) |}.

Next Obligation.
Proof.
  intros pro po f x y Hxy; simpl in *.
  apply (PROM_mono _ _ f); trivial.
Qed.

Program Definition preorder_partial_order_adj :
  (partial_order_of_preorder_func ⊣ preorder_of_partial_order_func)%functor :=
{| adj_unit := preorder_partial_order_adj_unit;
   adj_morph_ex := preorder_partial_order_adj_morph_ex |}.

Next Obligation.
Proof.
  intros pro po f; simpl in *.
  apply PROM_morphism_eq; simpl in *.
  intros x.
  apply PO_antisymm.
  - apply (PROM_mono _ _ f).
    etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) x)]; reflexivity.
  - apply (PROM_mono _ _ f).
    etransitivity;
    [apply (representative_of_class_of (antisymm_rel pro) x)|]; reflexivity.
Qed.
Next Obligation.
Proof.
  intros pro po f g h Hfg Hfh; simpl in *.
  pose proof (equal_f (f_equal PROM_mor Hfg)) as Hfg'; simpl in *.
  pose proof (equal_f (f_equal PROM_mor Hfh)) as Hfh'; simpl in *.
  apply POM_morphism_eq; intros x; simpl in *.
  specialize (Hfg' (representative x)).
  specialize (Hfh' (representative x)).
  rewrite class_of_representative in Hfg', Hfh'.
  rewrite <- Hfg', <- Hfh'; trivial.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Bifunctor.
Require Import Category.Functor.Strong.
Require Import Category.Functor.Applicative.
Require Import Category.Functor.Structure.Monoidal.
Require Import Category.Functor.Structure.Monoidal.Id.
Require Import Category.Functor.Structure.Monoidal.Compose.
Require Import Category.Functor.Structure.Monoidal.Pure.
Require Import Category.Natural.Transformation.Monoidal.
Require Import Category.Natural.Transformation.Applicative.
Require Import Category.Natural.Transformation.Strong.
Require Import Category.Structure.Monoidal.Closed.
Require Import Category.Structure.Monoidal.Internal.Product.
Require Import Category.Functor.Applicative.

Generalizable All Variables.

Section Traversable.

Context {C : Category}.
Context `{@ClosedMonoidal C}.
Context {F : C ⟶ C}.

#[local] Obligation Tactic := idtac.

Program Instance Id_Applicative : @Applicative C _ (Id[C]) := {
  applicative_is_strong := Id_StrongFunctor;
  applicative_is_lax_monoidal := Id_LaxMonoidalFunctor
}.

Program Instance Compose_Applicative
  `{@Applicative C _ G}
  `{@Applicative C _ K} :
  @Applicative C _ (Compose G K) := {
  applicative_is_strong := Compose_StrongFunctor G K _ _;
  applicative_is_lax_monoidal := Compose_LaxMonoidalFunctor _ _
}.

Class Traversable := {
  sequence {G : C ⟶ C} `{@Applicative C _ G} : F ◯ G ⟹ G ◯ F;

  sequence_naturality {G : C ⟶ C} `{@Applicative C _ G}
                      {H : C ⟶ C} `{@Applicative C _ H} (N : G ⟹ H)
                      (f : @Applicative_Transform C _ _ _ _ _ N) {X} :
    transform[N] (F X) ∘ transform[@sequence G _] X
      ≈ transform[@sequence H _] X ∘ fmap[F] (transform[N] _);

  sequence_Id {X} : transform[@sequence Id _] X ≈ id;
  sequence_Compose {G : C ⟶ C} `{@Applicative C _ G}
                   {H : C ⟶ C} `{@Applicative C _ H} {X} :
    transform[@sequence (Compose G H) _] X
      ≈ fmap[G] (transform[sequence] X) ∘ transform[sequence] _
}.

End Traversable.

Arguments Traversable {_ _} F.

#[export]
Program Instance Id_Traversable `{@ClosedMonoidal C} (x : C) :
  Traversable (@Id C) := {
  sequence := fun _ _ => {| transform := fun _ => id |}
}.

Require Import Category.Functor.Diagonal.

#[export]
Program Instance Diagonal_Traversable
  {C J : Category} `{@ClosedMonoidal C} (x : C) :
  Traversable (Diagonal C x) := {
  sequence := fun G _ => {| transform := fun _ => pure[G] |}
}.
Next Obligation.
  unfold pure.
  simpl; normal.
  rewrite <- !comp_assoc.
  normal.
  rewrite <- naturality.
  rewrite <- !comp_assoc.
  apply compose_respects; [reflexivity|].
  rewrite !comp_assoc.
  apply compose_respects; [|reflexivity].
  rewrite (lax_pure_transform[N]).
  rewrite <- strength_transform; simpl.
  rewrite <- !comp_assoc; cat.
  apply compose_respects; [reflexivity|].
  now rewrite bimap_comp_id_left.
Qed.
Next Obligation.
  unfold pure, bimap; simpl; cat.
  apply iso_to_from.
Qed.
Next Obligation.
  unfold pure; simpl.
  normal.
  rewrite <- !comp_assoc.
  rewrite !fmap_comp.
  rewrite <- !comp_assoc.
  apply compose_respects; [reflexivity|].
  rewrite !comp_assoc.
  apply compose_respects; [|reflexivity].
  rewrite <- !comp_assoc.
  apply compose_respects; [reflexivity|].
  rewrite !comp_assoc.
  rewrite <- !fmap_comp.
  rewrite <- !comp_assoc; cat.
  rewrite iso_from_to, id_right.
  rewrite bimap_comp_id_left.
  rewrite !comp_assoc.
  comp_right.
  symmetry.
  spose (@strength_natural _ _ G _ x _ id _ _ lax_pure) as X0.
  rewrite bimap_id_id in X0.
  rewrite fmap_id in X0.
  rewrite id_right in X0.
  rewrite X0.
  cat.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (plus lv1 (Succ lv0))).
Admitted.
QuickChick conj8synthconj6.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

(* translation of this fails because of clashes due to unnabed binders
Inductive NatLike (A B:Set) (C: (A->B) -> Set): Set :=
| SS : forall (f:A->B), C f -> NatLike A B C.
*)

Inductive NatLike (A:Set) (C: A-> Set): Set :=
(* | SS : forall (f:A->B) (c:C f)  (d:forall a:A, NatLike A B C)
     (e:forall (fi:A->B) (ci:C fi), NatLike A B C), NatLike A B C *)
 | SS2 :  forall (d:forall a:A,NatLike A C),
       NatLike A C.

Run TemplateProgram (genParamInd [] true true "Top.indFunArg.NatLike").


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.Vectors.Vector.
Require Import Cava.Arrow.ArrowExport.
Require Import Cava.Arrow.CombinatorProperties.
Require Import Cava.BitArithmetic.
Require Import Cava.NatUtils.
Require Import Cava.ListUtils.
Require Import Cava.Tactics.
Require Import Cava.VectorUtils.
Require Import AesSpec.Cipher.
Require Import AesSpec.CipherProperties.
Require Import AesSpec.ExpandAllKeys.
Require Import AesSpec.InterleavedCipher.
Require Import Aes.CipherEquivalenceCommon
     Aes.OpenTitanCipherProperties Aes.CipherRoundProperties
     Aes.UnrolledOpenTitanCipher.
Import VectorNotations ListNotations.
Import CipherEquivalenceCommon.Notations.

Section Equivalence.
  Context (sbox : Pkg.SboxImpl)
          (aes_key_expand_spec :
             Pkg.SboxImpl -> bool -> Vector.t bool 4 ->
             rconst -> keypair -> rconst * keypair)
          (aes_key_expand_correct :
             forall sbox_impl op_i round_id rcon key_i,
               kinterp (aes_key_expand sbox_impl)
                       (op_i, (round_id, (rcon, (key_i, tt))))
               = aes_key_expand_spec sbox_impl op_i round_id rcon key_i)
          (aes_sub_bytes_correct :
             forall sbox_impl op_i state,
               kinterp (SubBytes.aes_sub_bytes sbox_impl) (op_i, (state, tt))
               = aes_sub_bytes_spec sbox_impl op_i state)
          (aes_shift_rows_correct :
             forall op_i state,
               kinterp ShiftRows.aes_shift_rows (op_i, (state, tt))
               = aes_shift_rows_spec op_i state)
           (aes_mix_columns_correct :
             forall op_i state,
               kinterp MixColumns.aes_mix_columns (op_i, (state, tt))
               = aes_mix_columns_spec op_i state).

  Definition add_round_key : state -> key -> state :=
    @bitwise (Vector (Vector (Vector Bit 8) 4) 4) (fun a b => xorb a b).
  Definition sub_bytes : state -> state := aes_sub_bytes_spec sbox false.
  Definition shift_rows : state -> state := aes_shift_rows_spec false.
  Definition mix_columns : state -> state := aes_mix_columns_spec false.

  Definition key_expand : nat -> rconst * keypair -> rconst * keypair :=
    fun i rk => aes_key_expand_spec sbox false (nat_to_bitvec _ i) (fst rk) (snd rk).

  Lemma unrolled_cipher_spec_equiv
        init_keypair first_key last_key middle_keys input :
    let Nr := 14 in
    let init_rcon := nat_to_byte 1 in
    (* reverse initial keypair (which is round key 0 ++ round key 1)
       so that the first round key (0) is in second position *)
    let init_keypair_rev := swap_keys init_keypair in
    (* key_expand state is rconst * keypair *)
    let init_rk := (init_rcon, init_keypair_rev) in
    let all_rcons_and_keypairs := all_keys key_expand Nr init_rk in
    (* representation change: project out the round (second) key and transpose it *)
    let all_keys := List.map (fun x : rconst * keypair =>
                                transpose_rev (sndkey (snd x)))
                             all_rcons_and_keypairs in
    all_keys = (first_key :: middle_keys ++ [last_key])%list ->
    unrolled_cipher_spec aes_key_expand_spec sbox false input init_keypair
    = cipher state key add_round_key sub_bytes shift_rows mix_columns
             first_key last_key middle_keys input.
  Proof.
    cbv zeta. cbn [denote_kind] in *. intro Hall_keys.

    (* Get all states from key expansion *)
    map_inversion Hall_keys; subst.
    match goal with H : @eq (list (_ * keypair)) _ (_ :: _ ++ [_])%list |- _ =>
                    rename H into Hall_keys end.

    (* representation change; use full key-expansion state (rconst * keypair) *)
    erewrite cipher_change_key_rep with
        (projkey := fun x => transpose_rev (sndkey (snd x)))
      by reflexivity.

    erewrite <-cipher_interleaved_equiv by eassumption.
    cbv [unrolled_cipher_spec final_cipher_round_spec
                              cipher_interleaved cipher_round_interleaved].
    repeat destruct_pair_let.
    rewrite denote_kind_eqb_refl. cbn [mux].
    rewrite fold_left_fst_unchanged by auto.
    autorewrite with push_to_list.
    rewrite fold_left_map. cbn [fst snd].
    match goal with
    | |- ?LHS = ?RHS =>
      match LHS with
      | context [ @List.fold_left (?A1 * (?A2 * ?A3)) ?B1 ?f1 ?ls1 ?b1 ] =>
        match RHS with
        | context [ @List.fold_left (A1 * A3 * A2) ?B2 ?f2 ?ls2 ?b2 ] =>
          change ls1 with ls2;
            rewrite (fold_left_preserves_relation_seq
                       (fun _ x y => x = (fst (fst y), (snd y, snd (fst y))))
                       f1 f2 _ _ b1 b2)
        end
      end
    end; [ | | ].
    { (* equivalence post-loop *)
      reflexivity. }
    { (* equivalence at start of loop *)
      reflexivity. }
    { (* equivalence holds through loop body *)
      intros; subst. cbv [key_expand_and_round_spec].
      repeat destruct_pair_let; cbn [fst snd].
      rewrite denote_kind_eqb_refl. cbn [mux].
      fold fstkey sndkey. repeat (f_equal; [ ]).
      rewrite denote_kind_eqb_N2Bv_sized by (apply N.size_nat_le; cbn; Lia.lia).
      cbv [mux]. change 0%N with (N.of_nat 0).
      rewrite N.eqb_compare, N2Nat.inj_compare, !Nat2N.id, <-Nat.eqb_compare.
      reflexivity. }
  Qed.
End Equivalence.


Require Import ZArith.
Require Import Coq.Strings.String.
Require Import List. Import ListNotations.

Require Import QuickChick.
Require Import Show.
Require Import Test.

Require Import Rules.
Require Import TestingCommon.
Require Import Generation.
Require Import Shrinking.
Require Import SSNI.
Require Import Reachability.
Require Import SingleStateArb.

Require Import SanityChecks.

(* Testing well-formedness first *)

QuickCheck prop_stamp_generation.

QuickCheck prop_generate_indist.

QuickCheck (prop_fstep_preserves_well_formed default_table).

(* Testing non-interference second (default table) *)

Definition testSSNI t := quickCheck (propSSNI t).

QuickCheck (propSSNI default_table).

(* Testing mutants third *)

Require Import Mutate.
Require Import MutateCheck.

Instance mutateable_table : Mutateable table :=
{|
  mutate := mutate_table
|}.
(*
Eval simpl in (nth 24 (mutate_table default_table) default_table).
*)
MutateCheckMany default_table (fun t => [propSSNI t;
    prop_fstep_preserves_well_formed t]).

(* The rest of this file is mostly garbage *)

(*
Eval lazy -[labelCount helper] in
  nth 26 (mutate_table default_table) default_table.
*)

Definition testMutantX x y :=
  let mutant := fun o' =>
    (helper x y o' (default_table o'))  in
  testSSNI mutant.

Definition testMutant7 := testMutantX
  OpBCall (≪TRUE, JOIN Lab2 LabPC, Lab1 ≫).
(* CH: most often we catch this one; but sometimes it escapes *)

Definition testMutant9 := testMutantX
  OpBRet (≪LE Lab1 (JOIN Lab2 Lab3), Lab2, Lab3 ≫).
(* Problem: we weren't generating _any_ HIGH -> LOW cases;
            doing a very bad job at generating stacks!
("Some OpBRet, Failed",484),
("Some OpBRet, HIGH -> HIGH",206),
("Some OpBRet, LOW -> *",224),
("Some OpBRet, Second failed H",28),
("Some OpBRet, Second not low",83),
   After expedient fix this finds the bug and looks like this:
("Some OpBRet, Failed",85),
("Some OpBRet, HIGH -> HIGH",23),
("Some OpBRet, LOW -> *",40),
("Some OpBRet, Second failed H",6),
("Some OpBRet, HIGH -> LOW",7), <---- this case was missing
*)

Definition testMutant26 := testMutantX
  OpBNZ (≪TRUE, __ , LabPC ≫).
(* This was found, just not often enough (once in 20000-30000 tests)
   We weren't generating zeroes often enough (1 in 200)
   Changed to 1 in 10 and we're finding this just fine. *)

Definition testMutant29 := testMutantX
  OpLoad (≪TRUE, Lab3, JOIN Lab1 Lab2 ≫).
(* CH: this one is at the limit (with 10000 tests sometimes we catch
       it and sometimes we don't)*)

Definition testMutant36 := testMutantX
  OpAlloc (≪TRUE, Lab2, LabPC ≫).
(* XXX: this and the next mutants break well-formedness;
   but we don't test that as a precondition to SSNI
   DONE: for each mutant we should also test well-formedness
   and if that fails the mutant is also killed *)

Definition testMutantWF x y :=
  let mutant := fun o' =>
    (helper x y o' (default_table o'))  in
  quickCheck (prop_fstep_preserves_well_formed mutant).

Definition testMutant36wf := testMutantWF
  OpAlloc (≪TRUE, Lab2, LabPC ≫).
(* XXX: this sometimes fails, and otherwise gives stack overflow
   during shrinking (probably an infinite loop of some sort) *)

Definition testMutant37 := testMutantX
  OpAlloc (≪TRUE, Lab1, LabPC ≫).

Definition testMutant37wf := testMutantWF
  OpAlloc (≪TRUE, Lab1, LabPC ≫).
(* XXX: this sometimes fails, and otherwise gives stack overflow
   during shrinking (probably an infinite loop of some sort) *)

(* Definition testNI := testMutant37wf. *)

(* QuickCheck testMutants.*)
(* Definition testNI := testMutant9.*)
(* Definition testNI := testSSNI default_table. *)
(* Definition testNI := quickCheck prop_stamp_generation. *)
(* Definition testNI :=
  quickCheck (prop_preserves_well_formed default_table). *)
(* Definition testNI := quickCheck prop_generate_indist. *)
(*(forAllShrink (fun _ => "implement me!")
                           genSingleExecState
                           (fun _ => nil)
                           (propWellFormednessPreserved default_table)).*)

(*Definition testNI :=
  let l := lab_of_list [Pos.of_nat 1] in
  let h := lab_of_list [Pos.of_nat 1; Pos.of_nat 2] in
  match alloc 2%Z l bot (Vint Z0 @ bot) (Mem.empty Atom Label) with
    | Some (mf, m') =>
      map (Mem.get_frame m') (Mem.get_all_blocks h m')
    | _ => []
  end.
*)


(** * Formalization of CPS-Conversion *)

(** We'll start out by defining the syntax of a direct-style program,
followed by defining what evaluating said program means. Once we've
done that, we'll define a CPS-conversion function, and then prove that
the resulting expression is equivalent to the original. *)

From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.

(* This "CpsFormalization" comes from the _CoqProject file *)
From CpsFormalization Require Import Env.

(* ################################################################# *)
(** * Syntax Definition *)

(** We're going to be modeling an untyped lambda calculus for
    simplicity's stake. What follows below are the formal
    definitions of the syntax. *)

(* Primitive binary operators *)
Inductive prim_binop : Type :=
  | PrimPlus
  | PrimMinus
  | PrimMult
  | PrimEq.

Inductive sexpr : Type :=
  | SId (x : string)
  | SNum (n : nat)
  (* TODO: include a closure case maybe *)
  | SLambda (args : list string) (body : sexpr)
  (* I'd like to add a constraint that fexpr reduces to an instance of SLambda. *)
  | SApp (fexpr : sexpr) (args : list sexpr)
  (* Might be nice to constrain the set of strings *)
  | SPrimBinary (op : prim_binop) (a1 a2 : sexpr)
  | SIf (cond : sexpr) (tcase : sexpr) (fcase : sexpr).

Definition environment := total_map sexpr.

(** ** Notations *)

(** Now we'll define some convenience notations so we don't have to
    write awkward Coq and can write something a little closer to the
    Lisp we all know and love. *)

Coercion SId : string >-> sexpr.
Coercion SNum : nat >-> sexpr.
(* TODO: fill in here *)

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

(** Let's write a little interpreter for our language. *)

Fixpoint zip_map {X Y Z : Type} (f : X -> Y -> Z) (l1 : list X) (l2 : list Y) : list Z :=
  match l1, l2 with
  | nil, _ => nil
  | _, nil => nil
  | x :: xs, y :: ys => (f x y) :: (zip_map f xs ys)
  end.

Fixpoint extend_env (env : environment) (params : list string) (args : list sexpr) : environment :=
  match params, args with
  | nil, _ => env
  | _, nil => env
  | x :: rest_params, arg :: rest_args => (x !-> arg ; (extend_env env rest_params rest_args))
  end.

(* Consider defining this as a relation so I can model a partial function; alternatively, instead of returning sexpr; return sexpr + error *)
Fixpoint seval (env : environment) (expr : sexpr) : sexpr :=
  match expr with
  | SId x => env x
  | SNum n => SNum n
  | SLambda args body => SLambda args body
  (* Now the fun begins *)
  | SApp func args =>
    (* TODO: evaluate the function *)
    (* evaulate the arguments *)
    let xs := map (seval env) args in
    seval (extend_env env )

  | SPrimBinary op a1 a2 => SNum 42
  | SIf cond tcase fcase => SNum 42
  end.

Definition empty_env := t_empty (SId "null").
Check (seval empty_env).


(**
This just transforms "pretty print" notation to internal
de Bruijn indices. It's probably the most involved code
that has the least to do with the actual type theoretic
machinery.
*)
Require Import String.
Require Export Coq.Lists.List.
Require Export Coq.Arith.Compare_dec.
Require Export Coq.Arith.EqNat.
Require Export Util.
Require Import Expression.

(**
For denaming some pretty-printed lambda expression into our
internal representation.
*)
Module PrettyTerm.
Inductive pterm : Type :=
 | tau : pterm
 | Var : string -> pterm
 | Lam : string -> pterm -> pterm -> pterm
 | App : pterm -> pterm -> pterm.

(** The free variables in a given [pterm]. *)
Fixpoint FV (t:pterm): list string :=
  match t with
  | tau => nil
  | Var s => s::nil
  | Lam x t b => rm x (append (FV t) (FV b))
  | App t1 t2 => append (FV t1) (FV t2)
  end.

(** A [context] for pretty print reasons is a list of
declarations, which themselves are ordered pairs of a
[string] identifier, and its corresponding [pterm] "type".
*)
Definition context := list (string * pterm).
End PrettyTerm.

Notation "` x" := (if string_dec x "tau"
                   then PrettyTerm.tau
                   else PrettyTerm.Var x) (at level 20).
Notation "\ x t ~> M" := (PrettyTerm.Lam x t M) (at level 30).
Infix "$" := PrettyTerm.App (at level 25, left associativity).

(* Unit tests for [FV] *)
Example FV_ex1 :
  PrettyTerm.FV (`"f" $ `"g" $ `"h" $ `"i") =
  "f"%string :: "g"%string :: "h"%string :: "i"%string :: nil.
Proof. reflexivity. Qed.

Example prettier_left_assoc_ex1 :
  `"f" $ `"g" $ `"h" $ `"i" =
  PrettyTerm.App
    (PrettyTerm.App
       (PrettyTerm.App (PrettyTerm.Var "f") (PrettyTerm.Var "g"))
       (PrettyTerm.Var "h")) (PrettyTerm.Var "i").
Proof.
  simpl. reflexivity.
Qed.

Example prettier_ex2 :
  \ "f" `"tau" ~> `"f" $ (\ "x" `"tau" ~> `"x" $ `"y") =
  PrettyTerm.Lam "f" PrettyTerm.tau
    (PrettyTerm.App (PrettyTerm.Var "f")
       (PrettyTerm.Lam "x" PrettyTerm.tau
          (PrettyTerm.App (PrettyTerm.Var "x") (PrettyTerm.Var "y")))).
Proof. simpl. reflexivity. Qed.

Fixpoint lookup (s : string) (ls : list (string * nat)):
option nat :=
  match ls with
  | nil => None
  | (x, n) :: t => if string_dec x s then Some n else lookup s t
  end.

(** Pushes the depth one layer, introduces a "new" variable [s]. *)
Fixpoint hide (s : string) (ls : list (string * nat)):
list (string * nat) :=
  match ls with
  | nil => (s, 0) :: nil
  | (x, n) :: t =>
      if string_dec x s then (x, 0) :: hide s t else (x, n + 1) :: hide s t
  end.

Fixpoint dename' (t : PrettyTerm.pterm) (binds : list (string * nat)): exp :=
  match t with
  | PrettyTerm.tau => tau
  | PrettyTerm.Var s =>
      match lookup s binds with
      | Some n => EVar n
      | None => EVar 0
      end
  | PrettyTerm.Lam s t b =>
      ELam (dename' t (hide s binds)) (dename' b (hide s binds))
  | PrettyTerm.App t1 t2 => EApp (dename' t1 binds) (dename' t2 binds)
  end.

(** Given a list [identifiers] of free variables, and a list [binds] of
    binds to de Bruijn indices, update it adding values for the free variables. *)
Fixpoint FV_binds (identifiers : list string) (binds : list (string * nat)):
list (string * nat) :=
  match identifiers with
  | nil => binds
  | x :: tl =>
      match lookup x binds with
      | Some n => FV_binds tl binds
      | None => FV_binds tl (cons (x, length binds) binds)
      end
  end.

Fixpoint context_binds' (Gamma : PrettyTerm.context)
(binds : list (string * nat)): list (string * nat) :=
  match Gamma with
  | nil => binds
  | (x, _) :: tl =>
      match lookup x binds with
      | Some n => context_binds' tl binds
      | None => context_binds' tl (cons (x, length binds) binds)
      end
  end.

(** Given a [context Gamma = (xN,type_N), ..., (x1, type_1)] produce a lookup
    map for the variables and identifiers to convert to de Bruijn indices. *)
Definition context_binds (Gamma : PrettyTerm.context) :
  list (string * nat) := context_binds' (rev Gamma) nil.

(* Unit tests for the [context_binds] *)
Open Scope string_scope.
Example context_binds_ex1 :
  context_binds (cons ("f", PrettyTerm.tau) nil) = ("f", 0) :: nil.
Proof.
  reflexivity.
Qed.

Example context_binds_ex2 :
  context_binds
    (cons ("f", PrettyTerm.tau)
       (cons ("g", PrettyTerm.tau) (cons ("f", PrettyTerm.tau) nil))) =
  ("g", 1) :: ("f", 0) :: nil.
Proof.
  reflexivity.
Qed.

Example fv_binds_context_binds_ex1 :
  FV_binds (PrettyTerm.FV (`"f" $ `"g" $ `"f"))
    (context_binds (cons ("g", PrettyTerm.tau) nil)) =
  ("f", 1) :: ("g", 0) :: nil.
Proof.
  reflexivity.
Qed.
Close Scope string_scope.

(** Given a [PrettyTerm.pterm] without a [context], convert it
    into a [exp] using de Bruijn indices. *)
Definition dename (t : PrettyTerm.pterm) : exp :=
  dename' t (FV_binds (PrettyTerm.FV t) nil).

(** If we have a given [context Gamma], then we want to convert it into
    a [list exp] which binds to de Bruijn indices. *)
Fixpoint deconstruct_context (c : PrettyTerm.context)
(binds : list (string * nat)): list exp :=
  match c with
  | nil => nil
  | (x, t) :: ctxt => cons (dename' t binds) (deconstruct_context ctxt binds)
  end.

(** Claim: Let [c = f : tau, h : \g:tau~>f], then
    [deconstruct_context c (context_binds c) = Elam tau f :: tau].
*)
Example deconstruct_context_ex1 :
  let c :=
    snoc ("f"%string, `"tau") (cons ("h"%string, \ "g" `"tau" ~> `"f") nil) in
  deconstruct_context c (context_binds c) = ELam tau (EVar 1) :: tau :: nil.
Proof. reflexivity. Qed.

(** Claim: Let [c = h : \g:tau~>f, g : tau, f : tau], then
    [deconstruct_context c (context_binds c) = Elam tau f :: tau :: tau].
*)
Example deconstruct_context_ex2 :
  let c :=
    snoc ("f"%string, `"tau")
      (snoc ("g"%string, `"tau") (cons ("h"%string, \ "x" `"g" ~> `"f") nil)) in
  deconstruct_context c (context_binds c) =
  ELam (EVar 2) (EVar 1) :: tau :: tau :: nil.
Proof. reflexivity. Qed.

(** Convert a [PrettyTerm.pterm] in a given [PrettyTerm.context] to
    a pair [context, exp] using de Bruijn indices. Free Variables are
    handled properly.
*)
Definition dename_with_context (c : PrettyTerm.context)
  (t : PrettyTerm.pterm) : context * exp :=
  let binds := FV_binds (PrettyTerm.FV t) (context_binds c) in
  (deconstruct_context c binds, dename' t binds).

(* Unit tests for [dename_with_context] *)
Open Scope string_scope.
Example dename_with_context_ex1 :
  dename_with_context (cons ("g", PrettyTerm.tau) nil) (`"f" $ `"g" $ `"f") =
  (tau :: nil, EApp (EApp (EVar 1) (EVar 0)) (EVar 1)).
Proof.
  reflexivity.
Qed.

Example dename_ex1 :
  dename (`"f" $ `"g" $ `"f") = EApp (EApp (EVar 0) (EVar 1)) (EVar 0).
Proof.
  reflexivity.
Qed.
Close Scope string_scope.


(** * Profunctors *)
Require Import Category.Core Functor.Core Category.Prod Category.Dual SetCategory.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Declare Scope profunctor_scope.
Delimit Scope profunctor_scope with profunctor.

Section profunctor.
  (** Quoting nCatLab:

      If [C] and [D] are categories, a profunctor from [C] to [D] is a functor [Dᵒᵖ * C -> Set]. Such a profunctor is usually written as [F : C ⇸ D].

      Every functor [f : C -> D] induces two profunctors [D(1, f) : C ⇸ D] and [D(f, 1) : D ⇸ C], defined by [D(1,f)(d,c) = D(d, f(c))] and [D(f, 1)(c,d) = D(f(c), d)]. These profunctors are called representable (or sometimes one of them is corepresentable).

      In particular the identity profunctor [Id : C ⇸ C] is represented by the identity functor and hence is given by the hom-functor [C(−, −) : Cᵒᵖ * C -> Set].

      The notion generalizes to many other kinds of categories. For instance, if [C] and [D] are enriched over some symmetric closed monoidal category [V], then a profunctor from [C] to [D] is a [V]-functor [Dᵒᵖ ⊗ C -> V]. If they are internal categories, then a profunctor [C ⇸ D] is an internal diagram on [Dᵒᵖ * C], and so on. There are also other equivalent definitions in each case; see below.

      A profunctor is also sometimes called a (bi)module or a distributor or a correspondence, though the latter word is also used for a span. The term “module” tends to be common in Australia, especially in the enriched case; here the intuition is that for one-object [V]-categories, i.e. monoids in [V], profunctors really are the same as bimodules between such monoids in the usual sense. “Profunctor” is perhaps more common in the Set-based and internal cases (but is also used in the enriched case); here the intuition is that a profunctor is a generalization of a functor, via the construction of “representable” profunctors. Jean Bénabou, who invented the term and originally used “profunctor,” now prefers “distributor,” which is supposed to carry the intuition that a distributor generalizes a functor in a similar way to how a distribution generalizes a function.

      Note that the convention that a profunctor is a functor [Dᵒᵖ * C -> Set] is not universal; some authors reverse C and D and/or put the “op” on the other one. See the discussion below. *)

  Context `{Funext}.
  Variables C D : PreCategory.

  (** We capitalize [Profunctor] just like we capitalize [Functor]. *)
  Definition Profunctor := Functor (D^op * C) set_cat.
End profunctor.

Bind Scope profunctor_scope with Profunctor.

Module Export ProfunctorCoreNotations.
  Notation "x -|-> y" := (Profunctor x y) : type_scope.
End ProfunctorCoreNotations.


(**  ** Rules of the system

This file defines the rules of transition system specified in:

Joëlle Despeyroux, Amy Felty, Pietro Lio and Carlos Olarte: A Logical
Framework for Modelling Breast Cancer Progression

There are 177 rules that modify the state of the cell according to the driven
mutations it posses.
 *)

Require Export TSystem.Syntax.
Require Export FLL.SL.FLLTactics.
Require Export FLL.Misc.Permutations.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Hint Constructors plusOne : core .
Hint Constructors uniform_atm'  : core.
Hint Constructors IsTerm : core .

(** Rules changing the state of the system:
1. Advancing the time in Dt units
2. Modifying the three parameters of the cell: location, fitness and list of mutations.
*)
  Definition EncodeRule (Dt loc fit listMut loc' fit' listMut': nat) (t n :uexp) : oo :=
    ( (perp  T{ t} ) ** perp C{n ; loc ; fit ; listMut}) ** ( (atom T{ t s+ (CN Dt)} $ (atom C{n ;loc' ; fit' ; listMut'}) )) .

  (** Rules for apoptosis *)
  Definition EncodeRuleAP (Dt loc fit listMut : nat) (t n : uexp): oo :=
    ( (perp  T{ t} ) ** perp C{n ; loc ; fit ; listMut }) ** ( (atom T{ t s+ (CN Dt)}) $ (atom A{ n })).

Hint Unfold EncodeRule : core  .
Hint Unfold EncodeRuleAP : core .

(* ================================================ *)
(** Definition of the rules *)
(* ================================================ *)
(**  In the breast: *)
Definition br0             := EncodeRule d00 breast 1 NONE breast 0 NONE .
Definition br1 (f:nat)     := EncodeRuleAP (d01 f) breast f NONE .
Definition br2             := EncodeRule d02 breast 1 NONE breast 1 TG .
Definition brt0            := EncodeRule d10 breast 1 TG breast 0 TG .
Definition brt0r            := EncodeRule d10r breast 1 TG breast 2 TG .
Definition brt1 (f:nat)    := EncodeRuleAP (d11 f) breast f TG .
Definition brt2 (f:nat)    := EncodeRule d12 breast f TG breast (f+1) EP .
Definition bre0 (f:nat)    := EncodeRule (d20 f) breast f EP breast (f-1) EP .
Definition bre0r (f:nat)    := EncodeRule (d20r f) breast f EP breast (f+1) EP .
Definition bre1 (f:nat)    := EncodeRuleAP (d21 f) breast f EP .
Definition bre2 (f:nat)    := EncodeRule (d22 f) breast f EP blood (f+1) EP .

(** In the blood: *)
Definition ble0 (f:nat)    := EncodeRule (d30 f) blood f EP blood (f-1) EP .
Definition ble0r (f:nat)   := EncodeRule (d30r f) blood f EP blood (f+1) EP .
Definition ble1 (f:nat)    := EncodeRuleAP (d31 f) blood f EP .
Definition ble2 (f:nat)    := EncodeRule (d32 f) blood f EP blood (f+2) EPCD .
Definition blec0 (f:nat)   := EncodeRule (d40 f) blood f EPCD blood (f-1) EPCD .
Definition blec1 (f:nat)   := EncodeRuleAP (d41 f) blood f EPCD .
Definition blec2 (f:nat)   := EncodeRule (d42 f) blood f EPCD blood (f+2) EPCDCD .
Definition blec3 (f:nat)   := EncodeRule (d43 f) blood f EPCD blood (f+2) EPCDME .
Definition blecc0 (f:nat)  := EncodeRule (d50 f) blood f EPCDCD blood (f-1) EPCDCD .
Definition blecc1 (f:nat)  := EncodeRuleAP (d51 f) blood f EPCDCD .
Definition blecc2 (f:nat)  := EncodeRule (d52 f) blood f EPCDCD blood (f+2) EPCDCDME .
Definition blecm0 (f:nat)  := EncodeRule (d60 f) blood f EPCDME blood (f-1) EPCDME .
Definition blecm1 (f:nat)  := EncodeRuleAP (d61 f) blood f EPCDME .
Definition blecm2 (f:nat)  := EncodeRule (d62 f) blood f EPCDME blood (f+2) EPCDCDME .
Definition bleccm0 (f:nat) := EncodeRule (d70 f) blood f EPCDCDME blood (f-1) EPCDCDME .
Definition bleccm1 (f:nat) := EncodeRuleAP (d71 f) blood f EPCDCDME .
Definition bleccm2 (f:nat) := EncodeRule (d72 f) blood f EPCDCDME bone (f+1) EPCDCDME .

(** In the bone: *)
Definition bo0 (f:nat)     := EncodeRule (d80 f) bone f EPCDCDME bone (f-1) EPCDCDME .
Definition bo1 (f:nat)     := EncodeRuleAP (d81 f) bone f EPCDCDME .
Definition bo2 (f:nat)     := EncodeRule (d82 f) bone f EPCDCDME bone (f+1) EPCDCDMEse .

(** Theory containing the whole set of rules *)

Definition GenRs (R : nat -> uexp -> uexp -> oo) (l: list nat) := map R l.

Definition Theory := [br0] ++ (GenRs br1 [0;1]) ++ [br2 ; brt0 ; brt0r] ++
                           (GenRs brt1 [0;1;2]) ++ (GenRs brt2 [1;2]) ++
                           (GenRs bre0 [1;2;3]) ++ (GenRs bre0r [1;2]) ++
                           (GenRs bre1 [0;1;2;3]) ++ (GenRs bre2 [1;2;3]) ++
                           (* blood *)
                           (GenRs ble0 [1;2;3;4]) ++ (GenRs ble0r [1;2;3]) ++
                           (GenRs ble1 [0;1;2;3;4]) ++
                           (GenRs ble2 [1;2;3;4]) ++ (GenRs blec0 [1;2;3;4;5;6]) ++
                           (GenRs blec1 [0;1;2;3;4;5;6]) ++ (GenRs blec2 [1;2;3;4;5;6]) ++
                           (GenRs blec3 [1;2;3;4;5;6]) ++ (GenRs blecc0 [1;2;3;4;5;6]) ++
                           (GenRs blecc1 [0;1;2;3;4;5;6;7;8]) ++
                           (GenRs blecc2 [1;2;3;4;5;6;7;8])  ++
                           (GenRs blecm0 [1;2;3;4;5;6;7;8]) ++
                           (GenRs blecm1 [0;1;2;3;4;5;6;7;8]) ++
                           (GenRs blecm2 [1;2;3;4;5;6;7;8]) ++
                           (GenRs bleccm0 [1;2;3;4;5;6;7;8;9;10]) ++
                           (GenRs bleccm1 [0;1;2;3;4;5;6;7;8;9;10]) ++
                           (GenRs bleccm2 [1;2;3;4;5;6;7;8;9;10]) ++
                           (* Bone *)
                           (GenRs bo0 [1;2;3;4;5;6;7;8;9;10;11]) ++
                           (GenRs bo1 [0;1;2;3;4;5;6;7;8;9;10;11]) ++
                           (GenRs bo2 [1;2;3;4;5;6;7;8;9;10;11]).

Inductive OLTheory : oo -> Prop :=
| oltheory : forall F t n, In F Theory -> IsTerm t -> IsTerm n ->  OLTheory (F t n)
.

Notation " n '|---' B ';' L ';' X " := (seqN OLTheory n B L X) (at level 80).
Notation " '|--' B ';' L ';' X " := (seq OLTheory  B L X) (at level 80).

(** Solves goals of the form [In F Theory] *)
Ltac SolveInTheory :=
  try
    match goal with
    | [|- OLTheory _] => constructor;auto; unfold Theory;
                         simpl;
                         repeat match goal with
                                | [|- ?F = ?F \/ ?G] => left;auto
                                | _ => right
                                end
    end.

Lemma tensorapp : forall B L1 L2 F G,
    |-- B ; L2 ; ( >> F) -> |-- B ; L1 ; ( >>  G) -> |-- B ; L1 ++ L2 ;  ( >>  F ** G) .
  intros.
  eapply tri_tensor' with (N:= L1) (M:=L2);solveF.
Qed.

Lemma tensorapp' : forall B L1 L2 F G,
    |-- B ; L1 ; ( >> F) -> |-- B ; L2 ; ( >>  G) -> |-- B ; L1 ++ L2 ;  ( >>  F ** G) .
  intros.
  eapply tri_tensor' with (N:= L2) (M:=L1);solveF.
Qed.

(** This tactic applies the rule R on the current goal. The splitting
of the context is made automatically due to the particular
representation of the state of the system we have here.  *)
Ltac applyRule R :=
  decide3 R;SolveInTheory;
  SplitContext' 1;
  apply tensorapp; [
    SplitContext' 1; apply tensorapp';solveLL| simpl];solveLL.

Ltac ApplyRule R :=
  match goal with
    [|- context[ T{ ?time}  ]  ] =>
    match goal with
      [|- context[ C{ ?n ; _ ; _ ; _ }]] =>
      applyRule (R time n)
    end
  end.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Essentials.HoTT_Facts.
Require Import Category.Main.
Require Import Functor.Functor.
Require Import Cat.Cat.
Require Import Coq_Cats.Type_Cat.Type_Cat.

(* empty and singleton categories *)

(** The empty category – initial object of Cat. *)
Definition EmptyCat : Category :=
  {|
    Obj := (Empty : Type);
    Hom := fun _ _ => (Unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => idpath;
    assoc_sym := fun _ _ _ _ _ _ _ => idpath;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    Hom_HSet := fun x _ => match x with end
  |}.

(** The singleton category – terminal object of Cat. *)
Program Definition SingletonCat : Category :=
  {|
    Obj := (Unit : Type);
    Hom := fun _ _ => (Unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => idpath;
    assoc_sym := fun _ _ _ _ _ _ _ => idpath;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    Hom_HSet := fun _ _ h h' => @trunc_contr _ _ (istrunc_trunctype_type HUnit h h')
  |}.

Notation "0" := (EmptyCat) : category_scope.
Notation "1" := (SingletonCat) : category_scope.

(* discrete categories in general *)
Section Discr.
  Context (obj : hSet).

  (** Discrete category – one in which has no arrow but identitities.
Note that this definition is not necessarily a discrete cat in Coq as UIP is not
generally provable. We simply assume so by implicitly assuming object type to have UIP.
In HoTT terms, we assume obj to be a HSet. *)
  Program Definition Discr_Cat : Category :=
    {|
      Obj := obj;
      Hom := fun a b => a = b;
      compose := @concat _;
      id := fun a => idpath
    |}.

End Discr.

(*
Definition Type_n (n : nat) : Type := {x : nat | Tle x n}.

Notation "'Discr_n' n" := (Discr_Cat (Type_n n)) (at level 200, n bigint) : category_scope.
*)

(*
(** Any discrete category is ismorphic to its dual. *)
Section Discr_Cat_Dual_Iso.
  Context (obj : Type).

  Local Hint Extern 1 => progress cbn.

  Program Definition Discr_Cat_Dual_Iso :
    (Discr_Cat obj ≃≃ (Discr_Cat obj)^op ::> Cat)%isomorphism%category
    :=
      {|
        iso_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|};
        inverse_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|}
      |}.

End Discr_Cat_Dual_Iso.
 *)
(*
(** Any two isomorphic types form isomorphic discrete categories. *)
Section Discr_Cat_Iso.
  Context {obj obj' : Type} (I : (obj <~> obj' ::> Type_Cat)%isomorphism).

  Program Definition Discr_Cat_Iso :
    ((Discr_Cat obj) ≃≃ (Discr_Cat obj') ::> Cat)%isomorphism
    :=
      {|
        iso_morphism :=
          {|
            FO := iso_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (iso_morphism I c) = (iso_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |};
        inverse_morphism :=
          {|
            FO := inverse_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (inverse_morphism I c) = (inverse_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |}
      |}.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (left_inverse I)); trivial.
    }
  Qed.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (right_inverse I)); trivial.
    }
  Qed.

End Discr_Cat_Iso.
*)
(* Functor from SingletonCat to another category. *)
Section Func_From_SingletonCat.
  Context {C : Category} (Cobj : C).

  (** The functor from SingletonCat to C induced bo Cobj. *)
  Program Definition Func_From_SingletonCat : (SingletonCat –≻ C)%functor :=
    {|
      FO := fun _ => Cobj;
      FA := fun _ _ _ => id
    |}.

End Func_From_SingletonCat.

(* Discrete Functor *)
Section Discr_Func.
  Context {C : Category} {A : hSet} (Omap : A → C).

  (** The discrete functor – a functor from a discrete category of type A
 to a category C based on a function from A to objects of C. *)
  Program Definition Discr_Func : ((Discr_Cat A) –≻ C)%functor :=
    {|
      FO := Omap;

      FA := fun (a b : A) (h : a = b) =>
              match h in _ = y return ((Omap a) –≻ (Omap y))%morphism with
              | idpath => id
              end
    |}.

  (** The discrete-opposite functor – a functor from the opposite of a
discrete category of type A to a category C based on a function from A to objects of C. *)
  Program Definition Discr_Func_op : ((Discr_Cat A)^op –≻ C)%functor :=
    {|
      FO := Omap;
      FA := fun (a b : A) (h : b = a) =>
              match h in _ = y return ((Omap y) –≻ (Omap b))%morphism with
              | idpath => id
              end
    |}.

End Discr_Func.

Arguments Discr_Func {_ _} _, _ {_} _.
Arguments Discr_Func_op {_ _} _, _ {_} _.