(** * Build a table for the next binop at a given level *)
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Common.

Set Implicit Arguments.

Section specific.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.

  Local Ltac induction_str_len str :=
    let len := fresh "len" in
    set (len := length str);
      generalize (eq_refl : length str = len);
      clearbody len; revert str;
      induction len; intros str ?.

  Section paren_balanced_def.
    Definition paren_balanced'_step (ch : Char) (pbh_rest : nat -> bool) (start_level : nat)
    : bool
      := if is_bin_op ch
         then pbh_rest start_level
         else if is_open ch
              then pbh_rest (S start_level)
              else if is_close ch
                   then ((Compare_dec.gt_dec start_level 0)
                           && pbh_rest (pred start_level))%bool
                   else pbh_rest start_level.

    Global Instance paren_balanced'_step_Proper {ch}
    : Proper ((eq ==> eq) ==> eq ==> eq) (paren_balanced'_step ch).
    Proof.
      unfold paren_balanced'_step.
      repeat intro; subst.
      unfold respectful in *.
      edestruct Compare_dec.gt_dec; simpl;
      repeat match goal with
               | _ => reflexivity
               | [ |- context[if ?e then _ else _] ] => destruct e
               | [ H : _ |- _ ] => apply H
             end.
    Qed.

    Definition paren_balanced' (str : String) (start_level : nat)
    : bool
      := fold
           paren_balanced'_step
           Compare_dec.zerop
           str
           start_level.

    Lemma paren_balanced'_nil (str : String) (H : length str = 0)
    : paren_balanced' str = Compare_dec.zerop.
    Proof.
      apply fold_nil; assumption.
    Qed.

    Lemma paren_balanced'_recr {HSLP : StringLikeProperties Char} (str : String)
    : paren_balanced' str
      = match get 0 str with
          | Some ch => paren_balanced'_step ch (paren_balanced' (drop 1 str))
          | None => Compare_dec.zerop
        end.
    Proof.
      apply fold_recr.
    Qed.

    Global Instance paren_balanced'_Proper1 {HSLP : StringLikeProperties Char}
    : Proper (beq ==> eq ==> eq) paren_balanced'.
    Proof.
      unfold paren_balanced'.
      repeat intro; subst.
      match goal with
        | [ |- ?f ?x = ?g ?x ] => cut (f = g); [ let H := fresh in intro H; rewrite H; reflexivity | ]
      end.
      setoid_subst_rel beq.
      reflexivity.
    Qed.

    Typeclasses Opaque paren_balanced'.
    Opaque paren_balanced'.

    (*Lemma paren_balanced'_S {HSLP : StringLikeProperties Char} (str : String) n
    : paren_balanced' str n -> paren_balanced' str (S n).
    Proof.
      revert n.
      induction_str_len str.
      { rewrite paren_balanced'_nil by assumption; simpl.
        reflexivity. }
      { specialize (IHlen (drop 1 str)).
        rewrite drop_length in IHlen.
        repeat match goal with
                 | [ H : ?A -> ?B |- _ ] => let H' := fresh in assert (H' : A) by omega; specialize (H H'); clear H'
               end.
        rewrite paren_balanced'_recr.
        destruct (singleton_exists (take 1 str)) as [ch H''].
        { rewrite take_length, H; reflexivity. }
        { rewrite (proj1 (get_0 _ _) H'').
          unfold paren_balanced'_step.
          repeat match goal with
                   | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                   | _ => reflexivity
                   | _ => solve [ eauto with nocore ]
                   | _ => progress simpl in *
                   | _ => setoid_rewrite Bool.andb_true_iff
                   | _ => intro
                   | [ H : and _ _ |- _ ] => destruct H
                   | [ H : bool_of_sumbool ?x = true |- _ ] => destruct x
                   | _ => progress subst
                   | _ => congruence
                   | [ H : ?n > 0 |- _ ] => is_var n; destruct n
                 end. } }
    Qed.

    Lemma paren_balanced'_le {HSLP : StringLikeProperties Char} (str : String) n1 n2 (H : n1 <= n2)
    : paren_balanced' str n1 -> paren_balanced' str n2.
    Proof.
      apply Minus.le_plus_minus in H.
      revert str.
      generalize dependent (n2 - n1).
      intros diff ?; subst n2; revert n1.
      induction diff; simpl.
      { intros ?? H.
        replace (n1 + 0) with n1 by omega.
        assumption. }
      { intro n1.
        replace (n1 + S diff) with (S (n1 + diff)) by omega.
        intros.
        eauto using paren_balanced'_S with nocore. }
    Qed.*)

    Definition paren_balanced (str : String) := paren_balanced' str 0.

    Global Instance paren_balanced_Proper1 {HSLP : StringLikeProperties Char}
    : Proper (beq ==> eq) paren_balanced.
    Proof.
      repeat intro.
      unfold paren_balanced.
      setoid_subst_rel beq.
      reflexivity.
    Qed.

    Lemma paren_balanced'_split {HSLP : StringLikeProperties Char}
          (str : String) (n : nat) (level1 level2 : nat)
          (H1 : paren_balanced' (take n str) level1)
          (H2 : paren_balanced' (drop n str) level2)
    : paren_balanced' str (level1 + level2).
    Proof.
      revert n level1 level2 H1 H2.
      set (len := length str).
      generalize (eq_refl : length str = len).
      clearbody len.
      revert str.
      induction len as [|len IHlen].
      { intros str Hlen ???.
        rewrite !paren_balanced'_nil
          by (rewrite ?drop_length, ?take_length, Hlen; destruct n; reflexivity).
        destruct level1, level2; simpl; intros; congruence. }
      { intros str Hlen ???.
        specialize (IHlen (drop 1 str)).
        specialize_by (rewrite drop_length; omega).
        specialize (IHlen (pred n)).
        destruct n as [|n].
        { clear IHlen.
          rewrite drop_0.
          rewrite !paren_balanced'_nil
            by (rewrite ?drop_length, ?take_length, Hlen; reflexivity).
          destruct level1; simpl; intros; [ assumption | congruence ]. }
        { simpl in *.
          setoid_rewrite drop_drop in IHlen.
          setoid_rewrite take_drop in IHlen.
          rewrite !NPeano.Nat.add_1_r in IHlen.
          specialize (fun H' level1 H => IHlen level1 level2 H H').
          intros H1 H2.
          specialize_by assumption.
          rewrite paren_balanced'_recr in H1 |- *.
          rewrite get_take_lt in H1 by omega.
          destruct (get 0 str) eqn:H'.
          { unfold paren_balanced'_step in *.
            repeat match goal with
                     | _ => progress simpl in *
                     | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                     | [ IHlen : forall level : nat, _ -> _, H : is_true (paren_balanced' _ _) |- _ ]
                       => specialize (IHlen _ H)
                     | [ IHlen : forall level : nat, _ -> _, H : paren_balanced' _ _ = true |- _ ]
                       => specialize (IHlen _ H)
                     | _ => solve [ eauto with nocore ]
                     | [ H : is_true (andb _ _) |- _ ] => apply Bool.andb_true_iff in H
                     | _ => progress split_and
                     | [ |- is_true (andb _ _) ] => apply Bool.andb_true_iff
                     | _ => congruence
                     | _ => omega
                     | [ H : context[bool_of_sumbool ?e] |- _ ] => destruct e; simpl in H
                     | [ |- context[bool_of_sumbool ?e] ] => destruct e; simpl
                     | [ |- _ /\ _ ] => split
                     | [ H : context[pred ?x] |- _ ] => is_var x; destruct x
                   end. }
          { apply no_first_char_empty in H'.
            omega. } } }
    Qed.

    Lemma paren_balanced'_split_0 {HSLP : StringLikeProperties Char}
          (str : String) (n : nat) (level : nat)
          (H1 : paren_balanced' (take n str) 0)
          (H2 : paren_balanced' (drop n str) level)
    : paren_balanced' str level.
    Proof.
      change level with (0 + level).
      eapply paren_balanced'_split; eassumption.
    Qed.
  End paren_balanced_def.

  Section paren_balanced_hiding_def.
    Definition paren_balanced_hiding'_step (ch : Char) (pbh_rest : nat -> bool) (start_level : nat)
    : bool
      := if is_bin_op ch
         then ((Compare_dec.gt_dec start_level 0)
                 && pbh_rest start_level)%bool
         else paren_balanced'_step ch pbh_rest start_level.

    Global Instance paren_balanced_hiding'_step_Proper {ch}
    : Proper ((eq ==> eq) ==> eq ==> eq) (paren_balanced_hiding'_step ch).
    Proof.
      unfold paren_balanced_hiding'_step.
      repeat intro; subst.
      edestruct Compare_dec.gt_dec; simpl;
      repeat match goal with
               | _ => reflexivity
               | [ H : _ |- _ ] => erewrite !H; reflexivity
             end.
    Qed.

    Definition paren_balanced_hiding' (str : String) (start_level : nat)
    : bool
      := fold
           paren_balanced_hiding'_step
           (Compare_dec.zerop)
           str
           start_level.

    Lemma paren_balanced_hiding'_nil (str : String) (H : length str = 0)
    : paren_balanced_hiding' str = Compare_dec.zerop.
    Proof.
      apply fold_nil; assumption.
    Qed.

    Lemma paren_balanced_hiding'_recr {HSLP : StringLikeProperties Char} (str : String)
    : paren_balanced_hiding' str
      = match get 0 str with
          | Some ch => paren_balanced_hiding'_step ch (paren_balanced_hiding' (drop 1 str))
          | None => Compare_dec.zerop
        end.
    Proof.
      apply fold_recr.
    Qed.

    Global Instance paren_balanced_hiding'_Proper1 {HSLP : StringLikeProperties Char}
    : Proper (beq ==> eq ==> eq) paren_balanced_hiding'.
    Proof.
      unfold paren_balanced_hiding'.
      repeat intro; subst.
      match goal with
        | [ |- ?f ?x = ?g ?x ] => cut (f = g); [ let H := fresh in intro H; rewrite H; reflexivity | ]
      end.
      setoid_subst_rel beq.
      reflexivity.
    Qed.

    Typeclasses Opaque paren_balanced_hiding'.
    Opaque paren_balanced_hiding'.

    (*Lemma paren_balanced_hiding'_S {HSLP : StringLikeProperties Char} (str : String) n
    : paren_balanced_hiding' str n -> paren_balanced_hiding' str (S n).
    Proof.
      revert n.
      induction_str_len str.
      { rewrite paren_balanced_hiding'_nil by assumption; simpl.
        reflexivity. }
      { specialize (IHlen (drop 1 str)).
        rewrite drop_length in IHlen.
        repeat match goal with
                 | [ H : ?A -> ?B |- _ ] => let H' := fresh in assert (H' : A) by omega; specialize (H H'); clear H'
               end.
        rewrite paren_balanced_hiding'_recr.
        destruct (singleton_exists (take 1 str)) as [ch H''].
        { rewrite take_length, H; reflexivity. }
        { rewrite (proj1 (get_0 _ _) H'').
          unfold paren_balanced_hiding'_step, paren_balanced'_step.
          repeat match goal with
                   | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                   | _ => reflexivity
                   | _ => solve [ eauto with nocore ]
                   | _ => progress simpl in *
                   | _ => setoid_rewrite Bool.andb_true_iff
                   | _ => intro
                   | [ H : and _ _ |- _ ] => destruct H
                   | [ H : bool_of_sumbool (Compare_dec.gt_dec ?a ?b) = true |- _ ] => destruct (Compare_dec.gt_dec a b)
                   | _ => congruence
                   | [ H : ?n > 0 |- _ ] => is_var n; destruct n
                 end. } }
    Qed.

    Lemma paren_balanced_hiding'_le {HSLP : StringLikeProperties Char} (str : String) n1 n2 (H : n1 <= n2)
    : paren_balanced_hiding' str n1 -> paren_balanced_hiding' str n2.
    Proof.
      apply Minus.le_plus_minus in H.
      revert str.
      generalize dependent (n2 - n1).
      intros diff ?; subst n2; revert n1.
      induction diff; simpl.
      { intros ?? H.
        replace (n1 + 0) with n1 by omega.
        assumption. }
      { intro n1.
        replace (n1 + S diff) with (S (n1 + diff)) by omega.
        intros.
        eauto using paren_balanced_hiding'_S with nocore. }
    Qed.*)

    Definition paren_balanced_hiding (str : String) := paren_balanced_hiding' str 0.

    Global Instance paren_balanced_hiding_Proper1 {HSLP : StringLikeProperties Char}
    : Proper (beq ==> eq) paren_balanced_hiding.
    Proof.
      repeat intro.
      unfold paren_balanced_hiding.
      setoid_subst_rel beq.
      reflexivity.
    Qed.

    Lemma paren_balanced_hiding'_split {HSLP : StringLikeProperties Char}
          (str : String) (n : nat) (level1 level2 : nat)
          (H1 : if Compare_dec.gt_dec level2 0
                then paren_balanced' (take n str) level1
                else paren_balanced_hiding' (take n str) level1)
          (H2 : paren_balanced_hiding' (drop n str) level2)
    : paren_balanced_hiding' str (level1 + level2).
    Proof.
      revert n level1 level2 H1 H2.
      set (len := length str).
      generalize (eq_refl : length str = len).
      clearbody len.
      revert str.
      induction len as [|len IHlen].
      { intros str Hlen ???.
        rewrite !paren_balanced_hiding'_nil
          by (rewrite ?drop_length, ?take_length, Hlen; destruct n; reflexivity).
        destruct level1, level2; simpl; intros; congruence. }
      { intros str Hlen ???.
        specialize (IHlen (drop 1 str)).
        specialize_by (rewrite drop_length; omega).
        specialize (IHlen (pred n)).
        destruct n as [|n].
        { clear IHlen.
          rewrite drop_0.
          rewrite ?paren_balanced_hiding'_nil, ?paren_balanced'_nil
            by (rewrite ?drop_length, ?take_length, Hlen; reflexivity).
          destruct level1, level2; simpl; intros; first [ assumption | congruence ]. }
        { simpl in *.
          setoid_rewrite drop_drop in IHlen.
          rewrite !NPeano.Nat.add_1_r in IHlen.
          specialize (fun H' level1 H => IHlen level1 level2 H H').
          intros H1 H2.
          specialize_by assumption.
          rewrite paren_balanced_hiding'_recr in H1 |- *.
          rewrite paren_balanced'_recr in H1.
          rewrite !get_take_lt in H1 by omega.
          destruct (get 0 str) eqn:H'.
          { unfold paren_balanced_hiding'_step, paren_balanced'_step in *.
            repeat match goal with
                     | _ => progress simpl in *
                     | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                     | [ IHlen : forall level : nat, is_true (?f _ _) -> _, H : is_true (?f _ _) |- _ ]
                       => specialize (IHlen _ H)
                     | [ IHlen : forall level : nat, is_true (?f _ _) -> _, H : ?f _ _ = true |- _ ]
                       => specialize (IHlen _ H)
                     | _ => solve [ eauto with nocore ]
                     | [ H : is_true (andb _ _) |- _ ] => apply Bool.andb_true_iff in H
                     | _ => progress split_and
                     | [ |- is_true (andb _ _) ] => apply Bool.andb_true_iff
                     | _ => congruence
                     | _ => omega
                     | [ H : context[take _ (drop _ _)] |- _ ] => setoid_rewrite take_drop in H
                     | [ H : context[(_ + 1)%nat] |- _ ] => rewrite !NPeano.Nat.add_1_r in H
                     | [ H : context[bool_of_sumbool ?e] |- _ ] => destruct e; simpl in H
                     | [ H : context[match ?e with left _ => _ | right _ => _ end] |- _ ] => destruct e; simpl in H
                     | [ |- context[bool_of_sumbool ?e] ] => destruct e; simpl
                     | [ |- _ /\ _ ] => split
                     | [ H : context[pred ?x] |- _ ] => is_var x; destruct x
                   end. }
          { apply no_first_char_empty in H'.
            omega. } } }
    Qed.

    Lemma paren_balanced_hiding'_split_0 {HSLP : StringLikeProperties Char}
          (str : String) (n : nat) (level : nat)
          (H1 : if Compare_dec.gt_dec level 0
                then paren_balanced' (take n str) 0
                else paren_balanced_hiding' (take n str) 0)
          (H2 : paren_balanced_hiding' (drop n str) level)
    : paren_balanced_hiding' str level.
    Proof.
      change level with (0 + level).
      eapply paren_balanced_hiding'_split; eassumption.
    Qed.
  End paren_balanced_hiding_def.

  Section paren_balanced_to_hiding.
    Lemma paren_balanced_hiding_impl_paren_balanced' {HSLP : StringLikeProperties Char} n (str : String)
    : paren_balanced_hiding' str n -> paren_balanced' str n.
    Proof.
      revert n.
      induction_str_len str.
      { rewrite paren_balanced_hiding'_nil, paren_balanced'_nil by assumption; trivial. }
      { specialize (IHlen (drop 1 str)).
        rewrite drop_length, <- Minus.pred_of_minus in IHlen.
        specialize (IHlen (f_equal pred H)).
        rewrite paren_balanced_hiding'_recr, paren_balanced'_recr.
        edestruct get as [ch|]; trivial; [].
        unfold paren_balanced_hiding'_step, paren_balanced'_step.
        destruct (is_bin_op ch); try reflexivity;
        intros [|?]; simpl;
        destruct (is_open ch), (is_close ch);
        eauto with nocore;
        try (unfold is_true; intros; congruence). }
    Qed.

    Lemma paren_balanced_hiding_impl_paren_balanced {HSLP : StringLikeProperties Char} (str : String)
    : paren_balanced_hiding str -> paren_balanced str.
    Proof.
      apply paren_balanced_hiding_impl_paren_balanced'.
    Qed.

    (*Lemma paren_balanced_impl_paren_balanced_hiding' {HSLP : StringLikeProperties Char} n (str : String)
    : paren_balanced' str n -> paren_balanced_hiding' str (S n).
    Proof.
      revert n.
      induction_str_len str.
      { rewrite paren_balanced_hiding'_nil, paren_balanced'_nil by assumption; trivial. }
      { specialize (IHlen (drop 1 str)).
        rewrite drop_length, <- Minus.pred_of_minus in IHlen.
        specialize (IHlen (f_equal pred H)).
        rewrite paren_balanced_hiding'_recr, paren_balanced'_recr.
        edestruct get as [ch|]; trivial; [].
        unfold paren_balanced_hiding'_step, paren_balanced'_step.
        destruct (is_bin_op ch); simpl; eauto with nocore; [].
        intros [|?]; simpl;
        destruct (is_open ch), (is_close ch);
        eauto with nocore;
        try (unfold is_true; intros; congruence). }
    Qed.

    Lemma paren_balanced_impl_paren_balanced_hiding'_lt {HSLP : StringLikeProperties Char} n n' (Hlt : n < n') (str : String)
    : paren_balanced' str n -> paren_balanced_hiding' str n'.
    Proof.
      apply Minus.le_plus_minus in Hlt.
      generalize dependent (n' - S n).
      intros n'' ?; subst.
      revert n.
      induction n''.
      { intro.
        rewrite <- plus_n_O.
        apply paren_balanced_impl_paren_balanced_hiding'. }
      { simpl in *.
        intros n H'.
        apply paren_balanced_hiding'_S.
        rewrite NPeano.Nat.add_succ_r; eauto with nocore. }
    Qed.*)
  End paren_balanced_to_hiding.
End specific.

Global Opaque paren_balanced' paren_balanced_hiding'.


(************************************************************************)
(* This library include Coq definitions of Android inter-component communication,
   intent, intent filter and tests required for intent delivery. The proofs
   of intent delivery and intent broadcasts are carried. *)
(************************************************************************)

 Require Import Arith.
 Require Import Atom.
 Require Import List.

(************************ Basic Definitions *********************************************)

(**Decidable equality on atoms *)

Notation "x == y" :=
  (eq_atom_dec x y) (at level 67) : metatheory_scope.
Open Scope metatheory_scope.

Definition eq_atom (x y : atom) : bool :=
    if (x == y) then true else false.

Notation "x =?= y" :=
  (eq_atom x y) (at level 67) : metatheory_scope.

(**Finds a name in the list.*)
Fixpoint find (n: atom) (nl: list atom) : bool :=
 match nl with
 | nil => false
 | cons h tl => if (h =?= n) then true else find n tl
 end.

(**Boolean and*)
Definition andb (b1 b2: bool) : bool :=
 match b1, b2 with
 | true, _ => b2
 | false, _ => false
 end.

(**Boolean or*)
Definition orb (b1 b2: bool) : bool :=
 match b1, b2 with
 | false, false => false
 | _, _ => true
 end.

Notation "b1 & b2" := (andb b1 b2) (at level 60, right associativity).

(****************************************************************************************)
(**************************** IPC Formalization *****************************************)
(****************************************************************************************)

(*************************** URI, Intent, Filter ****************************************)

(*Content URI: optional scheme, host, port, and path:*)
Inductive uri: Type :=
 | valid_uri: option atom -> option atom -> option nat -> option atom -> uri.

(**Implicit intent: action, category, data (uri, MIME type)*)
Inductive intent: Type :=
  int: atom -> list atom -> uri -> atom -> intent.

(**Intent filter: contain specification of actions, categories, URI and MIME types.*)
Inductive filter: Type :=
  filt: list atom -> list atom -> list uri -> list atom -> filter.

(*************************** Testing ACTION ********************************************)

(**Finds a match for an intent action in the filter actions.*)
Definition testaction (action : atom) (fil : filter) : bool :=
 match fil with
 | filt actions _ _ _ => find action actions
 end.

(*************************** Testing CATEGORIES ****************************************)

(**Checks if ALL intent categories exist in the filter.*)
Fixpoint testcategory (intentcats : list atom) (filtercats : list atom ) {struct intentcats} : bool :=
  match intentcats with
  | nil => true
  | cons x l => match (find x l) with
           | false => false
           | true => testcategory l filtercats
           end
  end.

(*************************** Testing URI ************************************************)
(*Compare optional filter URI attribute with an intent URI attribute. *)
Definition cmpoattr (on1 on2: option atom) : bool :=
 match on1, on2 with
 | None, _ => true (*if attribute is NOT specified in filter, test is passed.*)
 | Some n1, Some n2 => (n1 =?= n2)
 | Some n, None => false (*if a filter URI attribute is not listed in intent, test fails*)
 end.

(**Equivality on optional port numbers (listed in filter and intent)*)
Definition beq_nato (on1 on2: option nat) : bool :=
 match on1, on2 with
 | None, _ => true  (*no port is specified in filter*)
 | Some n1, Some n2 => beq_nat n1 n2 (*both specifies ports and equality is test*)
 | Some n, None => false (*no port is specified in the intent*)
 end.

(**"When the URI in an intent is compared to a URI specification in a filter,
 it's compared only to the parts of the URI included in the filter. For example:
 a) If a scheme is not specified, the host is ignored.
 b) If a host is not specified, the port is ignored.
 c) If both the scheme and host are not specified, the path is ignored.
 d) If a filter specifies only a scheme, all URIs with that scheme match the filter.
 e) If a filter specifies a scheme and an authority but no path, all URIs with the same
  scheme and authority pass the filter, regardless of their paths.
 f) If a filter specifies a scheme, an authority, and a path, only URIs with the same
  scheme, authority, and path pass the filter." *)
Fixpoint testuri (filuri iuri: uri) : bool :=
 match filuri, iuri with
 | valid_uri None None None None, _ => true (*no URI in filter, test is passed.*)
 | valid_uri None _ (Some port) (Some path), valid_uri _ _ porto patho =>
    beq_nato (Some port) porto & cmpoattr (Some path) patho (*a*)
 | valid_uri (Some scheme) None _ (Some path), valid_uri schemeo _ _ patho =>
    cmpoattr (Some scheme) schemeo & cmpoattr (Some path) patho (*b*)
 | valid_uri None None (Some port) _, valid_uri _ _ porto _ =>
    beq_nato (Some port) porto (*c*)
 | valid_uri (Some scheme) None None None, valid_uri (Some scheme') _ _ _ => scheme =?= scheme' (*d*)
 | valid_uri (Some scheme) (Some host) _ None, valid_uri (Some scheme') (Some host') _ _ =>
    (scheme =?= scheme') & (host =?= host')  (*e*)
 | valid_uri (Some scheme) (Some host) _ (Some path), valid_uri (Some scheme') (Some host') _ (Some path') =>
    (scheme =?= scheme') & (host =?= host') & (path =?= path') (*f*)
 | valid_uri schemeo hosto porto patho, valid_uri schemeo' hosto' porto' patho' =>  (*otherwise case*)
    cmpoattr schemeo schemeo' & cmpoattr hosto hosto' & beq_nato porto porto' & cmpoattr patho patho'
 end.

(**Example of ambiguity captured
 (*If a host is not specified, the port is ignored.*)
 | valid_uri (Some scheme) None _ patho, valid_uri schemeo' _ _ patho' =>
    cmpoattr (Some scheme) schemeo' & cmpoattr patho patho'

 Contradicts

 If a filter specifies only a scheme, all URIs with that scheme match the filter.
 | valid_uri (Some scheme) None None None, valid_uri (Some scheme') _ _ _ => namecmp scheme scheme'
*)

(*************************** Testing MIME Type *****************************************)

(**Finds an atom (intent type) match in the list of atoms (filter types).
  NOTE: If there is no type, one should be inferred, however, this is not formalized.*)
Definition testtype (filtypes: list atom) (itype: atom): bool :=
 match filtypes, itype with
 | nil, _ => true
 | filtypes, it => find it filtypes
 end.

(*************************** Testing DATA *********************************************)

(**"The data test compares both the URI and the MIME type in the intent to a URI and MIME type
 specified in the filter. The rules are as follows:
 a) An intent that contains neither a URI nor a MIME type passes the test only if the
  filter does not specify any URIs or MIME types.
 b) An intent that contains a URI but no MIME type (neither explicit nor inferable from
  the URI) passes the test only if its URI matches the filter's URI format and the filter
  likewise does not specify a MIME type.
 c) An intent that contains a MIME type but not a URI passes the test only if the filter
  lists the same MIME type and does not specify a URI format.
 d) An intent that contains both a URI and a MIME type (either explicit or inferable from
  the URI) passes the MIME type part of the test only if that type matches a type listed
  in the filter. It passes the URI part of the test either if its URI matches a URI in
  the filter *****or if it has a content: or file: URI and the filter does not specify a
  URI****. In other words, a component is presumed to support content: and file: data if
  its filter lists only a MIME type."*)
Fixpoint testdata (iuri: option uri) (itype: option atom)
      (filuris: list uri) (filtypes: list atom) : bool :=
 match iuri, itype, filuris, filtypes with
 | None, None, nil, nil => true  (*a*)
 | Some u, None, cons u' ul, nil => orb (testuri u' u) (testdata iuri None ul nil)  (*b*)
 | None, Some it, nil, ftl => testtype ftl it (*c*)
 | Some u, Some it, cons u' ul, ftl =>
    (orb (testuri u' u) (testdata iuri None ul nil)) & (testtype ftl it) (*d*)
 | None, None, cons u' ul, nil => false
 | None, None, nil, cons t' tl => false
 | None, None, cons u' ul, cons t' tl => true  (*a*)
 | _, _, _, _ => false  (*otherwise cases*)
 end.

(*************************** Delivering Intent *****************************************)

(**An intent is accepted only if it passes all the three tests*)
Definition accept (i: intent) (f: filter) : bool :=
 match i, f with
 | int a cl u t, filt fal fcl ful ftl =>
    testaction a (filt fal fcl ful ftl) &
    testcategory cl fcl &
    testdata (Some u) (Some t) ful ftl
 end.

(****************************************************************************************)
(**************************** Proof of Delivery *****************************************)
(****************************************************************************************)

(**A component accepts an inent ONLY IF it passes all the three tests.*)
Theorem accept_intent: forall a cl u t fal fcl ful ftl,
  testaction a (filt fal fcl ful ftl) = true ->
  testcategory cl fcl = true ->
  testdata (Some u) (Some t) ful ftl = true ->
  accept (int a cl u t) (filt fal fcl ful ftl) = true.
Proof.
 intros ???????? TA TC TD.
 unfold accept.
 rewrite TA.
 rewrite TC.
 rewrite TD.
 simpl. auto.
Qed.

(*An application is modeled as a filter.*)
Definition application := filter.

(*Android system is a list of application.*)
Definition system := list application.

(*An intent is broadcast, if it is accepted by every application in the system*)
Fixpoint broadcast (I: intent) (S: system) : bool :=
  match S with
 | nil => true
 | cons A A' => (accept I A) & broadcast I A'
 end.

Lemma app_nil_left : forall l:list application, l = nil++l.
Proof.
 induction l; simpl in |- *; auto.
Qed.

Lemma broadcast_append: forall l l' a I,
  broadcast I (l'++(a :: l)) = accept I a & broadcast I (l'++l).
Proof.
 intros.
 induction l'.
  (*CASE: l'=nil*)
  do 2 rewrite <- app_nil_left.
  auto.
  (*CASE: l'=a0::l'*)
  simpl in *.
  rewrite IHl'.
  destruct (accept I a0);simpl;auto.
  destruct (accept I a);simpl;auto.
Qed.

Theorem broadcast_general: forall I A S,
 broadcast I S = true ->
 In A S ->
 accept I A = true.
Proof.
 intros ?????.
 apply In_split in H0.
 destruct H0.
 destruct H0.
 rewrite H0 in H.
 rewrite -> broadcast_append in H.
 unfold andb in *.
 destruct (accept I A).
  (*CASE true*)
  auto.
  (*CASE false*)
  inversion H.
Qed.

(****************** End ******************)


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Examples.Cells.Cells.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Definition swap_gallina (c1 c2: cell) :=
    let/n v1 := get c1 in
    let/n v2 := get c2 in
    let/n c1 := put v2 in
    let/n c2 := put v1 in
    (c1, c2).

  Instance spec_of_swap : spec_of "swap" :=
    fnspec! "swap" c1_ptr c2_ptr / c1 c2 R,
    { requires tr mem :=
        (cell_value c1_ptr c1 ⋆ cell_value c2_ptr c2 ⋆ R) mem;
      ensures tr' mem' :=
        tr' = tr /\
        let p := (swap_gallina c1 c2) in
        (cell_value c1_ptr (fst p) ⋆ cell_value c2_ptr (snd p) ⋆ R) mem' }.

  Derive swap_br2fn SuchThat
         (defn! "swap"("c1", "c2") { swap_br2fn },
          implements swap_gallina)
    As swap_br2fn_ok.
  Proof.
    compile.
  Qed.
End with_parameters.

From bedrock2 Require Import BasicC64Semantics NotationsCustomEntry.
Compute swap_br2fn. (* (word := word) *)


Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.StateMonad.

Set Implicit Arguments.
Set Strict Implicit.

Section Graph.
  Variable V : Type.
  Variable G : Type.

  Class BuildGraph : Type :=
  { emptyGraph : G
  ; addVertex : V -> G -> G
  ; addEdge   : V -> V -> G -> G
  }.
End Graph.

Arguments emptyGraph {_} {_} {_}.
Arguments addVertex {_} {_} {_} _ _.
Arguments addEdge {_} {_} {_} _ _ _.

(** A State Monad simplifies things **)
Section Monadic.
  Variable m : Type -> Type.
  Context {Monad_m : Monad m}.

  Variable V : Type.
  Variable G : Type.
  Variable BuildGraph_VG : BuildGraph V G.

  Definition GraphBuilderT (T : Type) : Type := stateT G m T.

  Global Instance Monad_GraphBuilder : Monad GraphBuilderT :=
    Monad_stateT _ _.

  Global Instance MonadT_GraphBuilder : MonadT GraphBuilderT m :=
    MonadT_stateT _ _.

  Instance State_GraphBuilder : MonadState G GraphBuilderT :=
    MonadState_stateT _ _.

  Import MonadNotation.
  Local Open Scope monad_scope.

  Definition newEdge (f t : V) : GraphBuilderT unit :=
    g <- get ;;
    put (addEdge f t g).

  Definition newVertex (v : V) : GraphBuilderT unit :=
    g <- get ;;
    put (addVertex v g).

  Definition buildGraph {v} (c : GraphBuilderT v) (g : G) : m G :=
    execStateT c g.

End Monadic.

Arguments newEdge {_} {_} {_} {_} {_} (_) (_).
Arguments newVertex {_} {_} {_} {_} {_} (_).


(*! Proof of correctness of the multiplier module !*)

Require Import Koika.Frontend Koika.Std Koika.ProgramTactics.
Require Export rv.Multiplier.
Require Import Lia.

Module MultiplierProofs.
  Module Sig32 <: Multiplier_sig.
    Definition n := 32.
  End Sig32.
  Module mul32 := ShiftAddMultiplier Sig32.
  Import mul32.
  Import Sig32.

  Definition default := ContextEnv.(create) r.

  Definition typed_enq :=
    tc_function R empty_Sigma enq.

  Definition typed_step :=
    tc_function R empty_Sigma step.

  Definition typed_deq :=
    tc_function R empty_Sigma deq.

  Notation all_regs :=
    [valid; operand1; operand2; result; n_step; finished].

  Definition partial_mul (a b n_step: N) :=
    (a * (b mod (2 ^ n_step)))%N.

  Lemma mod_succ_add (a n: N) :
    (a mod (2 ^ N.succ n) = a mod 2 ^ n + (N.b2n (N.testbit a n)) * 2 ^ n)%N.
  Proof.
    rewrite N.pow_succ_r'.
    rewrite (N.div_mod' a (2 ^ n)) at 1.
    rewrite N.testbit_spec'.
    rewrite N.add_mod by (destruct n; cbn; lia).
    rewrite (N.mul_comm 2 (2 ^ n)).
    rewrite N.mul_mod_distr_l by (destruct n; cbn; lia).
    rewrite (N.mod_small (a mod 2 ^ n)).
    - rewrite N.mod_small; [ ring | ].
      eapply N.le_lt_trans.
      + apply N.add_le_mono.
        * apply N.mul_le_mono_l, N.lt_le_pred.
          apply N.mod_upper_bound. lia.
        * apply N.lt_le_pred, N.mod_lt. destruct n; cbn; lia.
      + cbn. rewrite N.mul_1_r. rewrite N.pred_sub.
        enough (2 ^ n > 0)%N by lia.
        destruct n; cbn; lia.
    - eapply N.lt_trans.
      + apply N.mod_lt.
        destruct n; discriminate.
      + rewrite <-(N.mul_1_r (2 ^ n)) at 1.
        apply N.mul_lt_mono_pos_l; destruct n; cbn; lia.
  Qed.

  Lemma partial_mul_step (a b n_step: N) :
    partial_mul a b (N.succ n_step) =
    ((partial_mul a b n_step) +
     a * (N.b2n (N.testbit b n_step) * (2 ^ n_step)))%N.
  Proof.
    unfold partial_mul.
    rewrite mod_succ_add.
    ring.
  Qed.

  Lemma mul_to_partial_mul :
    forall n x y,
      (y < 2 ^ n)%N ->
      (x * y = partial_mul x y n)%N.
  Proof.
    intros.
    unfold partial_mul.
    rewrite N.mod_small; auto.
  Qed.

  Definition step_invariant (reg: ContextEnv.(env_t) R) :=
    (Bits.to_N (ContextEnv.(getenv) reg n_step) < N.of_nat n)%N.

  Definition finished_invariant (reg: ContextEnv.(env_t) R) :=
    let valid_val := Bits.to_N (ContextEnv.(getenv) reg valid) in
    let finished_val := Bits.to_N (ContextEnv.(getenv) reg finished) in
    valid_val = 0%N -> finished_val = 0%N.

  Definition result_invariant (reg: ContextEnv.(env_t) R) :=
    let valid_val := Bits.to_N (ContextEnv.(getenv) reg valid) in
    let finished_val := Bits.to_N (ContextEnv.(getenv) reg finished) in
    let result_val := Bits.to_N (ContextEnv.(getenv) reg result) in
    let op1_val := Bits.to_N (ContextEnv.(getenv) reg operand1) in
    let op2_val := Bits.to_N (ContextEnv.(getenv) reg operand2) in
    let n_step_val := Bits.to_N (ContextEnv.(getenv) reg n_step) in
    valid_val = 1%N ->
    finished_val = 0%N ->
    result_val = partial_mul op1_val op2_val n_step_val.

  Definition result_finished_invariant (reg: ContextEnv.(env_t) R) :=
    let finished_val := Bits.to_N (ContextEnv.(getenv) reg finished) in
    let result_val := Bits.to_N (ContextEnv.(getenv) reg result) in
    let op1_val := Bits.to_N (ContextEnv.(getenv) reg operand1) in
    let op2_val := Bits.to_N (ContextEnv.(getenv) reg operand2) in
    finished_val = 1%N ->
    (result_val = op1_val * op2_val)%N.

  Definition invariant reg :=
    step_invariant reg /\
    finished_invariant reg /\
    result_invariant reg /\
    result_finished_invariant reg.

  (** Interpret all possible branches of an action **)
  Lemma enq_preserves_invariant :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_enq =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      invariant (commit_update env sched_log) ->
      invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    unfold invariant, step_invariant, finished_invariant,
           result_invariant, result_finished_invariant in *.
    interp_action_all_t.
    Bits_to_N_t.
    repeat (split).
    - discriminate.
    - intros.
      unfold partial_mul. cbn.
      rewrite N.mod_1_r.
      ring.
    - intros.
      match goal with
      | [ H1: ?x = ?y, H2: _ -> ?x = ?z |- _ ] =>
        rewrite H2 in H1 by auto
      end.
      discriminate.
  Qed.

  Lemma deq_preserves_invariant :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_deq =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      invariant (commit_update env sched_log) ->
      invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    unfold invariant, step_invariant, finished_invariant, result_invariant in *.
    interp_action_all_t.
    Bits_to_N_t.
    repeat (split); auto || discriminate.
  Qed.

  Lemma step_preserves_finished_invariant :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_step =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      invariant (commit_update env sched_log) ->
      finished_invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    unfold invariant, step_invariant, finished_invariant, result_invariant in *.
    interp_action_all_t;
    Bits_to_N_t;
    intros;
    match goal with
    | [H1: ?x = ?y, H2: ?x = ?z |- _ ] => rewrite H1 in H2; discriminate H2
    end.
  Qed.

  Lemma step_preserves_step_invariant :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_step =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      invariant (commit_update env sched_log) ->
      step_invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    unfold invariant, step_invariant, finished_invariant, result_invariant in *.
    interp_action_all_t;
    Bits_to_N_t; try (assumption);
    rewrite Bits.to_N_of_N_lt;
    lia_bits.
  Qed.

  Lemma step_preserves_result_invariant :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_step =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      no_latest_writes sched_log all_regs ->
      invariant (commit_update env sched_log) ->
      result_invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    unfold invariant, step_invariant, finished_invariant, result_invariant in *.
    interp_action_all_t;
    intros;
    Bits_to_N_t;
    unfold n in *;
    try discriminate.
    match goal with
    | [ H: context[_ = partial_mul _ _ _] |- _ ] =>
      setoid_rewrite H; try assumption
    end; cbn in *.
    - rewrite Bits.to_N_of_N_lt.
      + rewrite Bits.to_N_of_N_lt by lia_bits.
        cbn. rewrite_all_hypotheses. cbn.
        rewrite N.add_1_r.
        rewrite partial_mul_step.
        rewrite_all_hypotheses.
        f_equal. cbn [N.b2n].
        rewrite N.mod_small. ring.
        assert (2 ^ 32 * 2 ^ 32 = 18446744073709551616)%N as Hdouble32 by reflexivity.
        rewrite <-Hdouble32.
        apply N.mul_lt_mono.
        * lia_bits.
        * apply N.pow_lt_mono_r; lia_bits.
      + unfold partial_mul.
        assert (2 ^ 63 + 2 ^ 63 = 18446744073709551616)%N as Hdouble63 by reflexivity.
        cbn. rewrite <-Hdouble63 at -1.
        assert (2 ^ 32 * 2 ^ 31 = 2 ^ 63)%N as H2pow3231 by reflexivity.
        rewrite <-H2pow3231.
        pose_bits_bound_proofs.
        remember_bits_to_N.
        apply N.add_lt_le_mono.
        * apply N.mul_lt_mono.
          -- lia_bits.
          -- eapply N.lt_le_trans.
             ++ apply N.mod_lt.
               match goal with
               | [ |- context[(2 ^ ?x)%N] ] => destruct x; discriminate
               end.
             ++ apply N.pow_le_mono_r; lia_bits.
        * eapply N.le_trans.
          -- apply N.mod_le. discriminate.
          -- apply N.mul_le_mono.
             ++ lia_bits.
             ++ apply N.pow_le_mono_r; lia_bits.
    - rewrite Bits.to_N_of_N_lt by lia_bits.
      cbn. rewrite N.add_1_r.
      rewrite partial_mul_step.
      setoid_rewrite_all_hypotheses. cbn.
      rewrite N.mul_0_r. rewrite N.add_0_r.
      auto.
  Qed.

  Lemma step_preserves_result_finished_invariant :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_step =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      no_latest_writes sched_log all_regs ->
      invariant (commit_update env sched_log) ->
      result_finished_invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    unfold invariant, step_invariant, finished_invariant, result_invariant, result_finished_invariant in *.
    interp_action_all_t;
    intros;
    Bits_to_N_t;
    unfold n in *;
    try match goal with
        | [ H1: ?x = ?y, H2: ?x = ?z |- _ ] =>
          rewrite H1 in H2; discriminate H2
        end;
    match goal with
    | [ H: context[_ = partial_mul _ _ _] |- _ ] =>
      setoid_rewrite H; try assumption
    end;
    cbn in *.
    - rewrite_all_hypotheses.
      rewrite Bits.to_N_of_N_lt.
      + rewrite N.mod_small by lia_bits.
        rewrite (mul_to_partial_mul (N.of_nat n) (Bits.to_N _) (Bits.to_N _)) by lia_bits.
        cbn.
        assert (32 = 31 + 1)%N as H32S by reflexivity.
        rewrite H32S.
        rewrite N.add_1_r, partial_mul_step.
        repeat (f_equal; []).
        match goal with
        | [ H1: ?x = ?y, H2: context[N.testbit _ _] |- _ ] =>
          rewrite H1 in H2
        end.
        rewrite_all_hypotheses.
        reflexivity.
      + unfold partial_mul.
        assert (2 ^ 63 + 2 ^ 63 = 18446744073709551616)%N as Hdouble63 by reflexivity.
        cbn. rewrite <-Hdouble63 at -1.
        assert (2 ^ 32 * 2 ^ 31 = 2 ^ 63)%N as H2pow3231 by reflexivity.
        rewrite <-H2pow3231.
        apply N.add_lt_le_mono.
        * apply N.mul_lt_mono; [lia_bits | ].
          apply N.mod_lt. discriminate.
        * eapply N.le_trans; [ apply N.mod_le; discriminate | ].
          apply N.mul_le_mono; lia_bits.
    - rewrite_all_hypotheses.
      rewrite (mul_to_partial_mul (N.of_nat n)) by lia_bits.
      cbn.
      assert (32 = 31 + 1)%N as H32S by reflexivity.
      rewrite H32S.
      rewrite N.add_1_r, partial_mul_step.
      repeat (f_equal; []).
      match goal with
      | [ H1: ?x = ?y, H2: context[N.testbit _ _] |- _ ] =>
        rewrite H1 in H2
      end.
      rewrite_all_hypotheses. cbn.
      rewrite N.mul_0_r. rewrite N.add_0_r.
      reflexivity.
  Qed.

  Lemma step_preserves_invariants :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_step =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      no_latest_writes sched_log all_regs ->
      invariant (commit_update env sched_log) ->
      invariant (commit_update env (log_app action_log_new sched_log)).
  Proof.
    intros.
    repeat split.
    - eapply step_preserves_step_invariant; eassumption.
    - eapply step_preserves_finished_invariant; eassumption.
    - eapply step_preserves_result_invariant; eassumption.
    - eapply step_preserves_result_finished_invariant; eassumption.
  Qed.

  Lemma enq_set_operands :
    forall (env: ContextEnv.(env_t) R) Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_enq =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log [operand1; operand2] ->
      latest_write action_log_new operand1 = Some (chd Gamma) /\
      latest_write action_log_new operand2 = Some (chd (ctl Gamma)).
  Proof.
    intros.
    interp_action_all_t.
    auto.
  Qed.

  Lemma step_keep_operands :
    forall (env: ContextEnv.(env_t) R) Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_step =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log [operand1; operand2] ->
      no_latest_writes action_log_new [operand1; operand2].
  Proof.
    intros.
    interp_action_all_t;
    auto.
  Qed.

  Lemma deq_result :
    forall env Gamma sched_log action_log action_log_new v Gamma_new,
      interp_action env empty_sigma Gamma sched_log action_log typed_deq =
        Some (action_log_new, v, Gamma_new) ->
      no_latest_writes action_log all_regs ->
      no_latest_writes sched_log all_regs ->
      invariant (commit_update env sched_log) ->
      let operand1_val := Bits.to_N (ContextEnv.(getenv) env operand1) in
      let operand2_val := Bits.to_N (ContextEnv.(getenv) env operand2) in
      (Bits.to_N v = operand1_val * operand2_val)%N.
  Proof.
    intros.
    unfold invariant, result_finished_invariant in *.
    interp_action_all_t.
    Bits_to_N_t.
    auto.
  Qed.

End MultiplierProofs.