From PlutusCert Require Import Language.PlutusIR.
From PlutusCert Require Import Language.PlutusIR.Transform.Congruence.
From PlutusCert Require Import Language.PlutusIR.Analysis.FreeVars.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Import Coq.Lists.List.ListNotations.

Import NamedTerm.

(* Desugars let-nonrec with only type bindings
*)

Inductive ty_let : Term -> Term -> Type :=

  | tl_Let : forall bs t_body t_body' f_bs,
      ty_let t_body t_body' ->
      ty_let_Bindings bs f_bs ->
      ty_let (Let NonRec bs t_body) (fold_right apply t_body' f_bs )

  | tl_Cong : forall t t',
      Cong ty_let t t' ->
      ty_let t t'

with ty_let_Bindings : list Binding -> list (Term -> Term) -> Type :=

  | tl_Nil  :
      ty_let_Bindings nil nil

  | tl_Cons : forall {b bs f_b f_bs},
      ty_let_Binding        b   f_b ->
      ty_let_Bindings       bs  f_bs ->
      ty_let_Bindings (b :: bs) (f_b :: f_bs)

with ty_let_Binding : Binding -> (Term -> Term) -> Type :=
  | tl_Desugar : forall α k τ,
      ty_let_Binding
        (TypeBind (TyVarDecl α k) τ)
        (fun t_bs => TyInst (TyAbs α k t_bs) τ)
  .


From Coq Require Import
     Relation_Definitions
     RelationClasses
.

Require Import Fix.
Require Import GHC.Base.

Variant EqEq {F : Set -> Set}
        (Kr : forall (A : Set), relation (F A))
        {A : Set} : relation (F A) :=
| EqRefl : forall (a : F A), EqEq Kr a a
| EqSym  : forall (a b : F A), Kr _ a b -> EqEq Kr b a
| EqTrans : forall (a b c : F A), Kr _ a b -> Kr _ b c -> EqEq Kr a c.

#[export] Instance FunctorRel__EqEq {F : Set -> Set} : FunctorRel (F:=F) EqEq.
constructor. intros. destruct H0.
- apply EqRefl.
- apply EqSym. auto.
- eapply EqTrans; apply H; eassumption.
Qed.

Section EqEq_SmartConstructors.

  Variable F : Set -> Set.
  Variable R : (forall (A : Set), relation (F A)) ->
               forall (A : Set), relation (F A).

  Context `{FunctorRel F R} `{EqEq -⋘ R}.

  Lemma eqEq : forall {A : Set} (a : F A),
      FixRel R _ a a.
  Proof.
    intros. apply inFRel, injRel.
    apply EqRefl.
  Qed.

  Lemma eqSym : forall {A : Set} (a b : F A),
      FixRel R _ a b -> FixRel R _ b a.
  Proof.
    intros. apply inFRel, injRel.
    apply EqSym. assumption.
  Qed.

  Lemma eqTrans : forall {A : Set} (a b c : F A),
      FixRel R _ a b -> FixRel R _ b c -> FixRel R _ a c.
  Proof.
    intros. apply inFRel, injRel.
    eapply EqTrans; eassumption.
  Qed.

  Global Instance Equivalence_EqEq {A : Set} : Equivalence (FixRel R A).
  Proof.
    constructor.
    - intros a. apply eqEq.
    - intros a b. apply eqSym.
    - intros a b c. apply eqTrans.
  Qed.

End EqEq_SmartConstructors.


Require Import VST.progs.conclib.
Require Import VST.floyd.proofauto.
Require Import VST.sepcomp.Address.
Require Import inthash.
Require FMapWeakList.
Require Import Program.Basics. Open Scope program_scope.
Require Import Structures.OrdersEx.

Definition N: Z := 10.
Global Opaque N.
Lemma N_eq: N = 10. reflexivity. Qed.
Hint Rewrite N_eq: rep_omega.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Set Default Timeout 20.
Require Import VST.msl.iter_sepcon.
Require Import VST.floyd.library.

Definition V := sig is_pointer_or_null.
Definition nullV: V := exist _ nullval mapsto_memory_block.is_pointer_or_null_nullval.

Instance EqDecV: EqDec V.
Proof.
  intros [x hx] [y hy]. destruct (eq_dec x y).
  + left. now apply exist_ext.
  + right. intro hcontr. apply n. exact (f_equal (@proj1_sig _ _) hcontr).
Qed.

Module int_table := FMapWeakList.Make Z_as_DT.

Notation "{{ m }}" := (int_table.this m).

Section IntTable.
  Import int_table.
  Check SetoidList.InA .
  Definition get_buckets (m: t V): list (int_table.Raw.t V) :=
    List.map (fun n => filter (fun kv => eq_dec (fst kv mod N) n) {{ m }}) (upto (Z.to_nat N)).

  Lemma Zlength_get_buckets: forall m, Zlength (get_buckets m) = N.
  Proof.
    intros []. unfold get_buckets.
    rewrite Zlength_map, Zlength_upto. reflexivity.
  Qed.

  Lemma get_buckets_spec (m: t V):
    forall k v, MapsTo k v m <-> SetoidList.InA (eq_key_elt (elt := V)) (k, v) (Znth (k mod N) (get_buckets m)).
  Proof.
    intros.
    unshelve epose proof (Z_mod_lt k N _). rep_omega.
    assert (mapsto_iff: MapsTo k v m <-> SetoidList.InA (@eq_key_elt _) (k, v) (elements m)).
    split; [apply elements_1 | apply elements_2].
    rewrite mapsto_iff. clear mapsto_iff.
    destruct m as [l nodup]. unfold get_buckets.
    rewrite Znth_map, SetoidList.filter_InA, Znth_upto.
    now destruct eq_dec.
    rep_omega.
    intros x y hxy%Raw.PX.eqke_eqk. rewrite hxy; reflexivity.
    rewrite Zlength_upto; rep_omega.
  Qed.

  Lemma add_bucket_Znth: forall key v m,
      let i := key mod N in
      Znth i (get_buckets (add key v m)) = Raw.add key v (Znth i (get_buckets m)).
  Proof.
    intros key v m i.
    assert (0 <= i < N). { unfold i. apply Z_mod_lt. rep_omega. }
    unfold get_buckets.
    do 2 rewrite Znth_map, Znth_upto by (try rewrite Zlength_upto; rep_omega).
    unfold i, int_table.add. cbn.
    symmetry.
    induction {{m}} as [|[k' v'] l]; cbn.
    + rewrite proj_sumbool_is_true; reflexivity.
    + destruct (Z_as_DT.eq_dec key k'). subst key. cbn.
      rewrite proj_sumbool_is_true by reflexivity.
      cbn. destruct Z_as_DT.eq_dec.  reflexivity. contradiction.
      cbn. destruct eq_dec. cbn.
      destruct Z_as_DT.eq_dec. contradiction. f_equal. apply IHl.
      apply IHl.
  Qed.

  Lemma NoDupA_filter: forall (m: t V) (p: Z * V -> bool),
      Proper (eq_key (elt := V) ==> eq) p ->
 SetoidList.NoDupA (int_table.Raw.PX.eqk (elt:=V))
    (filter p (int_table.elements (elt:=V) m)).
  Proof.
    intros [] p h.
    induction this0.
    constructor.
    cbn. destruct p. constructor.
    intros hcontr%SetoidList.filter_InA. now inversion NoDup0.
    assumption.
    unshelve eapply IHthis0. inversion NoDup0. assumption.
    unshelve eapply IHthis0. inversion NoDup0. assumption.
  Qed.

  Lemma NoDupA_bucket: forall k m,
    SetoidList.NoDupA (Raw.PX.eqk (elt:=V)) (Znth (k mod N) (get_buckets m)).
  Proof.
    intros k [].
    unfold get_buckets.
    unshelve epose proof (Z_mod_lt k N _). rep_omega.
    rewrite Znth_map, Znth_upto by (try rewrite Zlength_upto; rep_omega). apply NoDupA_filter.
    intros x y <-; reflexivity.
  Qed.

  Definition get_bucket (k: Z) (m: t V): t V :=
    Build_slist (NoDupA_bucket k m).

  Lemma add_buckets: forall k v m,
      let i := k mod N in
      get_buckets (add k v m) =
     upd_Znth i (get_buckets m) (add k v (get_bucket k m)).
  Proof.
    intros k v [l nodup].
    unshelve epose proof (Z_mod_lt k N _). rep_omega.
    unfold get_bucket, get_buckets.
    rewrite upd_Znth_eq, map_length, upto_length by (rewrite Zlength_map, Zlength_upto; rep_omega).
    cbn. rewrite Znth_map, Znth_upto by (try rewrite Zlength_upto; rep_omega).
    apply list_map_exten. intros x hx%In_upto. rewrite Z2Nat.id in hx by rep_omega.
    clear nodup. rewrite Znth_map, Znth_upto by (try rewrite Zlength_upto; rep_omega).
    induction l as [|[k' v'] l]; cbn.
    + destruct eq_dec, eq_dec; cbn; try reflexivity; subst; contradiction.
    + destruct (eq_dec (k' mod N) (k mod N)) as [h|h]; cbn;
      destruct Z_as_DT.eq_dec; cbn; repeat rewrite h;
      destruct eq_dec, eq_dec; cbn; subst; try contradiction; try rewrite IHl; reflexivity.
  Qed.

  Lemma get_buckets_spec' (m: t V):
    forall k v, MapsTo k v m <-> MapsTo k v (get_bucket k m).
  Proof.
    intros. destruct m as [l nodup].
    unshelve epose proof (Z_mod_lt k N _). rep_omega.
    unfold MapsTo, get_bucket, Raw.PX.MapsTo.
    unfold get_buckets, this.
    rewrite Znth_map, SetoidList.filter_InA, Znth_upto; try rewrite Zlength_upto; try rep_omega.
    now destruct eq_dec.
    intros x y hxy%Raw.PX.eqke_eqk. rewrite hxy. reflexivity.
  Qed.

  Lemma find_None: forall m k,
      find k m = None <-> forall v: V, not (MapsTo k v m).
  Proof.
    intros.
    split; intro h.
    + intros v hmapsto%find_1; congruence.
    + case_eq (find (elt := V) k m).
      intros v hfind%find_2. specialize (h v). contradiction.
      easy.
  Qed.

  Corollary find_get_bucket (m: t V):
    forall k, find k m = find k (get_bucket k m).
  Proof.
    intro.
    case_eq (find (elt := V) k m).
    + intros v hv%find_2.
      symmetry. apply find_1. now rewrite <- get_buckets_spec'.
    + intro hnone.
      symmetry. rewrite find_None in hnone |- *.
      intros v hcontr.
      rewrite <- get_buckets_spec' in hcontr.
      now apply (hnone v).
  Qed.

  Lemma MapsTo_inj: forall (m: t V) k v1 v2,
      MapsTo k v1 m -> MapsTo k v2 m -> v1 = v2.
  Proof.
    intros * h1 h2.
    apply find_1 in h1. apply find_1 in h2.
    rewrite h1 in h2. now inv h2.
  Qed.

End IntTable.

Definition t_icell := Tstruct _icell noattr.
Definition t_inthash := Tstruct _inthash noattr.

Definition maybe {A: Type} (o: option A) (default: A) :=
  match o with Some a => a | None => default end.

Definition V_repr: V -> val := @proj1_sig _ _.

Fixpoint icell_rep (l: int_table.Raw.t V) (p: val): mpred :=
  match l with
  | [] => !!(p = nullval) && emp
  | (k, v) :: tl => EX q: val,
                    !! (0 <= k < Int.max_unsigned) &&
                       malloc_token Ews t_icell p *
                    data_at Ews t_icell (Vint (Int.repr k), (V_repr v, q)) p *
                    icell_rep tl q
  end.

Definition icell_rep_local_facts:
  forall l p, icell_rep l p |-- !! (is_pointer_or_null p /\ (p=nullval <-> l = [])).
Proof.
  intros l. induction l as [ | [] tl]; intro p; simpl.
  + entailer!. easy.
  + Intros q. entailer!. now apply field_compatible_nullval1 in H1.
Qed.
Hint Resolve icell_rep_local_facts: saturate_local.

Definition icell_rep_valid_pointer:
  forall l p, icell_rep l p |-- valid_pointer p.
Proof. intros [|[]] p; cbn; entailer. Qed.
Hint Resolve icell_rep_valid_pointer: valid_pointer.

Definition inthash_rep (m: int_table.t V) (p: val): mpred :=
  let buckets := get_buckets m in
  EX buckets_p: list val,
  !! (Zlength buckets_p = N) &&
     malloc_token Ews t_inthash p *
  data_at Ews t_inthash buckets_p p *
  iter_sepcon (prod_curry icell_rep) (combine buckets buckets_p).

Definition inthash_new_spec: ident * funspec :=
   DECLARE _inthash_new
 WITH gv: globals
 PRE [ ]
   PROP()
   LOCAL(gvars gv)
   SEP(mem_mgr gv)
 POST [ tptr t_inthash ]
   EX p:val,
      PROP()
      LOCAL(temp ret_temp p)
      SEP(inthash_rep (int_table.empty V) p; mem_mgr gv).

Definition new_icell_spec: ident * funspec :=
   DECLARE _new_icell
 WITH gv: globals, key: Z, value: V, pnext: val, tl: list (Z*V)
 PRE [ _key OF tuint, _value OF tptr tvoid, _next OF tptr t_icell ]
   PROP( 0 <= key < Int.max_unsigned )
   LOCAL(gvars gv; temp _key (Vint (Int.repr key)); temp _value (V_repr value); temp _next pnext)
   SEP(icell_rep tl pnext; mem_mgr gv)
 POST [ tptr t_icell ]
   EX p:val,
      PROP()
      LOCAL(temp ret_temp p)
      SEP(icell_rep ((key, value) :: tl) p; mem_mgr gv).

Definition inthash_lookup_spec: ident * funspec :=
   DECLARE _inthash_lookup
 WITH gv: globals, m: int_table.t V, key: Z, pm: val
 PRE [ _p OF tptr t_inthash, _key OF tuint ]
   PROP(0 <= key < Int.max_unsigned)
   LOCAL(gvars gv; temp _p pm; temp _key (Vint (Int.repr key)))
   SEP(mem_mgr gv; inthash_rep m pm)
 POST [ tptr tvoid ]
      PROP()
      LOCAL(temp ret_temp (V_repr (maybe (int_table.find key m) nullV)))
      SEP(mem_mgr gv; inthash_rep m pm).

Definition inthash_insert_list_spec: ident * funspec :=
   DECLARE _inthash_insert_list
 WITH gv: globals, l: int_table.t V, key: Z, ppl: val, pl: val
 PRE [ _r0 OF tptr (tptr t_icell), _key OF tuint ]
   PROP(0 <= key < Int.max_unsigned)
   LOCAL(gvars gv; temp _r0 ppl; temp _key (Vint (Int.repr key)))
   SEP(mem_mgr gv; data_at Ews (tptr t_icell) pl ppl; icell_rep (int_table.this l) pl)
 POST [ tptr t_icell ]
   EX p_ret: val, EX r: val, EX tl: int_table.Raw.t V,
            let v := maybe (int_table.find key l) nullV in
      PROP( )
      LOCAL(temp ret_temp p_ret)
      SEP(mem_mgr gv; data_at Ews (tptr t_icell) p_ret r * icell_rep ((key, v) :: tl) p_ret;
          ALL v: V, data_at Ews (tptr t_icell) p_ret r * icell_rep ((key, v) :: tl) p_ret -*
          EX pl: val, data_at Ews (tptr t_icell) pl ppl * icell_rep (int_table.Raw.add key v {{ l }}) pl).

Definition inthash_insert_spec: ident * funspec :=
   DECLARE _inthash_insert
 WITH gv: globals, m: int_table.t V, key: Z, pm: val, v: V
 PRE [ _p OF tptr t_inthash, _key OF tuint, _value OF tptr tvoid ]
   PROP(0 <= key < Int.max_unsigned)
   LOCAL(gvars gv; temp _p pm; temp _key (Vint (Int.repr key)); temp _value (proj1_sig v))
   SEP(mem_mgr gv; inthash_rep m pm)
 POST [ tptr tvoid ]
      PROP( )
      LOCAL(temp ret_temp (V_repr (maybe (int_table.find key m) nullV)))
      SEP(mem_mgr gv; inthash_rep (int_table.add key v m) pm).

Definition Gprog : funspecs :=
        ltac:(with_library prog [ inthash_new_spec; new_icell_spec; inthash_lookup_spec ;
             inthash_insert_list_spec ; inthash_insert_spec ]).

Lemma body_inthash_insert: semax_body Vprog Gprog f_inthash_insert inthash_insert_spec.
Proof.
  start_function.
  unfold inthash_rep. Intros buckets_p.
  pose (i := key mod N). fold i.
  assert (0 <= i < N). { apply Z_mod_lt. rep_omega. }
  rewrite (iter_sepcon_Znth _ _ i) by
      (rewrite Zlength_combine, Z.min_r; try rewrite Zlength_get_buckets; rep_omega).
  Intros.
  unfold_data_at (data_at _ _ _ pm).
  rewrite field_at_data_at'. simpl nested_field_type. rewrite <- N_eq. fold t_icell.
  rewrite wand_slice_array with (lo := i) (hi := i + 1) by (cbn; rep_omega).
  replace (i+1-i) with 1 by omega.
  rewrite sublist_len_1 by (cbn; rep_omega).
  erewrite data_at_singleton_array_eq by reflexivity. simpl reptype.
  forward_call (gv, get_bucket key m, key, (field_address0 (tarray (tptr t_icell) N) [ArraySubsc i]
           (offset_val (nested_field_offset t_inthash [StructField _buckets]) pm)), Znth i buckets_p).
  cbn. entailer!. entailer!.
  rewrite field_address0_offset. reflexivity.
  eapply field_compatible0_cons_Tarray. reflexivity. auto. rep_omega.
  instantiate (Frame := [malloc_token Ews t_inthash pm; array_with_hole Ews (tptr t_icell) i (i + 1) N buckets_p pm; iter_sepcon (prod_curry icell_rep) (remove_Znth i (combine (get_buckets m) buckets_p))]).
  unfold Frame, fold_right_sepcon. entailer!.
  unfold prod_curry, i; rewrite Znth_combine by (rewrite Zlength_get_buckets; rep_omega); cbn; apply derives_refl.
  Intros vret.
  destruct vret as [[p_ret r] tl]. unfold fst, snd in *.
  unfold icell_rep at 1; fold icell_rep. Intros q.
  forward. entailer!. now destruct (maybe (int_table.find (elt:=V) key (get_bucket key m)) nullV).
  do 2 forward.
  {
    entailer!.
    { rewrite <- find_get_bucket. reflexivity. }
    allp_left v.
    sep_apply (wand_frame_elim' (data_at Ews (tptr t_icell) p_ret r * malloc_token Ews t_icell p_ret *
  data_at Ews t_icell (Vint (Int.repr key), (proj1_sig v, q)) p_ret * icell_rep tl q)).
    cbn. Exists q. entailer!.
    Intro pl.
    unfold inthash_rep.
    Exists (upd_Znth i buckets_p pl).
    rewrite (iter_sepcon_Znth _ (combine _ _) i) by (rewrite Zlength_combine, Z.min_l; rewrite Zlength_get_buckets; try rewrite upd_Znth_Zlength; rep_omega).
    rewrite add_buckets, combine_upd_Znth, upd_Znth_same, remove_upd_Znth, upd_Znth_Zlength by
    ( try rewrite Zlength_combine, Z.min_r; try rewrite Zlength_get_buckets; rep_omega).
    unfold_data_at (data_at _ _ _ pm).
    rewrite field_at_data_at'. simpl nested_field_type.
    rewrite <- N_eq, wand_slice_array with (lo := i) (hi := i + 1) by (try rewrite upd_Znth_Zlength; cbn; rep_omega).
    replace (i+1-i) with 1 by omega.
    rewrite sublist_len_1 by (rewrite upd_Znth_Zlength; cbn; rep_omega).
    erewrite data_at_singleton_array_eq by reflexivity.
    simpl nested_field_offset.
    rewrite upd_Znth_same, isptr_offset_val_zero by (auto; cbn; rep_omega).
    entailer!.
    unfold array_with_hole. rewrite sublist_upd_Znth_l, sublist_upd_Znth_r by (cbn; rep_omega). apply derives_refl. }
Qed.

Lemma body_inthash_insert_list: semax_body Vprog Gprog f_inthash_insert_list inthash_insert_list_spec.
Proof.
  start_function.
  forward.
  forward_loop
    (EX l1 l2: list (Z * V), EX r: val,
      PROP ( {{ l }} = l1 ++ l2; not (int_table.Raw.PX.In key l1) )
     LOCAL (temp _r r; gvars gv; temp _r0 ppl; temp _key (Vint (Int.repr key)))
     SEP (mem_mgr gv;
          EX p: val, data_at Ews (tptr t_icell) p r * icell_rep l2 p;
          ALL l', (EX p, data_at Ews (tptr t_icell) p r * icell_rep l' p) -* EX pl: val, data_at Ews (tptr t_icell) pl ppl * icell_rep (l1 ++ l') pl)).
  + Exists (@nil (Z*V)) {{ l }} ppl pl.
    entailer!. destruct H3 as [x hx]. inversion hx.
    apply allp_right. intro.
    apply wand_refl_cancel_right.
  + Intros l1 l2 r p.
    forward.
    forward_if.
  - forward_call (gv, key, nullV, nullval, @nil (Z*V)).
    cbn. entailer!.
    Intro vret.
    do 2 forward.
    replace l2 with (@nil (Z*V)) in * by intuition.
    rewrite app_nil_r in H0.
    replace (maybe (int_table.find (elt:=V) key l) nullV) with nullV.
    Exists vret r (@nil (Z*V)).
    unfold icell_rep at 2.
    entailer!.
    apply allp_right. intro v.
    sep_apply (allp_instantiate (fun l' =>
                                   (EX p0 : val, data_at Ews (tptr t_icell) p0 r * icell_rep l' p0) -*
   (EX pl0 : val, data_at Ews (tptr t_icell) pl0 ppl * icell_rep ({{l}} ++ l') pl0)) [(key, v)]).

    apply wand_derives. Exists vret. apply derives_refl.

    replace (int_table.Raw.add key v {{ l }}) with ({{l}} ++ [(key, v)]).
    apply derives_refl.

    { induction {{l}} as [|[]]. reflexivity.
      rewrite int_table.Raw.add_equation, if_false, <- app_comm_cons, IHt.
      reflexivity.
      intro hcontr. apply H1.
      destruct hcontr as [e he]. exists e. now apply SetoidList.InA_cons_tl.
      intro heq. subst. apply H1. exists v0. constructor. now constructor. }
    replace (int_table.find (elt := V) key l) with (@None V). reflexivity.
    symmetry. rewrite find_None. intros v hv. apply H1. exists v. subst. apply hv.
  - destruct l2 as [|[k v]]. unfold icell_rep. Intros. contradiction.
    unfold icell_rep; fold icell_rep. Intros q.
    forward. forward_if.
    ++ forward.
       Exists p r l2.
       replace (maybe (int_table.find (elt:=V) key l) nullV) with v.
       unfold icell_rep at 4; fold icell_rep. Exists q.
       entailer!.
       apply allp_right. intro v'.
       allp_left ((key, v') :: l2).
       apply wand_derives.
       Exists p. apply derives_refl.
       replace (int_table.Raw.add key v' {{l}}) with (l1 ++ (key, v') :: l2).
       apply derives_refl.
       { rewrite H0.
         rename H1 into h.
         clear - h.
         induction l1 as [ | [k v'']].
         + cbn. now destruct Z_as_DT.eq_dec.
         + rewrite int_table.Raw.add_equation. cbn.
           destruct Z_as_DT.eq_dec.
           exfalso. apply h. subst k. rewrite int_table.Raw.PX.In_alt. exists v''.
           constructor. constructor.
           f_equal. apply IHl1. intro hcontr. apply h.
           rewrite int_table.Raw.PX.In_alt in hcontr |- *.
           destruct hcontr as [e he]. exists e.
           apply SetoidList.InA_cons_tl. assumption. }

       { replace (int_table.find (elt := V) key l) with (Some v). reflexivity.
         symmetry. apply int_table.find_1.
         unfold int_table.MapsTo, int_table.Raw.PX.MapsTo.
         rewrite H0, SetoidList.InA_app_iff. right. constructor. easy. }
    ++ forward. simpl offset_val.
       Exists (l1 ++ [(k,v)]) l2 (offset_val 8 p) q.
       entailer!.
       split.
       { rewrite <- app_assoc. easy. }
       { intros [e hcontr%SetoidList.InA_app].
         destruct hcontr.
         + apply H1. exists e. assumption.
         + apply SetoidList.InA_singleton in H12.
           compute in H12. omega. }

       unfold_data_at (data_at _ _ _ p).
       rewrite (field_at_data_at' _ _ [StructField _next]). simpl nested_field_type. simpl nested_field_offset.
       entailer!.

       apply allp_right. intro l'.
       allp_left ((k,v)::l').
       rewrite <- wand_sepcon_adjoint.
       sep_apply (wand_frame_elim' ((data_at Ews (tptr t_icell) p r *
   (malloc_token Ews t_icell p *
    (field_at Ews t_icell [StructField _key] (Vint (Int.repr k)) p *
     field_at Ews t_icell [StructField _value] (V_repr v) p))) *
  (EX p0 : reptype (tptr t_icell), data_at Ews (tptr t_icell) p0 (offset_val 8 p) * icell_rep l' p0))).
       cbn. Intro p0.
       Exists p p0. unfold_data_at (data_at _ _ _ p).
       rewrite (field_at_data_at _ _ [StructField _next]), field_address_offset.
       entailer!.
       auto with field_compatible.
       rewrite <- app_assoc. apply derives_refl.
Qed.

Lemma body_inthash_lookup: semax_body Vprog Gprog f_inthash_lookup inthash_lookup_spec.
Proof.
  start_function.
  unfold inthash_rep. Intros buckets_p.
  pose (i := key mod N). fold i.
  assert (0 <= i < N). { apply Z_mod_lt. rep_omega. }
  rewrite (iter_sepcon_Znth _ _ i), Znth_combine by
      (try rewrite Zlength_combine, Z.min_r; try rewrite Zlength_get_buckets; rep_omega).
  unfold prod_curry at 1.
  Intros.
  forward.
  fold i.
  remember (Znth i buckets_p) as q0.
  remember (Znth i (get_buckets m)) as kvs.
  remember (combine (get_buckets m) buckets_p) as l.
  forward_while (
        EX kvs1 kvs2: list (Z * V), EX q: val,
     PROP ( kvs = kvs1 ++ kvs2 /\ not (int_table.Raw.PX.In key kvs1))
     LOCAL (temp _q q; gvars gv; temp _p pm; temp _key (Vint (Int.repr key)))
     SEP (mem_mgr gv; malloc_token Ews t_inthash pm; data_at Ews t_inthash buckets_p pm;
     icell_rep kvs2 q;
     icell_rep kvs2 q -* icell_rep kvs q0;
     iter_sepcon (prod_curry icell_rep) (remove_Znth i l)))%assert.
  + Exists (@nil (Z*V)) kvs q0.
    entailer!.
    { rewrite int_table.Raw.PX.In_alt in H7. destruct H7 as [e he].
      inv he. }
    apply wand_refl_cancel_right.
  + entailer!.
  + destruct kvs2 as [|[k v] kvs2]. assert_PROP (q = nullval). entailer!. intuition.
    subst q. contradiction.
    unfold icell_rep at 1; fold icell_rep.
    Intros q1. forward.
    forward_if.
  - forward. destruct v; entailer!.
    forward.
    replace (int_table.find key m) with (Some v).
    unfold inthash_rep. Exists buckets_p.
    sep_apply (wand_frame_elim'
        (malloc_token Ews t_icell q * data_at Ews t_icell (vint key, (V_repr v, q1)) q * icell_rep kvs2 q1)). cbn. Exists q1; entailer!.
    rewrite (iter_sepcon_Znth _ (combine _ _) i) by
      (rewrite Zlength_combine, Z.min_r; try rewrite Zlength_get_buckets; rep_omega).
    unfold prod_curry at 2. rewrite Znth_combine by (rewrite Zlength_get_buckets; rep_omega).
    entailer!.
    { symmetry. apply int_table.find_1. rewrite get_buckets_spec. fold i.
    rewrite (proj1 H2), SetoidList.InA_app_iff. right. constructor. reflexivity. }
  - forward. Exists (kvs1 ++ [(k,v)], kvs2, q1).
    entailer!.
    rewrite <- app_assoc. split. easy.
    { intro hcontr.
      apply (proj2 H2).
      rewrite int_table.Raw.PX.In_alt in hcontr |- *.
      destruct hcontr as [e he].
      rewrite SetoidList.InA_app_iff in he. destruct he as [he|he].
      exists e. assumption.
      rewrite SetoidList.InA_singleton in he.
      compute in he. subst. contradiction. }
    cancel. rewrite <- wand_sepcon_adjoint.
    sep_apply (wand_frame_elim'
              (malloc_token Ews t_icell q * data_at Ews t_icell (vint k, (V_repr v, q1)) q * icell_rep kvs2 q1)).
    cbn. Exists q1; entailer!. apply derives_refl.
    + forward.
      replace (int_table.find (elt := V) key m) with (@None V).
      unfold inthash_rep. Exists buckets_p.
      sep_apply (wand_frame_elim' (icell_rep kvs2 nullval)). apply derives_refl.
      rewrite (iter_sepcon_Znth _ (combine _ _) i), Znth_combine by
          (try rewrite Zlength_combine, Z.min_r; try rewrite Zlength_get_buckets; rep_omega).
      unfold prod_curry at 2. entailer!.
      symmetry. apply find_None.
      intros v hv. apply (proj2 H2). exists v.
      replace (kvs1 ++ kvs2) with kvs1 in H2 by
      (replace kvs2 with (@nil (Z*V)) by intuition; now rewrite app_nil_r).
      rewrite <- (proj1 H2). rewrite get_buckets_spec' in hv.
      unfold int_table.MapsTo in hv. apply hv.
Qed.

Lemma body_inthash_new: semax_body Vprog Gprog f_inthash_new inthash_new_spec.
Proof.
  start_function.
  forward_call (t_inthash, gv).
  { split3; auto. cbn. computable. }
  Intros vret.
  forward_if
    (PROP ( )
     LOCAL (temp _p vret; gvars gv)
     SEP (mem_mgr gv; malloc_token Ews t_inthash vret * data_at_ Ews t_inthash vret)).
  { destruct eq_dec; entailer. }
  { forward_call tt. entailer. }
  { forward. rewrite if_false by assumption. entailer. }
  { Search complete. forward_for_simple_bound N
      (EX i: Z,
       PROP ( 0 <= i <= N )
       LOCAL (temp _p vret; gvars gv)
       SEP (mem_mgr gv;
              malloc_token Ews t_inthash vret;
              data_at Ews t_inthash (Zrepeat i nullval ++ Zrepeat (N-i) Vundef) vret))%assert.
    + entailer!. apply data_at__data_at. reflexivity.
    + forward.
      entailer!.
      autorewrite with sublist.
      rewrite Zlength_Zrepeat, Z.sub_diag, upd_Znth0, Zlength_Zrepeat by rep_omega.
      replace (Zrepeat (N - i) Vundef) with (Vundef :: Zrepeat (N - (i + 1)) Vundef).
      rewrite sublist_1_cons.
      unfold Zrepeat. rewrite Z2Nat.inj_add, repeat_plus, sublist_repeat by omega.
      change (Z.to_nat 1) with 1%nat.
      cbn. replace (N - i - 1 - 0) with (N - (i+1)) by omega.
      rewrite <- app_assoc.
      apply derives_refl.
      change (Vundef :: Zrepeat (N - (i + 1)) Vundef) with (Zrepeat 1 Vundef ++ Zrepeat (N-(i+1)) Vundef).
      unfold Zrepeat. rewrite <- repeat_plus. rewrite <- Z2Nat.inj_add by omega.
      replace  (1 + (N - (i + 1))) with (N - i) by omega. reflexivity.
    + forward. Exists vret. unfold inthash_rep, int_table.empty.
      Exists (Zrepeat N nullval).
      rewrite iter_sepcon_emp'.
      entailer!.
      { intros [l p] hxl. pose proof hxl as hxr.
        apply in_combine_l in hxl. apply in_combine_r in hxr.
        cbn in hxl.
        apply list_in_map_inv in hxl. rewrite <- Zrepeat_fold in hxr. apply in_list_repeat in hxr.
        destruct hxl as [? []].
        subst. cbn.
        apply pred_ext; entailer. }}
Qed.

Lemma body_new_icell: semax_body Vprog Gprog f_new_icell new_icell_spec.
Proof.
  start_function.
  forward_call (t_icell, gv).
  { now compute. }
  Intro vret.
  forward_if (PROP ( )
     LOCAL (temp _p vret; gvars gv; temp _key (Vint (Int.repr key)); temp _value (proj1_sig value);
     temp _next pnext)
     SEP (mem_mgr gv; malloc_token Ews t_icell vret * data_at_ Ews t_icell vret;
     icell_rep tl pnext)).
  + destruct eq_dec; entailer.
  + forward_call tt. contradiction.
  + forward. rewrite if_false by assumption. entailer.
  + Intros. do 4 forward. Exists vret. cbn.
    Exists pnext. entailer!.
Qed.

(* The above specifications are "tight".
   Indeed, the inthash_rep guarantees that the order of the elements in a bucket's linked list
   is the same as the order in which the elements were inserted in the functional model.
   Let's provide looser specifications using the int_table.Equal predicate, which states that
   two int_tables have the same key-value pairs, but not necessarily the same "history". *)

Definition inthash_rep_loose (m: int_table.t V) (p: val): mpred :=
  EX m_equal: int_table.t V,
  !! (int_table.Equal m m_equal) && inthash_rep m_equal p.

(* The inthash_new function doesn't need an additional spec *)

Definition inthash_lookup_spec_loose: ident * funspec :=
   DECLARE _inthash_lookup
 WITH gv: globals, m: int_table.t V, key: Z, pm: val
 PRE [ _p OF tptr t_inthash, _key OF tuint ]
   PROP(0 <= key < Int.max_unsigned)
   LOCAL(gvars gv; temp _p pm; temp _key (Vint (Int.repr key)))
   SEP(mem_mgr gv; inthash_rep_loose m pm)
 POST [ tptr tvoid ]
      PROP()
      LOCAL(temp ret_temp (V_repr (maybe (int_table.find key m) nullV)))
      SEP(mem_mgr gv; inthash_rep_loose m pm).

Definition inthash_insert_spec_loose: ident * funspec :=
   DECLARE _inthash_insert
 WITH gv: globals, m: int_table.t V, key: Z, pm: val, v: V
 PRE [ _p OF tptr t_inthash, _key OF tuint, _value OF tptr tvoid ]
   PROP(0 <= key < Int.max_unsigned)
   LOCAL(gvars gv; temp _p pm; temp _key (Vint (Int.repr key)); temp _value (proj1_sig v))
   SEP(mem_mgr gv; inthash_rep_loose m pm)
 POST [ tptr tvoid ]
      PROP( )
      LOCAL(temp ret_temp (V_repr (maybe (int_table.find key m) nullV)))
      SEP(mem_mgr gv; inthash_rep_loose (int_table.add key v m) pm).

Lemma sub_lookup:
  funspec_sub (snd inthash_lookup_spec) (snd inthash_lookup_spec_loose).
Proof.
  apply NDsubsume_subsume.
  split; extensionality x; reflexivity.
  split3; auto.
  intros [[[gv m] k] pm].
  unfold inthash_rep_loose. Intros m_equal.
  Exists (gv, m_equal, k, pm) emp.
  rewrite !insert_SEP.
  apply andp_right.
  entailer!.
  apply prop_right.
  Exists m_equal.
  entailer!. f_equal. f_equal. apply H0.
Qed.

Lemma sub_insert:
  funspec_sub (snd inthash_insert_spec) (snd inthash_insert_spec_loose).
Proof.
  apply NDsubsume_subsume.
  split; extensionality x; reflexivity.
  split3; auto.
  intros [[[[gv m] k] pm] v].
  unfold inthash_rep_loose. Intros m_equal.
  Exists (gv, m_equal, k, pm, v) emp.
  rewrite !insert_SEP.
  apply andp_right.
  entailer!.
  apply prop_right.
  Exists (int_table.add k v m_equal).
  entailer!. split. f_equal. f_equal. apply H0.
  intros k'.
  case_eq (int_table.find (elt := V) k' (int_table.add k v m)).
  + intros v0 hv0%int_table.find_2.
    symmetry.
    apply int_table.find_1.
    destruct (eq_dec k k').
  - assert (v = v0).
    { eapply MapsTo_inj.
      apply int_table.add_1. eassumption. apply hv0. }
    subst. apply int_table.add_1. reflexivity.
  - apply int_table.add_3 in hv0.
    eapply int_table.add_2. eassumption.
    apply int_table.find_2. apply int_table.find_1 in hv0. rewrite <- H0. assumption.
    assumption.
  + intros hnone. symmetry.
    rewrite find_None in hnone |- *.
    intros v0 hcontr. apply (hnone v0).
    destruct (eq_dec k k').
  - assert (v = v0).
    { eapply MapsTo_inj.
      apply int_table.add_1. eassumption. apply hcontr. }
    subst. apply int_table.add_1. reflexivity.
  - apply int_table.add_3 in hcontr.
    eapply int_table.add_2. eassumption.
    apply int_table.find_2. apply int_table.find_1 in hcontr. rewrite <- hcontr. apply H0.
    assumption.
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 conj22synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) (Succ lv2)) (plus lv1 (plus (Succ lv2) lv0))).
Admitted.
QuickChick conj22synthconj1.


(* Formalize On-chip Network
 * CS 6115 Big Project
 * Yao Wang
 *)

Require String.
Open Scope string_scope.

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

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

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

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

Require Import Arith.

Require Import Init.Datatypes.

Require Import Coq.Lists.List.

Require Import Coq.Lists.Streams.

(* ~~~~~~~~~ DEFINITIONS ~~~~~~~~~ *)
Inductive noc : nat -> nat -> Type :=
  | bus         : noc 0 0
  | rin {n}     : noc 0 n
  | mesh {m n}  : noc m n
  | torus {m n} : noc m n.

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Notation "( x , y )" := (pair x y).

Fixpoint abs_minus (m n : nat): nat :=
  match m with
    | O => n
    | S m' => match n with
                | O => m
                | S n' => abs_minus m' n'
              end
  end.

Definition tor_minus (s d m : nat): nat :=
  min (abs_minus (min s d + m) (max s d)) (abs_minus s d).

Eval compute in tor_minus 1 4 5.

Definition distance (m n : nat) (R : noc m n) (s d : natprod): nat :=
  match R with
    | bus => 1
    | rin n => tor_minus (fst s) (fst d) n
    | mesh m n => abs_minus (fst s) (fst d) + abs_minus (snd s) (snd d)
    | torus m n => tor_minus (fst s) (fst d) m + tor_minus (snd s) (snd d) n
  end.

(** tests for distance **)
Eval compute in distance 0 4 (rin) (1,0) (4,0).
Eval compute in distance 5 5 (torus) (4,4) (1,1).

Inductive dataflow : Type :=
  _dataflow : natprod -> natprod -> nat -> dataflow.

Inductive link : Type :=
  _link : natprod -> natprod -> nat -> link.

Fixpoint snoc (l: list natprod) (v:natprod) : list natprod :=
  match l with
  | nil => v::nil
  | h :: t => h :: (snoc t v)
  end.

(** partial routes functions for one dimension route **)
Fixpoint partial_routes_fst_r (sx : nat) (sy : nat) (d : nat) : list natprod :=
  match d with
    | O => cons (sx, sy) nil
    | S d' => if beq_nat sx d then cons (sx, sy) nil
              else snoc (partial_routes_fst_r sx sy d') (d, sy)
  end.

Fixpoint partial_routes_fst_l (sx : nat) (sy : nat) (d : nat) : list natprod :=
  match sx with
    | O => cons (sx, sy) nil
    | S sx' => if beq_nat sx d then cons (sx, sy) nil
               else cons (sx, sy) (partial_routes_fst_l sx' sy d)
  end.

Fixpoint partial_routes_snd_r (sx : nat) (sy : nat) (d : nat) : list natprod :=
  match d with
    | O => cons (sx, sy) nil
    | S d' => if beq_nat sy d then cons (sx, sy) nil
              else snoc (partial_routes_snd_r sx sy d') (sx, d)
  end.

Fixpoint partial_routes_snd_l (sx : nat) (sy : nat) (d : nat) : list natprod :=
  match sy with
    | O => cons (sx, sy) nil
    | S sy' => if beq_nat sy d then cons (sx, sy) nil
               else cons (sx, sy) (partial_routes_snd_l sx sy' d)
  end.

Definition partial_routes_fst (time : nat) (s : natprod) (d : nat) : list natprod :=
  if (leb (fst s) d) then partial_routes_fst_r (fst s) (snd s) d
  else partial_routes_fst_l (fst s) (snd s) d.

Definition partial_routes_snd (time : nat) (s : natprod) (d : nat) : list natprod :=
  if (leb (snd s) d) then partial_routes_snd_r (fst s) (snd s) d
  else partial_routes_snd_l (fst s) (snd s) d.

(** tests for partial routes **)
Eval compute in partial_routes_fst 10 (4,0) 1.
Eval compute in partial_routes_snd 10 (1,5) 10.

(** minimum routing **)
Definition min_routes (m n : nat) (R : noc m n) (s d : natprod) : list natprod :=
  match R with
    | bus => cons s (cons d nil)
    | rin n =>
      if beq_nat (tor_minus (fst s) (fst d) n) (abs_minus (fst s) (fst d)) then
          partial_routes_fst n s (fst d)
      else
        if leb (fst s) (fst d) then
          (partial_routes_fst n s 1) ++ (partial_routes_fst n (pair n 0) (fst d))
        else
          (partial_routes_fst n s n) ++ (partial_routes_fst n (pair 1 0) (fst d))
    | mesh m n =>
      (partial_routes_fst m s (fst d)) ++ (tail (partial_routes_snd n (pair (fst d) (snd s)) (snd d)))
    | torus m n =>
      if beq_nat (tor_minus (fst s) (fst d) m) (abs_minus (fst s) (fst d)) then
        if beq_nat (tor_minus (snd s) (snd d) n) (abs_minus (snd s) (snd d)) then
          (partial_routes_fst m s (fst d)) ++ (tail (partial_routes_snd n (pair (fst d) (snd s)) (snd d)))
        else
          if (leb (snd s) (snd d)) then
            (partial_routes_fst m s (fst d)) ++
              (tail ((partial_routes_snd n (pair (fst d) (snd s)) 1) ++
                      (partial_routes_snd n (pair (fst d) n) (snd d))))
          else
            (partial_routes_fst m s (fst d)) ++
              (tail ((partial_routes_snd n (pair (fst d) (snd s)) n) ++
                      (partial_routes_snd n (pair (fst d) 1) (snd d))))
      else
        if beq_nat (tor_minus (snd s) (snd d) n) (abs_minus (snd s) (snd d)) then
          if (leb (fst s) (fst d)) then
            ((partial_routes_fst m s 1) ++ (partial_routes_fst m (pair n (snd s)) (fst d))) ++
              (tail (partial_routes_snd n (pair (fst d) (snd s)) (snd d)))
          else
            ((partial_routes_fst m s n) ++ (partial_routes_fst m (pair 1 (snd s)) (fst d))) ++
              (tail (partial_routes_snd n (pair (fst d) (snd s)) (snd d)))
        else
          if (leb (fst s) (fst d)) then
            if (leb (snd s) (snd d)) then
              ((partial_routes_fst m s 1) ++ (partial_routes_fst m (pair n (snd s)) (fst d))) ++
                (tail ((partial_routes_snd n (pair (fst d) (snd s)) 1) ++
                      (partial_routes_snd n (pair (fst d) n) (snd d))))
            else
              ((partial_routes_fst m s 1) ++ (partial_routes_fst m (pair n (snd s)) (fst d))) ++
                (tail ((partial_routes_snd n (pair (fst d) (snd s)) n) ++
                      (partial_routes_snd n (pair (fst d) 1) (snd d))))
          else
             if (leb (snd s) (snd d)) then
              ((partial_routes_fst m s n) ++ (partial_routes_fst m (pair 1 (snd s)) (fst d))) ++
                (tail ((partial_routes_snd n (pair (fst d) (snd s)) 1) ++
                      (partial_routes_snd n (pair (fst d) n) (snd d))))
            else
              ((partial_routes_fst m s n) ++ (partial_routes_fst m (pair 1 (snd s)) (fst d))) ++
                (tail ((partial_routes_snd n (pair (fst d) (snd s)) n) ++
                      (partial_routes_snd n (pair (fst d) 1) (snd d))))
  end.

(** tests for minimal routes **)
Eval compute in min_routes 0 0 bus (0,0) (1,1).

Eval compute in min_routes 0 5 rin (1,0) (5,0).
Eval compute in min_routes 0 5 rin (1,0) (2,0).
Eval compute in min_routes 0 5 rin (5,0) (1,0).
Eval compute in min_routes 0 5 rin (2,0) (1,0).

Eval compute in min_routes 5 5 mesh (1,4) (5,1).
Eval compute in min_routes 5 5 mesh (1,4) (5,4).

Eval compute in min_routes 5 5 torus (2,4) (5,1).
Eval compute in min_routes 5 5 torus (2,4) (1,2).
Eval compute in min_routes 5 5 torus (2,4) (1,5).
Eval compute in min_routes 5 5 torus (2,4) (5,5).

(** non-minimum routing **)
Definition nonmin_routes (m n : nat) (R : noc m n) (s d : natprod) : list natprod :=
  match R with
    | bus => cons s (cons d nil)
    | rin n =>
      if leb (fst s) (fst d) then
        (partial_routes_fst n s (fst d))
      else
        (partial_routes_fst n s n) ++ (partial_routes_fst n (pair 1 0) (fst d))
    | mesh m n =>
      (partial_routes_fst m s m) ++ (tail (partial_routes_snd n (pair m (snd s)) (snd d))) ++
        (tail (partial_routes_fst m (pair m (snd d)) (fst d)))
    | torus m n =>
        (partial_routes_fst m s (fst d)) ++ (tail (partial_routes_snd n (pair (fst d) (snd s)) (snd d)))
  end.

Definition nonmin_distance (m n : nat) (R : noc m n) (s d : natprod) : nat :=
  match R with
    | bus => 1
    | rin n => abs_minus (fst s) (fst d)
    | mesh m n => abs_minus (fst s) m + abs_minus (snd s) (snd d) + abs_minus (fst d) m
    | torus m n => abs_minus (fst s) (fst d) + abs_minus (snd s) (snd d)
  end.

(** tests for non minimal routes **)
Eval compute in nonmin_routes 0 0 bus (0,0) (1,1).

Eval compute in nonmin_routes 0 5 rin (1,0) (5,0).
Eval compute in nonmin_routes 0 5 rin (1,0) (2,0).
Eval compute in nonmin_routes 0 5 rin (5,0) (1,0).
Eval compute in nonmin_routes 0 5 rin (2,0) (1,0).

Eval compute in nonmin_routes 5 5 mesh (1,4) (4,1).
Eval compute in nonmin_routes 5 5 mesh (1,4) (2,2).

Eval compute in nonmin_routes 5 5 torus (2,4) (5,1).
Eval compute in nonmin_routes 5 5 torus (2,4) (1,2).
Eval compute in nonmin_routes 5 5 torus (2,4) (1,5).
Eval compute in nonmin_routes 5 5 torus (2,4) (5,5).

(** power functions **)
Definition min_power (m n : nat) (R : noc m n) (df : dataflow) : nat :=
  match df with
    | _dataflow s d r => (length (min_routes m n R s d) - 1) * r
  end.

Eval compute in min_power 0 0 bus (_dataflow (1,1) (4,4) 15).
Eval compute in min_power 0 5 rin (_dataflow (1,0) (5,0) 30).
Eval compute in min_power 5 5 mesh (_dataflow (1,1) (4,4) 20).
Eval compute in min_power 5 5 torus (_dataflow (1,1) (4,4) 25).

Definition nonmin_power (m n : nat) (R : noc m n) (df : dataflow) : nat :=
  match df with
    | _dataflow s d r => (length (nonmin_routes m n R s d) - 1) * r
  end.

(** non-deterministic routing **)
CoFixpoint repeat (a:bool) : Stream bool :=
Cons a (repeat (negb a)).

Definition ref_stream := repeat true.

Definition nondet_routes (m n : nat) (t : nat) (R : noc m n) (s d : natprod) : list natprod :=
  match R with
    | bus => cons s (cons d nil)
    | rin n =>
      if Str_nth t ref_stream then
        if leb (fst s) (fst d) then
          (partial_routes_fst n s (fst d))
        else
          (partial_routes_fst n s n) ++ (partial_routes_fst n (pair 1 0) (fst d))
      else
        if leb (fst s) (fst d) then
          (partial_routes_fst n s 1) ++ (partial_routes_fst n (pair n 0) (fst d))
        else
          (partial_routes_fst n s (fst d))
    | mesh m n =>
      if Str_nth t ref_stream then
        (partial_routes_fst m s (fst d)) ++ (tail (partial_routes_snd n (pair (fst d) (snd s)) (snd d)))
      else
        (partial_routes_snd n s (snd d)) ++ (tail (partial_routes_fst n (pair (fst s) (snd d)) (fst d)))
    | torus m n =>
      if Str_nth t ref_stream then
        min_routes m n torus s d
      else
        if beq_nat (tor_minus (fst s) (fst d) m) (abs_minus (fst s) (fst d)) then
          if beq_nat (tor_minus (snd s) (snd d) n) (abs_minus (snd s) (snd d)) then
            (partial_routes_snd m s (snd d)) ++ (tail (partial_routes_fst n (pair (fst s) (snd d)) (fst d)))
          else
            if (leb (snd s) (snd d)) then
              (partial_routes_snd n s 1) ++ (partial_routes_snd n (pair (fst s) 1) (snd d)) ++
                (tail (partial_routes_fst m (pair (fst s) (snd d)) (fst d)))
            else
              (partial_routes_snd n s n) ++ (partial_routes_snd n (pair (fst s) n) (snd d)) ++
                (tail (partial_routes_fst m (pair (fst s) (snd d)) (fst d)))
        else
          if beq_nat (tor_minus (snd s) (snd d) n) (abs_minus (snd s) (snd d)) then
            if (leb (fst s) (fst d)) then
              (partial_routes_snd n s (snd d)) ++
                (tail ((partial_routes_fst m (pair (fst s) (snd d)) 1) ++
                      (partial_routes_fst m (pair n (snd d)) (fst d))))
            else
              (partial_routes_snd n s (snd d)) ++
                (tail ((partial_routes_fst m (pair (fst s) (snd d)) m) ++
                      (partial_routes_fst m (pair 1 (snd d)) (fst d))))
          else
            if (leb (fst s) (fst d)) then
              if (leb (snd s) (snd d)) then
                ((partial_routes_snd n s 1) ++ (partial_routes_snd m (pair (fst s) 1) (snd d))) ++
                  (tail ((partial_routes_fst m (pair (fst s) (snd d)) 1) ++
                        (partial_routes_fst m (pair 1 (snd d)) (fst d))))
              else
                ((partial_routes_snd n s n) ++ (partial_routes_snd m (pair (fst s) n) (snd d))) ++
                  (tail ((partial_routes_fst m (pair (fst s) (snd d)) 1) ++
                        (partial_routes_fst m (pair 1 (snd d)) (fst d))))
            else
              if (leb (snd s) (snd d)) then
                ((partial_routes_snd n s 1) ++ (partial_routes_snd m (pair (fst s) 1) (snd d))) ++
                  (tail ((partial_routes_fst m (pair (fst s) (snd d)) m) ++
                        (partial_routes_fst m (pair m (snd d)) (fst d))))
              else
                ((partial_routes_snd n s n) ++ (partial_routes_snd m (pair (fst s) n) (snd d))) ++
                  (tail ((partial_routes_fst m (pair (fst s) (snd d)) m) ++
                        (partial_routes_fst m (pair m (snd d)) (fst d))))
end.

(** Tests for nondeterministic routing **)
Eval compute in (nondet_routes 0 5 1 rin (1,0) (5,0)).
Eval compute in (nondet_routes 0 5 2 rin (1,0) (5,0)).
Eval compute in (nondet_routes 5 5 1 mesh (1,2) (4,3)).
Eval compute in (nondet_routes 5 5 2 mesh (1,2) (4,3)).
Eval compute in (nondet_routes 5 5 1 torus (1,2) (4,4)).
Eval compute in (nondet_routes 5 5 2 torus (1,2) (4,4)).

(** mapping function **)
Fixpoint mapping (m n : nat) (R : noc m n) (dfs : list dataflow) (l : nat) : list (list natprod) :=
  match l with
    | O => nil
    | S l' => match (List.hd (_dataflow (0,0) (1,1) 10) dfs) with
                | _dataflow s d r => let rt := min_routes m n R s d in cons rt (mapping m n R (List.tl dfs) l')
              end
  end.

(** tests for mapping **)
Definition dataflows := cons (_dataflow (1,1) (3,3) 10) (cons (_dataflow (2,2) (4,4) 20) nil).

Eval compute in (mapping 5 5 mesh dataflows 2).

(** Lemmas **)
Theorem abs_minus_theorem : forall (m n : nat),
  abs_minus m n = abs_minus n m.
Proof.
  intros m.
  induction m as [| m'].
  Case "m = O". intros n. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". simpl. reflexivity.
  Case "m = S m'". intros n. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". simpl. apply IHm'.
Qed.

Theorem tor_minus_theorem : forall (s d n : nat),
  tor_minus s d n = tor_minus d s n.
Proof.
  intros s d n.
  unfold tor_minus.
  destruct (le_lt_dec s d).
    SCase "s <= d".
      rewrite (min_l s d).
      rewrite (max_r s d).
      rewrite (min_r d s).
      rewrite (max_l d s).
      rewrite (abs_minus_theorem s d). reflexivity.
      apply l. apply l. apply l. apply l.
    SCase "s > d".
      rewrite (min_r s d).
      rewrite (max_l s d).
      rewrite (min_l d s).
      rewrite (max_r d s).
      rewrite (abs_minus_theorem s d). reflexivity.
      apply lt_le_weak in l. apply l.  apply lt_le_weak in l. apply l.
      apply lt_le_weak in l. apply l.  apply lt_le_weak in l. apply l.
Qed.

Theorem abs_minus_n_n : forall (m n : nat),
  m = n -> abs_minus m n = 0.
Proof.
  intros m.
  unfold abs_minus.
  induction m as [|m'].
  Case "m = O". intros n H. symmetry. apply H.
  Case "m = S m'".
    intros n H. destruct n as [|n'].
    SCase "n = O". apply H.
    SCase "n = S n'".
      apply IHm'. inversion H. reflexivity.
Qed.

Theorem abs_minus_inc : forall (m n : nat),
  m <= n -> abs_minus m (S n) = abs_minus m n + 1.
Proof.
  intros m.
  unfold abs_minus.
  induction m as [|m'].
  Case "m = O". intros n H. rewrite plus_comm. simpl. reflexivity.
  Case "m = S m'".
    intros n H. destruct n as [|n'].
    SCase "n = O". inversion H.
    SCase "n = S n'".
      apply IHm'. apply le_S_n in H. apply H.
Qed.

Theorem plus_n_n : forall (m n : nat),
  m = 0 -> m + n = n.
Proof.
  intros m n H.
  destruct m as [|m'].
  Case "m = O". simpl. reflexivity.
  Case "m = Sm'". inversion H.
Qed.

Theorem plus_same : forall (m n p : nat),
  m = n -> m + p = n + p.
Proof.
  intros m n p.
  generalize dependent n.
  induction m as [|m'].
  Case "m = O". intros n H. rewrite H. reflexivity.
  Case "m = S m'".
    intros n H.
    destruct n as [|n'].
    SCase "n = O". inversion H.
    SCase "n = S n'". rewrite H. reflexivity.
Qed.

Theorem snoc_length : forall (l : list natprod) (a : natprod),
  length (snoc l a) = length l + 1.
Proof.
  intros l a.
  induction l.
  SCase "l = nil". simpl. reflexivity.
  SCase "l = h::t". simpl. rewrite IHl. reflexivity.
Qed.

Theorem cons_length : forall (l : list natprod) (a : natprod),
  length (cons a l) = length l + 1.
Proof.
  intros l a.
  destruct l as [|a0 l'].
  SCase "l = nil". simpl. reflexivity.
  SCase "l = h::t". simpl. apply f_equal. rewrite plus_comm. simpl. reflexivity.
Qed.

Theorem lt_from_le : forall (m n : nat),
  m <= n -> m <> n -> m < n.
Proof.
  intros m n H0 H1.
  apply le_lt_eq_dec in H0.
  destruct H0. apply l.
  congruence.
Qed.

Theorem partial_routing_fst_r : forall (sx sy d : nat),
  sx <= d -> length (partial_routes_fst_r sx sy d) = (abs_minus sx d) + 1.
Proof.
  intros sx sy d H.
  induction d as [|d'].
  Case "d = O".
    apply le_n_0_eq in H. rewrite <- H. simpl. reflexivity.
  Case "d = S d'".
    unfold partial_routes_fst_r.
    destruct (beq_nat sx (S d')) eqn:H0.
    SCase "sx = S d'".
      simpl. symmetry. apply plus_n_n. apply abs_minus_n_n. apply beq_nat_true in H0. apply H0.
    SCase "sx <> S d'".
      apply beq_nat_false in H0.
      rewrite snoc_length. apply plus_same. rewrite abs_minus_inc. apply IHd'.
      apply lt_from_le in H. apply lt_n_Sm_le in H. apply H.
      apply H0. apply lt_from_le in H. apply lt_n_Sm_le in H. apply H. apply H0.
Qed.

Theorem partial_routing_fst_l : forall (sx sy d : nat),
  d <= sx -> length (partial_routes_fst_l sx sy d) = (abs_minus sx d) + 1.
Proof.
  intros sx sy d H.
  induction sx as [|sx'].
  Case "sx = O".
    apply le_n_0_eq in H. rewrite <- H. simpl. reflexivity.
  Case "sx = S sx'".
    unfold partial_routes_fst_l.
    destruct (beq_nat (S sx') d) eqn:H0.
    SCase "S sx' = d".
      rewrite abs_minus_theorem. simpl. symmetry. apply plus_n_n. apply abs_minus_n_n.
      apply beq_nat_true in H0. symmetry. apply H0.
    SCase "sx <> S d'".
      apply beq_nat_false in H0.
      rewrite cons_length. apply plus_same. rewrite abs_minus_theorem. rewrite abs_minus_inc.
      rewrite abs_minus_theorem. apply IHsx'.
      apply lt_from_le in H. apply lt_n_Sm_le in H. apply H. apply not_eq_sym. apply H0.
      apply lt_from_le in H. apply lt_n_Sm_le in H. apply H. apply not_eq_sym. apply H0.
Qed.

Theorem partial_routing_snd_r : forall (sx sy d : nat),
  sy <= d -> length (partial_routes_snd_r sx sy d) = (abs_minus sy d) + 1.
Proof.
  intros sx sy d H.
  induction d as [|d'].
  Case "d = O".
    apply le_n_0_eq in H. rewrite <- H. simpl. reflexivity.
  Case "d = S d'".
    unfold partial_routes_snd_r.
    destruct (beq_nat sy (S d')) eqn:H0.
    SCase "sx = S d'".
      simpl. symmetry. apply plus_n_n. apply abs_minus_n_n. apply beq_nat_true in H0. apply H0.
    SCase "sx <> S d'".
      apply beq_nat_false in H0.
      rewrite snoc_length. apply plus_same. rewrite abs_minus_inc. apply IHd'.
      apply lt_from_le in H. apply lt_n_Sm_le in H. apply H.
      apply H0. apply lt_from_le in H. apply lt_n_Sm_le in H. apply H. apply H0.
Qed.

Theorem partial_routing_snd_l : forall (sx sy d : nat),
  d <= sy -> length (partial_routes_snd_l sx sy d) = (abs_minus sy d) + 1.
Proof.
  intros sx sy d H.
  induction sy as [|sy'].
  Case "sy = O".
    apply le_n_0_eq in H. rewrite <- H. simpl. reflexivity.
  Case "sy = S sy'".
    unfold partial_routes_snd_l.
    destruct (beq_nat (S sy') d) eqn:H0.
    SCase "S sy' = d".
      rewrite abs_minus_theorem. simpl. symmetry. apply plus_n_n. apply abs_minus_n_n.
      apply beq_nat_true in H0. symmetry. apply H0.
    SCase "sy <> S d'".
      apply beq_nat_false in H0.
      rewrite cons_length. apply plus_same. rewrite abs_minus_theorem. rewrite abs_minus_inc.
      rewrite abs_minus_theorem. apply IHsy'.
      apply lt_from_le in H. apply lt_n_Sm_le in H. apply H. apply not_eq_sym. apply H0.
      apply lt_from_le in H. apply lt_n_Sm_le in H. apply H. apply not_eq_sym. apply H0.
Qed.

Theorem length_tl : forall (l : list natprod),
  0 < length l -> length (tail l) = length l - 1.
Proof.
  intros l.
  destruct l.
  Case "nil".
    intro H.
    inversion H.
  Case "a::l".
    intro H.
    simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Theorem plus_permute_3 : forall (n m p : nat),
  n + m + p = n + p + m.
Proof.
  intros n m p.
  rewrite <- plus_assoc. rewrite <- plus_assoc.
  rewrite (plus_comm m p). reflexivity.
Qed.

Lemma plus_n_1 : forall n : nat, S n = n + 1.
Proof.
 intro n; rewrite <- (plus_n_Sm n 0); auto with arith.
Qed.

Theorem plus_minus_3 : forall (n : nat),
  n + 1 - 1 = n.
Proof.
  intros n.
  induction n as [|n'].
  Case "n = O". simpl. symmetry. reflexivity.
  Case "n = S n'".
    simpl. rewrite <- plus_n_1. simpl. reflexivity.
Qed.

Theorem abs_minus_trans : forall (m n : nat),
  m <= n -> abs_minus m n = n - m.
Proof.
  intros m.
  unfold abs_minus.
  induction m as [|m'].
  Case "m = O". intros n H. apply minus_n_O.
  Case "m = S m'".
    intros n H.
    destruct n as [|n'].
    SCase "n = O". inversion H.
    SCase "n = S n'". simpl. rewrite IHm'. reflexivity. apply le_S_n. apply H.
Qed.

Theorem nonmin_routing : forall (m n : nat) (s d : natprod) (R : noc m n),
  (fst s) <= m -> (fst d) <= m -> length(nonmin_routes m n R s d) = nonmin_distance m n R s d + 1.
Proof.
  intros m n s d R.
  intros H0 H1.
  destruct R.
  Case "R = bus".
    reflexivity.
  Case "R = rin".
    admit.
  Case "R = mesh".
    simpl. rewrite app_length. rewrite app_length. rewrite length_tl. rewrite length_tl.
    unfold partial_routes_fst. unfold partial_routes_snd. simpl.
    apply leb_correct in H0. simpl. rewrite H0. apply le_lt_eq_dec in H1.
    destruct (leb (snd s) (snd d)) eqn:H2.
    SCase "leb (snd s) (snd d))".
      destruct H1.
      SSCase "fst d < m".
        apply leb_correct_conv in l. rewrite l.
        rewrite partial_routing_fst_r. rewrite partial_routing_snd_r. rewrite partial_routing_fst_l.
        rewrite plus_minus_3. rewrite plus_minus_3. rewrite plus_permute_3. rewrite plus_assoc.
        rewrite (abs_minus_theorem m (fst d)). reflexivity. apply leb_complete_conv in l.
        apply lt_le_weak. apply l. apply leb_complete in H2. apply H2. apply leb_complete in H0. apply H0.
      SSCase "fst d = m".
        simpl. rewrite (leb_correct m (fst d)).
        rewrite partial_routing_fst_r. rewrite partial_routing_snd_r. rewrite partial_routing_fst_r.
        rewrite plus_minus_3. rewrite plus_minus_3. rewrite plus_permute_3. rewrite plus_assoc.
        rewrite (abs_minus_theorem m (fst d)). reflexivity. rewrite e. reflexivity.
        apply leb_complete in H2. apply H2. apply leb_complete in H0. apply H0.
        rewrite e. reflexivity.
    SCase "leb (snd s) (snd d))".
      destruct H1.
      SSCase "fst d < m".
        apply leb_correct_conv in l. rewrite l.
        rewrite partial_routing_fst_r. rewrite partial_routing_snd_l. rewrite partial_routing_fst_l.
        rewrite plus_minus_3. rewrite plus_minus_3. rewrite plus_permute_3. rewrite plus_assoc.
        rewrite (abs_minus_theorem m (fst d)). reflexivity. apply leb_complete_conv in l.
        apply lt_le_weak. apply l. apply leb_complete_conv in H2. apply lt_le_weak. apply H2.
        apply leb_complete in H0. apply H0.
      SSCase "fst d = m".
        simpl. rewrite (leb_correct m (fst d)).
        rewrite partial_routing_fst_r. rewrite partial_routing_snd_l. rewrite partial_routing_fst_r.
        rewrite plus_minus_3. rewrite plus_minus_3. rewrite plus_permute_3. rewrite plus_assoc.
        rewrite (abs_minus_theorem m (fst d)). reflexivity. rewrite e. reflexivity.
        apply leb_complete_conv in H2. apply lt_le_weak. apply H2.
        apply leb_complete in H0. apply H0. rewrite e. reflexivity.
    unfold partial_routes_fst. simpl.
    destruct (leb m (fst d)) eqn:H2.
    SCase "leb m (fst d)) = true".
      rewrite partial_routing_fst_r. rewrite plus_comm. apply lt_plus_trans. rewrite nat_compare_lt.
      simpl. reflexivity. apply leb_complete in H2. apply H2.
    SCase "leb m (fst d)) = false".
      rewrite partial_routing_fst_l. rewrite plus_comm. apply lt_plus_trans. rewrite nat_compare_lt.
      simpl. reflexivity. apply H1.
    unfold partial_routes_snd. simpl.
    destruct (leb (snd s) (snd d)) eqn:H2.
    SCase "leb (snd s) (snd d) = true".
      rewrite partial_routing_snd_r. rewrite plus_comm. apply lt_plus_trans. rewrite nat_compare_lt.
      simpl. reflexivity. apply leb_complete in H2. apply H2.
    SCase "leb (snd s) (snd d) = false".
      rewrite partial_routing_snd_l. rewrite plus_comm. apply lt_plus_trans. rewrite nat_compare_lt.
      simpl. reflexivity. apply leb_complete_conv in H2. apply lt_le_weak. apply H2.
  Case "R = torus".
    admit.
Qed.

(** Properties **)

(** Distance Commutativity **)
Theorem distance_comm : forall (m n : nat) (s d : natprod) (R : noc m n),
  distance m n R s d = distance m n R d s.
Proof.
  intros m n s d R.
  destruct R.
  Case "R = bus".
    reflexivity.
  Case "R = rin".
    simpl. apply tor_minus_theorem.
  Case "R = mesh".
    simpl. rewrite (abs_minus_theorem (fst s) (fst d)).
    rewrite (abs_minus_theorem (snd s) (snd d)). reflexivity.
  Case "R = torus".
    simpl. rewrite (tor_minus_theorem (fst s) (fst d) m).
    rewrite (tor_minus_theorem (snd s) (snd d) n). reflexivity.
Qed.

(** Minimum Routing **)
Theorem min_routing : forall (m n : nat) (s d : natprod) (R : noc m n),
  length(min_routes m n R d s)  = distance m n R d s + 1.
Proof.
  intros m n s d R.
  destruct R.
  Case "R = bus". simpl. reflexivity.
  Case "R = rin".
    admit.
  Case "R = mesh".
    simpl. rewrite app_length. unfold partial_routes_fst. unfold partial_routes_snd.
    simpl.
    destruct (leb (fst d) (fst s)) eqn:H0.
      destruct (leb (snd d) (snd s)) eqn:H1.
      SCase "1".
        rewrite length_tl. rewrite partial_routing_fst_r. rewrite partial_routing_snd_r.
        rewrite plus_permute_3. rewrite plus_minus_3. reflexivity.
        apply leb_complete in H1. apply H1. apply leb_complete in H0. apply H0.
        rewrite partial_routing_snd_r. rewrite plus_comm. apply lt_plus_trans.
        rewrite nat_compare_lt. simpl. reflexivity. apply leb_complete in H1. apply H1.
      SCase "2".
        rewrite length_tl. rewrite partial_routing_fst_r. rewrite partial_routing_snd_l.
        rewrite plus_permute_3. rewrite plus_minus_3. reflexivity.
        apply leb_complete_conv in H1. apply lt_le_weak. apply H1. apply leb_complete in H0. apply H0.
        rewrite partial_routing_snd_l. rewrite plus_comm. apply lt_plus_trans.
        rewrite nat_compare_lt. simpl. reflexivity.
        apply leb_complete_conv in H1. apply lt_le_weak. apply H1.
      destruct (leb (snd d) (snd s)) eqn:H1.
      SCase "3".
        rewrite length_tl. rewrite partial_routing_fst_l. rewrite partial_routing_snd_r.
        rewrite plus_permute_3. rewrite plus_minus_3. reflexivity.
        apply leb_complete in H1. apply H1. apply leb_complete_conv in H0. apply lt_le_weak. apply H0.
        rewrite partial_routing_snd_r. rewrite plus_comm. apply lt_plus_trans.
        rewrite nat_compare_lt. simpl. reflexivity. apply leb_complete in H1. apply H1.
      SCase "4".
        rewrite length_tl. rewrite partial_routing_fst_l. rewrite partial_routing_snd_l.
        rewrite plus_permute_3. rewrite plus_minus_3. reflexivity.
        apply leb_complete_conv in H1. apply lt_le_weak. apply H1.
        apply leb_complete_conv in H0. apply lt_le_weak. apply H0.
        rewrite partial_routing_snd_l. rewrite plus_comm. apply lt_plus_trans.
        rewrite nat_compare_lt. simpl. reflexivity.
        apply leb_complete_conv in H1. apply lt_le_weak. apply H1.
  Case "R = torus".
    admit.
Qed.

(** Minimal Power **)
Theorem power_comp : forall (m n : nat) (R : noc m n) (s d : natprod) (r : nat),
  (fst s) <= m -> (fst d) <=  m -> min_power m n R (_dataflow s d r) <= nonmin_power m n R (_dataflow s d r).
Proof.
  intros m n R s d r.
  intros H0 H1.
  destruct R.
  Case "R = bus".
    simpl. reflexivity.
  Case "R = rin".
    admit.
  Case "R = mesh".
    unfold min_power. rewrite min_routing.
    unfold nonmin_power. rewrite nonmin_routing.
    apply mult_le_compat_r.
    rewrite plus_minus_3. rewrite plus_minus_3.
    simpl. rewrite plus_permute_3.
    apply plus_le_compat_r.
    destruct (le_lt_dec (fst s) (fst d)).
      SCase "fst s <= fst d".
        repeat (rewrite abs_minus_trans).
        assert (H: fst d - fst s <= m - fst s).
          SSCase "Proof of assertion". apply minus_le_compat_r.
        assumption. apply le_plus_trans. apply H. apply H1. apply H0. apply l.
      SCase "fst d < fst s".
        rewrite abs_minus_theorem.
        repeat (rewrite abs_minus_trans). rewrite plus_comm.
        assert (H: fst s - fst d <= m - fst d).
          SSCase "Proof of assertion". apply minus_le_compat_r.
        assumption. apply le_plus_trans. apply H. apply H1. apply H0. apply lt_le_weak. apply l.
        apply H0. apply H1.
  Case "R = torus".
    admit.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Associativity_A.

Coq < Goal forall p q r:Prop, (p \/ (q \/ r)) <-> ((p \/ q) \/ r).
1 subgoal

  ============================
   forall p q r : Prop, p \/ q \/ r <-> (p \/ q) \/ r

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  ============================
   p \/ q \/ r <-> (p \/ q) \/ r

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Section Associativity_A.
Goal forall p q r:Prop, (p \/ (q \/ r)) <-> ((p \/ q) \/ r).
intros.
tauto.
Qed.


(** * Kan Extensions *)
Require Import Category.Core Functor.Core.
Require Import FunctorCategory.Core.
Require Import Functor.Composition.Functorial.Core.
Require Import UniversalProperties.

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

Local Open Scope category_scope.

(** Quoting nCatLab on Kan Exensions:

    ** Idea

    The Kan extension of a functor [F : C → D] with respect to a
    functor

<<
    C
    |
    | p
    ↓
    C'
>>

    is, if it exists, a kind of best approximation to the problem of
    finding a functor [C' → D] such that

<<
        F
    C -----> D
    |       ↗
    | p   /
    |   /
    ↓ /
    C'
>>

    hence to extending the domain of [F] through [p] from [C] to [C'].

    More generally, this makes sense not only in Cat but in any
    2-category.

    Similarly, a Kan lift is the best approximation to lifting a
    morphism [F : C → D] through a morphism

<<
    D'
    |
    ↓
    D
>>

    to a morphism [F̂]

<<
                D'
              ↗ |
            /   |
        F̂ /     |
        /       |
      /   F     ↓
    C --------> D
>>

    Kan extensions are ubiquitous. See the discussion at Examples
    below.

    ** Definitions

    There are various slight variants of the definition of Kan
    extension. In good cases they all exist and all coincide, but in
    some cases only some of these will actually exist.

    We (have to) distinguish the following cases:

    - “ordinary” or “weak” Kan extensions

      These define the extension of an entire functor, by an
      adjointness relation.

      Here we (have to) distinguish further between

      - global Kan extensions,

        which define extensions of all possible functors of given
        domain and codomain (if all of them indeed exist);

      - local Kan extensions,

        which define extensions of single functors only, which may
        exist even if not every functor has an extension.

    - “pointwise” or “strong” Kan extensions

      These define the value of an extended functor on each object
      (each “point”) by a weighted (co)limit.

      Furthermore, a pointwise Kan extension can be “absolute”.

    If the pointwise version exists, then it coincides with the
    “ordinary” or “weak” version, but the former may exist without the
    pointwise version existing. See below for more.

    Some authors (such as Kelly) assert that only pointwise Kan
    extensions deserve the name “Kan extension,” and use the term as
    “weak Kan extension” for a functor equipped with a universal
    natural transformation. It is certainly true that most Kan
    extensions which arise in practice are pointwise. This distinction
    is even more important in enriched category theory. *)

Section kan_extensions.
  (** ** Ordinary or weak Kan extensions

      *** Global Kan extensions

      Let [p : C → C'] be a functor. For [D] any other category, write
      [p* : (C' → D) → (C → D)] for the induced functor on the functor
      categories: this sends a functor [h : C' → D] to the composite functor

<<
                p      h
      p* h : C --> C' --> D
>>
   *)

  (** *** Pullback-along functor *)
  Context `{Funext}.
  Variables C C' D : PreCategory.

  Section pullback_along.
    Definition pullback_along_functor
    : object ((C -> C') -> (C' -> D) -> (C -> D))
      := Functor.Composition.Functorial.Core.compose_functor _ _ _.

    Definition pullback_along (p : Functor C C')
    : object ((C' -> D) -> (C -> D))
      := Eval hnf in pullback_along_functor p.
  End pullback_along.

  (** Definition. If [p*] has a left adjoint, typically denoted [p_! :
      (C → D) → (C' → D)] or [Lan_p : (C → D) → (C' → D)] then this
      left adjoint is called the (ordinary or weak) left Kan extension
      operation along [p]. For [h ∈ (C -> D)] we call [p_! h] the left
      Kan extension of [h] along [p].

      Similarly, if [p*] has a right adjoint, this right adjoint is
      called the right Kan extension operation along [p]. It is
      typically denoted [p_* : (C → D) → (C' → D)] or [Ran = Ran_p :
      (C → D) → (C' → D)].

      The analogous definition clearly makes sense as stated in other
      contexts, such as in enriched category theory.

      Observation. If [C' = 1] is the terminal category, then

      - the left Kan extension operation forms the colimit of a functor;

      - the right Kan extension operation forms the limit of a functor. *)

  (** *** Left Kan extensions *)
  (** Colimits are initial morphisms. *)
  Definition IsLeftKanExtensionAlong (p : Functor C C') (h : Functor C D)
    := @IsInitialMorphism (_ -> _) _ h (pullback_along p).

  (** *** Right Kan extensions *)
  (** Limits are terminal morphisms *)
  Definition IsRightKanExtensionAlong (p : Functor C C') (h : Functor C D)
    := @IsTerminalMorphism _ (_ -> _) (pullback_along p) h.
End kan_extensions.


(*
  Copyright (c) 2016-2020, Adam Chlipala
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are met:

  - Redistributions of source code must retain the above copyright notice,
    this list of conditions and the following disclaimer.
  - Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
  - The names of contributors may not be used to endorse or promote products
    derived from this software without specific prior written permission.

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  POSSIBILITY OF SUCH DAMAGE.
*)

Set Implicit Arguments.

Section trc.
  Variable A : Type.
  Variable R : A -> A -> Prop.

  Inductive trc : A -> A -> Prop :=
  | TrcRefl : forall x, trc x x
  | TrcFront : forall x y z,
    R x y
    -> trc y z
    -> trc x z.

  Hint Constructors trc : core.

  Theorem trc_one : forall x y, R x y
    -> trc x y.
  Proof.
    eauto.
  Qed.

  Hint Resolve trc_one : core.

  Theorem trc_trans : forall x y, trc x y
    -> forall z, trc y z
      -> trc x z.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trc_trans : core.

  Inductive trcEnd : A -> A -> Prop :=
  | TrcEndRefl : forall x, trcEnd x x
  | TrcBack : forall x y z,
    trcEnd x y
    -> R y z
    -> trcEnd x z.

  Hint Constructors trcEnd : core.

  Lemma TrcFront' : forall x y z,
    R x y
    -> trcEnd y z
    -> trcEnd x z.
  Proof.
    induction 2; eauto.
  Qed.

  Hint Resolve TrcFront' : core.

  Theorem trc_trcEnd : forall x y, trc x y
    -> trcEnd x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trc_trcEnd : core.

  Lemma TrcBack' : forall x y z,
    trc x y
    -> R y z
    -> trc x z.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve TrcBack' : core.

  Theorem trcEnd_trans : forall x y, trcEnd x y
    -> forall z, trcEnd y z
      -> trcEnd x z.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trcEnd_trans : core.

  Theorem trcEnd_trc : forall x y, trcEnd x y
    -> trc x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trcEnd_trc : core.

  Inductive trcLiteral : A -> A -> Prop :=
  | TrcLiteralRefl : forall x, trcLiteral x x
  | TrcTrans : forall x y z, trcLiteral x y
    -> trcLiteral y z
    -> trcLiteral x z
  | TrcInclude : forall x y, R x y
    -> trcLiteral x y.

  Hint Constructors trcLiteral : core.

  Theorem trc_trcLiteral : forall x y, trc x y
    -> trcLiteral x y.
  Proof.
    induction 1; eauto.
  Qed.

  Theorem trcLiteral_trc : forall x y, trcLiteral x y
    -> trc x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trc_trcLiteral trcLiteral_trc : core.

  Theorem trcEnd_trcLiteral : forall x y, trcEnd x y
    -> trcLiteral x y.
  Proof.
    induction 1; eauto.
  Qed.

  Theorem trcLiteral_trcEnd : forall x y, trcLiteral x y
    -> trcEnd x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trcEnd_trcLiteral trcLiteral_trcEnd : core.
End trc.

Notation "R ^*" := (trc R) (at level 0).
Notation "*^ R" := (trcEnd R) (at level 0).

#[global]
Hint Constructors trc : core.


(** * Gen_J: 帰納法の仮定の一般化 *)

(* $Date: 2011-06-07 16:49:17 -0400 (Tue, 07 Jun 2011) $ *)

Require Export Poly_J.

(** 前章では[double]関数が単射であることの証明をしました。この証明を始める方法は少々デリケートです。
[[
      intros n. induction n.
]]
で始めればうまくいきます。 しかし
[[
      intros n m. induction n.
]]
で始めてしまうと、帰納段階の途中でつまってしまいます...

*)

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = O". simpl. intros eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros eq. destruct m as [| m'].
    SCase "m = O". inversion eq.
    SCase "m = S m'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
      (* Here we are stuck.  We need the assertion in order to
         rewrite the final goal (subgoal 2 at this point) to an
         identity.  But the induction hypothesis, [IHn'], does
         not give us [n' = m'] -- there is an extra [S] in the
         way -- so the assertion is not provable. *)
      Admitted.

(** 何がいけなかったのでしょうか?

    帰納法の仮定を導入した時点で [m] をコンテキストに導入してしまっていることが問題です。直感的に言うと、これはCoqに「ある特定の [n] と [m] について考えよう」と教えるようなものです。そのため、この特定の [n] と [m] について [double n = double m] ならば [n = m] を証明しなければなりません。

    次のタクティックス [induction n] はCoqに「このゴールの [n] に関する帰納法で示します」と伝えます。 なので、命題

      - [P n]  =  "[double n = double m] ならば [n = m]"

    がすべての[n]について成り立つことを

      - [P O]

         (すなわち、"[double O = double m] ならば [O = m]")

      - [P n -> P (S n)]

        (すなわち、 "[double n = double m] ならば [n = m]" が成り立つならば "
        [double (S n) = double m] ならば [S n = m]").

    2つめの文を見ると、これは奇妙なことを言っています。 それによると特定の [m] について

      - "[double n = double m] ならば [n = m]"

    が成り立つならば

       - "[double (S n) = double m] ならば [S n = m]".

    が証明できることになります。

    これがどう奇妙かを説明するために、特定の [m] 、例えば [5] について考えてみましょう。 するとこの文は

      - [Q] = "[double n = 10] ならば [n = 5]"

    が成り立つならば

      - [R] = "[double (S n) = 10] ならば [S n = 5]".

    が証明できると言っています。

    しかし [Q] を知っていても、[R]を証明するのには何の役にたちません! (もし [Q] から [R] を示そうとすると「[double (S n) = 10]...を仮定すると...」のようなことを言わないといけませんが、これは途中でつまってしまいます。 [double (S n)] が [10] があることは、 [double n]が[10]であるかどうかについては何も教えてくれません。なので[Q] はここでは役にたちません。)

    まとめると、[m]がすでにコンテキストにある状態で[n]に関する帰納法による証明がうまくいかないのは、すべての[n]と単一の[m]の関係を示そうとしてしまうかからです。 *)

(** [double_injective] のいい証明では、[induction]を[n]に対して使う時点では[m]をゴールに残しています。 *)

Theorem double_injective' : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = O". simpl. intros m eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'".
    (* Notice that both the goal and the induction
       hypothesis have changed: the goal asks us to prove
       something more general (i.e., to prove the
       statement for *every* [m]), but the IH is
       correspondingly more flexible, allowing us to
       choose any [m] we like when we apply the IH.  *)
    intros m eq.
    (* Now we choose a particular [m] and introduce the
       assumption that [double n = double m].  Since we
       are doing a case analysis on [n], we need a case
       analysis on [m] to keep the two "in sync." *)
    destruct m as [| m'].
    SCase "m = O". inversion eq.  (* The 0 case is trivial *)
    SCase "m = S m'".
      (* At this point, since we are in the second
         branch of the [destruct m], the [m'] mentioned
         in the context at this point is actually the
         predecessor of the one we started out talking
         about.  Since we are also in the [S] branch of
         the induction, this is perfect: if we
         instantiate the generic [m] in the IH with the
         [m'] that we are talking about right now (this
         instantiation is performed automatically by
         [apply]), then [IHn'] gives us exactly what we
         need to finish the proof. *)
      assert (n' = m') as H.
      SSCase "Proof of assertion". apply IHn'.
        inversion eq. reflexivity.
      rewrite -> H. reflexivity.  Qed.

(** 帰納法によって証明しようとしていることが、限定的すぎないかに注意する必要があることを学びました。
    もし[n]と[m]の性質に関する証明を[n]に関する帰納法で行ないたい場合は、[m]を一般的なままにしておく必要があるかもしれません。

    しかし、この戦略がいつもそのまま使えるわけではありません。ときには、ちょっとした工夫が必要です。 例えば、[double_injective]を[n]ではなく[m]に関する帰納法で示したいとします。 *)

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  Case "m = O". simpl. intros eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        (* Here we are stuck again, just like before. *)
Admitted.

(** [m]に関する帰納法の問題点は、最初に[n]をintroしなければいけないことです。 (もし何も導入せずに[induction m]をしても、Coqは自動的に[n]をintroします!) どうしたらいいでしょうか?

   1つめの方法は、補題の文を書き換えて[n]より先に[m]がくるようにします。
   これはうまくいきますが、いい方法ではありません。
   特定の証明戦略のために補題の文をめちゃくちゃにしたくありません。
   補題の文はできるかぎり明確かつ自然な形であるべきです。

   その代わりに、いったんすべての限量変数を導入し、そのうちいくつかをコンテキストから取りゴールの先頭に置くことで、再び一般化します。
   これは[generalize dependent]タクティックスによって実現できます。 *)

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* [n] and [m] are both in the context *)
  generalize dependent n.
  (* Now [n] is back in the goal and we can do induction on
     [m] and get a sufficiently general IH. *)
  induction m as [| m'].
  Case "m = O". simpl. intros n eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros n eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        apply IHm'. inversion eq. reflexivity.
      rewrite -> H. reflexivity.  Qed.

(** この定理の非形式な証明を見てみましょう。なお [n]を限量化したまま帰納法によって命題を証明する箇所は、形式的な証明では[generalize dependent]を使う箇所に対応します。

_Theorem_: すべての自然数 [n] と [m] について、 [double n = double m] ならば [n = m]。

_Proof_: [m]を[nat]とする。 [m]に関する帰納法によって、 すべての[n] に対して [double n = double m] ならば [n = m] を示す。

  - 最初に [m = 0] と仮定し、[n] を [double n = double m] をみたす数とし、 [n = 0] を示す。

    [m = 0]なので、[double]の定義より[double n = 0]。
    [n] について2つの場合分けが考えれる。
    [n = 0] ならば、それが示したいことなので、すでに終了している。
    そうでなくて[n = S n']となる[n']が存在する場合、矛盾を導くことで証明する。
    [double]の定義により[n = S (S (double n'))]だが、これは仮定 [dobule n = 0] と矛盾する。

  - そうでない場合、[m = S m'] と仮定し、[n]は再び [double n = double m] をみたす数とする。 [n = S m']を示すために、 帰納法の仮定「 すべての数 [s] に対して [double s = double m']ならば[s = m']」を用いる。

    [m = S m']と[double]の定義により、[double n = S (S (double m'))]。 [n]に関して2つの場合分けが考えられる。

    [n = 0]ならば、定義により[double n = 0]となり、矛盾を導ける。
    なので、[n = S n']となる[n']があると仮定すると、再び[double]の定義により、
    [S (S (double n')) = S (S (double m'))]。 ここでinversionにより[double n' = dobule m']。

    帰納法の仮定を[n']をあてはめることで、[n' = m']という結論を導ける。
    [S n' = n]かつ[S m' = m]なので、これにより示せる。 [] *)

(** **** 練習問題: ★★★ (gen_dep_practice) *)
(** [m]に関する帰納法で以下を示しなさい。 *)

Theorem plus_n_n_injective_take2 : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  (* FILL IN HERE *) Admitted.

(** [l]に関する帰納法で示しなさい。 *)

Theorem index_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     index (S n) l = None.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** 練習問題: ★★★, optional (index_after_last_informal) *)
(** [index_after_last]のCoqによる証明に対応する非形式的な証明を書きなさい。

     _Theorem_: すべてのSet [X], リスト [l : list X], 自然数[n]に対して、[length l = n] ならば [index (S n) l = None]。

     _Proof_:
     (* FILL IN HERE *)
[]
*)

(** **** 練習問題: ★★★, optional (gen_dep_practice_opt) *)
(** [l]に関する帰納法で示しなさい。 *)

Theorem length_snoc''' : forall (n : nat) (X : Type)
                              (v : X) (l : list X),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** 練習問題: ★★★, optional (app_length_cons) *)
(** [app_length]を使わずに[l1]に関する帰納法で示しなさい。 *)

Theorem app_length_cons : forall (X : Type) (l1 l2 : list X)
                                  (x : X) (n : nat),
     length (l1 ++ (x :: l2)) = n ->
     S (length (l1 ++ l2)) = n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** 練習問題: ★★★★, optional (app_length_twice) *)
(** [app_length]を使わずに[l]に関する帰納法で示しなさい。 *)

Theorem app_length_twice : forall (X:Type) (n:nat) (l:list X),
     length l = n ->
     length (l ++ l) = n + n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)


Require Export prison_flip_list.
Require Import prison.

Require Import Arith.
Require Import NPeano.
Require Import List.
Require Import Nat.
Require Import Omega.

Require Import prison_facts.
Require Import logic.
Require Import list_facts.

Definition evenmap lim (l : list (fliplelem lim)) := map (fun c => even (length (fe_divs _ c))) l.

Lemma consconv_proj1_sig_distr :
  forall lim h l lx ex,
    proj1_sig (consconv lim (h::l) h l eq_refl ex lx) = (proj1_sig ex)::(proj1_sig lx).
Proof.
  intros lim l h lx. destruct lx. simpl.
  revert a. revert l. induction x.
  - intros. destruct a. destruct ex. simpl. reflexivity.
  - intros. destruct a0. destruct ex. simpl. reflexivity.
Qed.

Lemma mapunfold :
  forall A B (f : A -> B) h t, map f (h::t) = (f h)::(map f t).
Proof.
  simpl. reflexivity.
Qed.

Lemma flipeqflipl :
  forall lim l lpf k kpf l',
    l' = (evenmap lim l) ->
    flip l' lim k = evenmap _ (proj1_sig (flipl _ l lpf k kpf)).
Proof.
  intros. rewrite H in *. clear H l'. revert lpf k kpf.
  induction l. simpl. reflexivity.
  intros. cbv zeta in kpf. simpl. destruct k.

  - rewrite (consconv_proj1_sig_distr _ a l).
    unfold plus at 1 in kpf.
    unfold evenmap. rewrite mapunfold. apply f_equal2.
    + destruct (fliplkzh _ _ _ _ _) as [ x [ xid xdiv ] ]. unfold dropsnd. unfold proj1_sig.
      rewrite xdiv. remember (fe_divs _ a).
      clear. assert (length (S lim::l0) = S (length l0)) as tmp. simpl. reflexivity.
      rewrite tmp. clear tmp.
      rewrite Nat.even_succ.
      rewrite Nat.negb_even.
      reflexivity.
    + unfold evenmap in *. rewrite <- IHl. reflexivity.

  - rewrite (consconv_proj1_sig_distr _ a l).
    unfold evenmap in *.
    rewrite mapunfold.
    apply f_equal2.
    + destruct (fliplknzh _ _ _ _ _ _) as [ x [ xid xdiv ] ].
      unfold dropsnd. unfold proj1_sig.
      rewrite xdiv. reflexivity.
    + rewrite <- IHl. reflexivity.
Qed.

Lemma flipeacheqflipleach :
  forall lim l cpf l',
    l' = evenmap lim l ->
    match l with
      | nil => True
      | h::_ => fe_idx _ h = 1
    end ->
    flipeach l' lim = evenmap _ (proj1_sig (flipleach lim l cpf)).
Proof.
  intros. unfold flipleach. rewrite <- flipeqflipl with (l' := l'); [ | assumption ].
  rewrite H in *. clear H l'.
  unfold flipeach. destruct l. simpl. reflexivity.
  rewrite H0. unfold plus. rewrite Nat.mod_same. rewrite <- minus_n_O.
  reflexivity.
  intro. discriminate.
Qed.

Lemma idxidemunfold :
  forall lim lim' h1 h2 l1 l2,
    idxidem (h1::l1) (h2::l2) ->
    (fe_idx lim h1 = fe_idx lim' h2 /\ idxidem l1 l2).
Proof.
  intros. unfold idxidem in H. simpl in H. rewrite Forall_forall in H.
  split.
  - apply (H (h1, h2)). simpl. left. reflexivity.
  - unfold idxidem. rewrite Forall_forall. intros.
    apply (H x). simpl. right. assumption.
Qed.

Lemma aiffbaiffcbiffc :
  forall a b c, ((a <-> b) /\ (a <-> c)) -> (b <-> c).
Proof.
  intros. destruct H. rewrite <- H. rewrite <- H0. split; intro; assumption.
Qed.

Lemma hin :
  forall A (h : A) l,
    In h (h::l).
Proof. simpl. left. reflexivity. Qed.

Lemma divseq :
  forall lim lim' a b,
    lim = lim' ->
    fe_idx lim a = fe_idx lim' b ->
    length (fe_divs _ a) = length (fe_divs _ b).
Proof.

  intros. subst. destruct a, b. simpl in *.
  subst. revert fe_idx0 fe_divs0 fe_invariant0 fe_invariant. intros.
  destruct fe_invariant0 as [ idnz [ dset [ dle iniff ] ] ].
  destruct fe_invariant as [ _ [ dset' [ dle' iniff' ] ] ].
  rewrite Forall_forall in dle, dle'.

  assert (forall x, In x fe_divs <-> In x fe_divs0) as indind0.
    intros; split; intro.
      destruct (dle' _ H). rewrite <- iniff; auto.
      destruct (dle _ H). rewrite <- iniff'; auto.
  revert indind0 dset dset'. clear. intros.
  revert dependent fe_divs.
  induction fe_divs0; intros. simpl in *. destruct fe_divs; auto. exfalso. destruct (indind0 n). elim H. simpl. left. reflexivity.
  assert (is_set eq_nat_dec fe_divs0 = true) as dsettail.
    destruct (settail _ _ _ _ dset); auto.
  simpl.
  rewrite <- (IHfe_divs0 dsettail) with (fe_divs := remove eq_nat_dec a fe_divs); clear IHfe_divs0.
  + rewrite <- lrm; auto. rewrite indind0. simpl. left. reflexivity.
  + intros. split; [ intro xinra | intro xind0 ].
    * destruct (eq_nat_dec x a) as [ xeqa | xnea ].
        subst. elim (remove_In eq_nat_dec fe_divs a). assumption.
        assert (a <> x) as anex. intro. subst. elim xnea. reflexivity.
        assert (xind0iffxinrad0 := remove_corr_neq _ eq_nat_dec fe_divs0 _ _ anex).
        assert (xindiffxinrad := remove_corr_neq _ eq_nat_dec fe_divs _ _ anex).
        rewrite <- xindiffxinrad in xinra.
        rewrite indind0 in xinra. simpl in xinra. destruct xinra as [ aeqx | xind0 ].
          elim anex. assumption.
          assumption.
    * destruct (eq_nat_dec a x) as [ aeqx | anex ]. subst. exfalso. destruct (settail _ eq_nat_dec _ _ dset) as [ _ xnind0 ]. elim xnind0. assumption.
        rewrite <- (remove_corr_neq _ eq_nat_dec fe_divs _ _ anex).
        rewrite indind0. simpl. right. assumption.
  + apply setrm. assumption.
Qed.

Lemma evenmapfliplelem :
  forall lim (l ll : list (fliplelem lim)),
    length l = length ll ->
    idxidem l ll ->
    evenmap _ l = evenmap _ ll.
Proof.
  induction l; destruct ll; auto; intros; simpl in *; try discriminate.
  destruct (idxidemunfold _ _ _ _ _ _ H0) as [ aeqf lidemll ].
  rewrite IHl with (ll := ll); auto.
  apply f_equal2; [ | reflexivity ].
  rewrite divseq with (b := f); auto.
Qed.

Lemma flipwhileeqfliplwhile :
  forall n l cpf l',
    l' = evenmap 0 l ->
    match l with
      | nil => True
      | h::_ => fe_idx _ h = 1
    end ->
    flipwhile l' n = evenmap _ (proj1_sig (fliplwhile 0 l cpf n)).
Proof.
  induction n.

  - simpl. intros.
    rewrite flipeacheqflipleach with (l := l) (cpf := cpf); auto.

  - intros l cpf l' l'eq h1.
    rewrite l'eq in *. clear l'eq l'.
    unfold flipwhile. fold flipwhile. rewrite flipwhileflipeach.
    assert (Hx := IHn l cpf _ eq_refl h1). rewrite Hx. clear IHn Hx.
    assert (leacheq := fun cpfx => flipeacheqflipleach _ (proj1_sig (fliplwhile 0 l cpf n)) cpfx _ eq_refl).
    assert (S n = S (n + 0)) as tmp; [ auto | ]. rewrite tmp at 1. clear tmp.

    assert (idxcont (proj1_sig (fliplwhile 0 l cpf n))) as cpf'. clear leacheq h1. destruct (fliplwhile _ _ _ _). simpl. destruct a. apply (idxidemidxc _ _ _ _ (eq_flip _ _ _ H) cpf). rewrite idxidemrefl. assumption.

    assert (match proj1_sig (fliplwhile 0 l cpf n) with
       | nil => True
       | h :: _ => fe_idx (S (n + 0)) h = 1
       end) as h1'. clear cpf' leacheq. destruct (fliplwhile _ _ _ _) as [ x [ xl xid ] ]. simpl. destruct x, l; auto; simpl in xl; try discriminate. unfold idxidem in xid. rewrite Forall_forall in xid. assert (xid' := xid (f, f0)). simpl in xid'. rewrite xid'. assumption. left. reflexivity.

    rewrite (leacheq cpf' h1'). clear leacheq h1'.
    simpl.
    match goal with
        |- evenmap _ (proj1_sig ?x) = evenmap _ (proj1_sig ?y) => remember x; remember y
    end. clear Heqs Heqs0.
    destruct s, s0. simpl.
    destruct a as [ xlen xidem ].
    destruct a0 as [ x0len x0idem ].
    destruct (fliplwhile 0 l _ _). simpl in *.
    destruct a as [ x1len x1idem ].
    apply evenmapfliplelem.
    + rewrite x0len. rewrite xlen. rewrite x1len. reflexivity.
    + assert (idxidem x l); [ apply (idxidemtrans _ _ _ x1 _ _); auto | ].
      apply (idxidemtrans _ _ _ l _ _); auto. rewrite xlen. rewrite x1len. reflexivity.
      apply idxidemrefl. assumption.
Qed.

Lemma fliplem0divs :
  forall x : fliplelem 0, fe_divs _ x = 0::nil.
Proof.
  clear. intros. destruct x. simpl. destruct fe_invariant as [ xx [ yy [ dle xin ] ] ].
  rewrite Forall_forall in dle.
  destruct fe_divs. destruct (xin _ (le_n 0)). simpl in H. elim (H eq_refl).
  simpl. destruct fe_divs.
  - destruct n. reflexivity.
    destruct (dle _ (hin _ (S n) nil)). omega.
  - exfalso. destruct n.
    + destruct (settail _ eq_nat_dec _ _ yy). simpl in H0. destruct n0. elim H0. left. reflexivity.
      clear H H0.
      assert (In (S n0) (0::S n0::fe_divs)). simpl. right. left. reflexivity.
      destruct (dle _ H). omega.
    + assert (In (S n) (S n :: n0::fe_divs)). simpl. left. reflexivity.
      destruct (dle _ H). omega.
Qed.

Lemma evenmapeq :
  forall (l ll : list (fliplelem 0)),
    length l = length ll ->
    evenmap _ l = evenmap _ ll.
Proof.
  intros x x0 lxeqlx0.
  unfold evenmap. revert x0 lxeqlx0. induction x; intros.
  + simpl. destruct x0. simpl. reflexivity.
    simpl in lxeqlx0. discriminate.
  + simpl. destruct x0.  simpl in lxeqlx0. discriminate. rewrite (IHx x0).
    * simpl. repeat rewrite fliplem0divs. simpl. reflexivity.
    * simpl in lxeqlx0. inversion lxeqlx0. reflexivity.
Qed.

Lemma prisoneq :
  forall cells,
    prison cells = evenmap _ (proj1_sig (prisonl cells)).
Proof.

  intros. unfold prison. unfold prisonl.
  rewrite <- flipwhileeqfliplwhile with (l' := evenmap _ (proj1_sig (prisonlbase cells))).

  - apply f_equal2; auto.
    induction cells. simpl. reflexivity.
    unfold rep in *. fold @rep in *. rewrite IHcells. clear.
    destruct (prisonlbase cells). unfold proj1_sig.
    destruct (prisonlbase (S cells)).
    assert (S (length x) = length x0).
      destruct a as [ xlen _ ]. destruct a0 as [ x0len _ ]. rewrite xlen, x0len. reflexivity.
    clear a a0.
    destruct x0. simpl in *. discriminate.
    simpl. rewrite fliplem0divs. simpl. apply f_equal2; auto.
    simpl in *. inversion H. rename H1 into lxeqlx0. clear H f.
    apply evenmapeq. assumption.

  - destruct cells. simpl. reflexivity.
    destruct (prisonlbase cells).
    destruct (prisonlbase (S cells)). unfold proj1_sig in *.
    apply evenmapeq. rewrite rev_length. reflexivity.

  - destruct (prisonlbase cells). unfold proj1_sig.
    destruct x. simpl. constructor.
    simpl. destruct a as [ _ [ endone _ ] ].
    simpl in endone. destruct (rev x ++ f::nil). constructor.
    apply endone. simpl. reflexivity.
Qed.

Lemma idxcifidxc' :
  forall lim (l : list (fliplelem lim)) a,
    idxcont' l a -> idxcont l.
Proof.
  destruct l. simpl. constructor.
  intros. simpl in *. split; [ reflexivity | ].
  apply H.
Qed.

Definition optmap A B (f : A -> B) (v : option A) := match v with
                                                       | None => None
                                                       | Some v' => Some (f v')
                                                     end.

Definition optidx lim v := optmap _ _ (fe_idx lim) v.

Lemma length_app_distr :
  forall A (l ll : list A),
    length (l ++ ll) = length l + length ll.
Proof.
  induction l. simpl. reflexivity.
  simpl. intros. rewrite IHl. reflexivity.
Qed.

Lemma idxstartend :
  forall lim (l : list (fliplelem lim)),
    idxcont l ->
    (forall h e,
       optidx _ (hd_error l) = Some h ->
       optidx _ (hd_error (rev l)) = Some e ->
       h + (length l) = S e).
Proof.
  induction l. simpl. intros. discriminate.
  simpl. intros.
  induction l using rev_ind; [ | clear IHl0 ].
  - simpl in *. inversion H1. inversion H0. rewrite H3 in *. rewrite H4 in *.
    rewrite plus_comm. simpl. reflexivity.
  - rewrite rev_app_distr in *. simpl in *.
    inversion H0. inversion H1. rewrite H3, H4 in *. rewrite length_app_distr. simpl.
    destruct H as [ _ idxc' ].
    assert (IHl' := IHl (idxcifidxc' _ _ _ idxc')). clear IHl.
    destruct l.
    + simpl in *. destruct idxc' as [ xid _ ]. rewrite xid in *.
      rewrite plus_comm. simpl. rewrite H4. reflexivity.
    + simpl in *. destruct idxc' as [ fid lxcont ]. rewrite fid in *.
      rewrite <- (IHl' _ _ eq_refl eq_refl). clear IHl'.
      rewrite length_app_distr. simpl. omega.
Qed.

Lemma idxend_ge :
  forall lim (l : list (fliplelem lim)),
    idxcont l ->
    (forall e,
       optmap _ _ (fe_idx _) (hd_error (rev l)) = Some e ->
       Forall (fun e' => fe_idx _ e' <= e) l).
Proof.
  intros lim l idxc e eeq. destruct l as [ | f l ]. constructor.
  assert (optidx _ (hd_error (f::l)) = Some (fe_idx _ f)) as tmp. simpl. reflexivity.
  assert (fidlenfleqSe := idxstartend _ _ idxc _ _ tmp eeq). clear tmp.
  simpl in fidlenfleqSe. rewrite plus_comm in fidlenfleqSe.
  simpl in fidlenfleqSe.
  inversion fidlenfleqSe as [ lenfeqe ]. clear fidlenfleqSe. clear eeq.
  rewrite Forall_forall.
  revert dependent f. revert e.
  induction l. simpl. intros. destruct H; subst; [ constructor | elim H ].
  intros e f idxc alfe x xin.
  assert (alcont := idxcontt _ _ _ _ idxc eq_refl).
  assert (length l + fe_idx _ a = e) as lenlaeqe.
    revert idxc alfe. clear. intros.
    simpl in *. destruct idxc as [ _ [ af _ ] ]. rewrite af.
    rewrite <- alfe. omega.
  assert (IHl' := IHl _ _ alcont lenlaeqe x). clear IHl.
  assert (f = x \/ In x (a::l)) as xin'. revert xin. clear. intros. simpl in *. assumption.
  destruct xin' as [ feqx | xinal ].
  - subst. simpl in *. clear.  omega.
  - assert (xleSll := IHl' xinal). clear xinal IHl'.
    assert (fe_idx _ a = S (fe_idx _ f)) as aidSfid. simpl in idxc. apply idxc.
    revert xleSll aidSfid. clear. intros. rewrite aidSfid in *. clear aidSfid.
    simpl. omega.
Qed.

Lemma idxidem_app_distr :
  forall lim lim' l ll a b,
    length l = length ll ->
    idxidem (l ++ a::nil) (ll ++ b::nil) ->
    fe_idx lim a = fe_idx lim' b.
Proof.
  induction l; destruct ll; intros; simpl in *; try discriminate.
  - simpl in H0. unfold idxidem in H0. rewrite Forall_forall in H0.
    apply (H0 (a, b) (or_introl eq_refl)).
  - apply (IHl ll a0 b).
    + inversion H. reflexivity.
    + assert (Hx := idxidemunfold _ _ _ _ _ _ H0).
      apply Hx.
Qed.

Lemma prisonl_idxle :
  forall n,
    Forall (fun e => fe_idx _ e <= S n) (proj1_sig (prisonl n)).
Proof.
  unfold prisonl. intros. rewrite Forall_forall. intros x xin.
  destruct (prisonlbase n) as [ base basepf ]. simpl in *.
  destruct basepf as [ baselen [ beg1 basecont ] ].
  destruct (fliplwhile _ _) as [ res respf ]. simpl in *.
  destruct respf as [ reslen resid ].
  rewrite idxidemrefl in resid.
  assert (rescont := idxidemidxc _ _ _ _ (eq_flip _ _ _ reslen) basecont resid).
  assert (Hx := idxend_ge _ _ rescont).
  destruct base. simpl in *. subst. destruct res. simpl in *. elim xin. simpl in reslen. discriminate reslen.
  assert (Hy := Hx (fe_idx _ f)). clear Hx.
  assert (optmap (fliplelem (S (n + 0))) nat (fe_idx (S (n + 0)))
         (hd_error (rev res)) = Some (fe_idx 0 f)) as lastidreseqbase. clear Hy.
    simpl in resid.
    induction res using rev_ind; [ | clear IHres ]. simpl in xin. elim xin.
    assert (Hx := fun leq => idxidem_app_distr _ _ _ _ _ _ leq resid).
    rewrite Hx. rewrite rev_app_distr. simpl. reflexivity.
    revert reslen baselen. clear. intros.
    simpl in *. repeat rewrite length_app_distr in reslen. simpl in *.
    repeat rewrite (plus_comm _ 1) in reslen. simpl in reslen. inversion reslen. reflexivity.
  assert (Hz := Hy lastidreseqbase). clear Hy lastidreseqbase.
  rewrite Forall_forall in Hz.
  assert (Hx := Hz _ xin). clear Hz.
  rewrite Hx. simpl in *. rewrite <- rev_length in baselen. destruct (rev base). simpl in *. rewrite beg1. rewrite <- baselen. constructor. constructor. reflexivity.
  simpl in *. destruct basecont as [ _ basecont ].
  assert (Hy := idxcont_idx _ _ _ _ basecont). rewrite (beg1 f0) in Hy; [ | reflexivity ].
  rewrite Hy. rewrite <- baselen. simpl. constructor. constructor.
Qed.

Lemma prisonl_alldiv :
  forall n,
    Forall (fun e => forall x, ((fe_idx _ e) mod x = 0) <-> In x (fe_divs _ e)) (proj1_sig (prisonl n)).
Proof.
  intro.
  assert (Hx := prisonl_idxle n).
  rewrite Forall_forall in *.
  intros.
  assert (Hy := Hx _ H).
  assert (S n = S n + 0). omega.
  assert (Hz := alldivs _ x).
  rewrite H0 in Hy. assert (Ha := Hz Hy).
  destruct Ha. destruct a as [ x1def [ x1set diviff ] ].
  assert (diviff' := diviff x0). clear diviff Hx Hy H0 Hz.
  rewrite diviff'. rewrite x1def.
  split; intro; assumption.
Qed.


Require Export Coq.Sets.Relations_1.
Require Export Coq.Sets.Ensembles.
Require Export Coq.Sets.Finite_sets.

Reserved Infix "*->" (at level 70, no associativity).
Reserved Infix "*=*" (at level 70, no associativity).
Reserved Infix "*=>" (at level 70, no associativity).

Section AuxiliaryDefs.
Variable U : Type.

  Definition Irreflexive (R : Relation U) : Prop := forall x : U, ~ R x x.

End AuxiliaryDefs.

Class EventSet (U : Type) :=
{ event := U
; precedence : Relation event where "x *-> y" := (precedence x y)
; synchronisation : Relation event
    where "x *=* y" := (synchronisation x y)
; causality := fun x y : event => x *-> y \/ x *=* y
    where "x *=> y" := (causality x y)
; ax_precedence : Irreflexive event precedence /\ Transitive event precedence
; ax_syncronisation : Equivalence event synchronisation
; ax_pre_synchro : forall x x' y y' : event,
    x *=* x' -> y *=* y' -> x *-> y -> x' *-> y'
}.

Notation "x *-> y" := (precedence x y).
Notation "x *=* y" := (synchronisation x y).
Notation "x *=> y" := (causality x y).

Section Causet.
Variable U : Type.
Context `{EventSet U}.

  Definition Bot (x : event) : Ensemble event := fun y : event => y *=> x.

  Class Causet :=
  { ax_liveness : forall x : event, exists x' : event, x *-> x'
  ; ax_fincaused : forall x : event, Finite event (Bot x)
  }.

End Causet.


Require Export XR_Rmult_eq_reg_l.
Require Export XR_Rinv_r.
Require Export XR_Ropp_mult_distr_r.
Require Export XR_Ropp_involutive.
Require Export XR_Ropp_eq_0_compat.

Local Open Scope R_scope.

Lemma Ropp_inv_permute : forall r, r <> R0 -> - / r = / - r.
Proof.
  intros x h.
  apply Rmult_eq_reg_l with (-x).
  {
    rewrite Rinv_r.
    {
      rewrite <- Ropp_mult_distr_l.
      rewrite <- Ropp_mult_distr_r.
      rewrite Ropp_involutive.
      rewrite Rinv_r.
      { reflexivity. }
      { exact h. }
    }
    {
      unfold not.
      intro heq.
      unfold not in h.
      apply h.
      apply Ropp_eq_0_compat in heq.
      rewrite Ropp_involutive in heq.
      exact heq.
    }
  }
  {
    unfold not.
    intro heq.
    unfold not in h.
    apply h.
    apply Ropp_eq_0_compat in heq.
    rewrite Ropp_involutive in heq.
    exact heq.
  }
Qed.


(*|
###################################################
Existential instantiation and generalization in coq
###################################################

:Link: https://stackoverflow.com/q/10686164
|*)

(*|
Question
********

Can someone please give me a simple example of existential
instantiation and existential generalization in Coq? When I want to
prove ``exists x, P``, where ``P`` is some ``Prop`` that uses ``x``, I
often want to name ``x`` (as ``x0`` or some such), and manipulate
``P``. Can this be one in Coq?
|*)

(*|
Answer
******

If you're going to prove the existential directly and not through a
lemma, you can use ``eapply ex_intro``. This introduces an existential
variable (written ``?42``). You can then manipulate the term. To
complete the proof, you need to eventually provide a way to construct
a value for that variable. You can do this explicitly with the
``instantiate`` tactic, or implicitly through tactics such as
``eauto``.

Beware that it is often cumbersome to work with existential variables.
Many tactics assume that all terms are instantiated and may hide
existentials in subgoals; you'll only find out when ``Qed`` tells you
"Error: Attempt to save an incomplete proof". You should only use
existential variables when you have a plan to instantiate them soon.

Here's a silly example that illustrates the use of ``eapply``.
|*)

Goal exists x, 1 + x = 3.
Proof.                        (* ⊢ exists x, 1 + x = 3 *)
  eapply ex_intro.            (* ⊢ 1 + ?42 = 3 *)
  simpl.                      (* ⊢ S ?42 = 3 *)
  apply f_equal.              (* ⊢ ?42 = 2 *)
  reflexivity.                (* proof completed *)
Qed.

(*|
----

**A:** With Coq trunk you can turn uninstantiated existentials into
subgoals at the end of the proof - which is something I wished for for
a long time.

**A:** An addition to the previous comment: this can be done with
``Grab Existential Variables.``
|*)