Require Import compcert.lib.Axioms.
Require Import compcert.lib.Maps.
(* Require Export compcert.lib.Coqlib. *)

Require Import VST.concurrency.common.sepcomp. Import SepComp.

Require Import VST.concurrency.common.pos.
Require Import VST.concurrency.common.scheduler.
Require Import VST.concurrency.common.konig.
Require Import VST.concurrency.common.addressFiniteMap. (*The finite maps*)
Require Import VST.concurrency.common.pos.
Require Import VST.concurrency.common.lksize.
Require Import VST.concurrency.common.permjoin_def.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import VST.concurrency.common.ssromega. (*omega in ssrnat *)

Require Import Coq.ZArith.ZArith.

Require Import VST.concurrency.common.permissions.
Require Import VST.concurrency.common.threadPool.

Require Import compcert.common.Memory. (*for Mem.perm_order'' *)

Set Bullet Behavior "Strict Subproofs".
Set Nested Proofs Allowed.

Definition map_leq {A B} (m1: PTree.t A)(m2: PTree.t B): Prop :=
  forall p, m1 ! p -> m2 ! p.

Lemma map_leq_apply:
  forall {A B} (m1: PTree.t A)(m2: PTree.t B) p f1,
    map_leq m1 m2 ->
    m1 ! p = Some f1 -> exists f2, m2 ! p = Some f2.
Proof.
  move => A B m1 m2 p f1.
  rewrite /map_leq => /(_ p) Mle AA.
  rewrite AA in Mle. specialize (Mle ltac:(auto)).
  destruct (m2 ! p) as [f2|]; try solve[inversion Mle].
  exists f2; auto.
Qed.

Lemma treemap_sub_map: forall {A B} (f: positive -> B -> A) m2,
    map_leq (PTree.map f m2) m2.
Proof.
  move => A B f m2 p.
  rewrite PTree.gmap.
  destruct (m2 ! p) eqn:m2p; auto; intros HH; inversion HH.
Qed.

Definition map_empty_def {A} (m1: PMap.t (Z -> option A)):=
  m1.1 = fun _ => None.

Definition fun_leq' {A B} (f1: Z -> option A) (f2: Z -> option B): Prop :=
  forall p, f1 p -> f2 p.

Definition fun_leq {A B} (o1: option (Z -> option A)) (o2: option (Z -> option B)): Prop :=
  match o1, o2 with
  | Some f1, Some f2 => fun_leq' f1 f2
  | None, None => True
  | _, _ => False
  end.

Definition option_eq {A B} (a:option A) (b: option B): Prop :=
  match a, b with
  | Some _ , Some _ => True
  | None, None => True
  | _, _ => False
  end.

Definition bounded_nat_func_aux {A} (f: nat -> option A) hi: Prop :=
  (forall p, (p >= hi )%nat -> f p = None).

Definition bounded_nat_func' {A} (f: nat -> option A) hi: Prop :=
  (forall p, (p > hi )%nat -> f p = None).

Definition bounded_func' {A} (f: Z -> option A) hi lo: Prop :=
  (forall p, (p > hi )%Z -> f p = None) /\
  (forall p, (p < lo)%Z -> f p = None).

Definition bounded_func_op {A} (f: option (Z -> option A)) hi lo: Prop :=
  match f with
  | Some f' => bounded_func' f' hi lo
  | None => True
  end.

Definition bounded_func {A} (f: Z -> option A): Prop :=
  exists hi lo,
  bounded_func' f hi lo.

Definition bounded_map {A} (m: PTree.t (Z -> option A)):=
  forall p f, m ! p = Some f -> bounded_func f.

Fixpoint strong_tree_leq {A B}
         (t1: PTree.t A) (t2: PTree.t B)
         (leq: option A -> option B -> Prop):=
  match t1, t2 with
  | PTree.Leaf, PTree.Leaf => True
  | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 =>
    leq o1 o2 /\
    strong_tree_leq l1 l2 leq /\
    strong_tree_leq r1 r2 leq
  | _, _ => False
  end.

