Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.theory.rings.

Class RingCongruence A (R : relation A) `{Ring A} :=
  { ring_congr_equivalence : Equivalence R
  ; ring_congr_subrelation : subrelation (=) R
  ; ring_congr_plus : Proper (R ==> R ==> R) (+)
  ; ring_congr_mult : Proper (R ==> R ==> R) (.*.)
  ; ring_congr_negate : Proper (R ==> R) (-)}.

(*
As far as I see, there are three ways to represent the quotient ring:
- Define the congruence as a new Equiv instance. This leads to ambiguity.
- Wrap it into a definition and define a ring structure on top of it.
     Definition Quotient A (R : relation A) := A.
   However, in order to avoid ambiguity we have to make it Opaque for
   type class resolution.
- Wrap it into an inductive and define a ring structure on top of it.
The latter makes the clearest distinction between the original structure
and the quotient. Unfortunately, it is sometimes a bit verbose.
*)
Inductive Quotient A (R : relation A) := quotient_inject : Cast A (Quotient A R).
#[global]
Existing Instance quotient_inject.
Arguments quotient_inject {A R} _.

#[global]
Instance quotient_rep {A R} : Cast (Quotient A R) A := λ x,
  match x with quotient_inject r => r end.

Section quotient_ring.
  Context `{cong : RingCongruence A R}.
  Add Ring A : (rings.stdlib_ring_theory A).

  Existing Instance ring_congr_equivalence.

  Global Instance quotient_equiv: Equiv (Quotient A R) := λ x y, R ('x) ('y).
  Global Instance quotient_0: Zero (Quotient A R) := cast A (Quotient A R) 0.
  Global Instance quotient_1: One (Quotient A R) := cast A (Quotient A R) 1.
  Global Instance quotient_plus: Plus (Quotient A R) := λ x y, cast A (Quotient A R) ('x + 'y).
  Global Instance quotient_mult: Mult (Quotient A R) := λ x y, cast A (Quotient A R) ('x * 'y).
  Global Instance quotient_negate: Negate (Quotient A R) := λ x, cast A (Quotient A R) (-'x).

  Instance: Setoid (Quotient A R).
  Proof.
    constructor; unfold equiv, quotient_equiv.
      intros [x]. reflexivity.
     intros [x] [y] E. now symmetry.
    intros [x] [y] [z] E1 E2. now transitivity y.
  Qed.

  Instance: Proper ((=) ==> (=) ==> (=)) quotient_plus.
  Proof. intros [?] [?] E1 [?] [?] E2. now rapply ring_congr_plus. Qed.

  Instance: Proper ((=) ==> (=) ==> (=)) quotient_mult.
  Proof. intros [?] [?] E1 [?] [?] E2. now rapply ring_congr_mult. Qed.

  Instance: Proper ((=) ==> (=)) quotient_negate.
  Proof. intros [?] [?] E. now rapply ring_congr_negate. Qed.

  Global Instance: Setoid_Morphism quotient_inject.
  Proof. split; try apply _. intros ?? E. now rapply ring_congr_subrelation. Qed.

  Global Instance: Ring (Quotient A R).
  Proof.
    repeat (constructor; try apply _); repeat intros [?];
      unfold mult, plus, sg_op, mon_unit, one_is_mon_unit, zero_is_mon_unit, plus_is_sg_op, mult_is_sg_op,
      quotient_0, negate, quotient_negate, quotient_1, quotient_plus, quotient_mult, cast in *; simpl; apply sm_proper; ring.
  Qed.
End quotient_ring.


Require Import NaryFunctions.
Require Import Wf_nat.
Require Export ZArith.

Definition size := 8%nat.

(** Digits *)

Inductive digits : Type := D0 | D1.

Definition digits8 t := Eval compute in nfun digits size t.

Inductive int8 : Type := I8 : digits8 int8.

Delimit Scope int8_scope with int8.
Bind Scope int8_scope with int8.
Local Open Scope int8_scope.

Definition On : int8 := Eval compute in napply_cst _ _ D0 size I8.

Definition In : int8 := Eval compute in (napply_cst _ _ D0 (size-1) I8) D1.

Definition Tn : int8 := Eval compute in napply_cst _ _ D1 size I8.

Definition Twon : int8 := Eval compute in (napply_cst _ _ D0 (size-2) I8) D1 D0.

(** * Bits manipulation *)

(** [sneakr b x] shifts [x] to the right by one bit.
   Rightmost digit is lost while leftmost digit becomes [b].
   Pseudo-code is
    [ match x with (I8 d0 ... dN) => I8 b d0 ... d(N-1) end ]
*)

Definition sneakr : digits -> int8 -> int8 := Eval compute in
 fun b => int8_rect _ (napply_except_last _ _ (size-1) (I8 b)).

(** [sneakl b x] shifts [x] to the left by one bit.
   Leftmost digit is lost while rightmost digit becomes [b].
   Pseudo-code is
    [ match x with (I8 d0 ... dN) => I8 d1 ... dN b end ]
*)

Definition sneakl : digits -> int8 -> int8 := Eval compute in
 fun b => int8_rect _ (fun _ => napply_then_last _ _ b (size-1) I8).

(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct
    consequences of [sneakl] and [sneakr]. *)

Definition shiftl := sneakl D0.
Definition shiftr := sneakr D0.
Definition twice := sneakl D0.
Definition twice_plus_one := sneakl D1.

(** [firstl x] returns the leftmost digit of number [x].
    Pseudo-code is [ match x with (I8 d0 ... dN) => d0 end ] *)

Definition firstl : int8 -> digits := Eval compute in
 int8_rect _ (fun d => napply_discard _ _ d (size-1)).

(** [firstr x] returns the rightmost digit of number [x].
    Pseudo-code is [ match x with (I8 d0 ... dN) => dN end ] *)

Definition firstr : int8 -> digits := Eval compute in
 int8_rect _ (napply_discard _ _ (fun d=>d) (size-1)).

(** [iszero x] is true iff [x = I8 D0 ... D0]. Pseudo-code is
    [ match x with (I8 D0 ... D0) => true | _ => false end ] *)

Definition iszero : int8 -> bool := Eval compute in
 let f d b := match d with D0 => b | D1 => false end
 in int8_rect _ (nfold_bis _ _ f true size).

(* NB: DO NOT transform the above match in a nicer (if then else).
   It seems to work, but later "unfold iszero" takes forever. *)

(** [base] is [2^8], obtained via iterations of [Z.double].
   It can also be seen as the smallest b > 0 s.t. phi_inv b = 0
   (see below) *)

Definition base := Eval compute in
 iter_nat size Z Z.double 1%Z.

(** * Recursors *)

Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int8->A->A)
 (i:int8) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftl i in
             caserec (firstl i) si (recl_aux next A case0 caserec si)
  end.

Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int8->A->A)
 (i:int8) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftr i in
             caserec (firstr i) si (recr_aux next A case0 caserec si)
  end.

