Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Dict.
Require Import Misc.
Require Import CpdtTactics.
Require Import JamesTactics.
Require Import KonneTactics.
Require Import Coq.Program.Basics.
Require Import EqDec.
Require Import Enumerable.
Require Import BGPSpec.
Require Import Equality.
Require Import SymbolicExecution.
Require Import Graph.
Import ListNotations.
Import EqNotations.

Section Tracing.
  Context `{PrefixClass}.
  Context `{TopologyClass}.
  Context {plainAttributes : PathAttributesClass}.
  Context {plainConfiguration : forall r, ConfigurationClass r}.
  Existing Instance enumerableIncoming.
  Existing Instance eqDecIncoming.
  Existing Instance eqDecUpdateMessage.

  Inductive Path : Type :=
  | start : Router -> Path
  | hop r d : connection r d -> Path -> Path.

  Fixpoint eqDecidePath (P P':Path) : {P = P'}+{P <> P'}.
    destruct P as [r|r d c p]; destruct P' as [r'|r' d' c' p'].
    - destruct (r =? r').
      + subst_max. left. reflexivity.
      + right. crush.
    - right. intro H'. inversion H'.
    - right. intro H'. inversion H'.
    - destruct ((r =? r') && (d =? d')).
      + break_and; subst_max.
        destruct ((c =? c') && (eqDecidePath p p')).
        * left; crush.
        * right.
          unfold not.
          intro X; inversion X.
          crush.
      + right.
        unfold not.
        intro X; inversion X.
        crush.
  Defined.

  Instance eqDecPath : eqDec Path.
    constructor.
    apply eqDecidePath.
  Defined.

  Fixpoint pathOk (P:Path) :=
    match P with
    | start _ => True
    | hop r d c P' => pathOk P' /\
                      r = match P' with
                      | start r' => r'
                      | hop _ d' _ _ => d'
                      end
    end.

  Record Tracking := {
    original : PathAttributes;
    current : PathAttributes;
    path : Path
  }.

  Instance eqDecTracking : eqDec Tracking.
    constructor. repeat decide equality; repeat apply eqDecide.
  Defined.

  Instance trackingAttributes : PathAttributesClass.
    refine {|
      PathAttributes := Tracking;
      localPref t := localPref (current t)
    |}.
  Defined.

  Instance trackingConfiguration r : ConfigurationClass r.
    refine {|
      import s p a :=
        let ' {| path:=P; current:=a; original:=a0 |} := a in
        match import r s p a with
        | notAvailable => notAvailable
        | available a' => available {| path:=P; original:=a0; current:=a' |}
        end;
      export s d p a :=
        let ' {| path:=P; current:=a; original:=a0 |} := a in
        match export r s d p a with
        | notAvailable => notAvailable
        | available a' => available {| path:=hop r (projT1 d) (projT2 d) P; original:=a0; current:=a' |}
        end;
      originate p a :=
        let ' {| path:=P; current:=a; original:=a0 |} := a in
        bool2sumbool (originate r p a) && (a =? a0) && (P =? start r)
    |}.
  Defined.

  Fixpoint transmit (P:Path) (p:Prefix) (a:@RoutingInformation plainAttributes) {struct P} : pathOk P -> @RoutingInformation plainAttributes.
    intro pok.
    refine(
      match P as P' return P = P' -> RoutingInformation with
      | start r => fun _ => if originate' r p a then a else notAvailable
      | hop r d c P' => fun _ => _
      end (eq_refl P)).
    subst. cbn in *. destruct pok.
    refine(
      let i :=
        match P' as P'' return P' = P'' -> incoming r with
        | start r => fun _ => injected
        | hop s r c _ => fun e => _
        end (eq_refl P')
      in export' r i [d & c] p (import' r i p (transmit P' p a _))
    ).
    subst. exact (received [s & c]).
  Proof.
    trivial.
  Defined.

  Definition forwardable r (s:incoming r) (p:Prefix) (a:@RoutingInformation trackingAttributes) : Prop.
    refine(match a with
    | notAvailable => True
    | available a => let P := path a in
      pathOk P /\ forall pok:pathOk P,
        transmit P p (available (original a)) pok = available (current a) /\
        match P with
        | start r' => r = r' /\ s = injected
        | hop r' d' c _ => r = d' /\ forall e:r = d', s = rew <- e in received [r' & c]
        end
    end).
  Defined.

  Opaque eqDecide.
  Opaque enumerate.
  Hint Unfold lookup update update' overwrite overwrite' build edge.
  Hint Unfold fst snd proj1_sig projT1 projT2 const id.
  Hint Unfold routerHandler messageHandling decisionProcess updateSendProcess
              import' export' originate' bindRoutingInformation connection emptyRIB argMax.

  Lemma trackingOk : forall r s d (c:connection r d) p a,
    forwardable r s p a ->
    forwardable d (received [r & c]) p (export' r s [d & c] p (import' r s p a)).
  Proof.
    intros.
    unfold forwardable in *.
    break_match; trivial.
    destruct a as [a|].
    - (* a is available *)
      rename p0 into a''.
      break_and.
      specialize (H2 H1).
      break_and.
      destruct (path a) eqn:?.
      + (* message was originated in router *)
        intuition; repeat symbolic_execution'' congruence.
        * intuition.
        * intuition; repeat symbolic_execution'' congruence.
      + (* message already had multiple hops through the network *)
        break_exists.
        subst_max.
        unfold eq_rect_r in *.
        unfold eq_rect in *.
        unfold eq_sym in *.
        subst.
        destruct a as [a0 a P].
        destruct a'' as [a0'' a'' P''].
        unfold path, original, current in *.
        unfold export', import' in *.
        unfold export, import in *.
        unfold trackingConfiguration in *.
        unfold bindRoutingInformation in *.
        break_and.
        subst_max.
        specialize (H4 eq_refl).
        subst_max.
        break_match.
        * repeat symbolic_execution'' congruence.
        * subst.
          break_match; try congruence.
          break_match; try congruence.
          break_match; try congruence.
          break_match; try congruence.
          break_match; try congruence.
          subst.
          subst_max.
          find_inversion.
          subst.
          subst_max.
          find_inversion.
          simpl_existTs.
          subst.
          rename d1 into d.
          rename current0 into a'.
          rename r0 into s.
          rename c1 into crd.
          rename c0 into csr.
          rename p0 into P.
          find_inversion.
          intuition.
          {
            cbn; cbn in H1.
            break_and.
            intuition.
          } {
            rename a0'' into a0.
            intuition. {
              cbv delta [transmit].
              cbv iota.
              fold transmit.
              Opaque export' import' transmit.
              cbn.
              break_match.
              subst.
              generalize_proofs.
              simpl_uip.
              cbn.
              Transparent export' import' transmit.
              unfold export', import'.
              break_match; crush.
           } }
           {
             repeat symbolic_execution'' congruence.
           }
    - (* a is not available *)
      exfalso.
      repeat symbolic_execution'' congruence.
  Qed.

  Lemma reachableImpliesForwardable :
    forall ns (R:reachable ns), (
      forall r (s:incoming r) p,
        let a := lookup (adjRIBsIn (lookup (routerState ns) r)) (s,p) in
        forwardable r s p a
    ) /\ (
      forall s d (c:connection s d),
        let ms := lookup (linkState ns) [(s,d) & c] in
        forall m (mInMs:In m ms), forwardable d (received [s & c]) (nlri m) (attributes m)
    ).
  Proof.
    intros.
    induction R as [|ns ns'']. { crush. }
    destruct IHR as [Hrs Hls].
    constructor.
    - (* router state *)
      intros.
      destruct t as [m r' rs ls | ].
      + (* gen *)
        destruct m as [p' a'].
        unfold snd, fst in *.
        destruct (r =? r'); destruct (p =? p').
        subst. destruct (s =? injected).
        * subst.
          clear Hrs.
          clear Hls.
          unfold originate' in *.
          break_match. {
            (* injected available *)
            unfold originate in *.
            unfold trackingConfiguration in *.
            destruct p.
            unfold attributes, nlri in *.
            unfold sumbool2bool in *.
            break_match; try congruence.
            break_and.
            subst_max.
            inline_all.
            cbn.
            repeat symbolic_execution'' congruence.
            intuition.
          } {
            (* injected unavailable *)
            repeat symbolic_execution'' congruence.
            exact I.
          }
        * repeat symbolic_execution'' intuition.
        * repeat symbolic_execution'' intuition.
        * repeat symbolic_execution'' intuition.
        * repeat symbolic_execution'' intuition.
     + (* fwd *)
        destruct c as [sr' c].
        destruct sr' as [s' r'].
        destruct m as [p' a'].
        unfold snd, fst in *.
        destruct (r =? r'); destruct (p =? p').
        subst. destruct (s =? received [s' & c]).
        * subst. specialize (Hls s' r' c (updateMessage p' a')).
          unfold update' in Hls.
          simpl in Hls.
          rewrite assocLookupOk in Hls.
          specialize (Hls (in_eq _ _)).
          assert (a = a') as H'. {
            repeat symbolic_execution'' congruence.
          }
          rewrite H'. trivial.
        * repeat symbolic_execution'' intuition.
        * repeat symbolic_execution'' intuition.
        * repeat symbolic_execution'' intuition.
        * repeat symbolic_execution'' intuition.
    - (* link state *)
      intros.
      destruct t as [m' r|m' c'].
      + (* gen *)
        unfold build, lookup in ms. simpl in ms.
        clear R.
        destruct (s =? r); destruct (nlri m =? nlri m').
        subst.
        apply in_app_or in mInMs.
        destruct mInMs.
        * (* s = r, r = p', m in old ms*)
          repeat symbolic_execution'' intuition.
        * destruct m as [p a].
          destruct m' as [p' a'].
          subst ms.
          simpl.
          clear Hls.
          unfold nlri in *.
          subst_max.
          specialize (fun i=>Hrs r i p').
          inline_all.
          rename H1 into X.
          unfold generateHandler in X.
          unfold routerHandler in X.
          unfold build in X.
          simpl in *.
          destruct (r =? r); crush.
          Require Import Coq.Logic.Eqdep.
          simpl_eq.
          simpl in *.
          unfold const, fst, snd, id in *.
          simpl in *.
          unfold updateSendProcess in *.
          unfold build in *.
          unfold lookup in X at 1.
          break_if. {
            (* out = out' *)
            solve_by_inversion.
          } {
            (* out <> out' *)
            simpl in *.
            clear n.
            destruct X; crush.
            simpl in *.
            destruct (p' =? p'); crush.
            match goal with
            | |- context[argMax' ?A ?B] => generalize (argMax' A B); intro
            end.
            unfold lookup.
            break_if; try congruence.
            unfold overwrite''.
            break_if; try congruence.
            break_if.
            - (* the generate announcement had highest local pref *)
              subst.
              unfold lookup. unfold overwrite.
              unfold originate' in *.
              cbn in e.
              apply trackingOk.
              clear Hrs.
              break_match; [|cbn; trivial].
              break_match.
              cbn in *.
              unfold sumbool2bool in *.
              break_if; try congruence.
              break_and.
              subst_max.
              assert (pathOk (start r)) as pok by crush.
              intuition.
              cbn.
              break_match; congruence.
            - simpl.
              unfold lookup. unfold overwrite.
              specialize (Hrs i).
              apply trackingOk.
              unfold lookup in *.
              trivial.
          }
        * (* r = s, p <> p' *)
          specialize (Hls s d c m).
          clear Hrs.
          cbn in Hls.
          apply Hls.
          clear Hls.
          unfold update'.
          unfold overwrite'.
          subst ms.
          subst_max.
          apply in_app_or in mInMs.
          intuition.
          unfold lookup.
          exfalso.
          subst Ers'.
          revert H1.
          subst E.
          subst rs'.
          unfold generateHandler.
          unfold routerHandler.
          break_match.
          unfold fst.
          unfold build in *.
          break_match; try congruence.
          Opaque messageHandling.
          simpl_eq.
          revert H3.
          unfold lookup in *.
          Set Printing Width 150.
          idtac.
          Transparent messageHandling.
          clear Heqp.
          cbn.
          unfold build.
          cbn.
          break_match; try congruence.
          match goal with
          | |- context[updateSendProcess _ _ _ ?x] => generalize x
          end.
          unfold updateSendProcess.
          unfold build.
          intro.
          break_match; try auto.
          unfold In.
          intuition.
          destruct m.
          destruct m'.
          cbn in *.
          congruence.
        * (* s <> r *)
          specialize (Hls s d c m).
          clear Hrs.
          cbn in Hls.
          apply Hls.
          clear Hls.
          unfold update'.
          unfold overwrite'.
          subst ms.
          apply in_app_or in mInMs.
          intuition.
          exfalso.
          match goal with
          | h:In m ?E |- _ => enough (E = []) by (find_rewrite; auto)
          end.
          clear H1.
          inline_all.
          symbolic_execution'' congruence.
        * (* s <> r, p <> p' *)
          specialize (Hls s d c m).
          clear Hrs.
          cbn in Hls.
          apply Hls.
          clear Hls.
          unfold update'.
          unfold overwrite'.
          subst ms.
          apply in_app_or in mInMs.
          intuition.
          exfalso.
          match goal with
          | h:In m ?E |- _ => enough (E = []) by (find_rewrite; auto)
          end.
          clear H1.
          inline_all.
          symbolic_execution'' congruence.
     + (* fwd *)
        destruct c' as [s'r c'].
        destruct s'r as [s' r].
        unfold snd, fst in *.
        unfold build, lookup in ms. simpl in ms.
        clear R.
        destruct (s =? r); destruct (nlri m =? nlri m').
        subst.
        apply in_app_or in mInMs.
        destruct mInMs.
        * (* s = r, r = p', m in old ms*)
          specialize (Hls r d c m).
          repeat symbolic_execution'' intuition.
        * destruct m as [p a].
          destruct m' as [p' a'].
          subst ms.
          simpl.
          simpl in Hls.
          simpl in Hrs.
          specialize (Hls s' r c' (updateMessage p' a')).
          simpl in Hls.
          unfold update' in Hls.
          rewrite assocLookupOk in Hls.
          simpl in Hls.
          specialize (Hls (or_introl (eq_refl))).
          subst rs'.
          subst E.
          subst Ers'.
          rename H1 into X.
          unfold forwardHandler in X.
          unfold routerHandler in X.
          unfold build in X.
          simpl in *.
          destruct (r =? r); crush.
          Require Import Coq.Logic.Eqdep.
          unfold eq_rect_r in *.
          unfold eq_rect in *.
          unfold eq_sym in *.
          rewrite (UIP_refl _ _ e) in *.
          simpl in *.
          clear e.
          unfold const, fst, snd, id in *.
          simpl in *.
          unfold updateSendProcess in *.
          unfold build in *.
          unfold lookup in X at 1.
          break_match. {
            (* out = out' *)
            solve_by_inversion.
          } {
            (* out <> out' *)
            simpl in *.
            clear n.
            destruct X; crush.
            simpl in *.
            destruct (p' =? p'); crush.
            match goal with
            | |- context[argMax' ?A ?B] => generalize (argMax' A B); intro
            end.
            destruct (i =? (received [s' & c'])).
            - (* the incomming announcement had highest local pref *)
              subst.
              unfold lookup. unfold overwrite.
              break_match; try solve_by_inversion.
              apply trackingOk.
              repeat symbolic_execution'' congruence.
            - simpl.
              unfold lookup. unfold overwrite.
              break_match; try solve_by_inversion.
              specialize (Hrs r i p').
              unfold lookup in Hrs.
              apply trackingOk.
              repeat symbolic_execution'' congruence.
          }
        * (* r = s, p <> p' *)
          specialize (Hls s d c m).
          clear Hrs.
          cbn in Hls.
          apply Hls.
          clear Hls.
          unfold update'.
          unfold overwrite'.
          subst ms.
          break_match. {
            (* message was removed from link to be delivered *)
            novel_injections.
            subst_max.
            unfold connection in *.
            unfold edge in *.
            assert (c = c') by crush.
            subst_max.
            simpl_eq.
            Hint  Resolve in_cons in_split in_nil.
            apply in_cons.
            apply in_app_or in mInMs.
            intuition.
            unfold lookup.
            exfalso.
            subst Ers'.
            revert H1.
            subst E.
            subst rs'.
            unfold forwardHandler.
            unfold routerHandler.
            break_match.
            break_match.
            unfold build in *.
            injection Heqp.
            intros _ ?.
            clear Heqp.
            subst_max.
            break_match; try auto.
            Opaque messageHandling.
            simpl_eq.
            revert H3.
            unfold lookup in *.
            Set Printing Width 150.
            idtac.
            Transparent messageHandling.
            clear Heqp0.
            cbn.
            idtac.
            unfold build.
            cbn.
            break_match; try congruence.
            match goal with
            | |- context[updateSendProcess _ _ _ ?x] => generalize x
            end.
            unfold updateSendProcess.
            unfold build.
            intro.
            break_match; try auto.
            unfold In.
            intuition.
            destruct m.
            destruct m'.
            cbn in *.
            congruence.
          } {
            subst_max.
            apply in_app_or in mInMs.
            intuition.
            unfold lookup.
            exfalso.
            subst Ers'.
            revert H1.
            subst E.
            subst rs'.
            unfold forwardHandler.
            unfold routerHandler.
            break_match.
            break_match.
            unfold build in *.
            injection Heqp.
            intros _ ?.
            clear Heqp.
            subst_max.
            break_match; try auto.
            Opaque messageHandling.
            simpl_eq.
            revert H3.
            unfold lookup in *.
            Set Printing Width 150.
            idtac.
            Transparent messageHandling.
            clear Heqp0.
            cbn.
            idtac.
            unfold build.
            cbn.
            break_match; try congruence.
            match goal with
            | |- context[updateSendProcess _ _ _ ?x] => generalize x
            end.
            unfold updateSendProcess.
            unfold build.
            intro.
            break_match; try auto.
            unfold In.
            intuition.
            destruct m.
            destruct m'.
            cbn in *.
            congruence.
          }
        * (* s <> r *)
          specialize (Hls s d c m).
          clear Hrs.
          cbn in Hls.
          apply Hls.
          clear Hls.
          unfold update'.
          unfold overwrite'.
          subst ms.
          break_match. {
            (* message was removed from link to be delivered *)
            novel_injections.
            subst_max.
            assert (c = c') by crush.
            subst_max.
            simpl_eq.
            Hint  Resolve in_cons in_split in_nil.
            apply in_cons.
            apply in_app_or in mInMs.
            intuition.
            unfold lookup.
            exfalso.
            match goal with
            | h:In m ?E |- _ => enough (E = []) by (find_rewrite; auto)
            end.
            clear H1.
            inline_all.
            symbolic_execution'' congruence.
          } {
            apply in_app_or in mInMs.
            intuition.
            exfalso.
            match goal with
            | h:In m ?E |- _ => enough (E = []) by (find_rewrite; auto)
            end.
            clear H1.
            inline_all.
            symbolic_execution'' congruence.
          }
        * (* s <> r, p <> p' *)
          specialize (Hls s d c m).
          clear Hrs.
          cbn in Hls.
          apply Hls.
          clear Hls.
          unfold update'.
          unfold overwrite'.
          subst ms.
          break_match. {
            (* message was removed from link to be delivered *)
            novel_injections.
            subst_max.
            assert (c = c') by crush.
            subst_max.
            simpl_eq.
            Hint  Resolve in_cons in_split in_nil.
            apply in_cons.
            apply in_app_or in mInMs.
            intuition.
            unfold lookup.
            exfalso.
            match goal with
            | h:In m ?E |- _ => enough (E = []) by (find_rewrite; auto)
            end.
            clear H1.
            inline_all.
            symbolic_execution'' congruence.
          } {
            apply in_app_or in mInMs.
            intuition.
            exfalso.
            match goal with
            | h:In m ?E |- _ => enough (E = []) by (find_rewrite; auto)
            end.
            clear H1.
            inline_all.
            symbolic_execution'' congruence.
          }
  Qed.

End Tracing.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require list.List.
Require list.Length.
Require int.Int.
Require list.Mem.
Require map.Map.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

Axiom set : forall (a:Type) {a_WT:WhyType a}, Type.
Parameter set_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (set a).
Existing Instance set_WhyType.

Parameter mem: forall {a:Type} {a_WT:WhyType a}, a -> (@set a a_WT) -> Prop.

(* Why3 assumption *)
Definition infix_eqeq {a:Type} {a_WT:WhyType a} (s1:(@set a a_WT)) (s2:(@set
  a a_WT)): Prop := forall (x:a), (mem x s1) <-> (mem x s2).

Axiom extensionality : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set
  a a_WT)) (s2:(@set a a_WT)), (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset {a:Type} {a_WT:WhyType a} (s1:(@set a a_WT)) (s2:(@set
  a a_WT)): Prop := forall (x:a), (mem x s1) -> (mem x s2).

Axiom subset_refl : forall {a:Type} {a_WT:WhyType a}, forall (s:(@set
  a a_WT)), (subset s s).

Axiom subset_trans : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set
  a a_WT)) (s2:(@set a a_WT)) (s3:(@set a a_WT)), (subset s1 s2) -> ((subset
  s2 s3) -> (subset s1 s3)).

Parameter empty: forall {a:Type} {a_WT:WhyType a}, (@set a a_WT).

(* Why3 assumption *)
Definition is_empty {a:Type} {a_WT:WhyType a} (s:(@set a a_WT)): Prop :=
  forall (x:a), ~ (mem x s).

Axiom empty_def1 : forall {a:Type} {a_WT:WhyType a}, (is_empty (empty :(@set
  a a_WT))).

Axiom mem_empty : forall {a:Type} {a_WT:WhyType a}, forall (x:a), ~ (mem x
  (empty :(@set a a_WT))).

Parameter add: forall {a:Type} {a_WT:WhyType a}, a -> (@set a a_WT) -> (@set
  a a_WT).

Axiom add_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a),
  forall (s:(@set a a_WT)), (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall {a:Type} {a_WT:WhyType a}, a -> (@set a a_WT)
  -> (@set a a_WT).

Axiom remove_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a)
  (s:(@set a a_WT)), (mem x (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(@set
  a a_WT)), (subset (remove x s) s).

Parameter union: forall {a:Type} {a_WT:WhyType a}, (@set a a_WT) -> (@set
  a a_WT) -> (@set a a_WT).

Axiom union_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set
  a a_WT)) (s2:(@set a a_WT)) (x:a), (mem x (union s1 s2)) <-> ((mem x s1) \/
  (mem x s2)).

Parameter inter: forall {a:Type} {a_WT:WhyType a}, (@set a a_WT) -> (@set
  a a_WT) -> (@set a a_WT).

Axiom inter_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set
  a a_WT)) (s2:(@set a a_WT)) (x:a), (mem x (inter s1 s2)) <-> ((mem x s1) /\
  (mem x s2)).

Parameter diff: forall {a:Type} {a_WT:WhyType a}, (@set a a_WT) -> (@set
  a a_WT) -> (@set a a_WT).

Axiom diff_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set a a_WT))
  (s2:(@set a a_WT)) (x:a), (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x
  s2)).

Axiom subset_diff : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set
  a a_WT)) (s2:(@set a a_WT)), (subset (diff s1 s2) s1).

Parameter choose: forall {a:Type} {a_WT:WhyType a}, (@set a a_WT) -> a.

Axiom choose_def : forall {a:Type} {a_WT:WhyType a}, forall (s:(@set
  a a_WT)), (~ (is_empty s)) -> (mem (choose s) s).

Parameter cardinal: forall {a:Type} {a_WT:WhyType a}, (@set a a_WT) -> Z.

Axiom cardinal_nonneg : forall {a:Type} {a_WT:WhyType a}, forall (s:(@set
  a a_WT)), (0%Z <= (cardinal s))%Z.

Axiom cardinal_empty : forall {a:Type} {a_WT:WhyType a}, forall (s:(@set
  a a_WT)), ((cardinal s) = 0%Z) <-> (is_empty s).

Axiom cardinal_add : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  forall (s:(@set a a_WT)), (~ (mem x s)) -> ((cardinal (add x
  s)) = (1%Z + (cardinal s))%Z).

Axiom cardinal_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  forall (s:(@set a a_WT)), (mem x s) ->
  ((cardinal s) = (1%Z + (cardinal (remove x s)))%Z).

Axiom cardinal_subset : forall {a:Type} {a_WT:WhyType a}, forall (s1:(@set
  a a_WT)) (s2:(@set a a_WT)), (subset s1 s2) ->
  ((cardinal s1) <= (cardinal s2))%Z.

Axiom cardinal1 : forall {a:Type} {a_WT:WhyType a}, forall (s:(@set a a_WT)),
  ((cardinal s) = 1%Z) -> forall (x:a), (mem x s) -> (x = (choose s)).

Axiom vertex : Type.
Parameter vertex_WhyType : WhyType vertex.
Existing Instance vertex_WhyType.

Parameter vertices: (@set vertex vertex_WhyType).

Parameter edges: (@set (vertex* vertex)%type _).

(* Why3 assumption *)
Definition edge (x:vertex) (y:vertex): Prop := (mem (x, y) edges).

Axiom edges_def : forall (x:vertex) (y:vertex), (mem (x, y) edges) -> ((mem x
  vertices) /\ (mem y vertices)).

Parameter s: vertex.

Axiom s_in_graph : (mem s vertices).

Axiom vertices_cardinal_pos : (0%Z < (cardinal vertices))%Z.

(* Why3 assumption *)
Inductive path : vertex -> (list vertex) -> vertex -> Prop :=
  | Path_empty : forall (x:vertex), (path x nil x)
  | Path_cons : forall (x:vertex) (y:vertex) (z:vertex) (l:(list vertex)),
      (edge x y) -> ((path y l z) -> (path x (cons x l) z)).

Axiom path_right_extension : forall (x:vertex) (y:vertex) (z:vertex)
  (l:(list vertex)), (path x l y) -> ((edge y z) -> (path x
  (List.app l (cons y nil)) z)).

Axiom path_right_inversion : forall (x:vertex) (z:vertex) (l:(list vertex)),
  (path x l z) -> (((x = z) /\ (l = nil)) \/ exists y:vertex,
  exists l':(list vertex), (path x l' y) /\ ((edge y z) /\
  (l = (List.app l' (cons y nil))))).

Axiom path_trans : forall (x:vertex) (y:vertex) (z:vertex) (l1:(list vertex))
  (l2:(list vertex)), (path x l1 y) -> ((path y l2 z) -> (path x
  (List.app l1 l2) z)).

Axiom empty_path : forall (x:vertex) (y:vertex), (path x nil y) -> (x = y).

Axiom path_decomposition : forall (x:vertex) (y:vertex) (z:vertex)
  (l1:(list vertex)) (l2:(list vertex)), (path x (List.app l1 (cons y l2))
  z) -> ((path x l1 y) /\ (path y (cons y l2) z)).

Parameter weight: vertex -> vertex -> Z.

(* Why3 assumption *)
Fixpoint path_weight (l:(list vertex)) (dst:vertex) {struct l}: Z :=
  match l with
  | nil => 0%Z
  | (cons x nil) => (weight x dst)
  | (cons x ((cons y _) as r)) => ((weight x y) + (path_weight r dst))%Z
  end.

Axiom path_weight_right_extension : forall (x:vertex) (y:vertex)
  (l:(list vertex)), ((path_weight (List.app l (cons x nil))
  y) = ((path_weight l x) + (weight x y))%Z).

Axiom path_weight_decomposition : forall (y:vertex) (z:vertex)
  (l1:(list vertex)) (l2:(list vertex)),
  ((path_weight (List.app l1 (cons y l2)) z) = ((path_weight l1
  y) + (path_weight (cons y l2) z))%Z).

Axiom path_in_vertices : forall (v1:vertex) (v2:vertex) (l:(list vertex)),
  (mem v1 vertices) -> ((path v1 l v2) -> (mem v2 vertices)).

(* Why3 assumption *)
Definition pigeon_set (s1:(@set vertex vertex_WhyType)): Prop :=
  forall (l:(list vertex)), (forall (e:vertex), (list.Mem.mem e l) -> (mem e
  s1)) -> (((cardinal s1) < (list.Length.length l))%Z -> exists e:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (List.app l1 (cons e (List.app l2 (cons e l3)))))).

Axiom Induction : (forall (s1:(@set vertex vertex_WhyType)), (is_empty s1) ->
  (pigeon_set s1)) -> ((forall (s1:(@set vertex vertex_WhyType)), (pigeon_set
  s1) -> forall (t:vertex), (~ (mem t s1)) -> (pigeon_set (add t s1))) ->
  forall (s1:(@set vertex vertex_WhyType)), (pigeon_set s1)).

Axiom corner : forall (s1:(@set vertex vertex_WhyType)) (l:(list vertex)),
  ((list.Length.length l) = (cardinal s1)) -> ((forall (e:vertex),
  (list.Mem.mem e l) -> (mem e s1)) -> ((exists e:vertex,
  (exists l1:(list vertex), (exists l2:(list vertex),
  (exists l3:(list vertex),
  (l = (List.app l1 (cons e (List.app l2 (cons e l3))))))))) \/
  forall (e:vertex), (mem e s1) -> (list.Mem.mem e l))).

Axiom pigeon_0 : (pigeon_set (empty :(@set vertex vertex_WhyType))).

Axiom pigeon_1 : forall (s1:(@set vertex vertex_WhyType)), (pigeon_set s1) ->
  forall (t:vertex), (pigeon_set (add t s1)).

Axiom pigeon_2 : forall (s1:(@set vertex vertex_WhyType)), (pigeon_set s1).

Axiom pigeonhole : forall (s1:(@set vertex vertex_WhyType))
  (l:(list vertex)), (forall (e:vertex), (list.Mem.mem e l) -> (mem e s1)) ->
  (((cardinal s1) < (list.Length.length l))%Z -> exists e:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (List.app l1 (cons e (List.app l2 (cons e l3)))))).

Axiom long_path_decomposition_pigeon1 : forall (l:(list vertex)) (v:vertex),
  (path s l v) -> ((~ (l = nil)) -> forall (v1:vertex), (list.Mem.mem v1
  (cons v l)) -> (mem v1 vertices)).

Axiom long_path_decomposition_pigeon2 : forall (l:(list vertex)) (v:vertex),
  (forall (v1:vertex), (list.Mem.mem v1 (cons v l)) -> (mem v1 vertices)) ->
  (((cardinal vertices) < (list.Length.length (cons v l)))%Z ->
  exists e:vertex, exists l1:(list vertex), exists l2:(list vertex),
  exists l3:(list vertex),
  ((cons v l) = (List.app l1 (cons e (List.app l2 (cons e l3)))))).

Axiom long_path_decomposition_pigeon3 : forall (l:(list vertex)) (v:vertex),
  (exists e:vertex, (exists l1:(list vertex), (exists l2:(list vertex),
  (exists l3:(list vertex),
  ((cons v l) = (List.app l1 (cons e (List.app l2 (cons e l3))))))))) ->
  ((exists l1:(list vertex), (exists l2:(list vertex),
  (l = (List.app l1 (cons v l2))))) \/ exists n:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (List.app l1 (cons n (List.app l2 (cons n l3)))))).

Axiom long_path_decomposition : forall (l:(list vertex)) (v:vertex), (path s
  l v) -> (((cardinal vertices) <= (list.Length.length l))%Z ->
  ((exists l1:(list vertex), (exists l2:(list vertex),
  (l = (List.app l1 (cons v l2))))) \/ exists n:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (List.app l1 (cons n (List.app l2 (cons n l3))))))).

Axiom simple_path : forall (v:vertex) (l:(list vertex)), (path s l v) ->
  exists l':(list vertex), (path s l' v) /\
  ((list.Length.length l') < (cardinal vertices))%Z.

(* Why3 assumption *)
Definition negative_cycle (v:vertex): Prop := (mem v vertices) /\
  ((exists l1:(list vertex), (path s l1 v)) /\ exists l2:(list vertex), (path
  v l2 v) /\ ((path_weight l2 v) < 0%Z)%Z).

Axiom key_lemma_1 : forall (v:vertex) (n:Z), (forall (l:(list vertex)), (path
  s l v) -> (((list.Length.length l) < (cardinal vertices))%Z ->
  (n <= (path_weight l v))%Z)) -> ((exists l:(list vertex), (path s l v) /\
  ((path_weight l v) < n)%Z) -> exists u:vertex, (negative_cycle u)).

(* Why3 assumption *)
Inductive t :=
  | Finite : Z -> t
  | Infinite : t.
Axiom t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 assumption *)
Definition add1 (x:t) (y:t): t :=
  match x with
  | Infinite => Infinite
  | (Finite x1) =>
      match y with
      | Infinite => Infinite
      | (Finite y1) => (Finite (x1 + y1)%Z)
      end
  end.

(* Why3 assumption *)
Definition lt (x:t) (y:t): Prop :=
  match x with
  | Infinite => False
  | (Finite x1) =>
      match y with
      | Infinite => True
      | (Finite y1) => (x1 < y1)%Z
      end
  end.

(* Why3 assumption *)
Definition le (x:t) (y:t): Prop := (lt x y) \/ (x = y).

Axiom Refl : forall (x:t), (le x x).

Axiom Trans : forall (x:t) (y:t) (z:t), (le x y) -> ((le y z) -> (le x z)).

Axiom Antisymm : forall (x:t) (y:t), (le x y) -> ((le y x) -> (x = y)).

Axiom Total : forall (x:t) (y:t), (le x y) \/ (le y x).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Definition t1 (a:Type) {a_WT:WhyType a} := (@ref (@set a a_WT) (@set_WhyType
  a a_WT)).

(* Why3 assumption *)
Definition distmap := (@map.Map.map vertex vertex_WhyType t t_WhyType).

(* Why3 assumption *)
Definition inv1 (m:(@map.Map.map vertex vertex_WhyType t t_WhyType)) (pass:Z)
  (via:(@set (vertex* vertex)%type _)): Prop := forall (v:vertex), (mem v
  vertices) -> match (map.Map.get m
  v) with
  | (Finite n) => (exists l:(list vertex), (path s l v) /\ ((path_weight l
      v) = n)) /\ ((forall (l:(list vertex)), (path s l v) ->
      (((list.Length.length l) < pass)%Z -> (n <= (path_weight l v))%Z)) /\
      forall (u:vertex) (l:(list vertex)), (path s l u) ->
      (((list.Length.length l) < pass)%Z -> ((mem (u, v) via) ->
      (n <= ((path_weight l u) + (weight u v))%Z)%Z)))
  | Infinite => (forall (l:(list vertex)), (path s l v) ->
      (pass <= (list.Length.length l))%Z) /\ forall (u:vertex), (mem (u, v)
      via) -> forall (lu:(list vertex)), (path s lu u) ->
      (pass <= (list.Length.length lu))%Z
  end.

(* Why3 assumption *)
Definition inv2 (m:(@map.Map.map vertex vertex_WhyType t t_WhyType))
  (via:(@set (vertex* vertex)%type _)): Prop := forall (u:vertex) (v:vertex),
  (mem (u, v) via) -> (le (map.Map.get m v) (add1 (map.Map.get m u)
  (Finite (weight u v)))).

Axiom key_lemma_2 : forall (m:(@map.Map.map vertex vertex_WhyType
  t t_WhyType)), (inv1 m (cardinal vertices) (empty :(@set (vertex*
  vertex)%type _))) -> ((inv2 m edges) -> forall (v:vertex),
  ~ (negative_cycle v)).

Require Import Why3.
Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem WP_parameter_bellman_ford : (((cardinal vertices) - 1%Z)%Z < 1%Z)%Z ->
  ((inv1 (map.Map.set (map.Map.const Infinite:(@map.Map.map
  vertex vertex_WhyType t t_WhyType)) s (Finite 0%Z)) (cardinal vertices)
  (empty :(@set (vertex* vertex)%type _))) -> forall (es:(@set (vertex*
  vertex)%type _)), (es = edges) -> forall (es1:(@set (vertex*
  vertex)%type _)), ((subset es1 edges) /\ (inv2
  (map.Map.set (map.Map.const Infinite:(@map.Map.map vertex vertex_WhyType
  t t_WhyType)) s (Finite 0%Z)) (diff edges es1))) -> forall (o:bool),
  ((o = true) <-> (is_empty es1)) -> ((~ (o = true)) -> ((~ (is_empty
  es1)) -> forall (es2:(@set (vertex* vertex)%type _)),
  forall (result:vertex) (result1:vertex), let result2 := (result,
  result1) in (((mem result2 es1) /\ (es2 = (remove result2 es1))) ->
  (match (map.Map.get (map.Map.set (map.Map.const Infinite:(@map.Map.map
  vertex vertex_WhyType t t_WhyType)) s (Finite 0%Z))
  result) with
  | Infinite => False
  | (Finite x) =>
      match (map.Map.get (map.Map.set (map.Map.const Infinite:(@map.Map.map
      vertex vertex_WhyType t t_WhyType)) s (Finite 0%Z))
      result1) with
      | Infinite => True
      | (Finite y) => ((x + (weight result result1))%Z < y)%Z
      end
  end -> exists v:vertex, (negative_cycle v)))))).
(* Why3 intros h1 h2 es h3 es1 (h4,h5) o h6 h7 h8 es2 result result1 result2
        (h9,h10) h11. *)
intros Hvertices _.
assert (Hs: (cardinal vertices = 1)%Z) by ae. clear Hvertices.
generalize (cardinal1 vertices Hs). clear Hs. intros H1.
assert (Hs: s = choose vertices) by ae.
intros result hresult. subst result.
intros es (Hes,_) _ _ _ _ es1.
intros u v res4. unfold res4.
intros (Huv, _).
assert (u = s) by ae. subst u.
assert (v = s) by ae. subst v.
rewrite Map.Select_eq; auto.
intros hneg.
exists s. red.
split. ae.
split. exists nil; ae.
exists (cons s nil); ae.
Qed.


(* 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                                                     *)

(* Axiomatisation of a hash table where the elements are ordered. *)

Require Import List.
Require Import ListDefs.
(* Require Extraction. *)
Require Import Exceptions.

Set Implicit Arguments.
Unset Strict Implicit.

Section Dictionary_Specification.

Variable Key : Set.
Variable keyEqDecide : forall k1 k2 : Key, {k1 = k2} + {k1 <> k2}.

Variable Data : Set.

Parameter dictionary : Set -> Set -> Set.

Notation dico := (dictionary Key Data) (only parsing).

Definition dico_result : Set := exc Data Key.
Definition dico_def (d : Data) : dico_result := Value Key d.
Definition dico_unDef (k : Key) : dico_result := Error Data k.
Local Coercion dico_def : Data >-> dico_result.

Parameter dico_empty : dictionary Key Data.
Parameter
  dico_addShdw : dictionary Key Data -> Key -> Data -> dictionary Key Data.
Parameter dico_map : dictionary Key Data -> Key -> dico_result.
Parameter
  dico_union :
    dictionary Key Data -> dictionary Key Data -> dictionary Key Data.
Parameter dico_rmv : dictionary Key Data -> Key -> dictionary Key Data.
(* dico_toList should list the elements respecting a certain order! *)
Parameter dico_toList : dictionary Key Data -> list (Key * Data).
Parameter
  dico_filter :
    (Key -> Data -> bool) -> dictionary Key Data -> dictionary Key Data.

Axiom
  dico_AddShdw1 :
    forall (m : dictionary Key Data) (k : Key) (d : Data),
    dico_map (dico_addShdw m k d) k = d.

Axiom
  dico_AddShdw2 :
    forall (m : dictionary Key Data) (k1 k2 : Key) (d : Data),
    k1 <> k2 -> dico_map (dico_addShdw m k1 d) k2 = dico_map m k2.

Axiom dico_Empty : forall k : Key, dico_map dico_empty k = dico_unDef k.

Axiom
  dico_Remove :
    forall (m : dictionary Key Data) (k1 k2 : Key) (d : Data),
    k1 <> k2 -> dico_map (dico_rmv m k1) k2 = dico_map m k2.

Axiom
  dico_Filter :
    forall (p : Key -> Data -> bool) (m : dictionary Key Data),
    dico_toList (dico_filter p m) =
    filter (fun x : Key * Data => p (fst x) (snd x)) (dico_toList m).

Definition dico_AssocValIs (m : dictionary Key Data)
  (k : Key) (d : Data) : Prop := dico_map m k = d.

Definition dico_IsDefined (m : dictionary Key Data)
  (k : Key) : Prop := exists d : Data, dico_AssocValIs m k d.

Definition dico_decIsDefined :
  forall (m : dictionary Key Data) (k : Key),
  {dico_IsDefined m k} + {~ dico_IsDefined m k}.
intros m k.
unfold dico_IsDefined in |- *.
unfold dico_AssocValIs in |- *.
case (dico_map m k).
intro d; left; split with d; auto.
intro d; right; (red in |- *; intro abs); elim abs; (intros; discriminate).
Defined.

Axiom
  dico_AppIntro1 :
    forall (m1 m2 : dictionary Key Data) (k : Key) (d : Data),
    ~ dico_IsDefined m2 k ->
    dico_AssocValIs m1 k d -> dico_AssocValIs (dico_union m1 m2) k d.

Axiom
  dico_AppIntro2 :
    forall (m1 m2 : dictionary Key Data) (k : Key) (d : Data),
    dico_AssocValIs m2 k d -> dico_AssocValIs (dico_union m1 m2) k d.

Axiom
  dico_AppElim :
    forall (m1 m2 : dictionary Key Data) (k : Key) (d : Data),
    dico_AssocValIs (dico_union m1 m2) k d ->
    dico_AssocValIs m1 k d \/ dico_AssocValIs m2 k d.

Axiom
  dico_ToList1 :
    forall (m : dictionary Key Data) (k : Key) (d : Data),
    dico_AssocValIs m k d -> In (k, d) (dico_toList m).

Axiom
  dico_ToList2 :
    forall (m : dictionary Key Data) (k : Key) (d : Data),
    In (k, d) (dico_toList m) -> dico_AssocValIs m k d.

Definition dico_add (m : dictionary Key Data) (k : Key)
  (d : Data) : dictionary Key Data :=
  try d = (dico_map m k) in m with x_ => (dico_addShdw m k d).

Definition dico_domain (d : dictionary Key Data) :
  list Key := map (fun p => fst p) (dico_toList d).

Definition dico_codomain (d : dictionary Key Data) :
  list Data := map (fun p => snd p) (dico_toList d).

Definition dico_fromList (l : list (Key * Data)) :
  dictionary Key Data :=
  fold_right (fun p d => dico_addShdw d (fst p) (snd p)) dico_empty l.

(* Properties *)

Hint Unfold dico_IsDefined dico_AssocValIs: Scade.

Hint Resolve dico_AddShdw1 dico_AddShdw2 dico_Empty dico_ToList1 dico_ToList1
  dico_ToList2: Scade.

Lemma DeclaredEmpty : forall k : Key, ~ dico_IsDefined dico_empty k.
unfold dico_IsDefined in |- *.
red in |- *; intros k (d, H).
absurd (dico_AssocValIs dico_empty k d);
 [ unfold dico_AssocValIs in |- *; rewrite dico_Empty; discriminate
 | assumption ].
Defined.

Lemma DeclaredAdd1 :
 forall (m : dictionary Key Data) (k : Key) (d : Data),
 dico_IsDefined (dico_addShdw m k d) k.
intros m k d; exists d; auto with *.
Defined.

Lemma DeclaredAdd2 :
 forall (m : dictionary Key Data) (k1 k2 : Key) (d : Data),
 dico_IsDefined m k1 -> k1 <> k2 -> dico_IsDefined (dico_addShdw m k2 d) k1.
unfold dico_IsDefined in |- *; unfold dico_AssocValIs in |- *;
 intros m k1 k2 d1 (d2, H) diseq; exists d2; rewrite <- H;
 auto with *.
Defined.

Lemma DeclaredAdd3 :
 forall (m : dictionary Key Data) (k1 k2 : Key) (d : Data),
 dico_IsDefined (dico_addShdw m k2 d) k1 -> k1 = k2 \/ dico_IsDefined m k1.
unfold dico_IsDefined in |- *; unfold dico_AssocValIs in |- *.
intros m k1 k2.
case (keyEqDecide k1 k2); auto with *.
intros diseq d1 (d2, H); right; exists d2; rewrite <- H; symmetry  in |- *;
 auto with *.
Defined.

Lemma DeclaredAdd4 :
 forall (m : dictionary Key Data) (k1 k2 : Key) (d : Data),
 ~ dico_IsDefined (dico_addShdw m k2 d) k1 ->
 k1 <> k2 /\ ~ dico_IsDefined m k1.
unfold dico_IsDefined in |- *; unfold dico_AssocValIs in |- *.
intros m k1 k2 d Hi.
case (keyEqDecide k1 k2).
intro H; rewrite <- H in Hi.
absurd (dico_IsDefined (dico_addShdw m k1 d) k1); trivial.
apply DeclaredAdd1.
split; trivial.
red in |- *; intros (d0, eqm); apply Hi.
exists d0; rewrite <- eqm; auto with *.
Defined.

Lemma declaredDecidable :
 forall (m : dictionary Key Data) (k : Key),
 {dico_IsDefined m k} + {~ dico_IsDefined m k}.

unfold dico_IsDefined in |- *; unfold dico_AssocValIs in |- *.
intros m k.
case (dico_map m k);
 [ intro d; left; exists d; auto with * | intro k1; right ].
red in |- *; intros (d, H); discriminate H.
Defined.

End Dictionary_Specification.

(* Morphisms on dictionaries *)

Section Dictionary_Iteration.
(*
Fixpoint dico_visit_right [l:(list (Key*Data))] :  S -> dico*S :=
 [s]Cases l of
       nil             => (dico_empty,s)
    | (cons (k,x0) l0) =>
        let (d0,s0) = (dico_visit l0 s) in
        let (x1,s1) = (f x0 s0)
        in  ((dico_addShdw k x1),s1)
    end.
*)

Variable Key1 Key2 Data1 Data2 : Set.
Let dico11 := dictionary Key1 Data1.
Let dico12 := dictionary Key1 Data2.
Let dico22 := dictionary Key2 Data2.

Variable h1 : Key1 -> Key2.
Variable h2 : Data1 -> Data2.

Fixpoint dico_imageFromList12 (l : list (Key1 * Data1)) : dico12 :=
  match l with
  | nil => dico_empty Key1 Data2
  | p :: l0 =>
      let (k, x) := p in dico_addShdw (dico_imageFromList12 l0) k (h2 x)
  end.
Fixpoint dico_imageFromList22 (l : list (Key1 * Data1)) : dico22 :=
  match l with
  | nil => dico_empty Key2 Data2
  | p :: l0 =>
      let (k, x) := p in dico_addShdw (dico_imageFromList22 l0) (h1 k) (h2 x)
  end.

Definition dico_image (d1 : dico11) : dico12 :=
  dico_imageFromList12 (dico_toList d1).

Definition dico_image2 (d1 : dico11) : dico22 :=
  dico_imageFromList22 (dico_toList d1).

Variable S : Set.
Variable f : Data1 -> S -> Data2 * S.

Definition modif (p : Key1 * Data1) (ds0 : dico12 * S) :
  dico12 * S :=
  let (d, s0) := ds0 in
  let (k, x0) := p in let (x1, s1) := f x0 s0 in (dico_addShdw d k x1, s1).

Fixpoint dico_visit (l : list (Key1 * Data1)) : dico12 * S -> dico12 * S :=
  fun ds =>
  match l with
  | nil => ds
  | p :: l0 => modif p (dico_visit l0 ds)
  end.

Definition dico_iter_right (d : dico11) (s : S) : dico12 * S :=
  dico_visit (dico_toList d) (dico_empty Key1 Data2, s).

Variable g : Key1 -> Data1 -> S -> S.
Definition dico_fold_left (d : dico11) (s : S) : S :=
  fold_left (fun (s : S) (p : Key1 * Data1) => let (k, d) := p in g k d s)
    (dico_toList d) s.

Definition dico_fold_right (d : dico11) (s : S) : S :=
  fold_right (fun (p : Key1 * Data1) (s : S) => let (k, d) := p in g k d s) s
    (dico_toList d).

End Dictionary_Iteration.

(*
Extract Constant  dictionary   => "Dico.t".
Extract Constant  dico_empty   => "Dico.empty".
Extract Constant  dico_addShdw => "Dico.addShdw".
Extract Constant  dico_map     => "Dico.map".
Extract Constant  dico_toList  => "Dico.toList".
*)


(* Additional lemmas / proof rules about VST stack *)

Require Import floyd.proofauto.
Require Export sha.general_lemmas.
Require Import sha.common_lemmas.
Local Open Scope logic.

Lemma force_lengthn_long {A}: forall n (l:list A) d, (n <= length l)%nat -> force_lengthn n l d = firstn n l.
Proof. induction n; simpl; intros. trivial.
  destruct l; simpl in H. omega.
  rewrite IHn; trivial. omega.
Qed.

Lemma data_at_triv {cs} sh t v v': v=v' -> @data_at cs sh t v |-- @data_at cs sh t v'.
Proof. intros; subst. cancel. Qed.

Lemma sizeof_Tarray {cs: composite_env} k: Z.max 0 k = k -> sizeof (Tarray tuchar k noattr) = k.
Proof. intros K; simpl; rewrite K. destruct k; trivial. Qed.

(*Require Import replace_refill_reptype_lemmas.*)
(*
Lemma data_at_Tarray_split3a {cs}: forall sh t n a i v,
  0 <= i <= n ->
  @data_at cs sh (Tarray t n a) v =
  @data_at cs sh (Tarray t n a) (upd_Znth i v (Znth i v (default_val _))) v.
    @data_at cs sh (Tarray t n a) (force_lengthn (nat_of_Z i) v (default_val _) ++
      (Znth i v (default_val _)) :: skipn (nat_of_Z (i + 1)) v).
Proof.
  intros.
  apply data_at_Tarray_ext.
  intros j ?H.
  unfold Znth.
  if_tac; [omega |].
  if_tac; [omega |].
  unfold nat_of_Z.
  destruct (Z_dec i j) as [[? | ?] | ?].
  + assert ((Z.to_nat i < Z.to_nat j)%nat) by (apply Z2Nat.inj_lt in l; omega).
    rewrite app_nth2 by (rewrite force_lengthn_length_n; omega).
    rewrite force_lengthn_length_n.
    simpl.
    destruct ((Z.to_nat j - Z.to_nat i)%nat) eqn:?H; [omega |].
    rewrite nth_skipn.
    f_equal.
    f_equal.
    change (i + 1) with (Z.succ i).
    rewrite Z2Nat.inj_succ by omega.
    omega.
  + assert ((Z.to_nat j < Z.to_nat i)%nat) by (apply Z2Nat.inj_lt; omega).
    rewrite app_nth1 by (rewrite force_lengthn_length_n; omega).
    rewrite nth_force_lengthn by omega.
    reflexivity.
  + subst.
    rewrite app_nth2 by (rewrite force_lengthn_length_n; omega).
    rewrite force_lengthn_length_n.
    rewrite minus_diag.
    simpl.
    reflexivity.
Qed.
*)
Lemma skipn_force_lengthn_app {A} n (l m:list A) a:
        skipn n (force_lengthn n l a ++ m) = m.
  intros. rewrite skipn_app1.
  specialize (skipn_exact_length (force_lengthn n l a)).
           rewrite force_lengthn_length_n. intros X; rewrite X; trivial.
  rewrite force_lengthn_length_n; omega.
Qed.

Lemma sepcon_fold: forall Frame P rho,
Frame = cons `(P) nil ->
P |-- fold_right
      (fun (P Q : environ -> mpred) (rho0 : environ) => P rho0 * Q rho0)
      `emp Frame rho.
Proof. intros. subst. simpl. entailer. Qed.

Lemma nth_mapVint: forall i (l:list Z) (Hi: (0 <= i < length l)%nat),
  exists n, nth i (map Vint (map Int.repr l)) Vundef = Vint n.
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. omega. eexists; reflexivity.
    destruct l; simpl in *. omega.
      destruct (IHi l). omega. rewrite H. eexists; reflexivity.
Qed.

Lemma nth_mapVint' {z}: forall i (l:list Z)
  (Hi: (0 <= i < length l)%nat),
  nth i (map Vint (map Int.repr l)) Vundef =
  Vint (Int.repr (nth i l z)).
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. omega. trivial.
    destruct l; simpl in *. omega.
      rewrite (IHi l). trivial. omega.
Qed.

Lemma nth_mapVintZ: forall i (l:list Z) (Hi: 0 <= i < Zlength l),
  exists n, nth (Z.to_nat i) (map Vint (map Int.repr l)) Vundef = Vint n.
Proof. intros.
  eapply nth_mapVint. rewrite Zlength_correct in Hi.
  destruct Hi; split.   omega.
unfold Z.of_nat in H0. unfold Z.to_nat.
destruct l; simpl in *. omega.
destruct i; try omega.
rewrite <- SuccNat2Pos.id_succ.
apply Pos2Nat.inj_lt.
apply H0.
Qed.

(*Same proof as semax_loadstore_array*)(*
Lemma NEWsemax_loadstore_array:
  forall {Espec: OracleKind},
 forall n k vi lo hi t1 (contents: Z -> reptype t1) v1 v2 (Delta: tycontext) e1 ei e2 sh P Q R,
  (*H0*) reptype t1 = val ->
  (*H1*) type_is_by_value t1 ->
  (*H2*) legal_alignas_type t1 = true ->
  (*H3*) typeof e1 = tarray t1 k->
  (*H4*) typeof ei = tint ->
  (*H8*) PROPx P (LOCALx Q (SEPx R)) |--  rel_expr e1 v1 && rel_expr ei (Vint (Int.repr vi))
           && rel_expr (Ecast e2 t1) v2 ->
  (*H7*) nth_error R n = Some (`(array_at t1 sh contents lo hi v1)) ->
  (*H *) writable_share sh ->
  (*H5*) tc_val t1 v2 ->
  (*H6*) in_range lo hi vi ->
   @semax Espec Delta (|> PROPx P (LOCALx Q (SEPx R))) (Sassign (Ederef (Ebinop Oadd e1 ei (tptr t1)) t1) e2)
          (normal_ret_assert
           (PROPx P (LOCALx Q (SEPx
            (replace_nth n R `(array_at t1 sh (upd contents vi (valinject _ v2)) lo hi v1)))))).
Proof.
intros until R.
intros H0 H1 H2 H3 H4 H8 H7 H H5 H6.
eapply semax_post_flipped'.
apply semax_loadstore_array'; eauto.
apply derives_trans with (!! isptr v1 && PROPx P (LOCALx Q (SEPx R))).
rewrite (SEP_nth_isolate _ _ _ H7).
repeat rewrite <- insert_SEP.
rewrite array_at_isptr. normalize.
normalize.
destruct v1; try contradiction.
instantiate (2:=v1).
simpl eval_binop. rewrite mul_repr.
apply andp_right; auto.
eapply derives_trans; [ apply H8 |].
intro rho. simpl.
repeat apply andp_right.
apply rel_lvalue_deref.
eapply rel_expr_binop.
repeat apply andp_left1. apply derives_refl.
apply andp_left1. apply andp_left2. apply derives_refl.
intro; rewrite H4; simpl. rewrite H3; simpl.
  unfold Cop.sem_add; simpl. rewrite mul_repr. auto.
 apply andp_left2. auto.
rewrite (SEP_nth_isolate _ _ _ H7).
repeat rewrite <- insert_SEP.
apply derives_refl.
rewrite (SEP_replace_nth_isolate _ _ _ `(array_at t1 sh (upd contents vi (valinject t1 v2)) lo hi v1) H7).
rewrite insert_SEP.
auto.
Qed.*)
(*
Lemma array_at_local_facts':
  forall (t : type) (sh : Share.t) (f : Z -> reptype t) (lo hi : Z) (v : val),
  array_at t sh f lo hi v |-- array_at t sh f lo hi v && !!isptr v && !!offset_in_range (sizeof t * lo) v &&
!!offset_in_range (sizeof t * hi) v && !!align_compatible t v.
Proof. intros. unfold array_at. entailer. Qed.
*)
(*
Lemma split_offset_array_at_: forall (ty : type) (sh : Share.t)
         (z lo hi : Z) (v : val),
       z <= lo <= hi ->
       sizeof ty > 0 ->
       legal_alignas_type ty = true ->
       array_at_ ty sh z hi v =
       !! offset_in_range (sizeof ty * z) v &&
       !! offset_in_range (sizeof ty * hi) v &&
       array_at_ ty sh z lo v *
       array_at_ ty sh 0 (hi - lo)
       (offset_val (Int.repr (sizeof ty * lo)) v).
Proof.
  intros. unfold array_at_.
  rewrite <- split_offset_array_at; trivial.
Qed.
*)
(*
Lemma offset_val_array_at0:
 forall t sh f lo hi v,
  sizeof t > 0 -> hi >= 0 ->
  legal_alignas_type t = true ->
  array_at t sh (fun i => f (i-lo)%Z) lo (lo + hi) v
  |--
  array_at t sh f 0 hi (offset_val (Int.repr (sizeof t * lo)) v).
Proof.
  intros.
  rewrite (split_offset_array_at t _ _ lo lo); trivial.
  rewrite array_at_emp.
  entailer. rewrite Zplus_comm. rewrite Z.add_simpl_r.
  apply array_lemmas.array_at_ext'. intros. rewrite Z.add_simpl_r. trivial.
  omega.
Qed.

Lemma offset_val_array_at1:
 forall t sh f g k lo hi ofs v,
    sizeof t > 0 -> hi >= 0 ->
    legal_alignas_type t = true ->
    k = lo + hi ->
    g = (fun i => f (i-lo)%Z) ->
    ofs = Int.repr (sizeof t * lo) ->
  array_at t sh g lo k v |--
  array_at t sh f 0 hi ((offset_val ofs) v).
Proof.
  intros. subst. apply offset_val_array_at0; trivial.
Qed.
*)
(*
Lemma split_memory_block p hi v sh:
      0 <= p <= hi -> isptr v ->
      memory_block sh (Int.repr hi) v =
      !!offset_in_range (sizeof tuchar * 0) v &&
      !!offset_in_range (sizeof tuchar * hi) v &&
      memory_block sh (Int.repr p) v * memory_block sh (Int.repr (hi-p)) (offset_val (Int.repr p) v).
Proof. intros.
rewrite memory_block_array_tuchar'; try omega; trivial.
rewrite memory_block_array_tuchar'; try omega; trivial.
rewrite memory_block_array_tuchar'; try omega.
rewrite (split_offset_array_at_ _ _ _ p).
   assert (K: (sizeof tuchar * p = p)%Z).
      assert (sizeof tuchar =1 ). reflexivity.
  rewrite H1. omega.
  rewrite K; trivial.
 assumption. simpl; omega. reflexivity. apply isptr_offset_val'; trivial.
Qed.
*)
Lemma isptrD v: isptr v -> exists b ofs, v = Vptr b ofs.
Proof. intros. destruct v; try contradiction. exists b, i; trivial. Qed.

(*
Lemma mysemax_frame_PQR:
  forall R2 Espec Delta R1 P Q P' Q' R1' c,
     closed_wrt_modvars c (LOCALx nil (SEPx R2)) ->
     @semax Espec Delta (PROPx P (LOCALx Q (SEPx R1))) c
                     (normal_ret_assert (PROPx P' (LOCALx Q' (SEPx R1')))) ->
     @semax Espec Delta (PROPx P (LOCALx (Q) (SEPx (R1++R2)))) c
                     (normal_ret_assert (PROPx P' (LOCALx (Q') (SEPx (R1'++R2))))).
Proof.
intros. specialize (semax_frame_PQR nil R2 Espec Delta R1 P Q P' Q' R1' c).
repeat rewrite app_nil_r. intros. apply H1; trivial. Qed.

Ltac frame_SEP'' L :=
 grab_indexes_SEP L;
 match goal with
 | |- @semax _ _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
  rewrite <- (firstn_skipn (length L) R);
    simpl length; unfold firstn, skipn;
    eapply (mysemax_frame_PQR);
      [ unfold closed_wrt_modvars;  auto 50 with closed
     | ]
 | |- (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
  rewrite <- (firstn_skipn (length L) R);
    simpl length; unfold firstn, skipn;
    apply derives_frame_PQR
end.
*)

Ltac myframe_SEP'' L :=  (* this should be generalized to permit framing on LOCAL part too *)
 grab_indexes_SEP L;
 match goal with
 | |- @semax _ _ (PROPx _ (LOCALx ?Q (SEPx ?R))) _ _ =>
  rewrite <- (firstn_skipn (length L) R);
  rewrite <- (firstn_skipn (length Q) Q);
    simpl length; unfold firstn, skipn;
    eapply (semax_frame_PQR nil);
      [ unfold closed_wrt_modvars;  auto 50 with closed
     | ]
 | |- (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
  rewrite <- (firstn_skipn (length L) R);
    simpl length; unfold firstn, skipn;
    apply derives_frame_PQR
end.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal18.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ (Succ Zero))         (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))).
Definition lfind_example_2  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_3  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_4  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_5  := ( Cons (Succ Zero) Nil).
Definition lfind_example_6  := ( Cons Zero Nil).
Definition lfind_example_7  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_8  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_9  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_10  := ( Cons (Succ (Succ (Succ Zero)))         (Cons Zero            (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)))).
Definition lfind_example_11  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_12  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal18_theorem0_43_lem3/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 .


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Cava.Cava.
Require Import Cava.CavaProperties.
Require Import Tests.DoubleCountBy.DoubleCountBy.

(* redefine simpl_ident to simplify the new semantics class *)
Definition bvadd {n} (a b : Vector.t bool n) : Vector.t bool n :=
  N2Bv_sized n (Bv2N b + Bv2N a).

Definition bvsum {n} (l : list (Vector.t bool n)) : Vector.t bool n :=
  fold_left bvadd l (N2Bv_sized n 0).

Definition boolsum {n} (l : list bool) : Vector.t bool n :=
  fold_left (fun acc (c : bool) => if c then N2Bv_sized n (Bv2N acc + 1) else acc)
            l (N2Bv_sized n 0).

Definition bvaddc {n} (a b : Vector.t bool n) : Vector.t bool n * bool :=
  let sum := (Bv2N b + Bv2N a)%N in
  let carry := (Bv2N a <? sum mod (2 ^ N.of_nat n))%N in
  (N2Bv_sized n sum, carry).

Definition bvsumc {n} (l : list (Vector.t bool n)) : Vector.t bool n * bool :=
  fold_left (fun acc_c => bvaddc (fst acc_c)) l (N2Bv_sized n 0, false).

Definition count_by_spec (i : list (Vector.t bool 8)) : list (Vector.t bool 8 * bool) :=
  map (fun t => bvsumc (firstn t i)) (seq 1 (length i)).

Definition double_count_by_spec (i : list (Vector.t bool 8)) : list (Vector.t bool 8) :=
  map (fun t => boolsum (firstn t (map snd (count_by_spec i)))) (seq 1 (length i)).

Lemma addN_correct {n} (x y : combType (Vec Bit n)) :
  addN (x, y) = bvadd x y.
Admitted.
Hint Rewrite @addN_correct : simpl_ident.

Lemma ltV_correct {n m} x y :
  ltV (n:=n) (m:=m) (x, y) = (Bv2N x <? Bv2N y)%N.
Admitted.
Hint Rewrite @ltV_correct : simpl_ident.

Lemma addC_correct {n} (x y : combType (Vec Bit n)) :
  addC (x, y) = bvaddc x y.
Proof.
  cbv [addC bvaddc]. cbv [CombinationalSemantics].
  simpl_ident. cbv [bvadd].
  rewrite Bv2N_N2Bv_sized_modulo.
  rewrite N.add_comm. reflexivity.
Qed.
Hint Rewrite @addC_correct : simpl_ident.

Lemma incrN_correct {n} (x : combType (Vec Bit (S n))) :
  incrN x = N2Bv_sized (S n) (Bv2N x + 1).
Proof.
  cbv [incrN].
  cbn [CombinationalSemantics unpackV packV unsignedAdd unsignedAddBool constant].
  simpl_ident. cbn [Nat.max Nat.add Bv2N N.succ_double].
  (* just proof about shiftout from here *)
Admitted.
Hint Rewrite @incrN_correct : simpl_ident.

Lemma bvaddc_comm {n} (a b : Vector.t bool n) : bvaddc a b = bvaddc b a.
Admitted.
Local Opaque bvaddc.

Lemma count_by_step (input st : combType (Vec Bit 8)) :
  step count_by (tt, (tt, st)) input
  = (tt, (tt, fst (bvaddc input st)), snd (bvaddc input st)).
Proof.
  intros; cbv [count_by Loop step].
  repeat first [ destruct_pair_let | progress simpl_ident].
  reflexivity.
Qed.

Lemma bvsumc_snoc {n} xs (x : Vector.t bool n) :
  bvsumc (xs ++ [x]) = bvaddc x (fst (bvsumc xs)).
Proof.
  cbv [bvsumc].
  autorewrite with pull_snoc.
  apply bvaddc_comm.
Qed.

Lemma boolsum_snoc {n} xs (x : bool) :
  boolsum (xs ++ [x]) = if x then N2Bv_sized n (Bv2N (n:=n) (boolsum xs) + 1) else boolsum xs.
Proof.
  cbv [boolsum]. autorewrite with pull_snoc.
  reflexivity.
Qed.

Lemma count_by_correct (input : list (combType (Vec Bit 8))) :
  simulate count_by input = map snd (count_by_spec input).
Proof.
  intros; cbv [count_by mcompose]. autorewrite with push_simulate.
  cbn [step]. simpl_ident.
  eapply fold_left_accumulate_invariant_seq
    with (I:=fun t st acc =>
            st = (tt, fst (bvsumc (firstn t input)))
            /\ acc = map snd (count_by_spec (firstn t input))).
  { (* invariant holds at start *)
    split; reflexivity. }
  { (* invariant holds through body *)
    cbv zeta. intros ? ? ? d; intros; logical_simplify; subst.
    cbv [step count_by_spec].
    repeat first [ destruct_pair_let | progress simpl_ident].
    rewrite firstn_succ_snoc with (d0:=d) by length_hammer.
    repeat (push_length || natsimpl || pull_snoc).
    rewrite Nat.add_1_r. pull_snoc. push_firstn.
    cbv [combType] in *. rewrite !bvsumc_snoc.
    repeat (push_nth || push_firstn || push_length || natsimpl || listsimpl).
    ssplit; [ reflexivity | ].
    f_equal; [ ]. apply f_equal.
    apply map_ext_in; intros.
    match goal with H : _ |- _ => apply in_seq in H end.
    repeat (push_nth || push_firstn || push_length || natsimpl || listsimpl).
    reflexivity. }
  { (* invariant implies postcondition *)
    intros; logical_simplify; subst. push_firstn. reflexivity. }
Qed.

Lemma count_by_spec_nth t input d :
  t < length input ->
  nth t (count_by_spec input) d = bvaddc (nth t input (fst d)) (fst (bvsumc (firstn t input))).
Proof.
  cbv [count_by_spec]. intros.
  rewrite map_nth_inbounds with (d2:=0) by length_hammer.
  push_nth. cbn [Nat.add].
  rewrite firstn_succ_snoc with (d0:=fst d) by length_hammer.
  rewrite bvsumc_snoc. reflexivity.
Qed.

Lemma count_by_spec_length input : length (count_by_spec input) = length input.
Proof. cbv [count_by_spec]; length_hammer. Qed.
Hint Rewrite @count_by_spec_length using solve [eauto] : push_length.

Lemma firstn_count_by_spec t input :
  firstn t (count_by_spec input) = count_by_spec (firstn t input).
Proof.
  cbv [count_by_spec]. intros.
  repeat (push_firstn || push_length || natsimpl).
  apply map_ext_in; intros.
  match goal with H : _ |- _ => apply in_seq in H end.
  repeat (push_firstn || push_length || natsimpl).
  reflexivity.
Qed.
Hint Rewrite @firstn_count_by_spec using solve [eauto] : push_firstn.

Lemma double_count_by_correct (input : list (combType (Vec Bit 8))) :
  simulate double_count_by input = double_count_by_spec input.
Proof.
  intros; cbv [double_count_by]. autorewrite with push_simulate.
  cbn [step]. simpl_ident.
  eapply fold_left_accumulate_invariant_seq
    with (I:= fun t (st : unit * (unit * Vector.t bool 8) * unit * Vector.t bool 8) acc =>
                st = (tt, (tt, fst (bvsumc (firstn t input))), tt,
                      boolsum (firstn t (map snd (count_by_spec input))))
                /\ acc = double_count_by_spec (firstn t input)).
  { (* invariant holds at start *)
    ssplit; reflexivity. }
  { (* invariant holds through body *)
    cbv zeta. intros ? ? ? d; intros; logical_simplify; subst.
    cbn [step]. cbv [double_count_by_spec].
    repeat first [ destruct_pair_let | progress simpl_ident].
    repeat (push_length || pull_snoc || natsimpl).
    rewrite !count_by_step. cbn [fst snd].
    cbv [combType] in *.
    rewrite !firstn_succ_snoc with (d0:=d) by length_hammer.
    rewrite !firstn_succ_snoc with (d0:=false) by length_hammer.
    cbv [combType] in *. rewrite !bvsumc_snoc, !boolsum_snoc.
    rewrite !map_nth_inbounds with (d2:=(d,false)) by length_hammer.
    rewrite !count_by_spec_nth by length_hammer.
    ssplit; [ reflexivity .. | ].
    repeat (push_nth || push_firstn || push_length || natsimpl || listsimpl).
    f_equal; [ ].
    apply map_ext_in; intros.
    match goal with H : _ |- _ => apply in_seq in H end.
    repeat (push_nth || push_firstn || push_length || natsimpl || listsimpl).
    reflexivity. }
  { (* invariant implies postcondition *)
    intros; logical_simplify; subst.
    rewrite firstn_all; reflexivity. }
Qed.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Bihong Zhang  <sa614257@mail.ustc.edu.cn>                        *)
(*                                       School of Software Engeering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import ListEx.
Require Import Monad.

Require Import Params.
Require Import Nand.
Require Import Data.
Require Import Dftl0.

Open Scope list_scope.

Definition nand_write_command : Set := (nat * nat  * data) %type.

(* Test NAND *)
Fixpoint nand_write_batch (c: chip) (wl : list nand_write_command)
  : option chip :=
  match wl with
    | nil => ret c
    | cons wr wl' =>
      let (pn, d) := wr in
      let (b,off) := pn in
      do c' <-- nand_write_page c b off d None;
      nand_write_batch c' wl'
  end.

Compute (
  let wl := (0,0,(metabyte (c_1::c_6::nil) ) ) :: nil in
  do c0 <-- Some nand_init;
  do c <-- nand_write_batch c0 wl;
  ret c).

Compute (
  let wl := (0,0,(metabyte (c_1::c_6::nil) )) :: (0,1,(metabyte (c_1::c_6::nil) )) :: nil in
  do c0 <-- Some nand_init;
  do c <-- nand_write_batch c0 wl;
  ret c).

Compute (
  let wl := (0,0,(metabyte (c_1::c_6::nil) )) :: (0,1,(metabyte (c_1::c_6::nil) )) :: nil in
  do c0 <-- Some nand_init;
  do c <-- nand_write_batch c0 wl;
  do c'<-- nand_erase_block c 0;
  ret c').

(************************************************************************)
(* -------------------------------------------------------------------- *)
(* -------------------------------------------------------------------- *)
(* Test DFTL *)

Definition ftl_write_command : Set := (nat  * bytelist) % type.

Fixpoint ftl_write_batch (c: chip) (f: FTL) (wl : list ftl_write_command)
  : option (chip * FTL) :=
  match wl with
    | nil => ret (c, f)
    | cons wr wl' =>
      let (lpn, d) := wr in
      do [c', f'] <-- FTL_write c f lpn (metabyte d);
      ftl_write_batch c' f' wl'
  end.

Fixpoint ftl_write_repeat (c: chip) (f: FTL) (wl : list ftl_write_command) (num:nat)
  : option (chip * FTL) :=
  match num with
   | O => ret (c, f)
   | S i => do [c',f'] <-- ftl_write_batch c f wl;
            ftl_write_repeat c' f' wl i
  end.

Definition ftl_read_command : Set := list nat.

Fixpoint ftl_read_batch (c: chip) (f: FTL) (rl:ftl_read_command)
  : option (chip * FTL) :=
  match rl with
    | nil => ret (c, f)
    | cons lpn rl' =>
      do [d,cf] <-- FTL_read c f lpn;
      do [c',f'] <-- Some cf;
      ftl_read_batch c' f' rl'
  end.

Fixpoint ftl_read_repeat (c: chip) (f: FTL) (rl : ftl_read_command) (num:nat)
  : option (chip * FTL) :=
  match num with
   | O => ret (c, f)
   | S i => do [c',f'] <-- ftl_read_batch c f rl;
            ftl_read_repeat c' f' rl i
  end.

Let c0 := nand_init.

(*
Write and read the lpn:0
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: nil in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_batch c0 f0 wl;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  ret (d,(c', f'))).

(*
Write and read the lpn:0,reapt 16 times
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: nil in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 16;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  ret (d,(c', f'))).

(*
Write and read the lpn:0,reapt 17 times
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: nil in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 17;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  ret (d,(c', f'))).

(*
Write and read the lpn:0,reapt random(61) times
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: nil in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 61;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  ret (d,(c', f') ) ).

(***********************************************************)

(*
write the sequence 16(0-15) different place
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_5:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_6:: nil))::nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 1;
  do [d,cf] <-- FTL_read c f 5;
  do [c',f'] <-- Some cf;
  ret (d,(c', f') ) ).

(*
write the squence 17(0-16) different place,and repeat 6 times
*)
Compute (
  let wl := (0,(c_1::c_2:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_6:: nil))::(16,(c_1::c_6:: nil))::nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 6;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  ret (d,(c', f') ) ).

(*
write the squence 17(0-16) different place,and repeat 6 times and more(2)
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_2:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_6:: nil))::(16,(c_1::c_6:: nil))::nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 6;
  do wl' <-- Some ((0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil)) ::nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 1;
  do [d,cf] <-- FTL_read c' f' 10;
  do [c'',f''] <-- Some cf;
  ret (d,(c'', f'') ) ).

(*
write the squence 17(0-16) different place and repeat 4 times.then read 12 and 1.
*)

Compute (
  let wl := (0,(c_1::c_0:: nil)) :: (1,(c_1::c_2:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_1:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_6:: nil))::
            (66,(c_1::c_6:: nil))::nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 4;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  do [d1,cf'] <-- FTL_read c' f' 12;
  do [c'',f''] <-- Some cf';
  do [d2,cf''] <-- FTL_read c'' f'' 1;
  do [c''',f'''] <-- Some cf'';
  ret (d,(d1,(d2,(c''', f''') ) ) ) ).

(*
write the squence 17(0-16) different place and repeat 4 times.then read 12 and 1,then go on write and 2 ,compare the 2 before and after write.*)

Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_6:: nil))::
            (66,(c_1::c_6:: nil))::nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  do [d1,cf'] <-- FTL_read c' f' 12;
  do [c'',f''] <-- Some cf';
  do [d2,cf''] <-- FTL_read c'' f'' 2;
  do [c''',f'''] <-- Some cf'';
  do wl' <-- Some ((2,(c_1::c_3::nil))::nil);
  do [c4,f4] <-- ftl_write_repeat c''' f''' wl' 1;
  do [d3,cf'''] <-- FTL_read c4 f4 2;
  do [c5,f5] <-- Some cf''';
  ret (d2,(d3,(c5, f5)))).

(*
write the squence 17(0-16) different place and repeat 4 times.then read 0,12 and 1,then go on write and 0 ,compare the 0 before and after write.
*)

Compute (
  let wl := (0,(c_1::c_1:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_6:: nil))::
            (66,(c_1::c_6:: nil))::nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 4;
  do [d,cf] <-- FTL_read c f 0;
  do [c',f'] <-- Some cf;
  do [d1,cf'] <-- FTL_read c' f' 12;
  do [c'',f''] <-- Some cf';
  do [d2,cf''] <-- FTL_read c'' f'' 1;
  do [c''',f'''] <-- Some cf'';
  do wl' <-- Some ((0,(c_1::c_3::nil))::nil);
  do [c4,f4] <-- ftl_write_repeat c''' f''' wl' 1;
  do [d3,cf'''] <-- FTL_read c4 f4 0;
  do [c5,f5] <-- Some cf''';
  ret (d,(d3,(c5, f5)))).

(*
The cmt have empty place,So the LRU insert the cmt in the fist empty,This case is for test the cmt.
*)

Compute (
  do f0 <-- ftl_init;
  do data <-- Some (metabyte (cons c_2 (cons c_b  nil) ) );
  do [c',f'] <-- FTL_write c0 f0 0 data;
  do [c'',f''] <-- FTL_write c' f' 15 data;
  do [d,cf] <-- FTL_read c'' f'' 0;
  do [c''',f'''] <-- Some cf;
  ret (c''',f''')).

(*
Write the length about two length of cmt,then read the 15 and 16
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 3;
  do [d1,cf] <-- FTL_read c' f' 15;
  do [c'',f''] <-- Some cf;
  do [d2,cf'] <-- FTL_read c'' f'' 16;
  do [c''',f'''] <-- Some cf';
  ret (d1,(d2,(c''',f''')))).

(*
Write the length about two length of cmt,then run a read list,and then read 28.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_5:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_6:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_2:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 3;
  do rl <-- Some (15::14::13::12::13::11::10::9::8::7::6::5::4::3::2::1::0::nil);
  do [c'',f''] <-- ftl_read_repeat c' f' rl 2;
  do [d,cf'] <-- FTL_read c'' f'' 28;
  do [c''',f'''] <-- Some cf';
  ret(d,(c''',f'''))).

(*
Write the length about two length of cmt,then run a read list,and then read 28.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_5:: nil)):: (16,(c_1::c_5:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some ((17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_2:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            (32,(c_1::c_6::nil))::nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 3;
  do [c'', f''] <-- ftl_write_repeat c' f' wl 2;
  do rl <-- Some (15::14::13::12::11::10::9::8::7::6::5::4::3::2::1::0::nil);
  do [c''',f'''] <-- ftl_read_repeat c'' f'' rl 2;
  do [d,cf'] <-- FTL_read c''' f''' 28;
  do [c4,f4] <-- Some cf';
  do [c5,f5] <-- ftl_write_repeat c4 f4 ((0,(c_1::c_1::nil))::nil) 1;
  do rl' <-- Some (16::15::14::13::12::11::10::9::8::7::6::5::4::3::2::1::nil);
  do [c6,f6] <-- ftl_read_repeat c5 f5 rl' 1;
  do [c7,f7] <-- ftl_read_repeat c6 f6 (0::nil) 1;
  ret (d,(c7,f7))).

(*
Write the length about two length of cmt,then run a read list(15-0).
The right answer is return None.
Attention:I don't write the lpn 1.
*)

Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (0,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_5:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_6:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 1;
  do rl <-- Some (15::14::13::12::11::10::9::8::7::6::5::4::3::2::1::0::nil);
  do [c'',f''] <-- ftl_read_repeat c' f' rl 2;
  ret (c'',f'')).

(*
Ftl_write, remove the head of cmt which the head one is clean.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 2;
  do rl <-- Some (15::14::13::12::11::10::9::8::7::6::5::4::3::2::1::0::nil);
  do [c'',f''] <-- ftl_read_repeat c' f' rl 1;
  do [c''',f'''] <-- FTL_write c'' f'' 20 (metabyte (c_1::c_6::nil) );
  ret (c''',f''')).

(*
Ftl_write, remove the head of cmt which the head one is dirty and which the gtd_loc is empty.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 1;
  ret (c',f')).

(*
Ftl_write, remove the head of cmt which the head one is dirty and which the gtd_loc is not empty,and insert the translation.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil))::(17,(c_1::c_2::nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 1;
  ret (c',f')).

(*
Ftl_write, remove the head of cmt which the head one is dirty and which the gtd_loc is not empty,and update the translation in the trans.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 1;
  do [c'',f''] <-- ftl_write_repeat c' f' wl 1;
  do wl'' <-- Some  ((16,(c_1::c_2:: nil))::nil);
  do [c''',f'''] <-- ftl_write_repeat c'' f'' wl'' 1;
  ret (c''',f''')).

(*
Ftl_write,and the lpn is in the cmt and remove the clean one(the head one).
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 2;
  do rl <-- Some (15::14::13::12::11::10::9::8::7::6::5::4::3::2::1::0::nil);
  do [c'',f''] <-- ftl_read_repeat c' f' rl 1;
  do wl'' <-- Some  ((10,(c_1::c_2:: nil))::(16,(c_1::c_2:: nil))::nil);
  do [c''',f'''] <-- ftl_write_repeat c'' f'' wl'' 1;
  ret (c''',f''')).
(* The above is FLT_WRITE testing,the FTL_WRITE testing is over *)

(* FTL_read: ftl_read the lpn,and the lpn in the cmt and the cmt have empty place *)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do rl <-- Some (3::nil);
  do [c',f'] <-- ftl_read_repeat c f rl 1;
  ret (c',f')).

(* FTL_read: ftl_read the lpn,and the lpn in the cmt and the cmt don't have empty place *)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do rl <-- Some (3::nil);
  do [c',f'] <-- ftl_read_repeat c f rl 1;
  ret (c',f')).

(*
Ftl_read,and the lpn is not in the cmt and remove the clean one (the head one).
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 2;
  do wl' <-- Some  ((16,(c_1::c_2:: nil)) :: (17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            nil);
  do [c',f'] <-- ftl_write_repeat c f wl' 2;
  do rl <-- Some (15::14::13::12::11::10::9::8::7::6::5::4::3::2::1::0::nil);
  do [c'',f''] <-- ftl_read_repeat c' f' rl 1;
  do wl'' <-- Some  ((16,(c_1::c_2:: nil))::nil);
  do [c''',f'''] <-- ftl_write_repeat c'' f'' wl'' 1;
  ret (c''',f''')).

(*
Ftl_read,and the lpn is not in the cmt and remove the dirty one (the head one),the remove one don't have the gtd_loc(in this case is lpn:8).
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            (16,(c_1::c_2:: nil)) ::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 1;
  do rl <-- Some (0::1::2::3::4::5::6::7::nil);
  do [c'',f''] <-- ftl_read_repeat c f rl 1;
  ret (c'',f'')).

(*
Ftl_read,and the lpn is not in the cmt and remove the dirty one (the head one),and have the gtd_loc.
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            (16,(c_1::c_2::nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 1;
  do rl <-- Some (0::1::2::3::4::5::6::7::8::9::nil);
  do [c'',f''] <-- ftl_read_repeat c f rl 1;
  ret (c'',f'')).

(*
The synthetical testing
*)
Compute (
  let wl := (0,(c_1::c_6:: nil)) :: (1,(c_1::c_6:: nil))::(2,(c_1::c_6:: nil))::(3,(c_1::c_6:: nil))::
            (4,(c_1::c_6:: nil)) :: (5,(c_1::c_6:: nil))::(6,(c_1::c_6:: nil))::(7,(c_1::c_6:: nil))::
            (8,(c_1::c_6:: nil)) :: (9,(c_1::c_6:: nil))::(10,(c_1::c_6:: nil))::(11,(c_1::c_6:: nil))::
            (12,(c_1::c_6:: nil)) :: (13,(c_1::c_6:: nil))::(14,(c_1::c_6:: nil))::(15,(c_1::c_1:: nil))::
            (16,(c_1::c_2::nil))::
            nil
  in
  do f0 <-- ftl_init;
  do [c, f] <-- ftl_write_repeat c0 f0 wl 1;
  do rl <-- Some (0::1::2::3::4::5::6::7::8::9::nil);
  do [c'',f''] <-- ftl_read_repeat c f rl 1;
  do [c''',f'''] <-- FTL_write c'' f'' 8 (metabyte (c_1::c_6::nil) );
  do [c4,f4] <-- FTL_write c''' f''' 8 (metabyte (c_1::c_6::nil) );
  do wl' <-- Some  ((17,(c_1::c_6:: nil))::(18,(c_1::c_6:: nil))::(19,(c_1::c_6:: nil))::
            (20,(c_1::c_6:: nil)) :: (21,(c_1::c_6:: nil))::(22,(c_1::c_6:: nil))::(23,(c_1::c_6:: nil))::
            (24,(c_1::c_6:: nil)) :: (25,(c_1::c_6:: nil))::(26,(c_1::c_6:: nil))::(27,(c_1::c_6:: nil))::
            (28,(c_1::c_6:: nil)) :: (29,(c_1::c_6:: nil))::(30,(c_1::c_6:: nil))::(31,(c_1::c_6:: nil))::
            (32,(c_1::c_6:: nil))::nil);

  do [c5, f5] <-- ftl_write_repeat c4 f4 wl' 1;
  ret (c5,f5)).

(*---------------------------------------------------*)

(*---------------------------------------------------*)
(* The White box testing *)


Require Import Util LengthEq IL RenamedApart LabelsDefined OptionR.
Require Import Keep Drop Take Restrict SetOperations OUnion.

Set Implicit Arguments.

Definition ogetdef X (d:X) (o:option X) :=
  match o with
  | Some x => x
  | None => d
  end.

Definition addAdd s := (fun (DL:set var) AP => mdo t <- AP; Some ((s ∩ DL) ∪ t)).
Definition addAdd' s := (fun (DL:set var) AP => ((s ∩ DL) ∪ oget AP)).

Lemma ifSndR_zip_addAdd s DL A B
 : length DL = length A
   -> PIR2 (ifSndR Subset) A B
   -> PIR2 (ifSndR Subset) A (zip (addAdd s) DL B).
Proof.
  intros. eapply length_length_eq in H.
  general induction H; inv H0; simpl.
  - constructor.
  - econstructor; eauto.
    + inv pf; simpl; econstructor.
      * cset_tac; intuition.
Qed.

Lemma ifFstR_addAdds s A B
: PIR2 (ifFstR Subset) B  A
  -> PIR2 (ifFstR Subset) (zip (addAdd s) A B) A.
Proof.
  intros.
  general induction H; simpl.
  + constructor.
  + econstructor; eauto.
    - inv pf; simpl; econstructor.
      * cset_tac; intuition.
Qed.

Lemma PIR2_addAdds s DL b
: length DL = length b
  -> PIR2 ≼ b (zip (addAdd s) DL b).
Proof.
  intros. eapply length_length_eq in H.
  general induction H.
  - econstructor.
  - simpl. econstructor.
    + destruct y.
      * econstructor. cset_tac; intuition.
      * constructor.
    + eauto.
Qed.

Lemma ifFstR_addAdds2 s A B C
  : PIR2 Subset A C
  -> PIR2 (ifFstR Subset) B C
  -> PIR2 (ifFstR Subset) (zip (addAdd s) A B) C.
Proof.
  intros R1 R2.
  general induction R1; inv R2; simpl; eauto using @PIR2.
  + econstructor; eauto.
    - inv pf0; simpl; econstructor.
      * cset_tac; intuition.
Qed.

Lemma PIR2_addAdds3 s DL b c
  : length DL = length b
    -> PIR2 ≼ b c
    -> PIR2 ≼ b (zip (addAdd s) DL c).
Proof.
  intros. eapply length_length_eq in H.
  general induction H; invt PIR2.
  - econstructor.
  - simpl. econstructor.
    + destruct y,y0; simpl; try now econstructor.
      * econstructor. inv pf. cset_tac; intuition.
      * inv pf.
    + eauto.
Qed.

Lemma PIR2_addAdds' s DL b c
  : length DL = length b
    -> PIR2 ≼ b c
    -> PIR2 ≼ b (Some ⊝ zip (addAdd' s) DL c).
Proof.
  intros. eapply length_length_eq in H.
  general induction H; invt PIR2.
  - econstructor.
  - simpl. econstructor.
    + destruct y,y0; simpl; try now econstructor.
      * econstructor. inv pf. unfold addAdd'; simpl.
        clear - H3; cset_tac.
    + eauto.
Qed.


Require Import VST.floyd.proofauto.
Require Import pile.
#[export] Instance PileCompSpecs : compspecs. make_compspecs prog. Defined.
Require Import simple_spec_stdlib.
Require Import PileModel.

Definition tlist := Tstruct _list noattr.
Definition tpile := Tstruct _pile noattr.

Fixpoint listrep (sigma: list Z) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
       !! (0 <= h <=  Int.max_signed) &&
      data_at Ews tlist (Vint (Int.repr h), y) x
     * malloc_token Ews tlist x
     * listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil) /\ Forall (Z.le 0) sigma).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros.
  entailer!; intuition.
Intros y. entailer!.
split.
split; intro. subst p. destruct H0; contradiction. discriminate.
constructor; auto. lia.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; entailer!; auto with valid_pointer.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

Opaque listrep.

Definition pilerep (sigma: list Z) (p: val) : mpred :=
  EX x:val, data_at Ews tpile x p * listrep sigma x.

Lemma pilerep_local_facts: forall sigma p,
    pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros. unfold pilerep. Intros x. entailer!.
Qed.

Lemma pilerep_valid_pointer: forall sigma p,
    pilerep sigma p |-- valid_pointer p.
Proof.
intros. unfold pilerep. Intros x. entailer!.
Qed.

Definition pile_freeable (p: val) : mpred :=
            malloc_token Ews tpile p.

#[export] Hint Resolve pilerep_local_facts : saturate_local.
#[export] Hint Resolve pilerep_valid_pointer : valid_pointer.

Local Open Scope assert.

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS() GLOBALS(gv) SEP(mem_mgr gv)
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(pilerep nil p; pile_freeable p; mem_mgr gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(pilerep sigma p; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep (n::sigma) p; mem_mgr gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS (p) GLOBALS ()
    SEP (pilerep sigma p)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) (GLOBALS (gv)
    SEP(pilerep sigma p; pile_freeable p; mem_mgr gv))
 POST[ tvoid ]
     PROP() LOCAL() SEP(mem_mgr gv).

Definition PileASI:funspecs := [ Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].