Definition same_shape {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  strong_tree_leq m1 m2 option_eq.

Definition sub_map' {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  forall p f1, m1 ! p = Some f1 ->
          exists f2, m2 ! p = Some f2 /\ fun_leq' f1 f2.

Definition sub_map {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  strong_tree_leq m1 m2 fun_leq.

Lemma sub_map_and_shape:
  forall { A B} m1 m2,
  @same_shape A B m1 m2 ->
  sub_map' m1 m2 ->
  sub_map m1 m2.
Proof.
  induction m1.
  - intros.
    destruct m2; inversion H.
    auto.
  - intros.
    rewrite /sub_map /=.
    destruct m2; try inversion H.
    split; [|split].
    + destruct o as [o|].
      2: destruct o0; inversion H1; auto.
      specialize (H0 1%positive o ltac:(auto)).
      destruct o0; try solve [inversion H1].
      destruct H0 as [f [ISo LEQ]].
      inversion ISo.
      auto.
    + destruct H as [AA [BB CC]].
      eapply IHm1_1; eauto.
      move => b f HH.
      move: H0 => /(_  (b~0)%positive f HH) //.
    + destruct H as [AA [BB CC]].
      eapply IHm1_2; eauto.
      move => b f HH.
      move: H0 => /(_  (b~1)%positive f HH) //.
Qed.

Definition nat_to_perm (i:nat) :=
  (match i with
  | 0 => Some None
  | 1 => Some (Some Nonempty)
  | 2 => Some (Some Readable)
  | 3 => Some (Some Writable)
  | 4 => Some (Some Freeable)
  | _ => None
  end)%nat.

Definition perm_to_nat (p: option (option permission)) :=
  match p with
  | Some (None) => 0
  | Some (Some Nonempty) => 1
  | Some (Some Readable) => 2
  | Some (Some Writable) => 3
  | Some (Some Freeable) => 4
  | None => 5
  end.

Definition nat_to_perm_simpl (i:nat) :=
  (match i with
  | 0 => None
  | 1 => Some Nonempty
  | 2 => Some Readable
  | 3 => Some Writable
  | 4 => Some Freeable
  | _ => None
  end)%nat.

Definition perm_to_nat_simpl (p: option permission) :=
  match p with
  | None => 0
  | Some Nonempty => 1
  | Some Readable => 2
  | Some Writable => 3
  | Some Freeable => 4
  end.
Lemma perm_to_nat_bound:
  forall p,
    perm_to_nat p < 6.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p as [p|]; try destruct p; compute; auto.
Qed.

Lemma perm_to_nat_bound_simpl:
  forall p,
    perm_to_nat_simpl p < 5.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p; compute; auto.
Qed.

Lemma nat_to_perm_perm_to_nat:
  forall p,
    nat_to_perm (perm_to_nat p) = p.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p as [p|];
    try destruct p;
    reflexivity.
Qed.

Lemma nat_to_perm_perm_to_nat_simpl:
  forall p,
    nat_to_perm_simpl (perm_to_nat_simpl p) = p.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p;
    reflexivity.
Qed.

Lemma finite_bounded_nat_aux_func:
  forall hi ,
    konig.finite
      ( fun f:nat -> option (option permission) => bounded_nat_func_aux f hi).
Proof.

   intros hi.
   pose (K:= perm_to_nat).
   induction hi.
   - exists 1%nat.
     exists (fun x _ => None).
     intros.
     exists 0%nat.
     split; auto.

     extensionality b.
     symmetry.
     apply H.
     apply /leP. omega.

   - destruct IHhi as [N [FN H]].
     exists (6*N)%nat.
     exists (fun x i => if (Nat.eq_dec i hi) then
                       nat_to_perm (Nat.modulo x 6)
                else FN (Nat.div x 6) i).
     move=> f HH.
     specialize (H (fun n => if (Nat.eq_dec n hi) then
                            None
                          else f n) ).
     destruct H as [i [ineq f_spec]].
     + intros pp pphi.
       destruct (Nat.eq_dec pp hi).
       * auto.
       * simpl; eapply HH.
         move: pphi=> /leP pphi.
         apply /ltP.
         omega.

     + exists ((6 * i) + (perm_to_nat (f hi))).
       split.
       * replace (6 * N) with
         (6 * (N - 1) + 6 ).
         { eapply (NPeano.Nat.lt_le_trans _ (6 * i  + 6)).
           - apply /leP.
             rewrite ltn_add2l.
             destruct (f hi) as [p|];
               [destruct p; try destruct p|]; simpl; apply /leP; try omega.
           - apply /leP.
             rewrite leq_add2r.
             rewrite leq_pmul2l.
             + apply / leP. clear -ineq.
               replace N with (S (N - 1)) in ineq.
               apply /leP.
               by rewrite - ltnS; apply /leP.
               rewrite -addn1.
               apply subnK.
               destruct N; apply /ltP; try omega.
             + compute; auto.
         }
         rewrite - mulnSr.
         replace (N -1).+1 with N; auto.
         rewrite -addn1.
         symmetry; apply subnK.
         destruct N; apply /ltP; try omega.
       * { extensionality i0.
           destruct (Nat.eq_dec i0 hi).
           - subst.
             rewrite addnC.
             rewrite mulnC.
             rewrite NPeano.Nat.mod_add; try omega.
             rewrite NPeano.Nat.mod_small;
               try (apply /ltP; eapply perm_to_nat_bound).
             rewrite nat_to_perm_perm_to_nat.
             reflexivity.

           - replace ((6 * i + perm_to_nat (f hi)) / 6) with i.
             + rewrite f_spec.
               simpl.
               destruct (Nat.eq_dec i0 hi);
                 try solve [exfalso; apply n; auto].
               reflexivity.
             + eapply NPeano.Nat.div_unique;
               try (apply /ltP; eapply perm_to_nat_bound).
               reflexivity.
         }
Qed.

Lemma finite_bounded_nat_aux_func_simpl:
  forall hi ,
    konig.finite
      ( fun f:nat -> option permission => bounded_nat_func_aux f hi).
Proof.

   intros hi.
   pose (K:= perm_to_nat_simpl).
   induction hi.
   - exists 1%nat.
     exists (fun x _ => None).
     intros.
     exists 0%nat.
     split; auto.

     extensionality b.
     symmetry.
     apply H.
     apply /leP. omega.

   - destruct IHhi as [N [FN H]].
     exists (5*N)%nat.
     exists (fun x i => if (Nat.eq_dec i hi) then
                       nat_to_perm_simpl (Nat.modulo x 5)
                else FN (Nat.div x 5) i).
     move=> f HH.
     specialize (H (fun n => if (Nat.eq_dec n hi) then
                            None
                          else f n) ).
     destruct H as [i [ineq f_spec]].
     + intros pp pphi.
       destruct (Nat.eq_dec pp hi).
       * auto.
       * simpl; eapply HH.
         move: pphi=> /leP pphi.
         apply /ltP.
         omega.

     + exists ((5 * i) + (perm_to_nat_simpl (f hi))).
       split.
       * replace (5 * N) with
         (5 * (N - 1) + 5 ).
         { eapply (NPeano.Nat.lt_le_trans _ (5 * i  + 5)).
           - apply /leP.
             rewrite ltn_add2l.
             destruct (f hi) as [p|]; [destruct p|]; simpl; apply /leP; try omega.
           - apply /leP.
             rewrite leq_add2r.
             rewrite leq_pmul2l.
             + apply / leP. clear -ineq.
               replace N with (S (N - 1)) in ineq.
               apply /leP.
               by rewrite - ltnS; apply /leP.
               rewrite -addn1.
               apply subnK.
               destruct N; apply /ltP; try omega.
             + compute; auto.
         }
         rewrite - mulnSr.
         replace (N -1).+1 with N; auto.
         rewrite -addn1.
         symmetry; apply subnK.
         destruct N; apply /ltP; try omega.
       * { extensionality i0.
           destruct (Nat.eq_dec i0 hi).
           - subst.
             rewrite addnC.
             rewrite mulnC.
             rewrite NPeano.Nat.mod_add; try omega.
             rewrite NPeano.Nat.mod_small;
               try (apply /ltP; eapply perm_to_nat_bound_simpl).
             rewrite nat_to_perm_perm_to_nat_simpl.
             reflexivity.

           - replace ((5 * i + perm_to_nat_simpl (f hi)) / 5) with i.
             + rewrite f_spec.
               simpl.
               destruct (Nat.eq_dec i0 hi);
                 try solve [exfalso; apply n; auto].
               reflexivity.
             + eapply NPeano.Nat.div_unique;
               try (apply /ltP; eapply perm_to_nat_bound_simpl).
               reflexivity.
         }
Qed.

Lemma finite_bounded_nat_func:
  forall hi ,
    konig.finite
      ( fun f:nat -> option (option permission) => bounded_nat_func' f hi).
Proof.
  intros.
  destruct (finite_bounded_nat_aux_func (S hi)) as [x [f HH]].
  exists x, f.
  move=> x0 BND.
  cut (bounded_nat_func_aux x0 hi.+1).
  2:{ intros b ineq; eapply BND; auto. }
  move=> /HH [] i [] A B.
  exists i; split; eauto.
Qed.

Lemma finite_bounded_nat_func_simpl:
  forall hi ,
    konig.finite
      ( fun f:nat -> option permission => bounded_nat_func' f hi).
Proof.
  intros.
  destruct (finite_bounded_nat_aux_func_simpl (S hi)) as [x [f HH]].
  exists x, f.
  move=> x0 BND.
  cut (bounded_nat_func_aux x0 hi.+1).
  2:{ intros b ineq; eapply BND; auto. }
  move=> /HH [] i [] A B.
  exists i; split; eauto.
Qed.

Lemma finite_bounded_func:
  forall hi lo,
    konig.finite
      ( fun f:Z -> option (option permission) => bounded_func' f hi lo).
Proof.
  intros hi lo.
  destruct (Coqlib.zlt hi lo).
  - exists 1%N.
    exists (fun _ _ => None).
    intros.
    exists 0%nat; split; auto.
    extensionality b.
    destruct H as[H1 H2].
    symmetry.
    destruct (Coqlib.zle b hi).
    + eapply H2.
      eapply Z.le_lt_trans; eauto.
    + eapply H1; assumption.
  - assert (0 <= hi - lo)%Z by omega.
    pose (n:= Z.to_nat (hi - lo)).
    destruct (finite_bounded_nat_func n) as [N [FN HN]].
    exists N.
    exists (fun n z => (if (Z_lt_ge_dec z lo)
                then None
                else FN n (Z.to_nat (z-lo)))).
    intros f [BOUND1 BOUND2].
    pose (f':= fun n => f (Z.of_nat n + lo)%Z).
    assert (bounded_nat_func' f' n).
    { intros b ineq.
      unfold f'.
      eapply BOUND1.
      unfold n in ineq.
      cut (Z.of_nat b > hi - lo)%Z.
      omega.
      move: ineq => /ltP /inj_lt /Z.gt_lt_iff.
      rewrite Z2Nat.id => //.
    }
    apply HN in H0.
    destruct H0 as [i [ineq FN_spec]].
    exists i; split; auto.
    extensionality z.
    rewrite FN_spec.
    unfold f'.
    destruct (Z_lt_ge_dec z lo).
    + simpl.
      symmetry.
        by apply BOUND2.
    + simpl.
      rewrite Z2Nat.id.
      * f_equal; omega.
      * omega.
Qed.

Lemma finite_bounded_func_simpl:
  forall hi lo,
    konig.finite
      ( fun f:Z -> option permission => bounded_func' f hi lo).
Proof.
  intros hi lo.
  destruct (Coqlib.zlt hi lo).
  - exists 1%N.
    exists (fun _ _ => None).
    intros.
    exists 0%nat; split; auto.
    extensionality b.
    destruct H as[H1 H2].
    symmetry.
    destruct (Coqlib.zle b hi).
    + eapply H2.
      eapply Z.le_lt_trans; eauto.
    + eapply H1; assumption.
  - assert (0 <= hi - lo)%Z by omega.
    pose (n:= Z.to_nat (hi - lo)).
    destruct (finite_bounded_nat_func_simpl n) as [N [FN HN]].
    exists N.
    exists (fun n z => (if (Z_lt_ge_dec z lo)
                then None
                else FN n (Z.to_nat (z-lo)))).
    intros f [BOUND1 BOUND2].
    pose (f':= fun n => f (Z.of_nat n + lo)%Z).
    assert (bounded_nat_func' f' n).
    { intros b ineq.
      unfold f'.
      eapply BOUND1.
      unfold n in ineq.
      cut (Z.of_nat b > hi - lo)%Z.
      omega.
      move: ineq => /ltP /inj_lt /Z.gt_lt_iff.
      rewrite Z2Nat.id => //.
    }
    apply HN in H0.
    destruct H0 as [i [ineq FN_spec]].
    exists i; split; auto.
    extensionality z.
    rewrite FN_spec.
    unfold f'.
    destruct (Z_lt_ge_dec z lo).
    + simpl.
      symmetry.
        by apply BOUND2.
    + simpl.
      rewrite Z2Nat.id.
      * f_equal; omega.
      * omega.
Qed.

Lemma finite_bounded_op_func_simpl:
  forall hi lo,
    konig.finite
      ( fun f: option (Z -> option permission) => bounded_func_op f hi lo).
Proof.
  move => hi lo.
  move: (finite_bounded_func_simpl hi lo) => [] N [] FN FN_spec.

  exists (S N).
  exists (fun n => if n == 0 then None
           else Some (FN (n -1)) ).
  move => f H.
  destruct f.
  - move: FN_spec => /(_ _ H) [] i [] ineqi speci.
    exists (S i); split.
    + omega.
    + rewrite - speci.
      simpl; repeat f_equal.
      rewrite - addn1 - addnBA=> //.
  - exists 0; split; auto.
    + omega.
Qed.

Lemma finite_bounded_op_func:
  forall hi lo,
    konig.finite
      ( fun f: option (Z -> option (option permission)) => bounded_func_op f hi lo).
Proof.
  move => hi lo.
  move: (finite_bounded_func hi lo) => [] N [] FN FN_spec.

  exists (S N).
  exists (fun n => if n == 0 then None
           else Some (FN (n -1)) ).
  move => f H.
  destruct f.
  - move: FN_spec => /(_ _ H) [] i [] ineqi speci.
    exists (S i); split.
    + omega.
    + rewrite - speci.
      simpl; repeat f_equal.
      rewrite - addn1 - addnBA=> //.
  - exists 0; split; auto.
    + omega.
Qed.

Lemma finite_sub_maps:
  forall m2,
    @bounded_map permission m2 ->
    konig.finite
      (fun m1 => @sub_map (option permission) permission m1 m2).
Proof.
  induction m2.
  - move => _.
    exists 1%nat.
    exists (fun _ => PTree.Leaf).
    intros .
    exists 0%nat.
    split; auto.
    destruct x; auto.
    unfold strong_tree_leq in H;
      simpl in H.
    destruct o; inversion H.
  - move => H.
    assert (HH1:
              forall (p : positive) (f : Z -> option permission),
                m2_1 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~0)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_1=> /(_ HH1) [] N1 [] F1 spec_F1.
    assert (HH2:
              forall (p : positive) (f : Z -> option permission),
                m2_2 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~1)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_2=> /(_ HH2) [] N2 [] F2 spec_F2.
    destruct o as [f1|].
    + move : H => /(_ 1%positive f1 ltac:(reflexivity)) [] hi [] lo BNDD.
      move : (finite_bounded_op_func hi lo) => [] N [] F F_spec.
      exists (S( N * N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (F ((n-1) / (N1 * N2)))
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        assert (bounded_func_op o hi lo).
        { Lemma fun_le_bounded_func_op:
            forall {A} o f hi lo,
              @bounded_func' A f hi lo ->
              fun_leq o (Some f) ->
              @bounded_func_op (option A) o hi lo.
          Proof.
            intros.
            destruct o; [|constructor].
            simpl.
            simpl in H0.
            split; intros p.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
          Qed.
          eapply fun_le_bounded_func_op ; eauto.
          }
        move: F_spec => /(_ _ H) []i [] ineq fi.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1) + (i * N1 * N2))); split.
        { apply lt_n_S.
          replace (N * N1 * N2) with
          (N1 + N1 * (N2 * N -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1 + i * N1 * N2)).
              apply /ltP.
              rewrite ltn_add2r;
                rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite -addnA.
              rewrite leq_add2l.
              apply /leP.
              replace (i * N1 * N2) with
              ((i * N2) * N1).
              *
                rewrite -mulnDl.
                rewrite mulnC.
                apply /leP.
                rewrite leq_pmul2l; try (apply /ltP; omega).
                apply /leP.
                eapply lt_n_Sm_le.
                rewrite - addn1.
                rewrite subnK.
                2:
                  rewrite muln_gt0;
                  apply /andP; split;
                  try (apply /ltP; omega).
                eapply (NPeano.Nat.lt_le_trans).
                -- instantiate (1:= N2 + i * N2).
                   apply /ltP.
                   rewrite ltn_add2r.
                   apply /leP; auto.
                -- replace (N2 + i * N2) with
                   (N2 * (1 + i)).
                   apply /leP.
                   rewrite leq_pmul2l.
                   rewrite add1n.
                   apply /ltP; auto.
                   apply /ltP; omega.
                   rewrite mulnDr.
                   rewrite mulnC.
                   f_equal.
                   compute; auto.
                   rewrite mulnC; auto.
              * do 2 rewrite - mulnA.
                f_equal. rewrite mulnC; auto.
          - replace (N1 + N1 * (N2 * N - 1))
            with (N1 * 1 + N1 * (N2 * N - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.

              2:
                rewrite muln_gt0;
                apply /andP; split;
                try (apply /ltP; omega).
              rewrite -mulnA.
              rewrite mulnA.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2) with
            (i1 + (i2  + i *  N2) * N1).
            2:
            rewrite mulnDl addnA; f_equal;
            do 2 rewrite -mulnA; f_equal; rewrite mulnC; auto.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ rewrite - fi.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    ((N1 * N2) * i) + (i1 + i2 * N1)).
            { rewrite addnC. f_equal.
              rewrite - mulnA mulnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            eapply (NPeano.Nat.lt_le_trans).
            ** instantiate (1:= N1 + i2 * N1).
               apply /ltP; rewrite ltn_add2r.
               apply /ltP; auto.
            ** replace (N1 + i2 * N1) with ( (1 + i2) * N1).
               rewrite add1n.
               rewrite mulnC.
               apply /leP; rewrite leq_pmul2l.
               apply /ltP; auto.
               destruct N1; ssromega.
               rewrite mulnDl; f_equal.
               ssromega.

         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    (N1 * (i2 + i * N2)) + i1).
            { rewrite -addnA.
              replace (i * N1 * N2) with
              (i  * N2 * N1).
              rewrite - mulnDl.
              rewrite mulnC addnC; auto.
              do 2 rewrite -mulnA; f_equal.
              rewrite mulnC. auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N2; omega.
    + exists (S( N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (None )
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1))); split.
        { apply lt_n_S.
          replace (N1 * N2) with
          (N1 + N1 * (N2 -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1)).
              apply /ltP.
              rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite leq_add2l.
              apply /leP.
              rewrite mulnC.
              apply /leP.
              rewrite leq_pmul2l; try (apply /ltP; omega).
              apply /leP.
              eapply lt_n_Sm_le.
              rewrite - addn1.
              rewrite subnK; auto.
              destruct N2; ssromega.

          - replace (N1 + N1 * (N2 - 1))
            with (N1 * 1 + N1 * (N2 - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.
              2: ssromega.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1) by ssromega.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ destruct o; auto; inversion FUN_lq.
         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1 ) by ssromega.
            assert (i1 + i2 * N1 =
                    (N1 * (i2) + i1)).
            { rewrite mulnC addnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            apply NPeano.Nat.mod_small; auto.
Qed.

Lemma finite_sub_maps_simpl:
  forall m2,
    @bounded_map permission m2 ->
    konig.finite
      (fun m1 => @sub_map permission permission m1 m2).
Proof.

  induction m2.
  - move => _.
    exists 1%nat.
    exists (fun _ => PTree.Leaf).
    intros .
    exists 0%nat.
    split; auto.
    destruct x; auto.
    unfold strong_tree_leq in H;
      simpl in H.
    destruct o; inversion H.
  - move => H.
    assert (HH1:
              forall (p : positive) (f : Z -> option permission),
                m2_1 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~0)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_1=> /(_ HH1) [] N1 [] F1 spec_F1.
    assert (HH2:
              forall (p : positive) (f : Z -> option permission),
                m2_2 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~1)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_2=> /(_ HH2) [] N2 [] F2 spec_F2.
    destruct o as [f1|].
    + move : H => /(_ 1%positive f1 ltac:(reflexivity)) [] hi [] lo BNDD.
      move : (finite_bounded_op_func_simpl hi lo) => [] N [] F F_spec.
      exists (S( N * N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (F ((n-1) / (N1 * N2)))
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        assert (bounded_func_op o hi lo).
        { Lemma fun_le_bounded_func_op_simpl:
            forall {A} o f hi lo,
              @bounded_func' A f hi lo ->
              fun_leq o (Some f) ->
              @bounded_func_op A o hi lo.
          Proof.
            intros.
            destruct o; [|constructor].
            simpl.
            simpl in H0.
            split; intros p.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
          Qed.
          eapply fun_le_bounded_func_op_simpl ; eauto.
          }
        move: F_spec => /(_ _ H) []i [] ineq fi.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1) + (i * N1 * N2))); split.
        { apply lt_n_S.
          replace (N * N1 * N2) with
          (N1 + N1 * (N2 * N -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1 + i * N1 * N2)).
              apply /ltP.
              rewrite ltn_add2r;
                rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite -addnA.
              rewrite leq_add2l.
              apply /leP.
              replace (i * N1 * N2) with
              ((i * N2) * N1).
              *
                rewrite -mulnDl.
                rewrite mulnC.
                apply /leP.
                rewrite leq_pmul2l; try (apply /ltP; omega).
                apply /leP.
                eapply lt_n_Sm_le.
                rewrite - addn1.
                rewrite subnK.
                2:
                  rewrite muln_gt0;
                  apply /andP; split;
                  try (apply /ltP; omega).
                eapply (NPeano.Nat.lt_le_trans).
                -- instantiate (1:= N2 + i * N2).
                   apply /ltP.
                   rewrite ltn_add2r.
                   apply /leP; auto.
                -- replace (N2 + i * N2) with
                   (N2 * (1 + i)).
                   apply /leP.
                   rewrite leq_pmul2l.
                   rewrite add1n.
                   apply /ltP; auto.
                   apply /ltP; omega.
                   rewrite mulnDr.
                   rewrite mulnC.
                   f_equal.
                   compute; auto.
                   rewrite mulnC; auto.
              * do 2 rewrite - mulnA.
                f_equal. rewrite mulnC; auto.
          - replace (N1 + N1 * (N2 * N - 1))
            with (N1 * 1 + N1 * (N2 * N - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.

              2:
                rewrite muln_gt0;
                apply /andP; split;
                try (apply /ltP; omega).
              rewrite -mulnA.
              rewrite mulnA.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2) with
            (i1 + (i2  + i *  N2) * N1).
            2:
            rewrite mulnDl addnA; f_equal;
            do 2 rewrite -mulnA; f_equal; rewrite mulnC; auto.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ rewrite - fi.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    ((N1 * N2) * i) + (i1 + i2 * N1)).
            { rewrite addnC. f_equal.
              rewrite - mulnA mulnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            eapply (NPeano.Nat.lt_le_trans).
            ** instantiate (1:= N1 + i2 * N1).
               apply /ltP; rewrite ltn_add2r.
               apply /ltP; auto.
            ** replace (N1 + i2 * N1) with ( (1 + i2) * N1).
               rewrite add1n.
               rewrite mulnC.
               apply /leP; rewrite leq_pmul2l.
               apply /ltP; auto.
               destruct N1; ssromega.
               rewrite mulnDl; f_equal.
               ssromega.

         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    (N1 * (i2 + i * N2)) + i1).
            { rewrite -addnA.
              replace (i * N1 * N2) with
              (i  * N2 * N1).
              rewrite - mulnDl.
              rewrite mulnC addnC; auto.
              do 2 rewrite -mulnA; f_equal.
              rewrite mulnC. auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N2; omega.
    + exists (S( N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (None )
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1))); split.
        { apply lt_n_S.
          replace (N1 * N2) with
          (N1 + N1 * (N2 -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1)).
              apply /ltP.
              rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite leq_add2l.
              apply /leP.
              rewrite mulnC.
              apply /leP.
              rewrite leq_pmul2l; try (apply /ltP; omega).
              apply /leP.
              eapply lt_n_Sm_le.
              rewrite - addn1.
              rewrite subnK; auto.
              destruct N2; ssromega.

          - replace (N1 + N1 * (N2 - 1))
            with (N1 * 1 + N1 * (N2 - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.
              2: ssromega.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1) by ssromega.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ destruct o; auto; inversion FUN_lq.
         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1 ) by ssromega.
            assert (i1 + i2 * N1 =
                    (N1 * (i2) + i1)).
            { rewrite mulnC addnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            apply NPeano.Nat.mod_small; auto.
Qed.

Lemma fun_leq_trans: forall {A B C} f1 f2 f3, @fun_leq A B f1 f2 -> @fun_leq B C f2 f3 ->
  @fun_leq A C f1 f3.
Proof.
  unfold fun_leq, fun_leq'; destruct f1, f2, f3; auto.
Qed.

Lemma sub_map_trans: forall {A B C} m1 m2 m3, @sub_map A B m1 m2 -> @sub_map B C m2 m3 ->
  @sub_map A C m1 m3.
Proof.
  unfold sub_map; induction m1; destruct m2; intros; inversion H; destruct m3; inversion H0;
    auto; simpl in *.
  repeat split.
  - eapply fun_leq_trans; eauto.
  - apply (IHm1_1 m2_1); tauto.
  - apply (IHm1_2 m2_2); tauto.
Qed.

Lemma same_shape_map:
  forall {A B} m f,
    @same_shape A B (PTree.map f m) m.
Proof.
  intros until m.
  unfold PTree.map.
  pose (i:=1%positive); fold i.
  generalize i; clear i.
  induction m.
  - intros;
      unfold same_shape;
      simpl; auto.
  - intros;
      unfold same_shape;
      split; [| split].
    + destruct o; simpl; auto.
    + eapply IHm1.
    + eapply IHm2.
Qed.

Lemma strong_tree_leq_xmap':
  forall {A B} f1 f2 t (leq: option B -> option A -> Prop),
  forall p,
    (forall a p0,
        PTree.get p0 t = Some a ->
        leq (Some (f1 (PTree.prev_append p p0)%positive a))
            (Some (f2 (PTree.prev_append p p0)%positive a))) ->
    leq None None ->
    strong_tree_leq
      (@PTree.xmap A B f1 t p)
      (@PTree.xmap A A f2 t p)
      leq.
Proof.
  intros. revert p H.
  induction t. simpl; auto.
  intros.
  repeat split.
  - destruct o; auto.
    move H at bottom.
    assert ((PTree.Node t1 (Some a) t2) ! 1%positive = Some a)
      by reflexivity.
    eapply H in H1. auto.
  -  eapply IHt1.
     intros; specialize (H a (p0~0)%positive).
     eapply H; auto.
  -  eapply IHt2.
     intros; specialize (H a (p0~1)%positive).
     eapply H; auto.
Qed.
Lemma strong_tree_leq_map':
  forall {A B} f1 f2 t (leq: option B -> option A -> Prop),
    (forall a p0,
        PTree.get p0 t = Some a ->
        leq (Some (f1 (PTree.prev_append 1 p0)%positive a))
            (Some (f2 (PTree.prev_append 1 p0)%positive a))) ->
    leq None None ->
    strong_tree_leq
      (@PTree.map A B f1 t)
      (@PTree.map A A f2 t)
      leq.
Proof. intros; eapply strong_tree_leq_xmap'; eauto. Qed.
Lemma strong_tree_leq_spec:
  forall {A B} (leq: option A -> option B -> Prop),
    leq None None ->
    forall t1 t2, strong_tree_leq t1 t2 leq ->
             forall b, leq (@PTree.get A b t1)(@PTree.get B b t2).
Proof.
  intros A B leq Hleq t1.
  induction t1; eauto.
  - intros.
    destruct t2; try solve[inversion H].
    destruct b; simpl; auto.
  - intros t2 HH.
    destruct t2; try solve[inversion HH].
    destruct HH as (INEQ&L&R).
    destruct b; simpl; eauto.
Qed.

Lemma sub_map_lt:
  forall {A B} dmap amap,
    @sub_map A B dmap (amap) ->
    forall b,
      fun_leq (dmap ! b) (amap ! b).
Proof.
  intros. eapply strong_tree_leq_spec; try constructor.
  eapply H.
Qed.


Require Import Coq.Unicode.Utf8.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

Reserved Notation "⟨ x , y , .. , z ⟩".

Reserved Notation "'some' x .. y , P"
         (at level 200, x binder, y binder, right associativity,
          format "'[ ' '[ ' 'some'  x .. y ']' ,  '/' P ']'").
Reserved Notation "'Σ' x .. y , P"
         (at level 200, x binder, y binder, right associativity,
          format "'[ ' '[ ' 'Σ'  x .. y ']' ,  '/' P ']'").

Record someT [A] (P: A → Type) := some_intro { head: A ; tail: P head ; }.

Arguments some_intro [A P].
Arguments head [A P].
Arguments tail [A P].

Module Import SomeNotations.
  Add Printing Let someT.

  Notation "'some' x .. y , P" := (someT (λ x, .. (someT (λ y,  P)) .. )) : type_scope.
  Notation "'Σ' x .. y , P" := (someT (λ x, .. (someT (λ y,  P)) .. )) : type_scope.
  Notation "⟨ x , y , .. , z ⟩" := (some_intro .. (some_intro x y) .. z) : core_scope.
End SomeNotations.

Record iso A B := {
  to: A → B ;
  from: B → A ;
  to_from x: to (from x) = x ;
  from_to x: from (to x) = x ;
}.

Arguments to {A B}.
Arguments from {A B}.

Inductive sort :=
| empty | unit
| sum (A B: sort)
| prod (A B: sort)
| exp (A B: sort)
| Forall (κ: string) (A: sort)
| Forsome (κ: string) (A: sort)
| diag (κ μ: string)
| basechange (p: (string → Type) → (string → Type)) (x: sort)
.

Inductive term: sort → sort → Type :=
| id A: term A A
| compose {A B C}: term B C → term A B → term A C

| bang {A}: term A unit
| fanout {A B C}: term C A → term C B → term C (prod A B)
| π1 {A B}: term (prod A B) A
| π2 {A B}: term (prod A B) B

| absurd {A}: term empty A
| fanin {A B C}: term A C → term B C → term (sum A B) C
| i1 {A B}: term A (sum A B)
| i2 {A B}: term B (sum A B)

| curry {A B C}: term (prod A B) C → term B (exp A C)
| ev {A B}: term (prod A (exp A B)) B

| map_Forsome {A B κ}: term A B → term (Forsome κ A) (Forsome κ B)
| pure {A κ}: term A (Forsome κ A)
| join {A κ}: term (Forsome κ (Forsome κ A)) (Forsome κ A)
| swap_Forsome {A κ μ}: κ ≠ μ → term (Forsome κ (Forsome μ A)) (Forsome μ (Forsome κ A))

| necessity {A κ}: term unit A → term unit (Forall κ A)
| map_Forall {A B κ}: term A B → term (Forall κ A) (Forall κ B)
| mon {A B κ}: term (prod (Forall κ A) (Forall κ B)) (Forall κ (prod A B))
| extract {A κ}: term (Forall κ A) A
| dup {A κ}: term (Forall κ A) (Forall κ (Forall κ A))
| swap_Forall {A κ μ}:
    κ ≠ μ → term (Forall κ (Forall μ A)) (Forall μ (Forall κ A))

| refl κ: term unit (diag κ κ)
| trans {i j k}: term (prod (diag i j) (diag j k)) (diag i k)
.

Infix "∘" := compose (at level 30).

Definition put (Γ: string → Type) (κ: string) (v: Type) (μ: string): Type :=
  if string_dec κ μ
  then
    v
  else
    Γ μ.

Lemma put_redundant {κ Γ}: put Γ κ (Γ κ) = Γ.
Proof.
  extensionality x.
  unfold put.
  destruct (string_dec κ x).
  all: subst.
  all: reflexivity.
Qed.

Lemma put_put {κ Γ x y}: put (put Γ κ x) κ y = put Γ κ y.
Proof.
  extensionality μ.
  unfold put.
  destruct (string_dec κ μ).
  all: subst.
  all: reflexivity.
Qed.

Lemma put_swap {κ μ Γ x y}:
  κ ≠ μ → put (put Γ κ x) μ y = put (put Γ μ y) κ x.
Proof.
  intro p.
  extensionality ν.
  unfold put.
  destruct (string_dec μ ν) eqn:q, (string_dec κ ν) eqn:r.
  all: subst.
  all: try reflexivity.
  contradiction.
Qed.

(*
 Sorts are interpreted as multi-profunctors over a groupoid [xs,V] → Set ?
 Dealing with variance is a massive pain.
*)

Fixpoint op (S: sort) (Γ: string → Type): Type :=
  match S with
  | empty => False
  | unit => True
  | sum A B => op A Γ + op B Γ
  | prod A B => op A Γ * op B Γ
  | exp A B => ∀ Δ, (∀ s, Δ s → Γ s) → op A Δ → op B Δ

  (* Still really confused about this part.  I think other sources
     might complicate it because they have to do a relation variant of
     put?  *)
  | Forall κ A => ∀ v, op A (put Γ κ v)
  | Forsome κ A => Σ v, op A (put Γ κ v)
  | diag κ μ => ∀ Δ, (∀ s, Δ s → Γ s) → Δ κ → Δ μ
  | basechange p x => ∀ Δ, (∀ s, p Δ s → Γ s) → op x Δ
  end.

(* Not even so important ? *)

Definition map (S: sort) {Γ Δ: string → Type} (f: ∀ κ, Δ κ → Γ κ): op S Γ → op S Δ.
Proof.
  generalize dependent Δ.
  generalize dependent Γ.
  induction S.
  all: intros Γ Δ f x.
  - cbn in *.
    contradiction.
  - cbn in *.
    exists.
  - cbn in *.
    destruct x as [x'|x'].
    + left.
      apply (IHS1 Γ Δ f x').
    + right.
      apply (IHS2 Γ Δ f x').
  - cbn in *.
    apply (IHS1 Γ Δ f (fst x), IHS2 Γ Δ f (snd x)).
  - cbn in *.
    intros Δ' p y.
    apply (x Δ').
    + intros ? ?.
      apply f.
      apply p.
      auto.
    + auto.
  - cbn in *.
    intros ?.
    apply (IHS (put Γ κ v)).
    + intros.
      unfold put in *.
      destruct (string_dec κ κ0).
      * auto.
      * apply f.
        auto.
    + apply x.
  - cbn in *.
    destruct x as [h x].
    exists h.
    apply (IHS (put Γ κ h)).
    + intros.
      unfold put in *.
      destruct (string_dec κ κ0).
      * auto.
      * apply f.
        auto.
    + apply x.
  - cbn in *.
    intros ? p y.
    apply x.
    + intros ? z.
      apply f.
      apply p.
      auto.
    + auto.
  - cbn in *.
    intros.
    apply (IHS Δ0).
    + intros.
      auto.
    + apply x.
      intros.
      apply f.
      apply X.
      auto.
Defined.

Definition eval {A B} (t: term A B) {κ}: op A κ → op B κ.
Proof.
  generalize dependent κ.
  induction t.
  all: intros Γ x.
  - apply x.
  - apply IHt1.
    apply IHt2.
    auto.
  - cbn in *.
    exists.
  - cbn in *.
    split.
    + apply IHt1.
      auto.
    + apply IHt2.
      auto.
  - apply x.
  - apply x.
  - cbn in x.
    contradiction.
  - cbn in *.
    destruct x as [x' | x'].
    + apply IHt1.
      auto.
    + apply IHt2.
      auto.
  - cbn in *.
    left.
    auto.
  - cbn in *.
    right.
    auto.
  - cbn in *.
    intros Δ p y.
    apply (IHt Δ).
    refine (y, _).
    apply (map _ p x).
  - destruct x as [x f].
    cbn in f.
    refine (f _ _ x).
    intros.
    auto.
  - cbn in *.
    exists (head x).
    apply IHt.
    apply (tail x).
  - cbn in *.
    exists (Γ κ).
    rewrite put_redundant.
    auto.
  - destruct x as [h [h' t]].
    cbn in *.
    exists h'.
    rewrite put_put in t.
    auto.
  - destruct x as [h [h' t]].
    cbn in *.
    exists h'.
    exists h.
    auto.
    rewrite put_swap.
    1: auto.
    auto.
  - cbn in *.
    intro v.
    apply IHt.
    apply x.
  - cbn in *.
    intro v.
    apply IHt.
    apply x.
  - cbn in *.
    destruct x as [x y].
    intro v.
    apply (x v, y v).
  - cbn in x.
    set (x' := x (Γ κ)).
    rewrite put_redundant in x'.
    auto.
  - cbn in *.
    intros.
    rewrite put_put.
    apply x.
  - cbn in *.
    intros.
    rewrite put_swap.
    2:auto.
    apply x.
  - cbn.
    intros.
    apply X0.
  - cbn in *.
    destruct x as [f g].
    intros Δ p y.
    apply g.
    1: apply p.
    apply f.
    1: apply p.
    auto.
Defined.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Construction.Opposite.
Require Import Category.Functor.Hom.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Sets.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Presheaves   (C : Category) := [C^op, Sets].
Definition Copresheaves (C : Category) := [C, Sets].

(* The Yoneda lemma tells us that a natural transformation, from the covariant
   or contravariant hom-functor on some object in C, to some other functor
   from C to Sets, is isomorphic to mapping the object by that functor
   directly from C to Sets.

   Writing this statement in code, it becomes a bit clearer what it's telling
   us: If the contravariant functor on `A` turns any `X` into the arrow `A ~>
   X`, and if natural transformation is given by `∀ x, f x ~> g x` (assuming
   naturality), the statement of the Yoneda lemma is:

       ∀ f x a, Functor f => (x ~{Sets}~> a) ~{Sets}~> f x ≅ f a

   The Lemma states: Since the only thing knowable about a functor is its
   ability to map objects and morphisms, any object `f x` through which we map
   a morphism `x ~> a` to obtain an object `f a`, *must* be identical to `f a`
   obtained directly, since the functor has no way of introducing additional
   meaning.

   A benefit of the lemma is that we can displace any source object `a` (from
   an arbitrary category `C`) into an object in the category of Sets -- i.e.,
   the hom-set whose domain or codomain is `a` -- allowing us to handle it
   using the structure of sets. This has the benefit of making many proofs
   easier, which become more difficult when restricted to the fully abstract
   nature of `C`. *)

Program Instance Yoneda_Lemma `(C : Category) `(F : C^op ⟶ Sets) {A : C} :
  [C^op, Sets] [Hom ─,A] F ≅ F A := {
  to   := {| morphism := fun x => transform[x] A id |};
  from := {| morphism := fun y : F A =>
             {| transform := fun x : C =>
                {| morphism := fun phi : A ~{ C^op }~> x =>
                     @fmap (C^op) Sets F A x phi y |} |} |}
}.
Next Obligation.
  (* [transform] preserves morphism equivalences. *)
  proper.
  destruct F; simpl in *.
  apply fmap_respects, X.
Qed.
Next Obligation.
  (* The action of [transform] is natural. *)
  autounfold.
  destruct F; simpl in *.
  symmetry.
  apply fmap_comp.
Qed.
Next Obligation.
  (* The action of [transform] is natural (symmetric). *)
  autounfold.
  destruct F; simpl in *.
  apply fmap_comp.
Qed.
Next Obligation.
  (* [from] preserves morphism equivalences. *)
  proper.
  destruct F; simpl in *.
  apply proper_morphism; assumption.
Qed.
Next Obligation.
  (* The result of [from] respects the laws of the functor category. *)
  autounfold; simpl.
  destruct F; simpl in *.
  apply fmap_id.
Qed.
Next Obligation.
  (* The result of [from] preserves morphism equivalences. *)
  autounfold.
  destruct F, x; simpl in *; intros.
  autounfold in *.
  rewrite naturality.
  apply transform; cat.
Qed.

Program Instance Covariant_Yoneda_Lemma `(C : Category) `(F : C ⟶ Sets) {A : C} :
  [C, Sets] [Hom A,─] F ≅ F A := {
  to   := {| morphism := fun x => transform[x] A id |};
  from := {| morphism := fun y : F A =>
             {| transform := fun x : C =>
                {| morphism := fun phi : A ~{ C }~> x =>
                     @fmap C Sets F A x phi y |} |} |}
}.
Next Obligation.
  (* [transform] preserves morphism equivalences. *)
  proper.
  destruct F; simpl in *.
  apply fmap_respects, X.
Qed.
Next Obligation.
  (* The action of [transform] is natural. *)
  autounfold.
  destruct F; simpl in *.
  symmetry.
  apply fmap_comp.
Qed.
Next Obligation.
  (* The action of [transform] is natural (symmetric). *)
  autounfold.
  destruct F; simpl in *.
  apply fmap_comp.
Qed.
Next Obligation.
  (* [from] preserves morphism equivalences. *)
  proper.
  destruct F; simpl in *.
  apply proper_morphism; assumption.
Qed.
Next Obligation.
  (* The result of [from] respects the laws of the functor category. *)
  autounfold; simpl.
  destruct F; simpl in *.
  apply fmap_id.
Qed.
Next Obligation.
  (* The result of [from] preserves morphism equivalences. *)
  autounfold.
  destruct F, x; simpl in *; intros.
  autounfold in *.
  rewrite naturality.
  apply transform; cat.
Qed.


(** * check_cdr.v: executable CDR checker *)
(* Hendra : Removed exception related SOAP *)
Require Export Lib.
Require Export cdr.
Require Export ZArith.

Module Make (M:MAP) (*M1:MAP) (M2:MAP*).

(*   Module M' := MapPair_Base M1 M2.
  Module M := Map_Of_MapBase M'. *)

  Section region.

    Definition PC : Set := M.key.
(*     Definition Kind: Set := M2.key. *)

    Variable step : PC -> (* Kind -> *) option PC -> Prop.
    Variable for_all_steps : (PC -> (* Kind ->  *) option PC->bool)  -> bool.
    Variable test_all_steps : (PC -> (* Kind -> *) option PC->bool)  -> list (PC*bool).
    Variable for_all_steps_true :
      forall test, for_all_steps test  = true ->
        forall i (* tau  *) oj,
          step i (* tau *) oj -> test i (* tau *) oj = true.
    Variable for_all_succs : PC -> ((* Kind -> *) option PC -> bool) -> bool.
    Variable for_all_succs_true : forall i test,
      for_all_succs i test = true ->
      forall (* tau *) oj, step i (* tau *) oj -> test (* tau *) oj = true.

    Definition result p := (* exists k, *) step p (* k *) None.

    Variable reg : M.t (M.t bool).
    Variable jun : M.t PC.

    Definition region (i:PC) (* (tau:Kind) *) (j:PC) : Prop :=
      exists m,
        M.get reg (i(* ,tau *)) = Some m
        /\ M.get m j = Some true.

    Definition junc (i:PC) (*tau:Kind*) (j:PC) : Prop :=
      M.get jun (i) = Some j.

    Definition check_junc_func : bool :=
      M.for_all
        (fun i j1 =>
          match M.get jun i with
            | None => true
            | Some j2 =>  M.eq_key j1 j2
          end) jun.

    Lemma check_junc_func_correct : check_junc_func = true ->
      forall i j1 j2,
        junc i j1 -> junc i j2 -> j1=j2.
    Proof.
      unfold check_junc_func, junc; intros.
      generalize (M.for_all_true _ _ _ H _ _ H0); simpl.
      rewrite H1; intros.
      generalize (M.eq_key_spec j1 j2); rewrite H2; auto.
    Qed.

    Definition in_region (i:PC) (*tau:Kind*) (j:PC) : bool :=
      match M.get reg (i) with
        | None => false
        | Some m => match M.get m j with
                      | Some true => true
                      | _ => false
                    end
      end.

    Lemma in_region_true : forall i j,
      in_region i j = true -> region i j.
    Proof.
      unfold in_region, region; intros i j.
      destruct (M.get reg (i)); try (intros; discriminate).
      case_eq (M.get t j); try (intros; discriminate).
      destruct b; intros; try discriminate.
      eauto.
    Qed.

    Definition test_junc (i:PC) (*tau:Kind*) (j:PC) : bool :=
      match M.get jun (i) with
        | None => false
        | Some j0 => M.eq_key j0 j
      end.

    Lemma test_junc_true : forall i j,
      test_junc i j = true -> junc i j.
    Proof.
      unfold test_junc, junc; intros i j.
      destruct (M.get jun (i)); intros; try discriminate.
      generalize (M.eq_key_spec p j); rewrite H; congruence.
    Qed.

(*     Definition check_soap1 : bool :=
      for_all_steps
        (fun i oj =>
          match oj with
            | None => true
            | Some j => orb (in_region i j) (test_junc i j)
          end). *)

     Definition check_soap1 : bool :=
      for_all_steps
        (fun i (* tau *) oj =>
          for_all_steps (fun i ok =>
            match oj, ok with
(*               | None, None => true *)
              | Some j, Some k => orb (M.eq_key j k) (orb (in_region i (* tau *) k) (test_junc i (* tau *) k))
              | _, _ => false
            end)).

    Definition check_soap1' : list (PC*bool) :=
      test_all_steps
        (fun i oj =>
          for_all_steps (fun i ok =>
          match oj, ok with
            | None, NOne => true
            | Some j, Some k => orb (M.eq_key j k) (orb (in_region i j) (test_junc i j))
            | _, _ => false
          end)).

    Lemma check_soap1_correct : check_soap1 = true ->
      forall i j k,
        step i (Some j) -> step i (Some k) -> j <> k ->
        region i k \/ junc i k.
    Proof.
      unfold check_soap1; intros.
      assert (T:=for_all_steps_true _ H _ _ H0); simpl in T.
      assert (T':=for_all_steps_true _ T _ _ H1); simpl in T'.
      elim orb_prop with (1:=T'); intros.
        generalize (M.eq_key_spec j k). rewrite H3; congruence.
      elim orb_prop with (1:=H3); intros.
      left; apply in_region_true; auto.
      right; apply test_junc_true; auto.
    Qed.

    Definition for_all_region (test:PC->PC->bool) : bool :=
      M.for_all
        (fun i m => (* let (i,kd):=ikd in *)
           M.for_all
             (fun j b => (negb b) || test i j)
             m)
        reg.

    Lemma for_all_region_true : forall test,
      for_all_region test = true ->
      forall i j, region i j -> test i j = true.
    Proof.
      unfold for_all_region, region; intros.
      destruct H0 as [m [H0 H1]].
      assert (T:=M.for_all_true _ _ _ H _ _ H0).
      elim orb_prop with (1:=M.for_all_true _ _ _ T _ _ H1); auto.
      intros; discriminate.
    Qed.

    Definition for_all_region1 (i0:PC) (test:PC->bool) : bool :=
      M.for_all
        (fun i m => (* let (i,kd):=ikd in *)
           negb (M.eq_key i0 i) ||
           M.for_all
             (fun j b => (negb b) || test j)
             m)
        reg.

    Lemma for_all_region1_true : forall i test,
      for_all_region1 i test = true ->
      forall j, region i j -> test j = true.
    Proof.
      unfold for_all_region1, region; intros.
      destruct H0 as [m [H0 H1]].
      assert (T:=M.for_all_true _ _ _ H _ _ H0).
      simpl in T.
      elim orb_prop with (1:=T); intros.
      generalize (M.eq_key_spec i i); destruct (M.eq_key i i); simpl in *; intros.
      discriminate.
      elim H3; auto.
      elim orb_prop with (1:=M.for_all_true _ _ _ H2 _ _ H1); auto.
      intros; discriminate.
    Qed.

    Definition for_all_region2 (i:PC) (*tau:Kind*) (test:PC->bool) : bool :=
      match M.get reg (i) with
        | None => true
        | Some m => M.for_all (fun j b => b && test j) m
      end.

    Lemma for_all_region2_true : forall test i,
      for_all_region2 i test = true ->
      forall j, region i j -> test j = true.
    Proof.
      unfold for_all_region2, region; intros.
      destruct H0 as [m [H0 H1]].
      rewrite H0 in H.
      assert (T:=M.for_all_true _ _ _ H _ _ H1).
      auto.
    Qed.

    Definition check_soap2 : bool :=
      for_all_region
        (fun i j =>
          for_all_succs j
            (fun ok =>
              match ok with
                | None => true
                | Some k => orb (in_region i k) (test_junc i k)
              end)).

    Lemma check_soap2_correct : check_soap2 = true ->
      forall i j k,
        region i j->
        step j (Some k) ->
        region i k \/ junc i k.
    Proof.
      unfold check_soap2; intros.
      generalize (for_all_region_true _ H _ _ H0); intros T.
      elim orb_prop with (1:=for_all_succs_true _ _ T _ H1); intros.
      left; apply in_region_true; auto.
      right; apply test_junc_true; auto.
    Qed.

    Definition test_all_region (test:PC->PC->bool) : list (PC*PC) :=
      M.fold
        (fun i m l =>
(*           let (i,kd):=ikd in *)
            M.fold
              (fun j (b:bool) l =>
                if b then
                  (if test i j then l else (i,j)::l)
                  else l)
              m l)
        reg nil.

    Definition test_soap2 : list (PC*PC) :=
      test_all_region
        (fun i j =>
          for_all_succs j
            (fun ok =>
              match ok with
                | None => true
                | Some k => orb (in_region i k) (test_junc i k)
              end)).

    Definition for_all_result (test:PC->bool) : bool :=
      for_all_steps
      (fun i oj =>
        match oj with
          | None => test i
          | Some _ => true
        end).

    Lemma for_all_result_true : forall test, for_all_result test = true ->
      forall i, result i -> test i = true.
    Proof.
      unfold for_all_result, result; intros.
(*       destruct H0 as [H0]. *)
      apply (for_all_steps_true _ H _ _ H0).
    Qed.

    Definition for_all_junc (test:PC->PC->bool) : bool :=
      M.for_all
        (fun i j => (* let (i,kd):=ikd in *)
           test i j)
        jun.

    Lemma for_all_junc_true : forall test,
      for_all_junc test = true ->
      forall i j, junc i j -> test i j = true.
    Proof.
      unfold for_all_junc, junc; intros.
      apply (M.for_all_true _ _ _ H _ _ H0).
    Qed.

    Definition for_all_junc1 (i0:PC) (test:PC->bool) : bool :=
      M.for_all
        (fun i j => (negb (M.eq_key i i0)) || (test j)(*M.for_all test m*))
        jun.

    Lemma for_all_junc1_true : forall i test,
      for_all_junc1 i test = true ->
      forall j, junc i j -> test j = true.
    Proof.
      unfold for_all_junc1, junc; intros.
      (* unfold M.get in H0.
      unfold M'.get in H0. *)
(*       simpl in H. *)
      (* case_eq (M.get jun i); intros.
      rewrite H1 in H0.       *)
      elim orb_prop with (1:=M.for_all_true _ _ _ H _ _ H0); intros; auto.
      generalize (M.eq_key_spec i i); destruct (M.eq_key i i); intuition.
      (* apply (M.for_all_true _ _ _ H1 _ _ H0).
      rewrite H1 in H0; discriminate. *)
    Qed.

    Definition check_soap3 : bool :=
      for_all_junc
      (fun i k =>
        (match M.get reg (i) with
           | None => true
           | Some m => M.for_all
             (fun j b =>
               (negb b) ||
                 (for_all_succs j
                   (fun ok =>
                     match ok with
                       | None => false
                       | Some k => true
                     end))) m
         end)).

    Lemma check_soap3_correct : check_soap3 = true ->
      forall i j k,
       region i j ->
       result j ->
       ~ junc i k.
    Proof.
      unfold check_soap3, region, result; red; intros.
      assert (HH:=(for_all_junc_true _ H _ _ H2)); clear H H2.
      destruct H0 as [m [H H2]].
(*       destruct H1 as [H1]. *)
      simpl in HH.
      rewrite H in HH.
      elim orb_prop with (1:=M.for_all_true _ _ _ HH _ _ H2); simpl; intros.
      discriminate.
      generalize (for_all_succs_true _ _ H0 _ H1); intros; discriminate.
    Qed.
(* DEX
    Definition check_soap4 : bool :=
      M1.for_all
      (fun i m =>
        M2.for_all
        (fun kd1 j1 =>
          M2.for_all
          (fun kd2 j2 =>
            (M1.eq_key j1 j2) ||
              (in_region i kd1 j2) ||
                (in_region i kd2 j1)
          ) m) m
      ) jun.

    Lemma check_soap4_correct : check_soap4 = true ->
      forall i j1 j2 kd1 kd2,
        junc i kd1 j1 ->
        junc i kd2 j2 ->
        j1=j2 \/ region i kd1 j2 \/ region i kd2 j1.
    Proof.
      unfold junc, check_soap4; intros H i j1 j2 kd1 kd2.
      unfold M.get, M'.get; simpl.
      case_eq (M1.get jun i); intros; try discriminate.
      generalize (M1.for_all_true _ _ _ H _ _ H0); intros.
      generalize (M2.for_all_true _ _ _ H3 _ _ H1); intros.
      generalize (M2.for_all_true _ _ _ H4 _ _ H2); intros.
      destruct (orb_prop _ _ H5); clear H5.
      destruct (orb_prop _ _ H6); clear H6.
      left.
      generalize (M1.eq_key_spec j1 j2); rewrite H5; auto.
      right; left; apply in_region_true; auto.
      right; right; apply in_region_true; auto.
    Qed.

    Definition check_soap5 : bool :=
      for_all_junc
      (fun i kd' k =>
        (match M1.get reg i with
           | None => true
           | Some m =>
             M2.for_all
             (fun kd m' =>
               M1.for_all
               (fun j b =>
                 (negb b) ||
                   (for_all_succs j
                     (fun tau ok =>
                       match ok with
                         | None => in_region i kd k
                         | Some _ => true
                       end)))
               m') m
         end)).

    Lemma check_soap5_correct : check_soap5 = true ->
      forall i j k kd kd',
        region i kd j ->
        result j ->
        junc i kd' k ->
        region i kd k.
    Proof.
      unfold check_soap5, result; intros.
      destruct H1 as [tau H1].
      generalize (for_all_junc_true _ H _ _ _ H2); clear H H2.
      intros T.
      destruct H0 as [m [Y2 Y3]].
      unfold M.get, M'.get in Y2.
      case_eq (M1.get reg i); intros; simpl in Y2; rewrite H in Y2; try discriminate.
      rewrite H in T.
      generalize (M2.for_all_true _ _ _ T _ _ Y2); clear T; intros T.
      generalize (M1.for_all_true _ _ _ T _ _ Y3); clear T; intros T.
      elim orb_prop with (1:=T); clear T; simpl.
      intros; discriminate.
      intros T; generalize (for_all_succs_true _ _ T _ _ H1).
      apply in_region_true.
    Qed.

    Definition check_soap5' : bool :=
      for_all_steps
        (fun i kd oj =>
          match oj with
            | Some _ => true
            | None =>
              (for_all_region1 i (fun kd' k => in_region i kd k))
              &&
              (for_all_junc1 i (fun kd' k => in_region i kd k))
          end).

    Lemma check_soap5'_correct : check_soap5' = true ->
      forall i k kd kd',
       step i kd None ->
       (region i kd' k \/ junc i kd' k) ->
       region i kd k.
    Proof.
      unfold check_soap5'; intros.
      elim andb_prop with (1:=for_all_steps_true _ H _ _ _ H0); intros.
      destruct H1; clear H.
      apply in_region_true.
      eapply (for_all_region1_true _ _ H2); eauto.
      apply in_region_true.
      eapply (for_all_junc1_true _ _ H3); eauto.
    Qed.
*)
    Definition check_soaps : bool :=
      check_junc_func &&
      check_soap1 &&
      check_soap2 &&
      check_soap3 (*&&
      check_soap4 &&
      check_soap5 &&
      check_soap5'*).

    Definition check_soaps' :=
      (check_junc_func,
        check_soap1,
        check_soap2,
        check_soap3(*,
        check_soap4,
        check_soap5,
        check_soap5'*)).

    Lemma check_soap_true :
      check_soaps = true ->
      { cdr : CDR step |
        forall i j, cdr.region cdr i j -> region i j }.
    Proof.
      unfold check_soaps; intros;
        repeat match goal with
                 [ id : _ && _ = true |- _ ] =>  destruct (andb_prop _ _ id); clear id
               end.
      exists (make_CDR step region junc
               (check_junc_func_correct H0)
               (check_soap1_correct H3)
               (check_soap2_correct H2)
               (check_soap3_correct H1)
               (*(check_soap4_correct H3)
               (check_soap5_correct H2)
               (check_soap5'_correct H1)*)).
      simpl; auto.
    Qed.

    Definition for_all_in_region : PC -> (PC->bool) -> bool :=
      fun i test =>
        match M.get reg (i) with
          | None => true
          | Some m =>
            M.for_all (fun j b => (negb b) || test j)
            m
        end.
    Lemma for_all_in_region_correct : forall i test,
      for_all_in_region i test = true ->
      forall j, region i j -> test j = true.
    Proof.
      unfold region, for_all_in_region; intros.
      destruct H0 as [m [H0 H1]].
      rewrite H0 in H.
      elim orb_prop with (1:=M.for_all_true _ _ _ H _ _ H1); simpl; intros.
      discriminate.
      auto.
    Qed.

  End region.

End Make.


(** printing sigma  %$\sigma$%   #σ#  *)
(** printing sigma0 %$\sigma_0$% #σ0# *)
(** printing sigma1 %$\sigma_1$% #σ1# *)

(** printing Sigma  %$\Sigma$%   #Σ#  *)
(** printing Sigma0 %$\Sigma_0$% #Σ0# *)
(** printing Sigma1 %$\Sigma_1$% #Σ1# *)

(** printing mm7  %$m_{-7}$%     #m-7#  *)
(** printing mm15 %$m_{-15}$%    #m-15# *)
(** printing mm2  %$m_{-2}$%     #m-2#  *)
(** printing m16  %$m_{16}$%     #m16# *)

(** printing oplus %$\oplus$%    #⊕#  *)

Require Import Verse.
Require Import Verse.CryptoLib.sha2.
Import Nat.
Require Import List.
Import ListNotations.

(** * SHA2 hashing algorithm.

We can now give a common iterator for both the sha512 and sha256
algorithm. It is implemented as a module parameterised over the
configuration module.

*)
Module SHA2 (C : CONFIG).

  Import C.

  Definition Word  := word WordSize.

  Definition Hash  := Array HASH_SIZE  hostE Word.
  Definition Block := Array BLOCK_SIZE bigE Word.

  Section Program.

    Variable v : VariableT.
    Arguments v [k] _.

    (** ** Program variables.

        We begin by defining the program variables. Recall that, the
        standard idiom of verse is to declare the parameters, local
        variables, and register variables in that order.

     *)

    (** *** Parameters

        SHA2 hashes are Merkel-Damgrad hash. Hence it needs only the
        hash of the previous blocks to process the current block. Thus
        there is only one parameter for the hash function namely the
        hash of the previous block.

     *)

    Variable hash : v Hash.

    Definition parameters : Declaration := [ Var hash ]%vector.

    (** *** Local variables.

        We keep the current block in a set of local variables. The
        advantage of this is that on a register rich machine all of
        them could be allocated in registers and thus could be faster.

     *)

    Variable w0 w1 w2 w3 w4 w5 w6 w7 w8 w9 w10 w11 w12 w13 w14 w15 : v Word.

    Definition message_variables
      := [w0; w1; w2; w3; w4; w5; w6; w7; w8; w9; w10; w11; w12; w13; w14; w15]%vector.

    Definition locals : Declaration := Vector.map Var message_variables.

    Definition W : VarIndex v BLOCK_SIZE Word := varIndex message_variables.
    Definition LOAD_BLOCK (blk : v Block) := loadCache blk W.

    (** ** The state and temporary variables.

        We choose to put them in registers as there are the variables
        that are frequently used.

     *)

    Variable a b c d e f g h : v Word.
    Variable t tp temp       : v Word.

    Definition state_variables := [ a ; b ; c ; d ; e ; f ; g ; h ]%vector.

    Definition registers : Declaration :=
      Vector.map Var (Vector.append state_variables [ t ; tp ; temp]%vector).

    Definition STATE : VarIndex v HASH_SIZE Word := varIndex state_variables.
    Definition LOAD_STATE : code v := loadCache hash STATE.

  (** * The hash transformation.

      The hashing algorithm transforms a state consisting of
      [HASH_SIZE] many [Word]s into [ROUNDS] many rounds. Each round
      uses a message word that is scheduled for that particular
      round. This section builds code towards implementing these.

   *)

    Section HashTransformation.

      (* The hash transformation is parameterised over the round [r]
      *)

      Variable r : nat.
      Variable rBoundPf : r < ROUNDS.

      (* ** Message scheduling.

         Although the message scheduling requires [ROUNDS] many
         values, we only need to keep track of a window of 16 values.
         This is because each the rth step requires only the rth
         message word and the subsequent message schedule requries
         only the previous 16 messages.

       *)

      Definition M : v Word.
        verse (W (r mod BLOCK_SIZE) _).
      Defined.

      (** This defines M(r - j) *)
      Definition MM (j : nat) : v Word.
        verse (W ((r + 16 - j) mod BLOCK_SIZE) _).
      Defined.

      (**

   The message schedule [m16 = m0 + mm7 + sigma0 (mm15) +  sigma1(mm2) ],
   requires computing the sigma functions of the form

   [ sigma(x) = RotR(x, r0) oplus RotR(x, r1) oplus ShiftR(x, s)]

   These functions can be implemented using a single temporary
   variable by updating them using the following telescopic values.

   [ RotR(x, r2 - r1) ]

   [ RotR(x, r2 - r1) oplus x]

   [ RotR(x, r2 - r0) oplus RotR(x, r1 - r0) oplus x]

   [ RotR(x, r2) oplus RotR(x, r1) oplus Rot(x, r0)]

   At each step the temporary variables need to be rotated and then
   xord by x. This message schedule is give by the following code.

       *)

      Definition SCHEDULE :=
        let sigma (r0 r1 s : nat)(x : v Word) :=
            [ t ::= x >>> (r1 - r0); t    ::=^ x;
              t ::=>>>    r0       ; tp   ::=  x >> s;
              t ::=^ tp            ; M    ::=+ t
            ]%list in

        let sigma0 := sigma r00 r01 s0 (MM 15) in
        let sigma1 := sigma r10 r11 s1 (MM 2) in
        [ M ::=+ MM 7 ] ++ sigma0 ++ sigma1.

      (** ** Individual rounds.

      The state of the hash function is kept track of in the set of
      variables a-h, and in the rth round the update is given by

       *)

      (**

<>

where

[t1 = h + k + m + Sigma1(e) + CH e f g]

[t2 = Sigma0(a) + MAJ a b c]

       *)

      (** So in each round we compute the following

[ temp = h + k + m + Sigma1(e) + CH(e,f,g)]

[d += temp;]

[ h = temp + Sigma0(a) + MAJ(a,b,c);]

       *)

      Definition ST (i : nat) : v Word.
        verse(
            let negr := HASH_SIZE - (r mod HASH_SIZE) in
            let idx  := i + negr in
            STATE (idx mod HASH_SIZE) _).
      Defined.

      Definition K : constant Word :=  Vector.nth_order KVec rBoundPf.

      Definition STEP : code v :=
        let A := ST 0 in
        let B := ST 1 in
        let C := ST 2 in
        let D := ST 3 in
        let E := ST 4 in
        let F := ST 5 in
        let G := ST 6 in
        let H := ST 7 in
        let Sigma r0 r1 r2 x :=
            [ t ::= x >>> (r2 - r1); t  ::=^ x;
              t ::=>>> (r1 - r0);    t ::=^ x;
              t ::=>>> r0; temp ::=+ t
            ]%list in
        let Sigma0 := Sigma R00 R01 R02 A in
        let Sigma1 := Sigma R10 R11 R12 E in
        let CH :=
            [ tp ::=~ E;
              tp ::=& G;
              t ::= E & F; t ::=^ tp; temp ::=+ t] in
        let MAJ :=
            [ t  ::=  B | C;
              t  ::=& A;
              tp ::=  B & C;
              t  ::=| tp
            ] in
        [ temp ::= H + K ; temp ::=+ M ]
          ++ CH ++  Sigma1        (* temp = H + K + M + CH e f g + σ₁(e) *)
          ++ [ D ::=+ temp ]
          ++ Sigma0               (* temp = H + K + M + CH e f g + σ₁(e) + σ₀(a) *)
          ++ MAJ
          ++ [ H ::= temp + t ]. (* h =  temp + MAJ a b c *)

      Definition UPDATE_ITH (i : nat) (pf : i < HASH_SIZE) : code v.
        verse ([STATE i _ ::=+ hash [- i -]]).
      Defined.

      Definition UPDATE : code v
        := foreach (indices hash) UPDATE_ITH ++ moveBackCache hash STATE.

      Definition Round : code v :=
        if leb r (ROUNDS - BLOCK_SIZE - 1) then STEP ++ SCHEDULE else STEP.

    End HashTransformation.

    Definition ALL_ROUNDS : code v := iterate Round.
    Definition sha2 : iterator Block v :=
      {|
        setup   := LOAD_STATE;
        process := fun block => (LOAD_BLOCK block
                                         ++ ALL_ROUNDS
                                         ++ UPDATE);
        finalise := [ ]
      |}.
  End Program.
End SHA2.