(** * Mutable map whose lookup operation provides a default value.*)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From ExtLib Require Import
     Core.RelDec.

From ExtLib.Structures Require
     Functor Monoid Maps.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.CategoryKleisli
     Basics.Monad
     Indexed.Function
     Indexed.Sum
     Core.ITreeDefinition
     Core.Subevent
     Interp.Interp
     Interp.Handler
     Events.State.

Import ITree.Basics.Basics.Monads.
(* end hide *)

Section Map.

  Variables (K V : Type).

  Variant mapE (d:V) : Type -> Type :=
  | Insert : K -> V -> mapE d unit
  | LookupDef : K -> mapE d V
  | Remove : K -> mapE d unit
  .

  Arguments Insert {d}.
  Arguments LookupDef {d}.
  Arguments Remove {d}.

  Definition insert {E d} `{(mapE d) -< E} : K -> V -> itree E unit := embed Insert.
  Definition lookup_def {E d} `{(mapE d) -< E} : K -> itree E V := embed LookupDef.
  Definition remove {E d} `{(mapE d) -< E} : K -> itree E unit := embed Remove.

  Import Structures.Maps.

  Context {map : Type}.
  Context {M : Map K V map}.

  Definition lookup_default {K V} `{Map K V} k d m :=
    match Maps.lookup k m with
    | Some v' => v'
    | None => d
    end.

  Definition handle_map {E d} : mapE d ~> stateT map (itree E) :=
    fun _ e env =>
      match e with
      | Insert k v => Ret (Maps.add k v env, tt)
      | LookupDef k => Ret (env, lookup_default k d env)
      | Remove k => Ret (Maps.remove k env, tt)
      end.

  (* SAZ: I think that all of these [run_foo] functions should be renamed
     [interp_foo].  That would be more consistent with the idea that
     we define semantics by nested interpretation.  Also, it seems a bit
     strange to define [interp_map] in terms of [interp_state].
  *)
  Definition interp_map {E d} : itree (mapE d +' E) ~> stateT map (itree E) :=
    interp_state (case_ (C := IFun) handle_map pure_state).

  (* The appropriate notation of the equivalence on the state associated with
     the MapDefault effects.  Two maps are equivalent if they yield the same
     answers under [lookup_default] *)
  Definition eq_map (d:V) (m1 m2 : map) : Prop :=
    forall k, lookup_default k d m1 = lookup_default k d m2.

End Map.

Arguments insert {K V E d _}.
Arguments lookup_def {K V E d _}.
Arguments remove {K V E d _}.
Arguments interp_map {K V map M _ _ } [T].
Arguments eq_map {K V map M d}.


From Coq Require Import Extraction.
Require Import TM.Code.ProgrammingTools.
Require Import TM.LM.HaltingProblem.

(* The number of symbols in the alphabet *)
(* You must change the [Retract] instances in [TM.Code.Code] to [Defined.] *)
Eval vm_compute in length (FinTypes.elem (finType_CS sigStep)).

Definition Loop_states : finType := TM.states (projT1 Loop).
Definition Loop_states_card : nat := length (FinTypes.elem Loop_states).

Extraction Language Haskell.
Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ].
Extract Inductive list => "([])" [ "[]" "(:)" ].
Extract Inductive prod => "(,)" [ "(,)" ].
Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ] "(\fO fS n -> if n==0 then fO () else fS (pred n))".

Recursive Extraction Loop_states_card.

(* Save the output to a "countStates.hs" file and make the following modifications: *)
(* Instead of [import qualid Prelude] -> [import Prelude hiding (seq, return, Left, Right, repeat, map, elem, concat, length, const, null, id, lookup)] *)
(* Add [main = print (loop_states_card)] to the end of the file *)
(* Compile and execute with [ghc -dynamic countStates.hs && ./countStates] *)
(* Should run in two-three minutes *)


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 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.                          *)
(*                                                                        *)
(**************************************************************************)

From compcert Require Import Coqlib Integers AST Values Memory Ctypes.
From compcert.arm Require Import Archi.
From Coq Require Import Lia ZArith.

Open Scope Z_scope.

Lemma size_chunk_gt_zero:
  forall chunk, 0 < size_chunk chunk.
Proof.
  intros.
  unfold size_chunk.
  destruct chunk; try lia.
Qed.

Lemma size_chunk_int_range:
  forall chunk, 0 <= size_chunk chunk <= Int.max_unsigned.
Proof.
  unfold size_chunk; intros.
  change Int.max_unsigned with 4294967295.
  split; destruct chunk; try lia.
Qed.

Lemma Int64_unsigned_ge_0:
  forall v, 0 <= Int64.unsigned v.
Proof.
  intro v.
  assert (Hrange: 0 <= Int64.unsigned v <= Int64.max_unsigned). {
    apply Int64.unsigned_range_2.
  }
  destruct Hrange as [Ha Hb]; assumption.
Qed.

Lemma Int_unsigned_ge_0:
  forall v, 0 <= Int.unsigned v.
Proof.
  intro v.
  assert (Hrange: 0 <= Int.unsigned v <= Int.max_unsigned). {
    apply Int.unsigned_range_2.
  }
  destruct Hrange as [Ha Hb]; assumption.
Qed.

Lemma Int_repr_zero:
  forall v, 0<=v<=Int.max_unsigned -> Int.unsigned (Int.repr v) = Int.unsigned (Int.zero) -> v = 0.
Proof.
  intros.
  rewrite (Int.unsigned_repr v H) in H0.
  rewrite Int.unsigned_zero in H0.
  assumption.
Qed.

Lemma Ptrofs_of_int_unsigned:
  forall v, Ptrofs.unsigned (Ptrofs.of_int v) = Int.unsigned v.
