From Coq Require Import NArith.BinNat Relations.Relations MSets.MSets
         MSets.MSetRBT Lists.List omega.Omega Sets.Ensembles Relations.Relations
         Classes.Morphisms Sorting.Permutation.
From SFS Require Import Ensembles_util functions List_util cps set_util.
From SFS Require Import heap.
From SFS Require Import Coqlib.

Import ListNotations.

Close Scope Z_scope.

Module MHeap : Heap.

  Definition loc := positive.

  Record heap' (block : Type) :=
    mkHeap
      { mheap : M.t block;
        mdom : Ensemble positive;
        mdom_spec : forall x, x \in mdom <-> exists v, M.get x mheap = Some v;
        next : positive;
        next_spec : forall x, (next <= x)%positive -> M.get x mheap = None }.

  Definition heap block := heap' block.

  Program Definition emp (A : Type) := mkHeap A (M.empty A) (Empty_set _) _ 1 _.
  Next Obligation.
    split; intros; try (zify; omega).
    inv H.
    destruct H as [v Hgetv].
    rewrite M.gempty in Hgetv. congruence.
  Qed.
  Next Obligation.
    rewrite M.gempty. congruence.
  Qed.

  Definition get {A : Type} l (h : heap A) : option A :=
    M.get l (mheap A h).

      Definition in_dom {A : Type} l h : {l \in mdom A h} + {~ l \in mdom A h}.
  Proof.
    destruct (get l h) eqn:Hget.
    - destruct h. unfold get in *. left. simpl in *.
      eapply mdom_spec0. eexists; eauto.
    - destruct h. unfold get in *. right. simpl in *.
      intros Hc. eapply mdom_spec0 in Hc. destruct Hc.
      congruence.
  Qed.

  Program Definition set {A : Type} v l h : option (heap A) :=
    match in_dom l h with
      | left Hin =>
        Some (mkHeap A (M.set l v (mheap A h)) (mdom A h) _ (next A h) _)
      | right Hnin => None
    end.
  Next Obligation.
    clear Heq_anonymous.
    destruct (peq x l); subst.
    - rewrite M.gss. split; eauto.
    - rewrite M.gso; [| eassumption ].
      eapply h.
  Qed.
  Next Obligation.
    clear Heq_anonymous.
    destruct (peq x l); subst.
    - destruct h as [h1 d1 dspec1 f1 fspec1].
      simpl in *. eapply fspec1 in H. eapply dspec1 in Hin.
      destruct Hin. congruence.
    - rewrite M.gso; eauto. eapply h. eassumption.
  Qed.

  Program Definition alloc {A : Type} (v : A) (h : heap A) :=
    let l := next A h in
    (l, mkHeap A (M.set l v (mheap A h)) (l |: mdom A h) _ ((next A h) + 1) _).
  Next Obligation.

    destruct (peq x (next A h)); subst.
    - rewrite M.gss. split; eauto.
    - rewrite M.gso; eauto. split; intros H.
      inv H. inv H0; contradiction.
      eapply h; eauto.

      right; eapply h; eauto.
  Qed.
  Next Obligation.

    destruct (peq x (next A h)); subst.
    - zify; omega.
    - rewrite M.gso; eauto. eapply h.
      zify; omega.
  Qed.

  Lemma emp_get A l : @get A l (@emp A) = None.
  Proof.
    unfold emp. unfold get. simpl. rewrite  M.gempty. reflexivity.
  Qed.

  Lemma gss A v l h h' :
    @set A v l h = Some h' ->
    @get A l h' = Some v.
  Proof.
    intros Hs. unfold set in Hs.
    destruct (in_dom l h).
    - inv Hs. unfold get. simpl. rewrite M.gss.
      reflexivity.
    - congruence.
  Qed.

  Lemma gso A v l l' h h' :
    @set A v l h = Some h' ->
    l <> l' ->
    @get A l' h' = @get A l' h.
  Proof.
    intros Hs Hneq. unfold set in Hs.
    destruct (in_dom l h).
    - inv Hs. unfold get. simpl. rewrite M.gso.
      reflexivity. intros Hc; subst; eauto.
    - congruence.
  Qed.

  Lemma gas (A : Type) (x : A) l (H H' : heap A) :
    alloc x H = (l, H') -> get l H' = Some x.
  Proof.
    intros Ha.
    unfold alloc, get in *. inv Ha. simpl.
    rewrite M.gss. reflexivity.
  Qed.

  Lemma gao (A : Type) (x : A) l1 l2 (H H' : heap A) :
    l1 <> l2 ->
    alloc x H = (l1, H') ->
    get l2 H' = get l2 H.
  Proof.
    intros Hneq Ha.
    unfold alloc, get in *. inv Ha. simpl.
    rewrite M.gso. reflexivity. eauto.
  Qed.

  Lemma alloc_fresh (A : Type) (x : A) (l : loc) (H H' : heap A) :
    alloc x H = (l, H') -> get l H = None.
  Proof.
    intros Ha.
    unfold alloc, get in *. inv Ha. eapply H.
    zify; omega.
  Qed.

  (** Subheap *)
  Definition subheap {A} (H1 H2 : heap A) :=
    forall x v, get x H1 = Some v -> get x H2 = Some v.

  Infix "⊑" := subheap (at level 70, no associativity).

  (** Extensional equality of heaps *)
  Definition heap_eq {A} (S : Ensemble loc) (H1 H2 : heap A) :=
    forall x, x \in S -> get x H1 = get x H2.

  Notation  "S |- H1 ≡ H2" := (heap_eq S H1 H2) (at level 70, no associativity).

  (** Domain *)
  Definition dom {A} (H : heap A) : Ensemble loc :=
    domain (fun l => get l H).

  Definition restrict (A : Type) S (H1 H2 : heap A) : Prop :=
    H2 ⊑ H1 /\
    dom H2 <--> dom H1 :&: S.

  Lemma restrict_subheap (A : Type) (S : Ensemble loc) (H1 H2 : heap A) :
    restrict A S H1 H2 -> H2 ⊑ H1.
  Proof.
    intros Hr. destruct Hr; eauto.
  Qed.

  Lemma restrict_In (A : Type) (l : loc) (S : Ensemble loc) (H H' : heap A) :
     restrict A S H H' -> In loc S l -> get l H' = get l H.
  Proof.
    intros [Hsub Hdom] Hin. unfold subheap in *.
    destruct (get l H') as [b1|] eqn:Hget.
    - symmetry. eauto.
    - destruct (get l H) as [b2|] eqn:Hget'; eauto.
      assert (Hc : l \in dom H :&: S).
      { constructor; eauto. eexists; eauto. }
      eapply Hdom in Hc.
      destruct Hc as [l' Hgetc']. congruence.
  Qed.

  Lemma restrict_notIn (A : Type) (l : loc) (S : Ensemble loc) (H H' : heap A) :
    restrict A S H H' -> ~ In loc S l -> get l H' = None.
  Proof.
    intros [Hsub Hdom] Hin. unfold subheap in *.
    destruct (get l H') as [b1|] eqn:Hget; eauto.

    assert (Hc : l \in dom H :&: S).
    { eapply Hdom. eexists; eauto. }

    inv Hc; contradiction.
  Qed.

  Definition restrict_map {A : Type} (S : Ensemble loc) {Hs : Decidable S} (m : M.t A) :=
    M.fold (fun mr x v => if @Dec _ S _ x then mr else M.remove x mr) m m.

  Lemma Sublist_refl A (l : list A) :
    Sublist l l.
  Proof.
    induction l; eauto.
    - now constructor.
    - constructor 3; eauto.
  Qed.

  Lemma restrict_map_submap_strong (A : Type) (S : Ensemble loc) {Hs : Decidable S} (m : M.t A) x v l :
    incl l (M.elements m) ->
    list_norepet (map fst l) ->
    M.get x (fold_left
               (fun (a : M.t A) (p : positive * A) =>
                  if Dec (fst p) then a else M.remove (fst p) a) l m) = Some v ->
    M.get x m = Some v.
  Proof.
    revert m.
    induction l as [| [l1 v1] l IHl1]; intros m Hspec Hr Hget.
    - eassumption.
    - simpl in Hget. simpl in *.
      destruct (@Dec positive S Hs l1).
      * inv Hr. eapply IHl1; eauto.
        intros y Hin.
        assert (Hin' : List.In y ((l1, v1) :: l)) by now right.
        eapply Hspec in Hin'. eassumption.
      * { eapply IHl1 in Hget; try eauto.
          - destruct (peq x l1).
            subst. rewrite M.grs in Hget. congruence.
            rewrite M.gro in Hget; eassumption.
          - intros y Hin.
            assert (Hin' : List.In y ((l1, v1) :: l)) by now right.
            eapply Hspec in Hin'.

            destruct y as [l2 v2].
            eapply M.elements_complete in Hin'.
            eapply M.elements_correct.
            rewrite M.gro. eassumption.
            intros Hceq; subst. inv Hr. eapply H1.

            eapply in_map with (f := fst) in Hin. eassumption.

          - inv Hr. eassumption.  }
  Qed.

  Lemma restrict_map_same_strong (A : Type) (S : Ensemble loc) {Hs : Decidable S} (m : M.t A) x v l :
    incl l (M.elements m) ->
    list_norepet (map fst l) ->
    x \in S ->
    M.get x m = Some v ->
    M.get x (fold_left
               (fun (a : M.t A) (p : positive * A) =>
                  if Dec (fst p) then a else M.remove (fst p) a) l m) = Some v.
  Proof.
    revert m.
    induction l as [| [l1 v1] l IHl1]; intros m Hspec Hr Hin Hget.
    - eassumption.
    - simpl in Hget. simpl in *.
      destruct (@Dec positive S Hs l1).
      * inv Hr. eapply IHl1; eauto.
        intros y Hin'.
        assert (Hin'' : List.In y ((l1, v1) :: l)) by now right.
        eapply Hspec in Hin''. eassumption.
      * { eapply IHl1; try eauto.
          - intros y Hin1.
            assert (Hin' : List.In y ((l1, v1) :: l)) by now right.
            eapply Hspec in Hin'.

            destruct y as [l2 v2].
            eapply M.elements_complete in Hin'.
            eapply M.elements_correct.
            rewrite M.gro. eassumption.
            intros Hceq; subst. inv Hr. eapply H1.

            eapply in_map with (f := fst) in Hin1. eassumption.

          - inv Hr. eassumption.
          - rewrite M.gro. eassumption. intros Hc; subst. contradiction. }
  Qed.

  Corollary restrict_map_submap (A : Type) (S : Ensemble loc) {Hs : Decidable S} (m : M.t A) x v :
    M.get x (restrict_map S m) = Some v -> M.get x m = Some v.
  Proof.
    unfold restrict_map. rewrite M.fold_spec.
    eapply restrict_map_submap_strong. now (clear; firstorder).
    eapply Maps.PTree.elements_keys_norepet.
  Qed.

  Lemma restrict_map_spec (A : Type) (S : Ensemble loc) {Hs : Decidable S} (m : M.t A) x v :
    M.get x (restrict_map S m) = Some v <-> x \in S /\ M.get x m = Some v.
  Proof.
    assert (Hsuf :
              (x, v) \in FromList (M.elements m) /\ M.get x (restrict_map S m) = Some v <->
              (x, v) \in FromList (M.elements m) /\ x \in S /\ M.get x m = Some v).
    { unfold restrict_map. rewrite M.fold_spec.
      assert (Hsub : incl (M.elements m) (M.elements m)) by (clear; firstorder).

      assert (Hnd  : list_norepet (map fst (M.elements m))).
      { eapply Maps.PTree.elements_keys_norepet. }

      revert Hsub Hnd. generalize (M.elements m) at 1 3 4 5 6. intros l. revert m.
      induction l as [| [l1 v1] l IHl1]; intros m Hspec Hr.
      - simpl. rewrite FromList_nil. split; intros [H1 H2]; now inv H1.
      - simpl. rewrite FromList_cons.
        inv Hr. split.
        + destruct (@Dec _ S _ l1).
          * { intros [Hget1 Hget2].
              inv Hget1.
              - inv H. subst. split; eauto. split; eauto.
                eapply M.elements_complete. eapply Hspec. now constructor.

              - split. now right. eapply IHl1; try eassumption.

                intros y Hin.
                assert (Hin' : List.In y ((l1, v1) :: l)) by now right.
                eapply Hspec in Hin'. eassumption.

                split. eassumption. eassumption. }
          * { simpl. intros [Hget1 Hget2].
              destruct (peq l1 x); subst.
              - (* extra lemma + congruence *)
                eapply restrict_map_submap_strong in Hget2; try eassumption.
                rewrite M.grs in Hget2. congruence.
                intros [l2 v2] Hin2.
                assert (Hin' : List.In (l2, v2)  ((x, v1) :: l)) by now right.
                eapply Hspec in Hin'. eapply M.elements_complete in Hin'.
                eapply M.elements_correct. rewrite M.gro. eassumption.
                intros Hc; subst. eapply H1. eapply in_map with (f := fst) in Hin2.
                eassumption.
              - inv Hget1. inv H; contradiction.
                split. now right.
                assert (Ha := conj H Hget2).
                eapply IHl1 in Ha; try eassumption.
                destruct Ha as [_ [HinS Heq]]. split; eauto. rewrite M.gro in Heq. eassumption.

                intros Hc; subst. rewrite M.grs in Heq. congruence.

                intros [l2 v2] Hin.
                assert (Hin' : List.In (l2, v2) ((l1, v1) :: l)) by now right.
                eapply M.elements_correct. rewrite M.gro.
                eapply M.elements_complete. eapply Hspec. now right.
                intros Hc. subst. eapply H1. eapply in_map with (f := fst) (x := (l1, v2)).
                eassumption. }
        + intros [Hin1 [Hin2 Hget1]].
          inv Hin1.
          * inv H.
            destruct (@Dec _ S _ x); try contradiction.

            split. now left.
            eapply restrict_map_same_strong; try eassumption.

            intros [l2 v2] Hin. eapply Hspec. now right.
          * assert (Hc : x <> l1).
            { intros Hc. subst. eapply H1. eapply in_map with (f := fst) (x := (l1, v)).
              eassumption. }

            split. now right.
            eapply IHl1; try eassumption.

            intros [l2 v2] Hin.
            assert (Hin' : List.In (l2, v2) ((l1, v1) :: l)) by now right.
            eapply Hspec in Hin'. eapply M.elements_complete in Hin'.
            eapply M.elements_correct.
            destruct (@Dec _ S _ l1); [ eassumption | ]. rewrite M.gro. eassumption.
            intros Hc'; subst.
            eapply H1. eapply in_map with (f := fst) (x := (l1, v2)).
            eassumption.

            split. eassumption. split. eassumption.

            destruct (@Dec _ S _ l1); [ eassumption | ]. rewrite M.gro; eassumption. }

    split; intros H; eapply Hsuf.
    - split; eauto.
      eapply M.elements_correct. eapply restrict_map_submap. eassumption.
    - split; eauto. destruct H.
      eapply M.elements_correct. eassumption.
  Qed.

  Program Definition restrict_heap A (S : Ensemble loc) {Hs : Decidable S} (h : heap A) : heap A :=
    mkHeap A (restrict_map S (mheap A h)) (mdom A h :&: S) _ (next A h) _.
  Next Obligation.
    split.
    - intros [y H1 H2].
      eapply h in H1. destruct H1 as [v Hget2].
      assert (Hand := conj H2 Hget2). eapply restrict_map_spec in Hand.
      eexists; eassumption.
    - intros [v Hin]. eapply restrict_map_spec in Hin. destruct Hin. split; eauto.
      eapply h.  eexists; eauto.
  Qed.
  Next Obligation.
    eapply h in H.
    destruct (M.get x (restrict_map S (mheap A h))) eqn:Hget; eauto.
    eapply restrict_map_spec in Hget. destruct Hget. congruence.
  Qed.

  Lemma restrict_exists (A : Type) (S : Ensemble loc) (H : heap A) :
    Decidable S -> exists H' : heap A, restrict A S H H'.
  Proof.
    intros Hs. eexists (restrict_heap A S H).
    split.
    - intros x v Hget. eapply restrict_map_spec. eassumption.
    - split.
      + intros x [c Hget]. eapply restrict_map_spec in Hget.
        destruct Hget. split; eauto. eexists; eauto.
      + intros y [l [v Hd] Hin]. eexists.
        eapply restrict_map_spec. split; eauto.
  Qed.

  Definition heap_elements {A : Type} (H : heap A) : list (loc * A) :=
    M.elements (mheap A H).

   Lemma heap_elements_sound (A : Type) (h : heap A) (l : loc) (v : A) :
     List.In (l, v) (heap_elements h) -> get l h = Some v.
   Proof.
     intros Hin. unfold heap_elements, get in *.
     eapply M.elements_complete. eassumption.
   Qed.

   Lemma heap_elements_complete (A : Type) (h : heap A) (l : loc) (v : A) :
     get l h = Some v -> List.In (l, v) (heap_elements h).
   Proof.
     intro Hget. unfold heap_elements, get in *. eapply M.elements_correct.
     eassumption.
   Qed.

   Lemma list_norepet_NoDup A B (l : list (A * B)) :
     list_norepet (map fst l) ->
     NoDup l.
   Proof.
     induction l; intros Hnr.
     now constructor.
     simpl in Hnr. inv Hnr. constructor; [| now eauto ].
     intros Hc. eapply H1. eapply in_map. eassumption.
   Qed.

   Lemma heap_elements_NoDup (A : Type) (h : heap A) : NoDup (heap_elements h).
   Proof.
     unfold heap_elements.
     eapply list_norepet_NoDup. eapply M.elements_keys_norepet.
   Qed.

   Lemma NoDup_filter (A : Type) P (l : list A) :
     NoDup l -> NoDup (filter P l).
   Proof.
     intros Hnd; induction l. now constructor.
     inv Hnd. simpl. destruct (P a); eauto. constructor; eauto.
     intros Hc. eapply H1.
     eapply filter_In. eassumption.
   Qed.

   Lemma filter_eq A P1 P2 (l : list A) :
     (forall x, P1 x = P2 x) ->
     filter P1 l = filter P2 l.
   Proof.
     intros Heq. induction l; eauto.
     simpl. rewrite Heq, IHl. reflexivity.
   Qed.

   Definition heap_elements_filter {A : Type} S {Hs : ToMSet S} (h : heap A) : list (loc * A) :=
     filter (fun p => @Dec _ S _ (fst p)) (heap_elements h).

   Lemma heap_elements_filter_sound (A : Type) (S : Ensemble loc) (H : ToMSet S)
         (h : heap A) (l : loc) (v : A) :
     List.In (l, v) (heap_elements_filter S h) ->
     get l h = Some v /\ In loc S l.
   Proof.
     intros Hin. unfold heap_elements_filter in *. eapply filter_In in Hin.
     destruct Hin as [Hin Hdec]. simpl in *.
     split. eapply heap_elements_sound; eassumption.

     eapply proj_sumbool_true in Hdec. eassumption.
   Qed.

   Lemma heap_elements_filter_complete (A : Type) (S : Ensemble loc) (H : ToMSet S)
         (h : heap A) (l : loc) (v : A) :
     get l h = Some v ->
     In loc S l -> List.In (l, v) (heap_elements_filter S h).
   Proof.
     intros Hget Hin. unfold heap_elements_filter in *. eapply filter_In.
     split. eapply heap_elements_complete; eassumption.
     simpl.
     eapply proj_sumbool_is_true. eassumption.
   Qed.

   Lemma heap_elements_filter_NoDup (A : Type) (S : Ensemble loc) (H : ToMSet S) (h : heap A) :
     NoDup (heap_elements_filter S h).
   Proof.
     eapply NoDup_filter. eapply heap_elements_NoDup; eassumption.
   Qed.

   Lemma heap_elements_filter_set_Equal (A : Type) (S1 : Ensemble loc) (H1 : ToMSet S1)
             (S2 : Ensemble loc) (H2 : ToMSet S2) (h : heap A) :
     S1 <--> S2 ->
     heap_elements_filter S1 h = heap_elements_filter S2 h.
   Proof.
     intros Heq. eapply filter_eq. intros x.

     destruct (@Dec positive S1 _ (fst x));
     destruct (@Dec positive S2 _ (fst x)); eauto.
     - assert (Hs' : S2 (fst x)). eapply Heq. eassumption.
       contradiction.
     - assert (Hs' : S1 (fst x)). eapply Heq. eassumption.
       contradiction.
   Qed.

   Definition heap_elements_minus {A : Type} S {Hs : ToMSet S} (h : heap A) : list (loc * A) :=
     filter (fun p => match @Dec _ S _ (fst p) with
                   | left _ => false
                   | right _ => true
                   end) (heap_elements h).

   Lemma heap_elements_minus_sound (A : Type) (S : Ensemble loc) (H : ToMSet S)
         (h : heap A) (l : loc) (v : A) :
     List.In (l, v) (heap_elements_minus S h) ->
     get l h = Some v /\ ~ In loc S l.
   Proof.
     intros Hin. unfold heap_elements_minus in *. eapply filter_In in Hin.
     destruct Hin as [Hin Hdec]. simpl in *.
     split. eapply heap_elements_sound; eassumption.

     destruct (@Dec positive S _ l); eauto. congruence.
   Qed.

   Lemma heap_elements_minus_complete (A : Type) (S : Ensemble loc) (H : ToMSet S)
         (h : heap A) (l : loc) (v : A) :
     get l h = Some v ->
     ~ In loc S l -> List.In (l, v) (heap_elements_minus S h).
   Proof.
     intros Hget Hin. unfold heap_elements_minus in *. eapply filter_In.
     split. eapply heap_elements_complete; eassumption.
     simpl.
     destruct (@Dec positive S _ l); eauto.
   Qed.

   Lemma heap_elements_minus_NoDup (A : Type) (S : Ensemble loc) (H : ToMSet S) (h : heap A) :
     NoDup (heap_elements_minus S h).
   Proof.
     eapply NoDup_filter. eapply heap_elements_NoDup; eassumption.
   Qed.

   Lemma heap_elements_minus_set_Equal (A : Type) (S1 : Ensemble loc) (H1 : ToMSet S1)
         (S2 : Ensemble loc) (H2 : ToMSet S2) (h : heap A) :
     S1 <--> S2 ->
     heap_elements_minus S1 h = heap_elements_minus S2 h.
   Proof.
     intros Heq. eapply filter_eq. intros x.

     destruct (@Dec positive S1 _ (fst x));
       destruct (@Dec positive S2 _ (fst x)); eauto.
     - assert (Hs' : S2 (fst x)). eapply Heq. eassumption.
       contradiction.
     - assert (Hs' : S1 (fst x)). eapply Heq. eassumption.
       contradiction.
   Qed.

   Definition size {A : Type} (h : heap A) : nat := List.length (heap_elements h).

   Definition size_with_measure {A : Type} (f : A -> nat) (h : heap A) : nat :=
     fold_left (fun acc h => acc + f (snd h)) (heap_elements h) 0%nat.

   Definition size_with_measure_filter {A : Type}
              (f : A -> nat) (S : Ensemble loc) {H : ToMSet S}  (h : heap A) : nat :=
     fold_left (fun acc h => acc + f (snd h)) (heap_elements_filter S h) 0%nat.

   Definition max_with_measure {A : Type} (f : A -> nat) (h : heap A) : nat :=
     fold_left (fun acc h => max acc (f (snd h))) (heap_elements h) 0%nat.

   Definition max_with_measure_filter {A : Type}
              (f : A -> nat) (S : Ensemble loc) {H : ToMSet S} (h : heap A) : nat :=
     fold_left (fun acc h => max acc (f (snd h))) (heap_elements_filter S h) 0%nat.

   Definition size_with_measure_minus {A : Type}
              (f : A -> nat) (S : Ensemble loc) {H : ToMSet S}  (h : heap A) : nat :=
     fold_left (fun acc h => acc + f (snd h)) (heap_elements_minus S h) 0%nat.

End MHeap.


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

Require Export Eqdep.
(* The lemma uniq is taken from Bruno Barras , see coq-club msg # Fri, 17 May 2002 17:17:49 +0200
   It does not require any axiom because equality over nat is decidable *)
Require Export Eqdep_dec.
(* required for vcons *)
Require Export Peano_dec.
Require Export Omega.

Axiom proof_irr : forall (A : Prop) (p q : A), p = q.

Lemma two_step_ind :
 forall P : nat -> Prop,
 P 0 -> P 1 -> (forall n : nat, P n -> P (S (S n))) -> forall n : nat, P n.
intros P h0 h1 hr n; cut (P n /\ P (S n)).
intros H; elim H; trivial.
elim n.
split; trivial.
intros n0 H; try assumption.
elim H.
intros H0 H1; try assumption.
split; [ trivial | apply hr; trivial ].
Qed.

Section vect_def.
Variable A : Set.

Inductive vect : nat -> Set :=
  | vnil : vect 0
  | vcons : forall n : nat, A -> vect n -> vect (S n).

Lemma uniq : forall v : vect 0, v = vnil.
intros v.
change (v = eq_rec _ vect vnil _ (refl_equal 0)) in |- *.
generalize (refl_equal 0).
change
  ((fun (n : nat) (v : vect n) =>
    forall e : 0 = n, v = eq_rec _ vect vnil _ e) 0 v)
 in |- *.
case v; intros.
apply K_dec_set with (p := e).
exact eq_nat_dec.
reflexivity.
discriminate e.
Qed.
(* These two following theorems are derived from the hardware contrib of Coq *)

Definition eq_vect := eq_dep nat vect.

Lemma decompose_dep :
 forall n m : nat,
 m = S n ->
 forall v : vect (S n),
 {a : A &  {v' : vect n | eq_vect (S n) v (S n) (vcons n a v')}}.
intros n m H v.
generalize H; clear H.
dependent inversion_clear v
 with
  (fun (n' : nat) (vl : vect n') =>
   m = n' -> {a : A &  {v' : vect n | eq_vect n' vl (S n) (vcons n a v')}}).
unfold eq_vect in |- *.
intros H; exists a; exists v0.
apply eq_dep_intro.
Qed.

Lemma decompose :
 forall (n : nat) (v : vect (S n)),
 {a : A &  {v' : vect n | v = vcons n a v'}}.
intros n v.
cut {a : A &  {t : vect n | eq_vect (S n) v (S n) (vcons n a t)}}.
intros H; elim H; clear H.
intros a H; elim H; clear H.
intros v' H.
exists a; exists v'.
apply eq_dep_eq with (U := nat) (P := vect) (p := S n).
unfold eq_vect in H; trivial.
apply (decompose_dep n (S n)); trivial.
Qed.
(* end of hardware contrib *)

Lemma eq_vect_vcons :
 forall (c n : nat) (vc : vect c) (vn : vect n) (a a' : A),
 a = a' ->
 eq_vect c vc n vn -> eq_vect (S c) (vcons c a vc) (S n) (vcons n a' vn).
intros c n vc vn a a' H H'.
rewrite H.
cut (eq_vect (S c) (vcons c a' vc) (S c) (vcons c a' vc)).
intros Hcut.
unfold eq_vect in |- *.
apply
 (eq_dep_ind nat vect c vc
    (fun (n0 : nat) (v0 : vect n0) =>
     eq_dep nat vect (S c) (vcons c a' vc) (S n0) (vcons n0 a' v0)) Hcut n vn
    H').
unfold eq_vect in |- *; apply eq_dep_intro.
Qed.

Lemma vcons_lemma :
 forall (n : nat) (x y : A) (xs ys : vect n),
 x = y -> xs = ys -> vcons n x xs = vcons n y ys.
intros n x y xs ys Hxy Hxsys.
rewrite Hxy.
rewrite Hxsys.
trivial.
Qed.
(* recursion principles *)

Lemma induc1 :
 forall P : forall n : nat, vect n -> Prop,
 P 0 vnil ->
 (forall (n : nat) (v : vect n), P n v -> forall a : A, P (S n) (vcons n a v)) ->
 forall (n : nat) (v : vect n), P n v.
intros P Hnil Hvcons n.
elim n.
intros v.
replace v with vnil; [ idtac | rewrite uniq; auto ].
exact Hnil.
intros n0 HR v.
elim (decompose n0 v).
intros ve Hve; elim Hve; intros xe Heq.
rewrite Heq.
apply Hvcons.
apply HR.
Qed.

Lemma induc2 :
 forall P : forall n : nat, vect n -> vect n -> Prop,
 P 0 vnil vnil ->
 (forall (n : nat) (v v' : vect n),
  P n v v' -> forall a b : A, P (S n) (vcons n a v) (vcons n b v')) ->
 forall (n : nat) (v v' : vect n), P n v v'.
intros P Hnil Hvcons n.
elim n.
intros v v'.
replace v with vnil; [ idtac | rewrite uniq; auto ].
replace v' with vnil; [ idtac | rewrite uniq; auto ].
exact Hnil.
intros n0 HR v v'.
elim (decompose n0 v).
intros ve Hve; elim Hve; intros xe Heq.
rewrite Heq.
elim (decompose n0 v').
intros ve' Hve'; elim Hve'; intros xe' Heq'.
rewrite Heq'.
apply Hvcons.
apply HR.
Qed.

Lemma induc3 :
 forall P : forall n : nat, vect n -> vect n -> vect n -> Prop,
 P 0 vnil vnil vnil ->
 (forall (n : nat) (v v' v'' : vect n),
  P n v v' v'' ->
  forall a b c : A, P (S n) (vcons n a v) (vcons n b v') (vcons n c v'')) ->
 forall (n : nat) (v v' v'' : vect n), P n v v' v''.
intros P Hvnil Hvcons n.
elim n.
intros v v' v''.
replace v with vnil; [ idtac | rewrite uniq; auto ].
replace v' with vnil; [ idtac | rewrite uniq; auto ].
replace v'' with vnil; [ idtac | rewrite uniq; auto ].
exact Hvnil.
intros n0 HR v v' v''.
elim (decompose n0 v).
intros ve Hve; elim Hve; intros xe Heq.
rewrite Heq.
elim (decompose n0 v').
intros ve' Hve'; elim Hve'; intros xe' Heq'.
rewrite Heq'.
elim (decompose n0 v'').
intros ve'' Hve''; elim Hve''; intros xe'' Heq''.
rewrite Heq''.
apply Hvcons.
apply HR.
Qed.
(* some basic operations on vectors *)

Definition head (n : nat) (v : vect n) :=
  match v in (vect n) return (0 < n -> A) with
  | vnil => fun h : 0 < 0 => False_rec A (lt_irrefl 0 h)
  | vcons p a v' => fun h : 0 < S p => a
  end.

Lemma head_lemma_1 :
 forall v v' : vect 1, v = v' -> head 1 v (le_n 1) = head 1 v' (le_n 1).
intros v v' H; rewrite H; trivial.
Qed.

Definition tail (n : nat) (v : vect n) :=
  match v in (vect m) return (vect (pred m)) with
  | vnil => vnil
  | vcons p a v' => v'
  end.

Lemma le_S_lt_O : forall n m : nat, S m <= n -> 0 < n.
intros; apply lt_le_trans with (S m); auto with arith.
Qed.

Lemma lt_le_pred : forall n m : nat, n < m -> n <= pred m.
simple induction n; simple induction m; auto with arith.
Qed.

Lemma le_Sn_le_n_pred : forall n m : nat, S n <= m -> n <= pred m.
intros; apply lt_le_pred; trivial.
Qed.

Theorem zerop : forall n : nat, {n = 0} + {0 < n}.
destruct n; auto with arith.
Defined.

Fixpoint nth (i : nat) : forall n : nat, vect n -> 0 < i -> i <= n -> A :=
  fun (n : nat) (v : vect n) =>
  match i as j return (0 < j -> j <= n -> A) with
  | O => fun (h' : 0 < 0) h'' => False_rec A (lt_irrefl 0 h')
  | S p =>
      fun (h' : 0 < S p) (h'' : S p <= n) =>
      match zerop p with
      | left _ => head n v (le_S_lt_O _ _ h'')
      | right h => nth p (pred n) (tail n v) h (le_Sn_le_n_pred _ _ h'')
      end
  end.

Remark nth_lemma_aux : forall (i n : nat) (Hi2 : S i <= S n), i <= n.
intros; apply le_S_n; trivial.
Qed.

Lemma nth_lemma :
 forall (i n : nat) (a : A) (v : vect n) (Hi1 : 0 < S (S i))
   (Hi2 : S (S i) <= S n) (Hi1' : 0 < S i),
 nth (S (S i)) (S n) (vcons n a v) Hi1 Hi2 =
 nth (S i) n v Hi1' (le_Sn_le_n_pred (S i) (S n) Hi2).
intros i; elim i using two_step_ind.
intros n a v Hi1 Hi2 Hi1'; simpl in |- *; trivial.
intros i' a v Hi1 Hi2 Hi1'; simpl in |- *; trivial.
intros i' HR n' a v Hi1 Hi2 Hi1'; simpl in |- *; trivial.
Qed.

Lemma nth_lemma' :
 forall (c n : nat) (w : vect n) (a : A) (H1 : 0 < S c)
   (H2 : S c <= S n) (H1' : 0 < c),
 nth (S c) (S n) (vcons n a w) H1 H2 =
 nth c n w H1' (le_Sn_le_n_pred c (S n) H2).
intros c; elim c.
intros n w a H1 H2 H1'; inversion H1'.
intros c' HR.
simpl in |- *; trivial.
Qed.
(* last *)

Lemma last_o1 : forall n c' : nat, S c' <= n -> 0 < n - c'.
intros; omega.
Qed.

Lemma last_o2 : forall n c' : nat, n - c' <= n.
intros; omega.
Qed.

Lemma last_o3 : forall c' : nat, 0 <= c'.
intros; omega.
Qed.

Lemma last_o4 : forall c' n : nat, S c' <= n -> c' <= n.
intros; omega.
Qed.

Definition last :
  forall (n : nat) (v : vect n) (c : nat), 0 <= c -> c <= n -> vect c.
intros n v; fix 1.
intros c; case c.
intros; apply vnil.
intros c' Hc1' Hc2'.
apply vcons.
apply (nth (n - c') n v).
apply last_o1; assumption.
apply last_o2; assumption.
apply last.
apply last_o3; assumption.
apply last_o4; assumption.
Defined.

Lemma last_vcons :
 forall (n : nat) (w : vect n) (c : nat) (H1 : 0 < n - c)
   (H2 : n - c <= n) (H1c' : 0 <= S c) (H2c' : S c <= n)
   (H1c : 0 <= c) (H2c : c <= n),
 vcons c (nth (n - c) n w H1 H2) (last n w c H1c H2c) =
 last n w (S c) H1c' H2c'.
intros n w c H1 H2 H1c' H2c' H1c H2c.
unfold last at 2 in |- *.
apply vcons_lemma.
rewrite (proof_irr _ H1 (last_o1 n c H2c')).
rewrite (proof_irr _ H2 (last_o2 n c)).
trivial.
rewrite (proof_irr _ H1c (last_o3 c)).
rewrite (proof_irr _ H2c (last_o4 c n H2c')).
trivial.
Qed.

Lemma last_S :
 forall (c n : nat) (a : A) (v : vect n) (H1 : 0 <= c)
   (H2 : c <= n) (H2' : c <= S n),
 last n v c H1 H2 = last (S n) (vcons n a v) c H1 H2'.
intros c; elim c.
intros n a v H1 H2 H2'; try assumption.
rewrite (uniq (last n v 0 H1 H2)).
rewrite (uniq (last (S n) (vcons n a v) 0 H1 H2')); trivial.
intros c' HR.
intros n a v H1 H2 H2'.
unfold last in |- *.
apply vcons_lemma.
generalize (last_o1 (S n) c' H2') (last_o2 (S n) c').
rewrite <- minus_Sn_m.
intros Hcut1 Hcut2.
symmetry  in |- *.
rewrite (nth_lemma' (n - c') n v a Hcut1 Hcut2 (last_o1 n c' H2)).
rewrite (proof_irr _ (le_Sn_le_n_pred (n - c') (S n) Hcut2) (last_o2 n c')).
trivial.
replace
 (fix last (c0 : nat) : 0 <= c0 -> c0 <= n -> vect c0 :=
    match c0 as c1 return (0 <= c1 -> c1 <= n -> vect c1) with
    | O => fun (_ : 0 <= 0) (_ : 0 <= n) => vnil
    | S c'0 =>
        fun (_ : 0 <= S c'0) (Hc2' : S c'0 <= n) =>
        vcons c'0 (nth (n - c'0) n v (last_o1 n c'0 Hc2') (last_o2 n c'0))
          (last c'0 (last_o3 c'0) (last_o4 c'0 n Hc2'))
    end) with (last n v); [ idtac | trivial ].
replace
 (fix last (c0 : nat) : 0 <= c0 -> c0 <= S n -> vect c0 :=
    match c0 as c1 return (0 <= c1 -> c1 <= S n -> vect c1) with
    | O => fun (_ : 0 <= 0) (_ : 0 <= S n) => vnil
    | S c'0 =>
        fun (_ : 0 <= S c'0) (Hc2' : S c'0 <= S n) =>
        vcons c'0
          (nth (S n - c'0) (S n) (vcons n a v) (last_o1 (S n) c'0 Hc2')
             (last_o2 (S n) c'0))
          (last c'0 (last_o3 c'0) (last_o4 c'0 (S n) Hc2'))
    end) with (last (S n) (vcons n a v)); [ idtac | trivial ].
omega.
apply (HR n a v (last_o3 c') (last_o4 c' n H2) (last_o4 c' (S n) H2')).
Qed.

Lemma last_vcons' :
 forall (n : nat) (w : vect n) (c : nat) (a : A) (H1 : 0 < n - c)
   (H2 : n - c <= n) (H1c' : 0 <= S c) (H2c' : S c <= S n)
   (H1c : 0 <= c) (H2c : c <= n),
 vcons c (nth (n - c) n w H1 H2) (last n w c H1c H2c) =
 last (S n) (vcons n a w) (S c) H1c' H2c'.
intros n; elim n.
intros w c a H1 H2 H1c' H2c' H1c H2c; cut (c = 0).
intros Hrew; generalize w a H1 H2 H1c' H2c' H1c H2c;
 clear w a H1 H2 H1c' H2c' H1c H2c.
rewrite Hrew.
intros w a H1; simpl in H1; inversion H1.
omega.
intros n0 HR v c.
intros a H1 H2 H1c' H2c' H1c H2c.
cut (c <= n0).
intros Hcut; generalize a H1 H2 H1c' H2c' H1c H2c;
 clear a H1 H2 H1c' H2c' H1c H2c.
rewrite <- (minus_Sn_m _ _ Hcut).
2: omega.
intros a H1 H2 H1c' H2c' H1c H2c.
unfold last at 2 in |- *.
apply vcons_lemma.
generalize (last_o1 (S (S n0)) c H2c') (last_o2 (S (S n0)) c).
replace (S (S n0) - c) with (S (S (n0 - c))); [ idtac | omega ].
intros Hcut1 Hcut2.
symmetry  in |- *.
rewrite (nth_lemma' (S (n0 - c)) (S n0) v a Hcut1 Hcut2 H1).
rewrite (proof_irr _ H2 (le_Sn_le_n_pred (S (n0 - c)) (S (S n0)) Hcut2)).
trivial.
replace
 (fix last (c : nat) : 0 <= c -> c <= S (S n0) -> vect c :=
    match c as c1 return (0 <= c1 -> c1 <= S (S n0) -> vect c1) with
    | O => fun (_ : 0 <= 0) (_ : 0 <= S (S n0)) => vnil
    | S c' =>
        fun (_ : 0 <= S c') (Hc2' : S c' <= S (S n0)) =>
        vcons c'
          (nth (S (S n0) - c') (S (S n0)) (vcons (S n0) a v)
             (last_o1 (S (S n0)) c' Hc2') (last_o2 (S (S n0)) c'))
          (last c' (last_o3 c') (last_o4 c' (S (S n0)) Hc2'))
    end) with (last (S (S n0)) (vcons (S n0) a v));
 [ idtac | trivial ].
generalize (last_S c (S n0) a v H1c H2c (last_o4 c (S (S n0)) H2c')).
rewrite (proof_irr _ H1c (last_o3 c)).
trivial.
Qed.

Lemma last_n :
 forall (c n : nat) (v : vect n) (H : c = n) (H1 : 0 <= c) (H2 : c <= n),
 eq_vect c (last n v c H1 H2) n v.
intros c; elim c.
intros n v H; simpl in |- *.
intros H1 H2.
generalize H v; case n.
intros; rewrite uniq.
unfold eq_vect in |- *; apply eq_dep_intro.
intros n' Hd; discriminate Hd.
intros c' HR n; case n.
intros v Hd; discriminate Hd.
intros n' v' Heq H1 H2.
cut (0 < S n' - c'); [ intros Hcut1 | omega ].
cut (S n' - c' <= S n'); [ intros Hcut2 | omega ].
cut (0 <= S c'); [ intros Hcut3 | omega ].
cut (S c' <= S n'); [ intros Hcut4 | omega ].
cut (0 <= c'); [ intros Hcut5 | omega ].
cut (c' <= S n'); [ intros Hcut6 | omega ].
elim (decompose _ v').
intros x0 Hx; elim Hx; clear Hx; intros v0 Heq'.
rewrite Heq'.
rewrite <-
 (last_vcons (S n') (vcons n' x0 v0) c' Hcut1 Hcut2 H1 H2 Hcut5 Hcut6)
 .
apply
 (eq_vect_vcons c' n' (last (S n') (vcons n' x0 v0) c' Hcut5 Hcut6) v0
    (nth (S n' - c') (S n') (vcons n' x0 v0) Hcut1 Hcut2) x0).
cut (S n' - c' = 1); [ intros Hcut'' | omega ].
generalize Hcut1 Hcut2; rewrite Hcut''.
simpl in |- *; trivial.
rewrite <- (last_S c' n' x0 v0 Hcut5 (le_S_n _ _ Hcut4) Hcut6).
apply HR.
omega.
Qed.

Lemma last_n' :
 forall (n : nat) (v : vect n) (H1 : 0 <= n) (H2 : n <= n),
 last n v n H1 H2 = v.
intros; apply (eq_dep_eq nat vect n (last n v n H1 H2) v).
apply last_n.
trivial.
Qed.

End vect_def.

Fixpoint map (A B : Set) (f : A -> B) (n : nat) (v : vect A n) {struct v} :
 vect B n :=
  match v in (vect _ p) return (vect B p) with
  | vnil _ => vnil B
  | vcons _ p x v' => vcons B p (f x) (map A B f p v')
  end.

Lemma map_2 :
 forall (A B : Set) (n : nat) (t : vect A n) (f : A -> B)
   (g : B -> A) (H : forall x : A, g (f x) = x),
 map B A g n (map A B f n t) = map A A (fun x : A => g (f x)) n t.
intros A2 B n; elim n.
intros t f g H; rewrite (uniq A2).
rewrite (uniq B (map A2 B f 0 t)).
simpl in |- *; trivial.
intros n0 H t f g H0; try assumption.
elim (decompose A2 n0 t).
intros x Hx; elim Hx; intros v Hvx; rewrite Hvx; clear Hx Hvx.
simpl in |- *.
rewrite H.
trivial.
apply H0.
Qed.

Lemma map_2' :
 forall (A B : Set) (n : nat) (t : vect A n) (f : A -> B)
   (g : B -> A) (H : forall x : A, g (f x) = x),
 map B A g n (map A B f n t) = t.
intros A2 B n; elim n.
intros t f g H; rewrite (uniq A2).
rewrite (uniq B (map A2 B f 0 t)).
simpl in |- *; trivial.
intros n0 H t f g H0; try assumption.
elim (decompose A2 n0 t).
intros x Hx; elim Hx; intros v Hvx; rewrite Hvx; clear Hx Hvx.
simpl in |- *.
rewrite H.
rewrite H0; trivial.
apply H0.
Qed.

  (*
  Local Variables:
  mode: coq
  coq-prog-name: "/usr/local/coq-7.4/bin/coqtop -emacs -q"
  compile-command: "make vectors.vo"
  End:
  *)


From RecordUpdate Require Import RecordSet.

Record X := mkX { A: nat; B: nat; C: bool; }.

(* all you need to do is provide something like this, listing out the fields of your record: *)
#[export] Instance etaX : Settable _ := settable! mkX <A; B; C>.

(* and now you can update fields! *)
Definition setAB a b x := set B b (set A a x).

(* you can also use a notation for the same thing: *)
Import RecordSetNotations.
Definition setAB' a b x := x <|A := a|> <|B := b|>.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Closed.
Require Export Category.Instance.Sets.
Require Export Category.Instance.Sets.Cartesian.

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

(* This instance must appear in a separate file, because the Closed structure
   makes use of isomorphisms in [Sets]. *)

Program Instance Sets_Closed : @Closed Sets _ := {
  exponent_obj := fun x y =>
    {| carrier := SetoidMorphism x y
     ; is_setoid := @SetoidMorphism_Setoid x y |};

  exp_iso := fun _ _ _ =>
    {| to   := {| morphism := fun f =>
                    {| morphism := fun x =>
                         {| morphism := fun y => f (x, y) |} |} |}
     ; from := {| morphism := fun f =>
                    {| morphism := fun p => f (fst p) (snd p) |} |} |}
}.
Next Obligation.
  proper; destruct f; simpl.
  apply proper_morphism.
  split; simpl; intuition.
Qed.
Next Obligation.
  proper; destruct f; simpl.
  apply proper_morphism.
  split; simpl; intuition.
Qed.
Next Obligation.
  proper; simpl in *.
  destruct f; simpl in *.
  unfold Proper, respectful in proper_morphism.
  rewrite (proper_morphism _ _ X).
  destruct (morphism y).
  apply proper_morphism0; assumption.
Qed.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.Lambda.ExprUnify_simul.
Require Import MirrorCore.Lambda.ExprVariables.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.VariablesI.

Require Import MirrorCharge.ILogicFunc.
Require Import MirrorCharge.OrderedCanceller.
Require Import MirrorCharge.BILNormalize.
Require Import MirrorCharge.SynSepLog.
Require Import MirrorCharge.SepLogFoldWithAnd.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.

Set Implicit Arguments.
Set Strict Implicit.

Section Canceller.
  Context (typ func subst : Type) (tyLogic : typ).
  Context {HIL : ILogicFunc typ func} {HBIL : BILogicFunc typ func}.
  Context {RType_typ : RType typ} {RelDec_typ : RelDec (@eq typ)}.
  Context {Typ2_typ : Typ2 RType_typ Fun}.
  Context {RSym_func : @RSym _ RType_typ func}.
  Existing Instance Expr_expr.
  Context {SS : Subst subst (expr typ func)}.
  Context {SU : SubstUpdate subst (expr typ func)}.
  Context {SO : SubstOk SS}.
  Context {MA : MentionsAny (expr typ func)}.
  Context {uis_pure : expr typ func -> bool}.

  Definition sls : SepLogAndSpec typ func :=
  {| is_pure := fun e : expr typ func =>
                  match ilogicS e with
		    | Some (ilf_true _)
		    | Some (ilf_false _) => true
		    | _ => uis_pure e
		  end
   ; is_emp := fun e => false
   ; is_star := fun e : expr typ func =>
 		  match bilogicS e with
 		    | Some (bilf_star _) => true
 		    | _ => false
 		  end
   ; is_and := fun e : expr typ func =>
 		  match ilogicS e with
 		    | Some (ilf_and _) => true
 		    | _ => false
 		  end
   |}.

  Let doUnifySepLog c (tus tvs : EnvI.tenv typ) (s : ctx_subst (typ := typ) (expr := expr typ func) c) (e1 e2 : expr typ func)
  : option (ctx_subst c) :=
    @exprUnify (ctx_subst c) typ func RType_typ RSym_func Typ2_typ _ _ 10 tus tvs 0 e1 e2 tyLogic s.

  Let ssl : SynSepLog typ func :=
  {| e_star := fun l r =>
                 match bilogicS l with
                   | Some (bilf_emp _) => r
                   | _ => match bilogicS r with
                            | Some (bilf_emp _) => l
                            | _ => mkStar tyLogic l r
                          end
                 end
   ; e_emp := mkEmp tyLogic
   ; e_and := fun l r =>
                match ilogicS l with
                  | Some (ilf_true _) => r
                  | _ => match ilogicS r with
                           | Some (ilf_true _) => l
                           | _ => mkAnd tyLogic l r
                         end
                end
   ; e_true := mkTrue tyLogic
   |}.

  Definition eproveTrue c (s : ctx_subst (typ := typ) (expr := expr typ func) c) (e : expr typ func) : option (ctx_subst c) :=
    match ilogicS e with
      | Some (ilf_true _) => Some s
      | _ => None
    end.

  Definition is_solved (e1 e2 : conjunctives typ func) : bool :=
    match e1 , e2 with
      | {| spatial := e1s ; star_true := t ; pure := _ |}
        , {| spatial := nil ; star_true := t' ; pure := nil |} =>
        if t' then
          (** ... |- true **)
          true
        else
          (** ... |- emp **)
          if t then false else match e1s with
                                 | nil => true
                                 | _ => false
                               end
      | _ , _ => false
    end.
Check @OrderedCanceller.ordered_cancel.

  Definition the_canceller tus tvs (lhs rhs : expr typ func) c
             (s : ctx_subst c)
  : (expr typ func * expr typ func * (ctx_subst c)) + (ctx_subst c) :=
    match @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic lhs
        , @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic rhs
    with
      | Some lhs_norm , Some rhs_norm =>
        match lhs_norm tt , rhs_norm tt with
          | Some lhs_norm , Some rhs_norm =>
            let '(lhs',rhs',s') :=
                OrderedCanceller.ordered_cancel (subst := ctx_subst c)
                  (doUnifySepLog (c := c) tus tvs) (eproveTrue (c := c))
                  ssl
                  (simple_order (func:=func)) lhs_norm rhs_norm s
            in
            if is_solved lhs' rhs' then
              inr s'
            else
              inl (conjunctives_to_expr ssl lhs',
                   conjunctives_to_expr ssl rhs',
                   s')
          | _ , _ => inl (lhs, rhs, s)
        end
      | _ , _ => inl (lhs, rhs, s)
    end.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Definition CANCELLATION : rtac typ (expr typ func) :=
    fun tus tvs nus nvs c s e =>
      match e with
        | App (App f L) R =>
          match ilogicS f with
	    | Some (ilf_entails t) =>
	      match t ?[ eq ] tyLogic with
	     	| true =>
		  match the_canceller tus tvs L R s with
		    | inl (l,r,s') =>
		      match bilogicS r with (* This is for intuitionistic logics only *)
		        | Some (bilf_emp _) => Solved s'
		        | _ => let e' := mkEntails tyLogic l r in
			       More s (GGoal e')
		      end
		    | inr s' => Solved s'
		  end
		| false => More s (GGoal e)
	      end
	    | _ => More s (GGoal e)
	  end
        | _ => More s (GGoal e)
      end.

Definition the_canceller2 tus tvs (lhs rhs : expr typ func) :=
    match @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic lhs
        , @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic rhs
    with
      | Some lhs_norm , Some rhs_norm =>
        match lhs_norm tt , rhs_norm tt with
          | Some lhs_norm , Some rhs_norm =>
            Some (simple_order (func := func) lhs_norm,
                  simple_order (func := func) rhs_norm)
          | _ , _ => None
        end
      | _ , _ => None
    end.

  Definition CANCELLATION2 tus tvs e :=
      match e with
        | App (App f L) R =>
          match ilogicS f with
	    | Some (ilf_entails t) =>
	      match t ?[ eq ] tyLogic with
	     	| true => the_canceller2 tus tvs L R
		    | false => None
	      end
	    | _ => None
	  end
        | _ => None
      end.

End Canceller.

Implicit Arguments CANCELLATION [[HIL] [HBIL] [RType_typ] [RelDec_typ]
                                [Typ2_typ] [RSym_func] [MA]].


Require Import Raft.
Require Import RaftRefinementInterface.
Require Import LeaderCompletenessInterface.

Section TransitiveCommit.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition transitive_commit net :=
    forall h e e' t,
      In e (log (snd (nwState net h))) ->
      In e' (log (snd (nwState net h))) ->
      eIndex e <= eIndex e' ->
      committed net e' t ->
      committed net e t.

  Class transitive_commit_interface : Prop :=
    {
      transitive_commit_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          transitive_commit net
    }.

End TransitiveCommit.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.Structures.
Require Export Parser.HList.

(* This describes a function on syntaxes, with type, forall A, Syntax A -> F A *)

Definition Rule (AS: list Type) (B: Type): Type := hlist (map option AS) -> option B.

Record Description (G: Type -> Type) := mkDescription {
  epsilon_descr: forall A, A -> list (Rule [] (G A));
  failure_descr: forall A, list (Rule [] (G A));
  token_descr: token_class ->  list (Rule [] (G token));
  map_descr: forall A B, (A -> B) -> (B -> list A) -> Syntax A -> list (Rule [G A] (G B));
  disj_descr: forall A, Syntax A -> Syntax A -> list (Rule [G A; G A] (G A));
  seq_descr: forall A1 A2, Syntax A1 -> Syntax A2 -> list (Rule [G A1; G A2] (G (A1 * A2)%type));
  var_descr: forall x, Syntax (get_type x) -> list (Rule [G (get_type x)] (G (get_type x)));
}.

Arguments epsilon_descr { G } d { A }.
Arguments failure_descr { G }.
Arguments token_descr { G }.
Arguments map_descr { G } d { A B }.
Arguments disj_descr { G } d { A }.
Arguments seq_descr { G } d { A1 A2 }.
Arguments var_descr { G }.


(* Copyright 2021 Pierre Courtieu
  This file is part of LibHyps. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it. *)

(* DEMO FILE FOR THE LIBHYPS LIBRARY FEATURES. *)

(* This acts as a documentation for LibHyps. *)

(* WARNING: You can play this file in any IDE but beware that it
contains "Undo" at many places and that your IDE may not support it.
In this case you can edit the script by commenting things instead of
playing the Undos. *)

(* You can install LibHyps with opam with:

opam install coq_libhyps *)

(*** Proof maintenance ***)
Unset Printing Compact Contexts.
Require Import Arith ZArith  List.
Require Import LibHyps.LibHyps.

Lemma foo: forall (x:nat) (b1:bool) (y:nat) (b2:bool),
    x = y
    -> orb b2 b1 = false
    -> forall  a b:nat, forall b3:bool, forall t : nat,
        a+1 = t+2
        -> b + 5 = t - 7
        -> forall z, forall b4:bool, forall z',
            orb b3 b4 = b2
            -> (forall u v, v+1 = 1 -> u+1 = 1 -> a = z+2)
            -> z = b + 5-> z' + 1 = b + x-> x < y + b.
Proof.
  (* tactical "; { }" to apply a tactic to each "new" hyp. *)
  intros ; { fun h => idtac h }.
  Undo.
  (* tactical "; {< }": same but newer hyps first. *)
  intros ; {< fun h => idtac h }.
  Undo.
  intros x b1.
  (* Only the *new* hyps are iterated *)
  intros ; { fun h => idtac h }.
  Undo 2.
  (* Simply based on new *names* *)
  intros x b1.
  (* this tactic renames x into aaa, which is a new name. *)
  rename x into aaa ; { fun h => idtac h }.
  Undo 2.
  (* Here x is reused by induction and thus not new. *)
  intros x.
  induction x ; {< (fun h => idtac h) }.
  Undo 2.
  (* tactical "onAllhyps": same thing but on all hyps. *)
  intros.
  onAllHyps (fun h => idtac h).

  (*** Use Cases  ***)

  (* Revert any new hyp. Must be older fist. *)
  intros.
  revert x H H6.
  induction x ; {< (fun h => revert dependent h) }.
  Undo.
  (* Shortcut *)
  induction x /r.

  Restart.
  (* Try subst on each new hyp. *)
  intros ; { fun h => try match type of h with
                        (?x = ?y) => (subst x+subst y)
                      end }.
  Undo.
  (* predefined tactic. *)
  intros ;{ subst_or_idtac }.
  Undo.
  (* and a shortcut. *)
  intros /s.
  Undo.
  (* combination: try subst and revert remaining hyps. *)
  intros x b1.
  intros ; { subst_or_idtac } ; {< (fun h => revert dependent h) }.
  Undo.
  intros /s/r.
  Undo 2.
  (* It really applies only on new hyps: *)
  intros until 1.
  intros /s/r.

Abort.

(*** Large Goals - Foraward reasoning and reordering and autorenaming of hypothesis. ***)

Lemma foo: forall (x:nat) (b1:bool) (y:nat) (b2:bool),
    x = y ->
    orb b2 b1 = false ->
    forall  a b:nat, forall b3:bool, forall t : nat,
      a+1 = t+2 ->
      b + 5 = t - 7 ->
      (forall n m p : nat,
          0 <= p ->
          Nat.divide n p ->
          Nat.divide m p ->
          (forall q : nat, Nat.divide n q -> Nat.divide m q
                    -> Nat.divide p q) ->
          Nat.lcm n m = p) ->
      (exists w:nat , ~(true=(andb false true)) /\ le w w /\ w = x) ->
      forall z, forall b4:bool, forall z',
        orb b3 b4 = b2 ->
        (forall u v, v+1 = 1 -> u+1 = 1 -> a = z+2) ->
        z = b + 5-> z' + 1 = b + x-> x < y + b.
Proof.
  intros.
  Set Printing Compact Contexts.
  (* BIG HYPS may clutter the goal. IDE solution. *)
  (* 1. ProofGeneral: just hide it by clicking on its button, or hit
        "f" while cursor on its name. Persistent and simply based on
        hyp name. *)

  (* 2. Big hyps ask for "non verbose forward reasoning". *)
  (* Since a few years coq allows "specialize" to re-quantifies
     non-unified premisses. *)
  specialize H3 with (1:= le_S _ _ (le_n 0)).

  (* Our tactic "especialize" starts a goal to instantiate a dependent
     premiss of a hyp, and then re-quantifies everything non
     instantiated. *)
  Undo.
  especialize H3 at 1.
  { apply le_S.
    apply le_n. }
  Undo 5.
  (* IDEs don't like Undo, replay the next ocommand twice will resync
     proofgeneral. *)
  (* It accepts several (up to 7) premisses numers. *)
  especialize H3 at 2,3.
  Undo.

  (* you can ask a goal for all premisses, in the spirit of the
     "exploit" tactic from CompCert. *)
  especialize H3 at *.
  Undo.

  (* You can also specify that you want to instantiate the n first premisses. *)
  especialize H3 until 3.
  Show 4.
  Undo.

  (* VARIABLES MIXED WITH HYPOTHESIS. *)
  (* move_up_types X. moves X at top near something of the same type,
     but only if X is Type-sorted (not Prop). *)
  move_up_types b4. (* group z on top *)
  move_up_types H. (* does nothing because H:..:Prop *)
  Undo 2.
  Unset Printing Compact Contexts.
  (* Do that on all hyps: *)
  onAllHyps move_up_types.
  Set Printing Compact Contexts.
  Restart.
  (* Better do that on new hyps only. *)
  intros ; { move_up_types }.
  Undo.
  (* Faster version dealing with the whole list of new hyps at once: *)
  intros; {! group_up_list }.
  Undo.
  (* Shortcut for this faster version: *)
  intros /g.
  Undo.
  (* combined with subst: *)
  intros /s/g.
  (* And have this coq option on fo saving a bit more room: *)
  Set Printing Compact Contexts.

  (*** HYPOTHESIS NAMES. ***)
  Restart.
  intros.
  Undo.
  (* After a lot of non interesting thinking. *)
  intros x b1 y b2 h_x_eq_y h_or_b2_b1 a b b3 t
         h_a_t h_b_t hh hex z b4 z' h_b3_b4 h_all_uvaz
         heq_z heq_z'_b.
  (* But at each change in definitions or statements ==> Adapt the
     intros and "as". *)
  Restart.
  intros.
  (* tactic "autorename H" applies the naming heursitc to H. *)
  autorename H.
  (* Notice the trailing "_": avoids coq replacing digits. *)
  Undo.
  (* Again, one can apply it to all hyps: *)
  onAllHyps autorename.

  (* experimental: (setq coq-libhyps-intros t) *)
  Undo 2.
  Show.

  Restart.
  Show.
  (* Again, better combine it with "; { }". *)
  intros ; { autorename }.
  (* You can still shorten big hyps. but hiding most of the time is better. *)
  rename h_all_eq_lcm_p_ into hall.
  Undo 2.
  (* shortcut: *)
  intros /n.
  Restart. Show. Set Printing Compact Contexts.
  (* Combining with other cleaning operators: *)
  intros /s/n/g. (* /sng is also accepted *)
  (* Long names, this is configurable (next demo), but IDE provides
     easy ways to see them (highlight) and to input them:
     - middle-click on hyp's name.
     - completion (company-coq). *)

  (* tactic that generate names can be easily tamed. *)
  decompose [ex and or] h_ex_and_neq_and_/sng.
  (* No more obscure "as" to maintain *)
  inversion h_le_y_y_ /sng.
  Show 2.
  (* You can still use destructive pattern, but without inventing names: *)
  Undo.
  assert (y < a /\ b < t /\ z' < t) /n.
  {admit. }
  destruct h_and_lt_y_a_and_lt_lt_ as [ ? [? ?]] /n.

Abort.

(* customization of autorename *)

Local Open Scope autonaming_scope.
Import ListNotations.

(* Define the naming scheme as new tactic pattern matching on a type
th, and the depth n of the recursive naming analysis. Here we state
that a type starting with Nat.eqb should start with _Neqb, followed by
the name of both arguments. #n here means normal decrement of depth.
(S n) would increase depth by 1 (n-1) would decrease depth. *)
Ltac rename_hyp_2 n th :=
  match th with
  | Nat.eqb ?x ?y => name(`_Neqb` ++ x#n ++ y#n)
  end.

(* Then overwrite the customization hook of the naming tactic *)
Ltac rename_hyp ::= rename_hyp_2.

Goal forall x y:nat, True.
  intros.
  (* computing a few names *)
  (* Customize the starting depth *)

  let res := fallback_rename_hyp_name (Nat.eqb 1 2) in idtac res.
  let res := fallback_rename_hyp_name (Nat.eqb x 4) in idtac res.
  let res := fallback_rename_hyp_name (Nat.eqb 1 2 = false) in idtac res.
  Ltac rename_depth ::= constr:(2).
  let res := fallback_rename_hyp_name (Nat.eqb 1 2 = false) in idtac res.
  Ltac rename_depth ::= constr:(3).
Abort.

(** Suppose I want to add another naming rule: I need to cumulate the
    previous scheme with the new one. First define a new tactic that
    will replace the old one. it should call previous naming schemes
    in case of failure of the new scheme. It is thus important that
    rename_hyp_2 was defined by itself and directly as rename_hyp. *)
Ltac rename_hyp_3 n th :=
  match th with
  | ?x = false => name(x#n ++ `_isf`)
  | ?x = true => name( x#n ++ `_ist`)
  | _ => rename_hyp_2 n th (* previous naming scheme *)
  end.

(* Then update the customization hook *)
Ltac rename_hyp ::= rename_hyp_3.
(* Close the naming scope *)
Local Close Scope autonaming_scope.

Goal forall x y:nat, True.
  intros.
  let res := fallback_rename_hyp_name (Nat.eqb 1 2 = false) in
  idtac res.
Abort.

Lemma foo: forall (x:nat) (b1:bool) (y:nat) (b2:bool),
    x = y
    -> orb b2 b1 = false
    -> forall  a b:nat, forall b3:bool, forall t : nat,
        true = Nat.eqb (a+1) (t+2)
        -> b + 5 = t - 7
        -> forall z, forall b4:bool, forall z',
            orb b3 b4 = b2
            -> (forall u v, v+1 = 1 -> u+1 = 1 -> a = z+2)
            -> z = b + 5-> z' + 1 = b + x-> x < y + b.
Proof.
  (* Customize the starting depth *)
  Ltac rename_depth ::= constr:(3).

  intros/n/g.
  Undo.
  (* Have shorter names: *)
  Ltac rename_depth ::= constr:(2).
  intros/n/g.

Abort.

(*** Local Variables: ***)
(*** eval: (company-coq-mode 1) ***)
(*** End: ***)


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Lia.
Require Import Language Tactical.
Require Import Subtyping.Toplike.
Require Import Subtyping.Splitable.
Require Import Subtyping.Subtyping.
Require Import Appsub.

Set Printing Parentheses.

(** * Definition *)

Definition result := option type.

Inductive partype : Set :=
| T : type -> partype
| P : arg -> partype.

Inductive unisub : type -> partype -> result -> Prop :=
| Us_Int :
    unisub Int (T Int) None
| Us_Top : forall A B,
    ordinary B -> toplike B ->
    unisub A (T B) None
| Us_Arr : forall A B C D,
    unisub C (T A) None ->
    unisub B (T D) None ->
    unisub (Arr A B) (T (Arr C D)) None
| Us_Rcd : forall A B l,
    ordinary B ->
    unisub A (T B) None ->
    unisub (Rcd l A) (T (Rcd l B)) None
| Us_And : forall A B B1 B2,
    splitable B B1 B2 ->
    unisub A (T B1) None ->
    unisub A (T B2) None ->
    unisub A (T B) None
| Us_And_L : forall A B C,
    ordinary C ->
    unisub A (T C) None ->
    unisub (And A B) (T C) None
| Us_And_R : forall A B C,
    ordinary C ->
    unisub B (T C) None ->
    unisub (And A B) (T C) None
| Us_As_Arr : forall A1 A2 B,
    unisub B (T A1) None ->
    unisub (Arr A1 A2) (P (Avt B)) (Some A2)
| Us_As_Lbl : forall l A,
    unisub (Rcd l A) (P (Alt l)) (Some A)
| Us_As_L : forall A1 A2 S C,
    unisub A1 (P S) (Some C) ->
    ~ (auxas (Some S) A2) ->
    unisub (And A1 A2) (P S) (Some C)
| Us_As_R : forall A1 A2 S C,
    unisub A2 (P S) (Some C) ->
    ~ (auxas (Some S) A1) ->
    unisub (And A1 A2) (P S) (Some C)
| Us_As_P : forall A1 A2 S C1 C2,
    unisub A1 (P S) (Some C1) ->
    unisub A2 (P S) (Some C2) ->
    unisub (And A1 A2) (P S) (Some (And C1 C2)).

Hint Constructors unisub : core.

Notation "A <: B ~> ∅" := (unisub A (T B) None) (at level 40).
Notation "A <: B ->? ~> C" := (unisub A (P B) (Some C)) (at level 40).

(** * Unified Subtyping & Normal Subtyping *)

(** ** Soundness *)

(** A <: B->? ~> . -> A <: B *)

Lemma unisub_sound_normal :
  forall A B,
    unisub A (T B) None ->
    sub A B.
Proof.
  introv Usub.
  dependent induction Usub; eauto.
Qed.

Lemma unisub_sound_appsub :
  forall A S C,
    unisub A (P S) (Some C) ->
    appsub (Some S) A C.
Proof.
  introv Usub.
  dependent induction Usub; eauto.
  eapply As_Arr.
  now eapply unisub_sound_normal.
Qed.

(** ** Completeness *)

Lemma unisub_complete_normal :
  forall A B,
    sub A B ->
    unisub A (T B) None.
Proof.
  introv Sub.
  dependent induction Sub; eauto.
Qed.

Lemma unisub_complete_appsub :
  forall A S B,
    appsub (Some S) A B ->
    unisub A (P S) (Some B).
Proof.
  introv As.
  dependent induction As; eauto.
  eapply Us_As_Arr.
  now eapply unisub_complete_normal.
Qed.

(** * Ultimate Unisubtyping *)

Inductive upartype : Set :=
| uT : type -> upartype
| uV : arg -> upartype
| uP : arg -> upartype.

Inductive uunisub : type -> upartype -> result -> Prop :=
| UUs_Int :
    uunisub Int (uT Int) None
| UUs_Top : forall A B,
    ordinary B -> toplike B ->
    uunisub A (uT B) None
| UUs_Arr : forall A B C D,
    uunisub C (uT A) None ->
    uunisub B (uT D) None ->
    uunisub (Arr A B) (uT (Arr C D)) None
| UUs_Rcd : forall A B l,
    ordinary B ->
    uunisub A (uT B) None ->
    uunisub (Rcd l A) (uT (Rcd l B)) None
| UUs_And : forall A B B1 B2,
    splitable B B1 B2 ->
    uunisub A (uT B1) None ->
    uunisub A (uT B2) None ->
    uunisub A (uT B) None
| UUs_And_L : forall A B C,
    ordinary C ->
    uunisub A (uT C) None ->
    uunisub (And A B) (uT C) None
| UUs_And_R : forall A B C,
    ordinary C ->
    uunisub B (uT C) None ->
    uunisub (And A B) (uT C) None
| UUs_As_Arr : forall A1 A2 B,
    uunisub B (uT A1) None ->
    uunisub (Arr A1 A2) (uP (Avt B)) (Some A2)
| UUs_As_Lbl : forall l A,
    uunisub (Rcd l A) (uP (Alt l)) (Some A)
| UUs_As_L : forall A1 A2 S C,
    uunisub A1 (uP S) (Some C) ->
    ~ (auxas (Some S) A2) ->
    uunisub (And A1 A2) (uP S) (Some C)
| UUs_As_R : forall A1 A2 S C,
    uunisub A2 (uP S) (Some C) ->
    ~ (auxas (Some S) A1) ->
    uunisub (And A1 A2) (uP S) (Some C)
| UUs_As_P : forall A1 A2 S C1 C2,
    uunisub A1 (uP S) (Some C1) ->
    uunisub A2 (uP S) (Some C2) ->
    uunisub (And A1 A2) (uP S) (Some (And C1 C2))
| UUs_V_As_Arr : forall A1 A2 B,
    uunisub B (uT A1) None ->
    uunisub (Arr A1 A2) (uV (Avt B)) None
| UUs_V_As_Lbl : forall l A,
    uunisub (Rcd l A) (uV (Alt l)) None
| UUs_V_As_L : forall A1 A2 S,
    uunisub A1 (uV S) None ->
    uunisub (And A1 A2) (uV S) None
| UUs_V_As_R : forall A1 A2 S,
    uunisub A2 (uV S) None ->
    uunisub (And A1 A2) (uV S) None.

Hint Constructors uunisub : core.

(** ** Soundness *)

Lemma uunisub_sound_normal :
  forall A B,
    uunisub A (uT B) None ->
    sub A B.
Proof.
  introv Uusub.
  dependent induction Uusub; eauto.
Qed.

Lemma uunisub_sound_appsub :
  forall A S C,
    uunisub A (uP S) (Some C) ->
    appsub (Some S) A C.
Proof.
  introv UUsub.
  dependent induction UUsub; eauto.
  eapply As_Arr.
  now eapply uunisub_sound_normal.
Qed.

Lemma uunisub_sound_auxas :
  forall A S,
    uunisub A (uV S) None ->
    auxas (Some S) A.
Proof.
  introv Uusub.
  dependent induction Uusub; eauto.
  eapply Aas_Arr.
  now eapply uunisub_sound_normal.
Qed.

(** ** Completeness *)

Lemma uunisub_complete_normal :
  forall A B,
    sub A B ->
    uunisub A (uT B) None.
Proof.
  introv Sub.
  dependent induction Sub; eauto.
Qed.

Lemma uunisub_complete_appsub :
  forall A S B,
    appsub (Some S) A B ->
    uunisub A (uP S) (Some B).
Proof.
  introv As.
  dependent induction As; eauto.
  eapply UUs_As_Arr.
  now eapply uunisub_complete_normal.
Qed.

Lemma uunisub_complete_auxas :
  forall A S,
    auxas (Some S) A ->
    uunisub A (uV S) None.
Proof.
  introv Aas.
  dependent induction Aas; eauto.
  eapply UUs_V_As_Arr.
  now eapply uunisub_complete_normal.
Qed.

(** * Automations *)

Lemma uunisub_auxas_false1 :
  forall B S,
    ~ uunisub B (uV S) None ->
    auxas (Some S) B ->
    False.
Proof.
  introv nUs Aux.
  eapply uunisub_complete_auxas in Aux. contradiction.
Qed.

Lemma uunisub_auxas_false2 :
  forall S B,
    uunisub B (uV S) None ->
    ~ auxas (Some S) B ->
    False.
Proof.
  introv Us nAux.
  eapply nAux. now eapply uunisub_sound_auxas.
Qed.

Lemma uunisub_appsub_false :
  forall S B C,
    ~ uunisub B (uV S) None ->
    appsub (Some S) B C ->
    False.
Proof.
  introv nUs As.
  eapply appsub_to_auxas in As.
  eapply uunisub_auxas_false1; eauto.
Qed.

Ltac contra_uunisub :=
  match goal with
  | H1: ~ uunisub ?B (uV ?S) _, H2: auxas (Some ?S) ?B |- _ =>
      pose proof (uunisub_auxas_false1 _ _ H1 H2) as Contra; inversion Contra
  | H1: uunisub ?B (uV ?S) _, H2: ~ auxas (Some ?S) ?B |- _ =>
      pose proof (uunisub_auxas_false2 _ _ H1 H2) as Contra; inversion Contra
  | H1: ~ uunisub ?B (uV ?S) _, H2: appsub (Some ?S) ?B _ |- _ =>
      pose proof (uunisub_appsub_false _ _ _ H1 H2) as Contra; inversion Contra
  end.

Hint Extern 5 => contra_uunisub : core.

Lemma appsub_to_uunisub :
  forall S A C,
    appsub (Some S) A C ->
    uunisub A (uV S) None.
Proof.
  introv As.
  eapply appsub_to_auxas in As.
  now eapply uunisub_complete_auxas.
Qed.

Hint Resolve appsub_to_uunisub : core.


Require Export DACandMAC.
Set Implicit Arguments.
Unset Strict Implicit.

Section Read.

Variable s : SFSstate.

(*********************************************************************)
(*                             read                                  *)
(*********************************************************************)

(*This operation outputs the first n BYTEs stored in a given file.   *)

Inductive read (eSub : ENTITY) (eObj : ENTITY) (n : nat) :
SFSstate -> Exc ENTCONT -> Prop :=
    ReadOK :
    match fsecmat (secmat s) eSub with
      | None => False
      | Some y => set_In eObj (EntReadingList y)
      end ->
      read eSub eObj n s
        match fsecmat (secmat s) eSub, fentities (entitycontent s) eObj with
        | None, _ => None (A:=ENTCONT)
        | _, None => None (A:=ENTCONT)
        | Some y, Some z => Some (take n z)
        end.

End Read.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A1 A2 P Q X Y B1 C1 : Universe, ((wd_ A1 X /\ (wd_ A2 X /\ (wd_ Q X /\ (wd_ A1 A2 /\ (wd_ A2 P /\ (wd_ A1 P /\ (wd_ X Y /\ (wd_ Q Y /\ (wd_ P Q /\ (wd_ P Y /\ (wd_ P X /\ (wd_ Q C1 /\ (wd_ P C1 /\ (wd_ C1 Y /\ (wd_ Q B1 /\ (wd_ P B1 /\ (wd_ B1 X /\ (col_ A1 A2 Q /\ (col_ A1 A2 X /\ (col_ A1 A2 Y /\ (col_ C1 B1 P /\ (col_ X P Q /\ col_ X Q Y)))))))))))))))))))))) -> col_ A1 A2 P)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D P Q C0 Q1 : Universe, ((wd_ P Q /\ (wd_ Q C0 /\ (wd_ P C0 /\ (wd_ C D /\ (wd_ D P /\ (wd_ C P /\ (wd_ A B /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ A C /\ (wd_ A D /\ (wd_ B C /\ (wd_ B D /\ (wd_ P Q1 /\ (wd_ C0 Q1 /\ (wd_ A C0 /\ (wd_ A Q1 /\ (wd_ B C0 /\ (wd_ B Q1 /\ (col_ A B P /\ (col_ C D C0 /\ (col_ Q P Q1 /\ (col_ P C0 A /\ col_ P C0 B))))))))))))))))))))))) -> col_ C0 A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import Robustdef.
Require Import ClassicalExtras.

(** This file contains several lemmas that are used in other proofs *)

Lemma list_longest_in_psem {K : language} : forall (P' : prg K) l,
    exists ll, (list_list_prefix ll l) /\ (psem P' (ftbd ll)) /\
          (forall l', list_list_prefix l' l -> psem P' (ftbd l') -> list_list_prefix l' ll).
Proof.
  intros P' l.
  induction l using list_ind_snoc.
  - exists nil; repeat (split; try now auto).
    + destruct (non_empty_sem K P') as [t Ht].
      exists t; split; simpl; auto. now case t.
  - destruct IHl as [ll [Hprefll [Hpsem Hmaxll]]].
    destruct (classic (psem P' (ftbd (snoc l a)))) as [Hsnoc | Hsnoc].
    + exists (snoc l a).  repeat (split; try now auto).
      now apply list_list_prefix_ref.
    + exists ll. repeat (split; try now auto).
      ++ simpl. now apply (list_prefix_snoc_list_prefix ll l a).
      ++ intros l' Hprefl' Hseml'.
         destruct (list_proper_or_equal l' (snoc l a)) as [Hequal | [aa Hproper]]; auto.
         +++ subst. contradiction.
         +++ apply list_pref_snoc_pref in Hproper.
             now apply (Hmaxll l').
Qed.

Lemma  longest_in_psem (tgt_sem : semantics_safety_like tgt) :
  forall W t, ~ sem tgt W t ->
    exists m, prefix m t /\ psem W m /\
     (forall m', prefix m' t -> psem W m' -> fpr m' m).
Proof.
  intros W [] HsemWt.
  + destruct (list_longest_in_psem W l) as [ll [Hpref [Hpsem Hmax]]].
    exists (ftbd ll). repeat (split; try now auto).
    intros [] Hm Hsem.
    ++ inversion Hm; subst. destruct Hsem as [tm [Hprefmtm Hsemm]].
       destruct tm; inversion Hprefmtm; subst. contradiction.
    ++ simpl in *. apply Hmax; auto.
  + destruct (list_longest_in_psem W l) as [ll [Hpref [Hpsem Hmax]]].
    exists (ftbd ll). repeat (split; try now auto).
    intros [] Hx Hsemx.
    ++ inversion Hx; subst.
    ++ simpl in *. apply Hmax; auto.
  + destruct (tgt_sem (tstream s) W) as [l [ebad [Hseml [Hprefl Hnsem_longer]]]]; auto.
    exists (ftbd l). simpl in *. repeat (split; try now auto).
    ++ apply (list_stream_prefix_trans l (snoc l ebad) s); auto.
       now apply snoc_longer.
    ++ intros [] Hpref_x HxsemW; try now inversion Hpref_x.
       simpl in *. destruct (list_stream_same_ext l0 (snoc l ebad) s); auto.
       * apply list_proper_or_equal in H. destruct H as [H | [a H]].
         ** subst. exfalso. apply Hnsem_longer. destruct HxsemW as [tx [H1 H2]].
                 now exists tx.
         ** now apply list_pref_snoc_pref in H.
       * exfalso. apply Hnsem_longer. destruct HxsemW as [tx [H1 H2]].
             exists tx. split; try now auto.
             destruct tx; simpl in *; try now apply (list_list_prefix_trans (snoc l ebad) l0 l1).
             now apply (list_stream_prefix_trans (snoc l ebad) l0 s0).
Qed.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Semantics Require Import
     Dynamic.Eval.Bool
     Static.TypeOf
     Static.TypeOf.Bool
     Static.WellTyped.Bool
.

From ExtensibleCompiler.Syntax Require Import
     Terms.Bool
     Types.BoolType
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Eval
     Functor
     IndexedAlgebra
     IndexedFunctor
     IndexedSubFunctor
     ProofAlgebra
     ProgramAlgebra
     SubFunctor
     Types
     TypeSoundness
     UniversalProperty
.

Local Open Scope SubFunctor.

Section Bool.

  Context
    {V}
    `{Functor V}
    `{! V supports Bool}

    {E}
    `{Functor E}
    `{! E supports Bool}

    {T}
    `{Functor T}
    `{! T supports BoolType}
  .

  Global Instance Soundness__Bool

         (WTV : (TypedExpr T V)-indexedPropFunctor)
         `(IndexedFunctor (TypedExpr T V) WTV)
         `((WellTypedValue__Bool <= WTV)%IndexedSubFunctor)

         `{Eval__E : ! forall R, ProgramAlgebra ForEval E R (EvalResult V)}
         `{! forall R, WellFormedCompoundProgramAlgebra (Eval__E R) Eval__Bool}

         (recEval   : WellFormedValue E -> EvalResult V)

         `{TypeOf__E : ! forall R, ProgramAlgebra ForTypeOf E R (TypeOfResult T)}
         `{! forall R, WellFormedCompoundProgramAlgebra (TypeOf__E R) TypeOf__Bool}

         (recTypeOf : WellFormedValue E -> TypeOfResult T)

    : ProofAlgebra
        ForSoundness Bool
        (sig (UniversalPropertyP2
                (AbstractSoundnessStatement' WTV recEval recTypeOf))).
  Proof.
    constructor.
    apply Induction2Algebra__Bool => b.
    rewrite / AbstractSoundnessStatement' / AbstractSoundnessStatement.
    rewrite / UniversalPropertyP2 /=.
    constructor.
    {
      apply conj; apply (proj2_sig (boolean b)).
    }
    {
      move => Gamma.
      rewrite / booleanF / boolean / inject /=.
      rewrite unwrapUP'_wrapF /=.
      rewrite fmapFusion / compose /=.
      rewrite wellFormedSubFunctor => //=.
      rewrite / programAlgebra'.
      rewrite wellFormedCompoundProgramAlgebra.
      rewrite wellFormedCompoundProgramAlgebra.
      move => IH tau TY.
      apply (iInject (F := WellTypedValue__Bool)) => /=.
      econstructor => //.
      move : TY => /=.
      move => [] <- //.
    }
  Defined.

End Bool.


From Tweetnacl.Libs Require Import Export.
From Tweetnacl.ListsOp Require Import Export.
From stdpp Require Import list.
Require Import ssreflect.

From Tweetnacl.Gen Require Import AMZubSqSel.
From Tweetnacl.Gen Require Import AMZubSqSel_Prop.
From Tweetnacl.Gen Require Import AMZubSqSel_List.
From Tweetnacl.Gen Require Import Get_abcdef.
From Tweetnacl.Gen Require Import abstract_fn_rev.

From Tweetnacl.Gen Require Import abstract_fn_rev_eq.
From Tweetnacl.Gen Require Import abstract_fn_rev_abcdef.
From Tweetnacl.Low Require Import Constant.
From Tweetnacl.Low Require Import List16.

Open Scope Z.

Section Crypto_Scalarmult_Eq_ac_List.

Context (List_Z_Ops : Ops (list Z) (list Z) id).
Context (List_Z_Ops_Prop : @Ops_List List_Z_Ops).
Local Instance List16_Ops : (Ops (@List16 Z) (List32B) id) := {}.
Proof.
apply A_List16.
apply M_List16.
apply Zub_List16.
apply Sq_List16.
apply C_0_List16.
apply C_1_List16.
apply C_121665_List16.
apply Sel25519_List16.
apply getbit_List32B.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
Defined.
Local Instance List16_List_Z_Eq : @Ops_Mod_P (List16 Z) (List32B) (list Z) id id List16_Ops List_Z_Ops := {
P := List16_to_List;
P' := List32_to_List
}.
Proof.
intros [] [] ; reflexivity.
intros [] [] ; reflexivity.
intros [] [] ; reflexivity.
intros [] ; reflexivity.
reflexivity.
reflexivity.
reflexivity.
intros b [] [] ; reflexivity.
intros i [] ; reflexivity.
Defined.

Lemma abstract_fn_rev_eq_a_list : ∀ (m p : ℤ) (CN : List32B) (L16ONE L16NUL L16UP : List16 ℤ) (Cn Up:list Z),
  0 ≤ m →
  List16_to_List L16ONE = Low.C_1 ->
  List16_to_List L16NUL = Low.C_0 ->
  List16_to_List L16UP = Up ->
  List32_to_List CN = Cn ->
  P (get_a (abstract_fn_rev m p CN L16ONE L16UP L16NUL L16ONE L16NUL L16NUL L16UP)) =
  get_a (abstract_fn_rev m p Cn Low.C_1 Up Low.C_0 Low.C_1 Low.C_0 Low.C_0 Up).
Proof.
  intros m p CN L16ONE L16NUL L16UP Cn Up.
  intros Hm.
  intros HL16ONE.
  intros HL16NUL.
  intros HL16UP.
  intros HL32CN.
  assert(Heq1:= @abstract_fn_rev_eq_a (List16 Z) List32B (list Z) id id List16_Ops List_Z_Ops List16_List_Z_Eq m p).
  specialize Heq1 with CN L16ONE L16UP L16NUL L16ONE L16NUL L16NUL L16UP.
  apply Heq1 in Hm.
  clear Heq1.
  move:Hm.
  rewrite /id /P /P' /List16_List_Z_Eq ?HL16ONE ?HL16NUL ?HL16UP ?HL32CN.
  trivial.
Qed.

Lemma abstract_fn_rev_eq_c_list : ∀ (m p : ℤ) (CN : List32B) (L16ONE L16NUL L16UP : List16 ℤ) (Cn Up:list Z),
  0 ≤ m →
  List16_to_List L16ONE = Low.C_1 ->
  List16_to_List L16NUL = Low.C_0 ->
  List16_to_List L16UP = Up ->
  List32_to_List CN = Cn ->
  P (get_c (abstract_fn_rev m p CN L16ONE L16UP L16NUL L16ONE L16NUL L16NUL L16UP)) =
  get_c (abstract_fn_rev m p Cn Low.C_1 Up Low.C_0 Low.C_1 Low.C_0 Low.C_0 Up).
Proof.
  intros m p CN L16ONE L16NUL L16UP Cn Up.
  intros Hm.
  intros HL16ONE HL16NUL HL16UP HL32CN.
  assert(Heq1:= @abstract_fn_rev_eq_c (List16 Z) List32B (list Z) id id List16_Ops List_Z_Ops List16_List_Z_Eq m p).
  specialize Heq1 with CN L16ONE L16UP L16NUL L16ONE L16NUL L16NUL L16UP.
  apply Heq1 in Hm.
  clear Heq1.
  move:Hm.
  rewrite /id /P /P' /List16_List_Z_Eq ?HL16ONE ?HL16NUL ?HL16UP ?HL32CN.
  trivial.
Qed.

End Crypto_Scalarmult_Eq_ac_List.

Close Scope Z.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^266 - 3
Base: 24 + 2/11
***)

Definition curve : CurveParameters :=
  {|
    sz := 11%nat;
    base := 24 + 2/11;
    bitwidth := 32;
    s := 2^266;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 11); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.