Definition recl := recl_aux size.
Definition recr := recr_aux size.

(** * Conversions *)

(** From int8 to Z, we simply iterates [Z.double] or [Z.succ_double]. *)

Definition phi : int8 -> Z :=
 recr Z (0%Z)
  (fun b _ => match b with D0 => Z.double | D1 => Z.succ_double end).

(** From positive to int8. An abstract definition could be :
      [ phi_inv (2n) = 2*(phi_inv n) /\
        phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *)

Fixpoint phi_inv_positive p :=
  match p with
    | xI q => twice_plus_one (phi_inv_positive q)
    | xO q => twice (phi_inv_positive q)
    | xH => In
  end.

(** The negative part : 2-complement  *)

Fixpoint complement_negative p :=
  match p with
    | xI q => twice (complement_negative q)
    | xO q => twice_plus_one (complement_negative q)
    | xH => twice Tn
  end.

(** A simple incrementation function *)

Definition incr : int8 -> int8 :=
 recr int8 In
   (fun b si rec => match b with
     | D0 => sneakl D1 si
     | D1 => sneakl D0 rec end).

(** We can now define the conversion from Z to int8. *)

Definition phi_inv : Z -> int8 := fun n =>
 match n with
 | Z0 => On
 | Zpos p => phi_inv_positive p
 | Zneg p => incr (complement_negative p)
 end.

Definition lor8 n m := phi_inv (Z.lor (phi n) (phi m)).
Definition land8 n m := phi_inv (Z.land (phi n) (phi m)).
Definition lxor8 n m := phi_inv (Z.lxor (phi n) (phi m)).
Definition lnot8 n := lxor8 Tn n.
Definition ldiff8 n m := land8 n (lnot8 m).

(** * Addition *)

(** Addition modulo [2^8] *)

Definition add8 (n m : int8) := phi_inv ((phi n)+(phi m)).
Notation "n + m" := (add8 n m) : int8_scope.

Definition sub8 (n m : int8) := phi_inv ((phi n)-(phi m)).
Notation "n - m" := (sub8 n m) : int8_scope.

(** Opposite *)

Definition opp8 x := On - x.
Notation "- x" := (opp8 x) : int8_scope.

(** Multiplication *)

(** multiplication modulo [2^8] *)

Definition mul8 (n m : int8) := phi_inv ((phi n)*(phi m)).
Notation "n * m" := (mul8 n m) : int8_scope.

Definition compare8 (n m : int8) := ((phi n)?=(phi m))%Z.
Notation "n ?= m" := (compare8 n m) (at level 70, no associativity) : int8_scope.

Definition eqb8 (n m : int8) :=
 match n ?= m with Eq => true | _ => false end.

(** Computing the [i]-th iterate of a function:
    [iter_int8 i A f = f^i] *)

Definition iter_int8 i A f :=
  recr (A->A) (fun x => x)
   (fun b si rec => match b with
      | D0 => fun x => rec (rec x)
      | D1 => fun x => f (rec (rec x))
    end)
    i.


Set Warnings "-notation-overridden".

Require Import Frap TransitionSystems.

Set Implicit Arguments.

(* invariant1 is a subset of invariant2 *)
Definition oneStepClosure_current {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st, invariant1 st
             -> invariant2 st.

(* step(invariant1) is a subset of invariant2 *)
Definition oneStepClosure_new {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st st', invariant1 st
                 -> sys.(Step) st st'
                 -> invariant2 st'.

Definition oneStepClosure {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  oneStepClosure_current sys invariant1 invariant2
  /\ oneStepClosure_new sys invariant1 invariant2.

Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
  (forall st, inv1 st -> inv2 st)
  -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
  -> oneStepClosure sys inv1 inv2.
Proof.
  unfold oneStepClosure.
  propositional.
Qed.

Theorem oneStepClosure_done : forall state (sys : trsys state) (invariant : state -> Prop),
  (forall st, sys.(Initial) st -> invariant st)
  (* if something is invariant for all initial states *)
  -> oneStepClosure sys invariant invariant
  (* and invariant is closed under any one step *)
  -> invariantFor sys invariant.
  (* then it is an invariant for the whole system *)
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new.
  propositional.
  apply invariant_induction.
  assumption.
  simplify.
  eapply H2.
  eassumption.
  assumption.
Qed.

(* compare to transitive reflexive closure *)
Inductive multiStepClosure {state} (sys : trsys state)
  : (state -> Prop) -> (state -> Prop) -> Prop :=

(* if one-step closure has no effect, we're done *) (* ~ nil *)
| MscDone : forall inv,
    oneStepClosure sys inv inv
    -> multiStepClosure sys inv inv

(* otherwise we need to recurse *) (* ~ cons *)
| MscStep : forall inv inv' inv'',
    oneStepClosure sys inv inv'
    -> multiStepClosure sys inv' inv''
    -> multiStepClosure sys inv inv''.

Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv inv' : state -> Prop),
  multiStepClosure sys inv inv'
  -> (forall st, sys.(Initial) st -> inv st)
  -> invariantFor sys inv'.
Proof.
  induct 1; simplify.

  apply oneStepClosure_done.
  assumption.
  assumption.

  apply IHmultiStepClosure.
  simplify.
  unfold oneStepClosure, oneStepClosure_current in *.
  (* TODO is this * just all available hypotheses? *)
  propositional.
  apply H3.
  apply H1.
  assumption.
Qed.

Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
  multiStepClosure sys sys.(Initial) inv
  -> invariantFor sys inv.
Proof.
  simplify.
  eapply multiStepClosure_ok'.
  eassumption.
  propositional.
Qed.

Theorem oneStepClosure_empty : forall state (sys : trsys state),
  oneStepClosure sys (constant nil) (constant nil).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.
Qed.

Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
  (forall st', sys.(Step) st st' -> inv1 st')
  -> oneStepClosure sys (constant sts) inv2
  -> oneStepClosure sys (constant (st :: sts)) ({st} \cup inv1 \cup inv2).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.

  invert H0.

  left. (* to prove A or B, switch to proving A *)
  left.
  simplify.
  propositional.

  right.
  apply H1.
  assumption.

  simplify.
  propositional.

  right.
  left.
  apply H.
  equality.

  right.
  right.
  eapply H2.
  eassumption.
  assumption.
Qed.

Theorem singleton_in : forall {A} (x : A) rest,
  ({x} \cup rest) x.
Proof.
  simplify.
  left.
  simplify.
  equality.
Qed.

Definition fact_correct (original_input : nat) (st : fact_state) : Prop :=
  match st with
  | AnswerIs ans => fact original_input = ans
  | WithAccumulator _ _ => True
    (* ^ this time around, we don't care about intermediate states *)
    (* (include all of them in our invariant) *)
  end.

Theorem fact_init_is : forall original_input,
  fact_init original_input = {WithAccumulator original_input 1}.
Proof.
  simplify.
  apply sets_equal; simplify.
  propositional.

  invert H.
  equality.

  rewrite <- H0.
  constructor.
Qed.

(* we can crunch this down by enumerating all states *)
Theorem factorial_ok_2 :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.
  rewrite fact_init_is.

  eapply MscStep.
  apply oneStepClosure_split.
  simplify.
  invert H.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  eapply MscStep.
  apply oneStepClosure_split.
  simplify.
  invert H.
  apply singleton_in.
  apply oneStepClosure_split.
  simplify.
  invert H.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  eapply MscStep.
  apply oneStepClosure_split.
  simplify.
  invert H.
  apply singleton_in.
  apply oneStepClosure_split.
  simplify.
  invert H.
  apply singleton_in.
  apply oneStepClosure_split.
  simplify.
  invert H.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  apply MscDone.
  apply prove_oneStepClosure; simplify.
  assumption.
  propositional; subst; invert H0; simplify; propositional.

  simplify.
  unfold fact_correct.
  propositional; subst; trivial.
Qed.

Hint Rewrite fact_init_is.

(* instead of doing all that by hand, write a tactic that will do it for us! *)
Ltac model_check_done :=
  apply MscDone; apply prove_oneStepClosure; simplify; propositional; subst;
  repeat match goal with
         | [ H : _ |- _ ] => invert H
         end; simplify; equality.

Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
  s2 x
  -> (s1 \cup s2) x.
Proof.
  simplify.
  right.
  right.
  assumption.
Qed.

Ltac singletoner :=
  repeat match goal with
         | _ => apply singleton_in
         | [ |- (_ \cup _) _ ] => apply singleton_in_other
         end.

Ltac model_check_step0 :=
  eapply MscStep; [
    repeat ((apply oneStepClosure_empty; simplify)
            || (apply oneStepClosure_split; [ simplify;
                                              repeat match goal with
                                                     | [ H : _ |- _ ] => invert H; try congruence
                                                     end; solve [ singletoner ] | ]))
  | simplify ].

Ltac model_check_step :=
  match goal with
  | [ |- multiStepClosure _ ?inv1 _ ] =>
    model_check_step0;
    match goal with
    | [ |- multiStepClosure _ ?inv2 _ ] =>
      (assert (inv1 = inv2) by compare_sets; fail 3)
      || idtac
    end
  end.

Ltac model_check_steps1 := model_check_step || model_check_done.
Ltac model_check_steps := repeat model_check_steps1.

Ltac model_check_finish := simplify; propositional; subst; simplify; equality.

Ltac model_check_infer :=
  apply multiStepClosure_ok; simplify; model_check_steps.

Ltac model_check_find_invariant :=
  simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.

Ltac model_check := model_check_find_invariant; model_check_finish.

Theorem factorial_ok_2_snazzy :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  model_check.
Qed.

Theorem factorial_ok_3 :
  invariantFor (factorial_sys 3) (fact_correct 3).
Proof.
  model_check.
Qed.

Theorem factorial_ok_5 :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check.
Qed.

(* notice it takes some time to find the invariant! *)
Theorem factorial_ok_5_again :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check_find_invariant.
  model_check_finish.
Qed.

Inductive isEven : nat -> Prop :=
| EvenO : isEven 0
| EvenSS : forall n, isEven n -> isEven (S (S n)).

Inductive add2_thread :=
| Read
| Write (local : nat).

Inductive add2_init : threaded_state nat add2_thread -> Prop :=
| Add2Init : add2_init {| Shared := 0; Private := Read |}.

Inductive add2_step : threaded_state nat add2_thread -> threaded_state nat add2_thread -> Prop :=
| StepRead : forall global,
    add2_step {| Shared := global; Private := Read |}
              {| Shared := global; Private := Write global |}
| StepWrite : forall global local,
    add2_step {| Shared := global; Private := Write local |}
              {| Shared := S (S local); Private := Read |}.

Definition add2_sys1 := {|
  Initial := add2_init;
  Step := add2_step
|}.

Definition add2_sys := parallel add2_sys1 add2_sys1.

Definition add2_correct (st : threaded_state nat (add2_thread * add2_thread)) :=
  isEven st.(Shared).

Inductive simulates state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2) : Prop :=
| Simulates :
  (forall st1, sys1.(Initial) st1
               -> exists st2, R st1 st2
                              /\ sys2.(Initial) st2)

  -> (forall st1 st2, R st1 st2
                      -> forall st1', sys1.(Step) st1 st1'
                                      -> exists st2', R st1' st2'
                                                      /\ sys2.(Step) st2 st2')

  -> simulates R sys1 sys2.

Inductive invariantViaSimulation state1 state2 (R : state1 -> state2 -> Prop)
  (inv2 : state2 -> Prop)
  : state1 -> Prop :=
| InvariantViaSimulation : forall st1 st2, R st1 st2
  -> inv2 st2
  -> invariantViaSimulation R inv2 st1.

Lemma invariant_simulates' : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2),
  (forall st1 st2, R st1 st2
                   -> forall st1', sys1.(Step) st1 st1'
                                   ->  exists st2', R st1' st2'
                                                    /\ sys2.(Step) st2 st2')
  -> forall st1 st1', sys1.(Step)^* st1 st1'
                      -> forall st2, R st1 st2
                                     -> exists st2', R st1' st2'
                                                     /\ sys2.(Step)^* st2 st2'.
Proof.
  induct 2.

  simplify.
  exists st2.
  propositional.
  constructor.

  simplify.
  eapply H in H2.
  first_order.
  apply IHtrc in H2.
  first_order.
  exists x1.
  propositional.
  econstructor.
  eassumption.
  assumption.
  assumption.
Qed.


(** * Structures/QuotientFilter/QuotientFilter_Definitions.v
-----------------

Provides the definitions and deterministic operations of a Quotient
Filter and uses them to instantiate the AMQ interface. *)

From mathcomp.ssreflect
     Require Import ssreflect ssrbool ssrnat eqtype fintype choice ssrfun seq path bigop finfun div.

From mathcomp.ssreflect
     Require Import tuple.

From mathcomp
     Require Import path.

Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Logic.FunctionalExtensionality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

From ProbHash.Computation
     Require Import Comp Notationv1.

From ProbHash.Utils
     Require Import InvMisc seq_ext.

From ProbHash.Core
     Require Import Hash HashVec FixedList AMQ AMQHash.

Module Type QuotientFilterSpec.

  (**
   q - the number of elements in the quotient - 1
   *)
  Parameter q:nat.
  (**
   r - the number of elements in the remainder - 1
  *)
  Parameter  r:nat.

  (** type being hashed in the quotient filter *)
  Parameter  B:finType.

End QuotientFilterSpec.

Module QuotientFilterDefinitions (Spec: QuotientFilterSpec).

  (**
   A fomalization of a simplified form of the quotientfilter structure.
  *)

  Export Spec.
  Module QuotientHash <: HashSpec.

    Definition B := B.

    Definition Hash_size := (q.+1 * r.+1).-1.

    Lemma Hash_size_unwrap : Hash_size = (q.+1 * r.+1).-1.
    Proof. by []. Qed.

  End QuotientHash.

  Module HashVec := (HashVec QuotientHash).

  Export HashVec.

  Definition hash_value_coerce (value: hash_valuetype) : 'I_(q.+1 * r.+1).
      move: value; rewrite/hash_valuetype Hash_size_unwrap //=.
  Defined.

  Lemma hash_value_coerce_eq x y: (hash_value_coerce x) = (hash_value_coerce y) -> x = y.
  Proof.
    rewrite/hash_value_coerce/eq_rect_r.
    by rewrite -eq_rect_eq.
  Qed.

  Record QuotientFilter (n: nat) := mkQuotientFilter
                             {
                               quotientfilter_state:
                               (** maps each quotient value *)
                                 (q.+1).-tuple
                                 (** to a variable length list of values *)
                                       (fixlist [eqType of 'I_r.+1] n.+1)
                             }.

  Definition Quotientfilter_prod (n: nat) (bf: QuotientFilter n) :=
    (quotientfilter_state bf).

  Definition prod_Quotientfilter (n:nat) pair := let: (state) := pair in @ mkQuotientFilter n state.

  Lemma quotientfilter_cancel n : cancel (@Quotientfilter_prod n) (@prod_Quotientfilter n).
  Proof.
      by case.
  Qed.

  Definition quotientfilter_eqMixin n :=
    CanEqMixin (@quotientfilter_cancel n) .

  Canonical quotientfilter_eqType n  :=
    Eval hnf in EqType (QuotientFilter n)  (quotientfilter_eqMixin n) .

  Definition quotientfilter_choiceMixin n:=
    CanChoiceMixin (@quotientfilter_cancel n).

  Canonical quotientfilter_choiceType n  :=
    Eval hnf in ChoiceType (QuotientFilter n)  (@quotientfilter_choiceMixin n).

  Definition quotientfilter_countMixin n :=
    CanCountMixin (@quotientfilter_cancel n).

  Canonical quotientfilter_countType n :=
    Eval hnf in CountType (QuotientFilter n)  (@quotientfilter_countMixin n).

  Definition quotientfilter_finMixin n :=
    CanFinMixin (@quotientfilter_cancel n).

  Canonical quotientfilter_finType n :=
    Eval hnf in FinType (QuotientFilter n)  (@quotientfilter_finMixin n).

    Definition quotientfilter_new n : QuotientFilter n :=
      mkQuotientFilter (nseq_tuple q.+1 (fixlist_empty [eqType of 'I_r.+1] n.+1)).

    Lemma quotient_num_quotient (value: 'I_(q.+1 * r.+1)) : (value %% q.+1 < q.+1).
    Proof.
      move: value => [m Hm] //=.
        by apply ltn_pmod.
    Qed.

  Lemma quotient_num_remainder (value: 'I_(q.+1 * r.+1)) : (value %/ q.+1 < r.+1).
  Proof.
    move: value => [m Hm] //=.
    by rewrite ltn_divLR //= mulnC.
  Qed.

  (** Implements the quotienting operation (note: this is slightly
  more general than the standard definition, which requires that q.+1
  and r.+1 be exact powers of 2 (as the operation is implemented using
  bit-level operations) ) *)
  Definition quotient_num (value: 'I_(q.+1 * r.+1)) : 'I_q.+1 * 'I_r.+1 :=
    (Ordinal (quotient_num_quotient value),
    Ordinal (quotient_num_remainder value)).

  Lemma quotient_num_inj value value':
    quotient_num value = quotient_num value' -> value = value'.
  Proof.
    move: value value' => [value Hvalue] [value' Hvalue'] //=.
    move=> [Hq Hr] //=.
    suff H: value = value'.
    by move: H Hvalue Hvalue' -> => H1 H2;rewrite (proof_irrelevance _ H1 H2).
    rewrite (divn_eq value q.+1).
    rewrite Hr Hq.
    by rewrite -(divn_eq value' q.+1).
  Qed.

  Section Definitions.

    Variable n: nat.

  Definition quotientfilter_add_internal (value: 'I_(q.+1 * r.+1)) qf : QuotientFilter n:=
    let: (quotient,remainder) := quotient_num value in
    let quotient_list := tnth (quotientfilter_state qf) quotient in
    let quotient_list' := fixlist_insert quotient_list remainder in
    mkQuotientFilter
      (set_tnth (quotientfilter_state qf) quotient_list' quotient).

  Definition quotientfilter_query_internal (value: 'I_(q.+1 * r.+1)) qf : bool :=
    let: (quotient,remainder) := quotient_num value in
    let quotient_list := tnth (@quotientfilter_state n qf) quotient in
    fixlist_contains remainder quotient_list.

  Definition quotientfilter_query (value: hash_keytype) (hashes: HashState n) (qf: QuotientFilter n) :
    Comp [finType of HashState n * bool ] :=
    hash_res <-$ (@hash _ value hashes);
      let (new_hashes, hash_vec) := hash_res in
      let qres := quotientfilter_query_internal (hash_value_coerce hash_vec) qf in
      ret (new_hashes, qres).

  Definition quotientfilter_has_free_spaces l qf :=
    all (fun ls => [length ls] + l <= n ) (@quotientfilter_state n qf).

  Definition quotientfilter_valid  qf :=
    all (fun ls => fixlist_is_top_heavy ls) (@quotientfilter_state n qf).

  Lemma fixlist_length_empty (A:eqType) k :
        [length (fixlist_empty A k)] = 0.
  Proof.
    rewrite/fixlist_length/fixlist_empty/fixlist_unwrap //=.
    elim: k => [//=|k IHk //=].
  Qed.

  End Definitions.

  Section Theorems.

    Variable l: nat.
    Variable n: nat.
    Hypothesis Hl: l > 0.

    Lemma quotientfilter_new_free_spaces :
      quotientfilter_has_free_spaces n (quotientfilter_new n).
    Proof.
      rewrite/quotientfilter_has_free_spaces/quotientfilter_new.
      apply/allP => ls; move=>/nseqP [Hls1 Hls2].
      by rewrite Hls1 fixlist_length_empty add0n leqnn.
    Qed.

    Lemma quotientfilter_new_valid :
      quotientfilter_valid (quotientfilter_new n).
    Proof.
      rewrite/quotientfilter_has_free_spaces/quotientfilter_new.
      apply/allP => ls; move=>/nseqP [Hls1 Hls2].
      rewrite Hls1.
      apply fixlist_empty_is_top_heavy.
    Qed.

    Lemma quotientfilter_add_query_base qf value:
      quotientfilter_valid qf ->
      quotientfilter_has_free_spaces l qf ->
      @quotientfilter_query_internal n value (quotientfilter_add_internal value qf).
    Proof.
      move: qf => [qf]//=; rewrite/quotientfilter_valid/quotientfilter_has_free_spaces
      => /allP Hvalid  /allP //=  Hall.
      rewrite /quotientfilter_query_internal/quotientfilter_add_internal //.
      move: (quotient_num value) => [quotient remainder] //.
      rewrite tnth_set_nth_eq //.
      apply fixlist_insert_contains; [ apply Hvalid; apply mem_tnth| ].
      move: (Hall _ (mem_tnth quotient qf)); rewrite -ltnS.
      move=>/InvMisc.addr_ltn //=.
    Qed.

    Lemma quotientfilter_add_preserve qf qf' value:
      quotientfilter_valid qf ->
      quotientfilter_has_free_spaces l qf ->
      qf' = (quotientfilter_add_internal value qf) ->
      quotientfilter_valid qf' && @quotientfilter_has_free_spaces n l.-1 qf'.
    Proof.
      move: qf qf' => [qf] //= [qf']//=; rewrite/quotientfilter_valid/quotientfilter_has_free_spaces
      => /allP Hvalid /allP Hall.
      rewrite/quotientfilter_add_internal; move: (quotient_num _) => [quotient remainder].
      move=>/eqP; rewrite inj_eq; last by (rewrite /injective => x y Hxy; injection Hxy).
      move=>/eqP ->.
      have Hsim x: quotientfilter_state ({| quotientfilter_state := x |}) = x; first by [].
      rewrite !Hsim; clear Hsim.
      apply/andP;split; apply/all_tnthP
      => ind; case Heq: (ind == quotient);
           try (move/Bool.negb_true_iff: Heq => Heq; rewrite tnth_set_nth_neq; last by []);
           try (rewrite tnth_set_nth_eq; last by[]);
           try apply fixlist_insert_preserves_top_heavy;
      try (by apply Hvalid; apply mem_tnth).
      rewrite fixlist_insert_length_incr.
      rewrite matrix.mx'_cast; last by move: (Ordinal Hl).
      rewrite addSn //=; apply Hall; apply mem_tnth.
      move: (Hall _ (mem_tnth quotient qf)); rewrite -ltnS => /InvMisc.addr_ltn //=.
      rewrite matrix.mx'_cast; last (by move: (Ordinal Hl)); rewrite -ltnS.
      apply InvMisc.ltn_subl1; apply Hall; apply mem_tnth.
    Qed.

    Lemma quotientfilter_add_query_preserve qf value value' :
      quotientfilter_query_internal value qf ->
      @quotientfilter_query_internal n value (quotientfilter_add_internal value' qf).
    Proof.
      move: qf => [qf].
      rewrite /quotientfilter_query_internal; move: (quotient_num value) => [quotient remainder].
      rewrite /fixlist_contains; move=> /hasP [val Hval Hvaleq].
      rewrite /quotientfilter_add_internal.
      move: (quotient_num value') => [quotient' remainder'].
      have Hsim x: quotientfilter_state ({| quotientfilter_state := x |}) = x; first by [].
      move: Hval; rewrite !Hsim; clear Hsim => Hval.
      case Hquoteient_eq: (quotient' == quotient); last first.
      - {
          apply/hasP; exists remainder; last by [].
          rewrite tnth_set_nth_neq; first by move: Hval; move/eqP: Hvaleq => -> .
          by move/Bool.negb_true_iff: Hquoteient_eq; rewrite eq_sym.
        }
      - {
          rewrite tnth_set_nth_eq; last by rewrite eq_sym.
          rewrite fixlist_has_eq; apply/orP; left; apply/hasP; exists remainder; last by [].
          by move/eqP: Hvaleq Hval => ->; move/eqP:Hquoteient_eq ->.
        }
    Qed.

    Lemma quotientfilter_add_query_eq qf value value' :
      ~~ quotientfilter_query_internal value qf ->
      @quotientfilter_query_internal n value (quotientfilter_add_internal value' qf) ->
      value = value'.
    Proof.
      rewrite /quotientfilter_query_internal.
      case Hvalue: (value == value'); rewrite /quotientfilter_add_internal; first by move/eqP:Hvalue <-.
      case_eq (quotient_num value) => [quotient remainder] Heq.
      move=>Hneq.
      have Hsim x: quotientfilter_state ({| quotientfilter_state := x |}) = x; first by [].
      case_eq (quotient_num value') => [quotient' remainder'] Heq'.
      rewrite !Hsim; clear Hsim.
      case Hquot: (quotient == quotient').
      - {
          rewrite tnth_set_nth_eq; last  by[].
          move/eqP:Hquot => Hquot.
          move/Bool.negb_true_iff: Hneq .
          rewrite /fixlist_contains.
          rewrite fixlist_has_eq Hquot.
          move=>  ->; rewrite Bool.orb_false_l =>/andP[/eqP Hrem]/andP[_ _].
          apply quotient_num_inj.
          by rewrite Heq Heq' //= -Hquot Hrem.
        }
      - {
          rewrite tnth_set_nth_neq; last by move/Bool.negb_true_iff: Hquot.
          by move/Bool.negb_true_iff: Hneq ->.
        }
    Qed.

    End Theorems.

End QuotientFilterDefinitions.

(** Instantiation of the AMQ interface for a Quotient filter *)
Module QuotientFilterAMQ (Spec: QuotientFilterSpec).

  Module QuotientFilterDefinitions :=  QuotientFilterDefinitions Spec.
  Module BasicHash := AMQHash.BasicHash QuotientFilterDefinitions.QuotientHash.

  Export BasicHash.
  Export QuotientFilterDefinitions.

  Module AMQ <: AMQ BasicHash.

      Definition AMQStateParams := nat.
      Definition AMQState (n: AMQStateParams) : finType :=
        [finType of QuotientFilter n].

      Section AMQ.
        Variable p: AMQStateParams.
        Variable h: BasicHash.AMQHashParams.

        Definition AMQ_add_internal
                   (amq: AMQState p) (value: BasicHash.AMQHashValue h):
          AMQState p := quotientfilter_add_internal value amq.

        Definition AMQ_query_internal
                   (amq: AMQState p) (key: BasicHash.AMQHashValue h) : bool :=
          quotientfilter_query_internal key amq.

        Definition AMQ_available_capacity
                   (h: BasicHash.AMQHashParams) (amq: AMQState p) (l:nat): bool:=
          quotientfilter_has_free_spaces (h.+1 * l) amq.

        Definition AMQ_valid (amq:AMQState p) : bool :=
          quotientfilter_valid amq.

        Definition AMQ_new: AMQState p := quotientfilter_new p.

        Lemma AMQ_new_nqueryE: forall vals, ~~ AMQ_query_internal  AMQ_new vals.
        Proof.
          move=> vals; rewrite/AMQ_query_internal/quotientfilter_query_internal//=.
          rewrite tnth_nseq_eq.
          rewrite/fixlist_contains //=.
          apply/hasPn => v.
          move: (@fixlist_empty_is_empty [eqType of 'I_r.+1] p.+1).
          rewrite/fixlist_is_empty =>/eqP -> //=.
        Qed.

        Lemma AMQ_new_validT: AMQ_valid AMQ_new.
        Proof.
            by apply quotientfilter_new_valid.
        Qed.

        Section DeterministicProperties.
          Variable amq: AMQState p.

          Lemma AMQ_available_capacityW: forall  n m,
              AMQ_valid amq -> m <= n -> AMQ_available_capacity h amq n -> AMQ_available_capacity h amq m.
          Proof.
            move=> n m Hvalid Hnm /allP Hvv; apply/allP => v Hv; move:(Hvv v Hv) => //=.
            apply leq_trans; rewrite leq_add2l //=.
              by rewrite leq_mul2l Hnm; apply/orP; right.
          Qed.
        End DeterministicProperties.

        Section DeterministicProperties.
          Variable amq: AMQState p.

          Lemma AMQ_add_query_base: forall (amq: AMQState p) inds,
              AMQ_valid amq -> AMQ_available_capacity h amq 1 ->
              AMQ_query_internal (AMQ_add_internal amq inds) inds.
          Proof.
            apply quotientfilter_add_query_base.
          Qed.

          Lemma AMQ_add_valid_preserve: forall (amq: AMQState p) inds,
              AMQ_valid amq -> AMQ_available_capacity h amq 1 ->
              AMQ_valid (AMQ_add_internal amq inds).
          Proof.
            rewrite /AMQ_available_capacity muln1/AMQHashValue/AMQ_valid.
            rewrite/quotientfilter_valid/quotientfilter_has_free_spaces.
            move=> [amq'] ind /allP Hvv /allP Hspace; apply /allP => v.
            rewrite/AMQ_add_internal/quotientfilter_add_internal.
            case_eq (quotient_num ind) => quot rem Heq.

            have H f:  quotientfilter_state {|  quotientfilter_state := f |} = f; first by [].
            rewrite !H.
            move=>/tnthP [ quot' ].
            case Hquot: (quot' != quot).
            - rewrite tnth_set_nth_neq; first move=>->; last by [].
              apply Hvv.
                by apply mem_tnth.
            - move/Bool.negb_true_iff: Hquot; rewrite Bool.negb_involutive => /eqP ->.
              rewrite tnth_set_nth_eq; first move=>->; last by [].
              apply fixlist_insert_preserves_top_heavy.
              apply Hvv.
                by apply mem_tnth.
          Qed.

          Lemma AMQ_add_query_preserve: forall (amq: AMQState p) inds inds',
              AMQ_valid amq -> AMQ_available_capacity h amq 1 -> AMQ_query_internal amq inds ->
              AMQ_query_internal (AMQ_add_internal amq inds') inds.
          Proof.
            move=> amq' ind inds' Hvalid Hcap.
              by apply quotientfilter_add_query_preserve.
          Qed.

          Lemma AMQ_add_capacity_decr: forall (amq: AMQState p) inds l,
              AMQ_valid amq -> AMQ_available_capacity h amq l.+1 ->
              AMQ_available_capacity h (AMQ_add_internal amq inds) l.
          Proof.
            move=> amq' ind l Hvalid Hcap.
            rewrite /AMQ_available_capacity in Hcap.
            have Hobv: 0 < h.+1 * l.+1; first by rewrite muln_gt0; apply/andP;split => //=.
            move: (@quotientfilter_add_preserve
                     _ p Hobv amq'
                     (quotientfilter_add_internal ind amq')
                     ind Hvalid Hcap
                     (Logic.eq_refl
                        (quotientfilter_add_internal ind amq'))
                  ) => /andP [_ ].

            rewrite/AMQ_available_capacity.
            rewrite mulnS addnC addnS -pred_Sn.
            move=>/allP Hvv; apply/allP => v Hv; move: (Hvv v Hv).
              by rewrite addnA =>/leq_addr_weaken.
          Qed.

        End DeterministicProperties.
      End AMQ.
    End AMQ.
End QuotientFilterAMQ.


(* 言語モデル論 第5回 レポート
 * 121015 冨田寛
 *
 * simply typed lambda calculus の lambda term にたいする型検査を coq で実装する。
 * 型検査関数の実装がただしいことを確認するため、型にかんする公理から導かれる
 * has_type 関数による検査と、実装した typing 関数が出力する型が、型解決できるときには
 * 一致することを証明する。
 *
 * 実装にあたっては次の文献を参考にした。 SfLib は [2] の Download から取得できる。
 * 原著と日本語訳では版に差異があり、掲載されているコードもすこし異なる。
 *
 * 1. http://proofcafe.org/sf/Stlc_J.html
 * 2. http://www.cis.upenn.edu/~bcpierce/sf/
 * 3. http://coq.inria.fr/refman/
 * 4. 萩谷昌己 西崎真也 『計算と論理の仕組み』
 * 5. Benjamin C. Pierce "Types and Programming Languages"
 *)

Require Export "SfLib".

Module STLC.

  (* type, コンストラクタを増やすことで任意の数の基本型が作れる *)
  Inductive ty : Type :=
  | TAlpha  : ty
  | TArrow : ty -> ty -> ty.

  (* lambda term *)
  Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm.

  (* ty, tm の使用例 *)
  Definition x := (Id 0).
  Definition y := (Id 1).
  Definition z := (Id 2).
  Hint Unfold x.
  Hint Unfold y.
  Hint Unfold z.

  Notation idB :=
    (tabs x TAlpha (tvar x)).

  Notation idBB :=
    (tabs x (TArrow TAlpha TAlpha) (tvar x)).

  Notation idBBBB :=
    (tabs x (TArrow (TArrow TAlpha TAlpha)
                    (TArrow TAlpha TAlpha))
          (tvar x)).

  Notation k := (tabs x TAlpha (tabs y TAlpha (tvar x))).

  Definition context := partial_map ty.

  Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T12 Gamma t1 t2 T11,
      has_type Gamma t1 (TArrow T11 T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (tapp t1 t2) T12.

  Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App" ].

  Hint Constructors has_type.

  (* これらの例に示すように、 has_type は与えられた lambda term の型を検査する *)

  Example typing_example_1:
    has_type empty (tabs (Id 1) TAlpha (tvar (Id 1))) (TArrow TAlpha TAlpha).
  Proof.
    apply T_Abs.
    apply T_Var.
    reflexivity.
  Qed.

  Example typing_example_1':
    has_type empty (tabs (Id 1) TAlpha (tvar (Id 1))) (TArrow TAlpha TAlpha).
  Proof.
    auto.
  Qed.

  Example typing_nonexample_1 :
    ~ exists T,
      has_type empty
        (tabs x TAlpha
            (tabs y TAlpha
               (tapp (tvar x) (tvar y))))
        T.
  Proof.
    intros C. destruct C.
    inversion H. subst. clear H.
    inversion H5. subst. clear H5.
    inversion H4. subst. clear H4.
    inversion H2. subst. clear H2.
    inversion H1.
  Qed.

  (* つぎに、与えられた context と term より型付けをする関数を定義する。
     typing_result の Failure は問題における Abort に対応する。
     Abort は coq の予約語であるため、やむなく別の単語を利用した。 *)

  Require String. Open Scope string_scope.

  Inductive typing_result : Type :=
  | Success  : ty -> typing_result
  | UnboundVariable : id -> typing_result
  | TypeMismatch : tm -> typing_result.

  Fixpoint type_eq (t1:ty) (t2:ty) : bool :=
    match (t1, t2) with
      | (TAlpha, TAlpha) => true
      | (TArrow a1 b1, TArrow a2 b2) =>
        andb (type_eq a1 a2) (type_eq b1 b2)
      | _ => false
    end.

  Theorem type_equality_iff_type_eq :
    forall (t1:ty) (t2:ty),
      t1 = t2 <-> Is_true (type_eq t1 t2).
  Proof.
    intro.
    induction t1.
    (* TAlpha *)

    split.
    (* -> *)
    intros.
    rewrite <- H.
    simpl.
    trivial.

    (* <- *)
    intros.
    destruct t2.
    reflexivity.
    simpl in H.
    contradiction.

    (* TArrow *)
    split.
    (* -> *)
    intros.
    rewrite <- H.
    simpl.
    apply andb_prop_intro.
    apply conj.
    apply IHt1_1. reflexivity.
    apply IHt1_2. reflexivity.

    (* <- *)
    intros.
    destruct t2.
    simpl in H. contradiction.
    simpl in H.
    apply andb_prop_elim in H.
    assert (t1_1 = t2_1). apply IHt1_1. apply H.
    assert (t1_2 = t2_2). apply IHt1_2. apply H.
    rewrite H0.
    rewrite H1.
    reflexivity.
  Qed.

  Fixpoint typing (Gamma:context) (tm:tm) : typing_result :=
    match tm with
      | tvar x =>
        match Gamma x with
          | Some T => Success T
          | None => UnboundVariable x
        end
      | tapp e1 e2 =>
        match (typing Gamma e1, typing Gamma e2) with
          | (Success TFun, Success TArg) =>
            (* TFun must be TArrow, otherwise fail with TypeMismatch *)
            match TFun with
              | TArrow A B =>
                if type_eq A TArg then Success B else TypeMismatch tm
              | _ => TypeMismatch tm
            end
          | (Success _, failure) => failure
          | (failure  , _)       => failure
        end
      | tabs x T body =>
        match (typing (extend Gamma x T) body) with
          | (Success BodyType) =>
            Success (TArrow T BodyType)
          | failure => failure
        end
    end.

  (* has_type を型付けの定義とし、 typing が sound and complete な型付けを
     おこなうことを証明する。 *)

  Theorem typing_matches_with_has_type :
    forall (e:tm) (Gamma:context) (T:ty),
      typing Gamma e = Success T ->
      has_type Gamma e T.
  Proof.
    intros tm.
    induction tm.

    (* TVar *)
    simpl.
    intro Gamma.
    remember (Gamma i) as g.
    destruct g.
    intros.
    apply T_Var.
    inversion H.
    rewrite <- H1.
    rewrite <- Heqg.
    reflexivity.
    intros.
    inversion H.

    intros.
    simpl in H.
    remember (typing Gamma tm1) as result1.
    destruct result1.
    remember (typing Gamma tm2) as result2.
    destruct result2.
    destruct t as [ x | TArg ty0 ].
    inversion H.
    remember (type_eq TArg t0).
    destruct b.
    inversion H.
    eapply T_App.
    eapply IHtm1.
    instantiate (1:=TArg).
    rewrite <- Heqresult1.
    rewrite H1.
    reflexivity.

    apply IHtm2.
    apply Is_true_eq_right in Heqb.
    apply type_equality_iff_type_eq in Heqb.
    rewrite Heqb.
    rewrite <- Heqresult2.
    reflexivity.

    inversion H.
    inversion H.
    inversion H.
    inversion H.
    inversion H.

    (* TAbs *)
    intros.
    simpl in H.
    remember (typing (extend Gamma i t) tm0) as result.
    destruct result.
    inversion H.

    eapply T_Abs.
    eapply IHtm.
    rewrite <- Heqresult.
    reflexivity.

    inversion H.
    inversion H.
  Qed.

  Theorem has_type_matches_with_typing :
    forall (e:tm) (Gamma:context) (T:ty),
      has_type Gamma e T ->
      typing Gamma e = Success T.
  Proof.
    intros.
    induction H.

    simpl.
    rewrite H.
    reflexivity.

    simpl.
    destruct H.
    rewrite IHhas_type.
    reflexivity.

    rewrite IHhas_type.
    reflexivity.

    rewrite IHhas_type.
    reflexivity.

    simpl.
    rewrite IHhas_type1.
    rewrite IHhas_type2.
    assert ((type_eq T11 T11) = true).
    apply Is_true_eq_true.
    rewrite <- type_equality_iff_type_eq.
    reflexivity.

    rewrite H1.
    reflexivity.
  Qed.

End STLC.