Proof.
  intros.
  assert (H1: Ptrofs.agree32 (Ptrofs.of_int v) v). { apply Ptrofs.agree32_of_int. reflexivity. }
  rewrite H1; reflexivity.
Qed.

Lemma ptrofs_unsigned_ge_0:
  forall v, 0 <= Ptrofs.unsigned v.
Proof.
  intro v.
  assert (Hrange: 0 <= Ptrofs.unsigned v <= Ptrofs.max_unsigned). {
    apply Ptrofs.unsigned_range_2.
  }
  destruct Hrange as [Ha Hb]; assumption.
Qed.

Lemma Cle_Zle_iff:
  forall lo ofs,
    negb (Int.ltu ofs lo) = true <-> Int.unsigned lo <= Int.unsigned ofs.
Proof.
  split; intros.
  - rewrite negb_true_iff in H.
    unfold Int.ltu in H.
    destruct (zlt _ _) in H; try inversion H.
    lia.
  - rewrite negb_true_iff.
    unfold Int.ltu.
    apply zlt_false.
    lia.
Qed.

Lemma Clt_Zlt_iff:
  forall ofs hi,
    Int.ltu ofs hi = true <->
      Int.unsigned ofs < Int.unsigned hi.
Proof.
  split; intros.
  - unfold Int.ltu in H.
    destruct (zlt _ _) in H; try inversion H.
    lia.
  - unfold Int.ltu.
    apply zlt_true.
    assumption.
Qed.

Lemma Int64_unsigned_size_chunk_ge_0:
  forall ofs chunk,
    0 <= Int64.unsigned ofs + size_chunk chunk.
Proof.
  intros.
  assert (Hchunk_lo: 0 < size_chunk chunk). apply size_chunk_gt_zero.
  assert (Hofs_lo: 0<= Int64.unsigned ofs). apply Int64_unsigned_ge_0.
  unfold size_chunk; destruct chunk; rewrite Z.add_comm; try lia.
Qed.

Lemma Int_unsigned_size_chunk_ge_0:
  forall ofs chunk,
    0 <= Int.unsigned ofs + size_chunk chunk.
Proof.
  intros.
  assert (Hchunk_lo: 0 < size_chunk chunk). apply size_chunk_gt_zero.
  assert (Hofs_lo: 0<= Int.unsigned ofs). apply Int_unsigned_ge_0.
  unfold size_chunk; destruct chunk; rewrite Z.add_comm; try lia.
Qed.

Lemma Int64_unsigned_ofs_size_chunk_ge_0:
  forall ofs chunk,
    Int64.unsigned ofs < Int64.unsigned ofs + size_chunk chunk.
Proof.
  intros.
  assert (Hchunk_lo: 0 < size_chunk chunk). apply size_chunk_gt_zero.
  assert (Hofs_lo: 0<= Int64.unsigned ofs). apply Int64_unsigned_ge_0.
  lia.
Qed.

Lemma Int_unsigned_ofs_size_chunk_ge_0:
  forall ofs chunk,
    Int.unsigned ofs < Int.unsigned ofs + size_chunk chunk.
Proof.
  intros.
  assert (Hchunk_lo: 0 < size_chunk chunk). apply size_chunk_gt_zero.
  assert (Hofs_lo: 0<= Int.unsigned ofs). apply Int_unsigned_ge_0.
  lia.
Qed.

(**r Here is a problem, 'ofs+size_chunk':Z may be greater than Int64.mex_unsigned!
     While the 'Vlong (Int64.repr (ofs+size_chunk))': Val is always within the range!
 *)

Lemma hi_ofs_max_unsigned:
  forall ofs chunk,
    negb
         (Int.ltu (Int.repr (Int.max_unsigned-(size_chunk chunk))) ofs) = true ->
      0 <= Int.unsigned ofs + size_chunk chunk <= Int.max_unsigned.
Proof.
  intros ofs chunk Hcmp.
  change Int.max_unsigned with 4294967295 in *.
  remember ((Int.ltu (Int.repr (4294967295 - size_chunk chunk))) ofs) as k eqn: Hk.
  rewrite Hk in Hcmp; clear Hk.
  rewrite negb_true_iff in Hcmp.
  unfold Int.ltu in Hcmp.
  destruct (zlt _ _) in Hcmp.
  - inversion Hcmp.
  - clear Hcmp.
    assert (Heq_max: 0 <= 4294967295 - size_chunk chunk <= 4294967295). {
      unfold size_chunk; destruct chunk; try lia.
    }
    rewrite (Int.unsigned_repr _ Heq_max) in g.
    split.
    apply Int_unsigned_size_chunk_ge_0.
    lia.
Qed.

Lemma Clt_implies_Zlt_add:
  forall ofs chunk hi, Int.ltu (Int.add ofs (Int.repr (size_chunk chunk))) hi = true ->
    0 <= (Int.unsigned ofs + size_chunk chunk) <= Int.max_unsigned ->
      0<= Int.unsigned ofs + (size_chunk chunk) < Int.unsigned hi.
Proof.
  intros.
  split.
  apply Int_unsigned_size_chunk_ge_0.
  unfold Int.ltu, Int.add in H.
  destruct (zlt _ _) in H; try inversion H.
  assert (H5: Int.unsigned (Int.repr (size_chunk chunk)) = size_chunk chunk). { apply Int.unsigned_repr; apply size_chunk_int_range; assumption. }
  rewrite H5 in l.
  assert (H6: Int.unsigned (Int.repr (Int.unsigned ofs + size_chunk chunk)) =
              (Int.unsigned ofs + size_chunk chunk)). { apply Int.unsigned_repr; assumption. }
  rewrite H6 in l; assumption.
Qed.

Close Scope Z_scope.