diff --git a/proof-libs/coq/ssprove/.gitignore b/proof-libs/coq/ssprove/.gitignore new file mode 100644 index 000000000..a16eba914 --- /dev/null +++ b/proof-libs/coq/ssprove/.gitignore @@ -0,0 +1,8 @@ +*.vo* +*.aux +*.glob +*.cache +.Makefile.d +Makefile +Makefile.conf +src/_temp/ diff --git a/proof-libs/coq/ssprove/README.md b/proof-libs/coq/ssprove/README.md new file mode 100644 index 000000000..139ed6b0d --- /dev/null +++ b/proof-libs/coq/ssprove/README.md @@ -0,0 +1,30 @@ +## Dependencies + +The coq libraries uses `ssprove/jasmin` for machine signed and unsigned integer modulo arithmetic, and `coqword` for finite field arithmetic on prime modulus (to support hacspec's `nat_mod p` type). +This requires the following repository: + +``` +opam repo add coq-released https://coq.inria.fr/opam/released --all-switches +``` + +Then one can install the dependencies through `opam` (assuming you have coq installed through opam) + +``` +opam update +opam install conf-ppl.1 -y +opam install coq-mathcomp-word.2.0 -y +opam pin jasmin https://github.com/SSProve/ssprove.git#3d40bc89 -y +opam pin ssprove https://github.com/SSProve/ssprove.git#bead4e76acbb69b3ecf077cece56cd3fbde501e3 -y +opam upgrade -y +``` +the development uses the Jasmin branch of SSProve, meaning one might need to install these from source. + +## Docker + +There is a docker container with the dependencies installed (Coq / Rust) at `ghcr.io/cmester0/hacspec_ssprove:8.15.2`. + +## Compiling the coq files + +In folder `/coq_ssprove`, type `make`. This compiles the coq libraries and the compiled examples, as defined in `_CoqProject`. + +If you want to add a new example to `_CoqProject`, such that it is compiled through `make`, you should run `coq_makefile -f _CoqProject -o Makefile` in `/coq` to update the makefile. diff --git a/proof-libs/coq/ssprove/_CoqProject b/proof-libs/coq/ssprove/_CoqProject new file mode 100644 index 000000000..b53f33579 --- /dev/null +++ b/proof-libs/coq/ssprove/_CoqProject @@ -0,0 +1,20 @@ +-R src/ Hacspec +-arg -w +-arg all + +src/Hacspec_Lib_Comparable.v +src/LocationUtility.v +src/ChoiceEquality.v +src/Hacspec_Lib_Pre.v +src/Hacspec_Lib.v + +# src/Hacspec_Aes_Jazz.v +# src/Hacspec_Xor.v + +# src/Hacspec_Aes.v +# src/Hacspec_Bls12_381.v +# src/Hacspec_Poly1305.v +# src/Hacspec_Curve25519.v +# src/Hacspec_Gf128.v +# src/Hacspec_P256.v +# src/Hacspec_Sha256.v diff --git a/proof-libs/coq/ssprove/coq-hacspec-ssprove.opam b/proof-libs/coq/ssprove/coq-hacspec-ssprove.opam new file mode 100644 index 000000000..28602eb7f --- /dev/null +++ b/proof-libs/coq/ssprove/coq-hacspec-ssprove.opam @@ -0,0 +1,21 @@ +opam-version: "2.0" +name: "coq-hacspec-ssprove" +version: "dev" +synopsis: "Hacspec coq library" +maintainer: "Lasse Letager Hansen " +authors: ["Lasse Letager Hansen "] +homepage: "https://github.com/hacspec/hacspec" +bug-reports: "https://github.com/hacspec/hacspec/issues" +depends: [ + "ssprove" {= "dev"} + "jasmin" {= "dev"} + "coq" {>= "8.15.2"} +] +build: [ + ["coq_makefile" "-f" "_CoqProject" "-o" "Makefile"] + [make "clean"] + [make "-j%{jobs}%"] +] +install: [ + [make "install"] +] diff --git a/proof-libs/coq/ssprove/docker_build/Dockerfile b/proof-libs/coq/ssprove/docker_build/Dockerfile new file mode 100644 index 000000000..043e525c0 --- /dev/null +++ b/proof-libs/coq/ssprove/docker_build/Dockerfile @@ -0,0 +1,28 @@ +FROM coqorg/coq:8.15.2-ocaml-4.14.0-flambda +RUN curl https://sh.rustup.rs -sSf | sh -s -- -y +ENV PATH $HOME/.cargo/bin:$PATH +RUN rustup update +RUN rustup toolchain install nightly-2022-07-04 +RUN rustup component add --toolchain nightly-2022-07-04 rustc-dev llvm-tools-preview rust-analysis rust-src +RUN rustc --version +RUN cargo --version +RUN sudo apt-get update +RUN sudo apt-get install libppl-dev -y +RUN sudo apt-get install libmpfr-dev -y +RUN opam update +RUN opam switch create 4.12.0 +RUN eval $(opam env --switch=4.12.0) +RUN opam config list; opam repo list; opam list +RUN opam repo add coq-released https://coq.inria.fr/opam/released --all-switches +RUN opam update +RUN opam pin coq 8.15.2 -y +RUN eval $(opam env) +RUN git clone https://github.com/jasmin-lang/jasmin.git +RUN git clone https://github.com/SSProve/ssprove.git +RUN cd jasmin && git checkout 3d40bc89 && cd .. +RUN opam install -y --verbose ./jasmin/. --working-dir +RUN eval $(opam env) +RUN cd ssprove && git checkout jasmin && cd .. +RUN opam upgrade -y +RUN (opam install -y --verbose ./ssprove/ssprove.opam --working-dir) || echo "failed" +RUN cd ssprove && make -j7 && opam install -y --verbose ./ssprove.opam --working-dir --assume-built diff --git a/proof-libs/coq/ssprove/src/ChoiceEquality.v b/proof-libs/coq/ssprove/src/ChoiceEquality.v new file mode 100644 index 000000000..17214c65c --- /dev/null +++ b/proof-libs/coq/ssprove/src/ChoiceEquality.v @@ -0,0 +1,1682 @@ +From Coq Require Import ZArith List. +From Crypt Require Import choice_type Package. +Import PackageNotation. +From Crypt Require Import pkg_interpreter. +From extructures Require Import ord fset fmap. +Require Import Hacspec_Lib_Comparable. + +Require Import LocationUtility. +Require Import Coq.Logic.FunctionalExtensionality. + +Import RulesStateProb. +Import RulesStateProb.RSemanticNotation. +Open Scope rsemantic_scope. + +From Crypt Require Import choice_type Package Prelude. +From Crypt Require Import Axioms. (* proof_irrelevance *) +Import PackageNotation. +From extructures Require Import ord fset fmap. + +Import choice.Choice.Exports. + +Import List.ListNotations. + +(*** Ltac *) + +Ltac normalize_fset := + hnf ; + autounfold with * ; + change ((Ord.sort + (@tag_ordType choice_type_ordType + (fun _ : choice_type => nat_ordType)))) with + Location ; + try rewrite !fset_cons ; + try rewrite <- !fset0E ; + try rewrite !fsetU0 ; + try rewrite !fset0U ; + try rewrite !fset1E ; + (* try rewrite <- !fsetUA *) + repeat (match goal with + | |- context [?a :|: ?b :|: ?c] => + replace (a :|: b :|: c) with (a :|: (b :|: c)) by apply fsetUA + end + || match goal with + | |- context [?a :|: (?a :|: ?b)] => + rewrite (fsetUA a a b) ; rewrite (fsetUid a) + end + || match goal with + | |- context [?a :|: (?b :|: (?a :|: (?b :|: ?c)))] => + rewrite (fsetUA a b (a :|: (b :|: c))) ; + rewrite (fsetUA a b c) ; + rewrite (fsetUA (a :|: b) (a :|: b) c) ; + rewrite (fsetUid (a :|: b)) + end). + +Ltac solve_match := + (lazymatch (* match *) goal with + | |- context [ fsubset ?a (?a :|: _) ] => apply fsubsetUl + | |- context [ fsubset ?a (_ :|: ?a) ] => apply fsubsetUr + | |- context [ fsubset fset0 _ ] => apply fsub0set + | |- context [ fsubset ?a ?a ] => apply fsubsetxx + end). +(* || (progress (try apply fsubsetUl ; *) +(* try apply fsubsetUr ; *) +(* try apply fsub0set ; *) +(* try apply fsubsetxx)) *) + +Ltac split_fsubset_lhs := + repeat (rewrite is_true_split_and || rewrite fsubUset) ; + repeat (try rewrite andb_true_intro ; split). + +Ltac solve_single_fset_fsubset := + repeat (solve_match || apply fsubsetU ; rewrite is_true_split_or ; (left ; solve_match) || right). + +Ltac solve_is_true := + now normalize_fset ; + split_fsubset_lhs ; + solve_single_fset_fsubset. + +Ltac solve_in_fset := + match goal with + | [ |- context [ is_true (fsubset _ _) ] ] => solve_is_true + | [ |- context [ fsubset _ _ = true ] ] => solve_is_true + end. + +Ltac solve_fset_eq := + apply (ssrbool.elimT eqtype.eqP) ; + rewrite eqEfsubset ; + rewrite is_true_split_and ; split ; + solve_in_fset. + +Ltac fset_equality := + repeat + match goal with + | H : fsubset (?x :|: ?y) ?z = true |- _ => + rewrite fsubUset in H ; + apply andb_prop in H ; + destruct H + end ; + match goal with + | [ |- context [ @eq (fset_of _) _ _ ] ] => + solve_fset_eq + | [ |- context [ @eq Interface _ _ ] ] => + solve_fset_eq + | [ |- context [ @Logic.eq (fset_of _) _ _ ] ] => + solve_fset_eq + | [ |- context [ @Logic.eq Interface _ _ ] ] => + solve_fset_eq + end. + +Notation "prod_ce( a , b )" := ((a , b) : chProd _ _) : hacspec_scope. +Notation "prod_ce( a , b , .. , c )" := ((.. ((a , b) : chProd _ _) .. , c) : chProd _ _) : hacspec_scope. + +Definition lift_to_code {ce L I} (x : choice.Choice.sort ce) : code L I ce := + {code ret x}. + +Definition pre_to_post (P : precond) {A} : postcond A A := + fun '(a, h₀) '(b, h₁) => a = b /\ P (h₀ , h₁). +Definition pre_to_post_ret (P : precond) {A} v : postcond A A := + fun '(a, h₀) '(b, h₁) => (a = b /\ b = v) /\ P (h₀ , h₁). + +Definition true_precond : precond := fun _ => True. + +Theorem forget_precond {B} (x y : raw_code B) P Q : + ⊢ ⦃ true_precond ⦄ x ≈ y ⦃ Q ⦄ -> + ⊢ ⦃ P ⦄ x ≈ y ⦃ Q ⦄. +Proof. + intros. + now apply (rpre_weaken_rule _ _ _ H). +Qed. + +(* Module Both. *) +(* Definition code_eq_proof_statement L I (A : choice_type) (functional : A) (state : code L I A) := *) +(* ⊢ ⦃ true_precond ⦄ state ≈ ret (functional) *) +(* ⦃ pre_to_post_ret true_precond (functional) ⦄. *) + +(* Record mixin_of L I (A : choice_type) := Mixin { *) +(* functional : A ; *) +(* state : code L I A ; *) +(* _ : code_eq_proof_statement L I A functional state ; *) +(* }. *) + +(* Record class_of L I (A : choice_type) := *) +(* Class {Base : choice.Choice.class_of A; mixin: mixin_of L I A}. *) + +(* Structure both L I := *) +(* Pack {sort; _ : class_of L I sort}. *) +(* End Both. *) + +(* Class cfset := *) +(* { *) +(* L : list Location ; *) +(* is_sorted : is_true (path.sorted (@Ord.lt _) L) ; *) +(* is_unique : is_true (@seq.uniq loc_eqType L) *) +(* }. *) +(* Definition cfset_to_fset : cfset -> {fset Location} := fun x => @FSet.FSet loc_ordType _ (FSet.fset_subproof (@L x)). *) +(* Coercion cfset_to_fset : cfset >-> fset_of. *) + +(* Instance cfset0 : cfset := *) +(* {| L := [] ; is_sorted := ltac:(reflexivity) ; is_unique := ltac:(reflexivity) |}. *) + +(* Instance cfset1 (ℓ : Location) : cfset := *) +(* {| L := [ℓ] ; is_sorted := ltac:(reflexivity) ; is_unique := ltac:(reflexivity) |}. *) + +(* Require Import Hacspec_Lib_Comparable. *) +(* Program Fixpoint merge_undup (L1 L2 : list Location) {measure (length L1 + length L2)%nat} := *) +(* match L1 with *) +(* | [] => *) +(* L2 *) +(* | a :: xs => *) +(* match L2 with *) +(* | [] => a :: xs *) +(* | b :: ys => *) +(* if Ord.lt (* Hacspec_Lib_Comparable.leb *) a b *) +(* then a :: merge_undup xs (b :: ys) *) +(* else *) +(* if Ord.lt b a (* Hacspec_Lib_Comparable.leb *) *) +(* then b :: merge_undup (a :: xs) ys *) +(* else a :: merge_undup xs ys *) +(* end *) +(* end. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* simpl. *) +(* Lia.lia. *) +(* Qed. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* simpl. *) +(* Lia.lia. *) +(* Qed. *) +(* Fail Next Obligation. *) + +(* Program Instance cfsetU (x y : cfset) : cfset := *) +(* {| L := merge_undup (@L x) (@L y) ; |}. *) + +(* Program Instance cfsetU (x y : cfset) : cfset := *) +(* {| L := path.sort Ord.leq (@seq.undup loc_ordType (@L x ++ @L y)) ; |}. *) +(* Next Obligation. *) +(* intros. *) +(* apply FSet.fset_subproof. *) +(* Qed. *) +(* Next Obligation. *) +(* intros. *) +(* apply (@path.sorted_uniq loc_ordType Ord.lt ). *) +(* - apply Ord.lt_trans. *) +(* - unfold ssrbool.irreflexive. *) +(* intros. *) +(* apply Ord.ltxx. *) +(* - apply FSet.fset_subproof. *) +(* Qed. *) +(* Fail Next Obligation. *) + +From mathcomp Require Import ssrbool. + +Section Both. + + Context (L : {fset Location}). + Context (I : Interface). + Context (A : choice_type). + + Class raw_both := + { + is_pure : choice.Choice.sort A ; + is_state : raw_code A ; + }. + Arguments is_pure raw_both. + Arguments is_state raw_both. + + Inductive valid_both : + forall (b : raw_both), Prop := + | both_valid_ret : + forall x, valid_both {| is_pure := x ; is_state := ret x |} + | both_valid_putr_getr : + forall l k v, + l \in L -> + (forall v, valid_both (k v)) -> + valid_both + ({| is_pure := @is_pure (k v) ; + is_state := putr l v (getr l (fun x => @is_state (k x))) |}) + | both_valid_putr : + forall l v k, + l \in L -> + valid_both k -> + valid_both ({| is_pure := @is_pure k ; is_state := putr l v (@is_state k) |}). + + (* | valid_opr : *) + (* forall o x k, *) + (* o \in import -> *) + (* (forall v, valid_both (k v)) -> *) + (* valid_both ({| is_pure := k v ; opr o x k |}) *) + + (* | valid_sampler : *) + (* forall op k, *) + (* (forall v, valid_code (k v)) -> *) + (* valid_code (sampler op k) *) + + Class ValidBoth (p : raw_both) := + { is_valid_code : ValidCode L I (@is_state p) ; + is_valid_both : @valid_both p ; + }. + Arguments is_valid_code {_} ValidBoth. + Arguments is_valid_both {_} ValidBoth. + + Record both : Type := + mk2prog { + both_prog :> raw_both ; + both_prog_valid : @ValidBoth both_prog ; + p_eq : ⊢ ⦃ true_precond ⦄ (@is_state both_prog) ≈ ret (@is_pure both_prog) ⦃ pre_to_post_ret true_precond (@is_pure both_prog) ⦄ ; + }. + Arguments both_prog b. + Arguments both_prog_valid b. + Arguments p_eq b. + +End Both. + +Arguments is_pure {_} raw_both. +Arguments is_state {_} raw_both. + +Arguments valid_both L {_}. +Arguments both_valid_ret L {_}. +Arguments both_valid_putr_getr L {_}. +Arguments both_valid_putr L {_}. + +Arguments ValidBoth L I {_} p. +Arguments is_valid_code {_} {_} {_} {_} ValidBoth. +Arguments is_valid_both {_} {_} {_} {_} ValidBoth. + +Arguments both_prog {_} {_} {_} b. +Arguments both_prog_valid {_} {_} {_} b. +Arguments p_eq {_} {_} {_} b. + +Section Both_helper. + + Lemma valid_both_eta : + forall {L (* I *)} {A : choice_type} {x : raw_both A}, + valid_both L (* I *) x -> + valid_both L (* I *) {| is_pure := is_pure x ; is_state := is_state x |}. + Proof. + now intros ? (* ? *) ? [] ?. + Defined. + + Lemma ValidBoth_eta : + forall {L I} {A : choice_type} {x : both L I A}, + ValidBoth L I x -> + ValidBoth L I {| is_pure := is_pure x ; is_state := is_state x |}. + Proof. + now intros ? ? ? [[] ? ?] ?. + Defined. + + Lemma both_valid_injectLocations : + forall A L1 L2 (* I *) (v : raw_both A), + fsubset L1 L2 -> + valid_both L1 (* I *) v -> + valid_both L2 (* I *) v. + Proof. + intros A L1 L2 (* I *) v h p. + induction p ; simpl in * ; intros. + + constructor. + + apply both_valid_putr_getr ; eauto. + eapply injectSubset. + apply h. + assumption. + - constructor ; eauto. + eapply injectSubset. + apply h. + assumption. + Qed. + + Lemma valid_injectLocations_both : + forall A L1 L2 I (v : raw_both A), + fsubset L1 L2 -> + ValidBoth L1 I v -> + ValidBoth L2 I v. + Proof. + intros A L1 L2 I v h p. + destruct p as [is_valid_code valid_both]. + constructor. + - eapply valid_injectLocations. + apply h. + apply is_valid_code. + - eapply both_valid_injectLocations. + apply h. + apply valid_both. + Qed. + + Lemma valid_injectMap_both : + forall A L I1 I2 (v : raw_both A), + fsubset I1 I2 -> + ValidBoth L I1 v -> + ValidBoth L I2 v. + Proof. + intros A L I1 I2 v h p. + destruct p as [is_valid_code valid_both]. + constructor. + - eapply valid_injectMap. + apply h. + apply is_valid_code. + - generalize dependent is_valid_code. + induction valid_both ; simpl in *. + + constructor. + + constructor ; eauto. + + constructor ; eauto. + Qed. + + Definition bind_raw_both {A B} (c : raw_both A) (k : A -> raw_both B) : raw_both B := + {| + is_pure := let x := (is_pure c) in is_pure (k x) ; + is_state := bind (is_state c) (fun x => is_state (k x)) + |}. + + Lemma valid_bind_both_ : + forall {L1 L2 (* I1 I2 *)} A B c k, + valid_both L1 (* I1 *) c -> + (forall x, valid_both L2 (* I2 *) {| is_pure := is_pure (k x) ; is_state := is_state (k x) |}) -> + `{is_true (fsubset L1 L2)} -> + valid_both L2 (@bind_raw_both A B c k). + Proof. + intros L1 L2 (* I1 I2 *) A B c k Hc Hk Hfsubset. + induction Hc ; intros. + - apply Hk. + - unfold bind_raw_both. + simpl. + apply (both_valid_putr_getr L2 l (fun l => bind_raw_both (k0 l) k) v (injectSubset Hfsubset H) H1). + - apply (both_valid_putr L2 l v (bind_raw_both k0 k) (injectSubset Hfsubset H) IHHc). + Qed. + + Lemma valid_bind_both : + forall {L1 L2 I1 I2} A B c k, + ValidBoth L1 I1 c -> + (forall x, ValidBoth L2 I2 (k x)) -> + `{fsubset L1 L2} -> + `{fsubset I1 I2} -> + ValidBoth L2 I2 (@bind_raw_both A B c k). + Proof. + intros L1 L2 I1 I2 A B c k Hc Hk Hloc Hopsig. + constructor ; simpl. + - apply valid_bind. + eapply valid_injectLocations. apply Hloc. + eapply valid_injectMap. apply Hopsig. + apply (is_valid_code Hc). + apply (fun x => is_valid_code (Hk x)). + - eapply valid_bind_both_. + apply (is_valid_both Hc). + intros. + apply valid_both_eta. + apply (fun x => is_valid_both (Hk x)). + assumption. + Qed. + + Instance valid_putr_both : + forall {L I A} ℓ v (k : both L I A), + ℓ \in L -> + ValidBoth L I ({| is_pure := is_pure k ; is_state := #put ℓ := v ;; is_state k |}). + Proof. + intros. + constructor. + - simpl. + apply valid_putr. assumption. + apply k. + - apply both_valid_putr. assumption. + apply k. + Qed. + + Instance valid_putr_getr_both : + forall {L I A} ℓ v (k : _ -> both L I A), + ℓ \in L -> + (forall v, ValidBoth L I (k v)) -> + ValidBoth L I ({| is_pure := is_pure (k v) ; + is_state := putr ℓ v (getr ℓ (fun x => is_state (k x))) |}). + Proof. + intros. + constructor. + - simpl. + apply valid_putr. assumption. + apply valid_getr. assumption. + apply k. + - apply (both_valid_putr_getr L (* I *) ℓ k v H). + apply H0. + Qed. + + + Definition both_ret {A : choice_type} (x : A) : raw_both A := + {| is_pure := x ; is_state := ret x |} . + + Program Definition both_ret_valid {L I} {A : choice_type} (x : A) : ValidBoth L I (both_ret x) := + {| is_valid_code := valid_ret _ _ _ ; is_valid_both := both_valid_ret L (* I *) _ |} + . + Fail Next Obligation. + + +End Both_helper. + +Program Definition ret_both (* {L I} *) {A : choice_type} (x : A) : both (fset []) ([interface]) A := + {| + both_prog := {| is_pure := x ; is_state := ret x |} ; + both_prog_valid := {| + is_valid_code := valid_ret (fset []) ([interface]) x ; + is_valid_both := both_valid_ret (fset []) x ; + |} ; + p_eq := r_ret _ _ _ _ _ ; + |}. +Fail Next Obligation. + +(* Program Definition ret_both {L I} {A : choice_type} (x : A) : both L I A := *) +(* {| *) +(* both_prog := {| is_pure := x ; is_state := ret x |} ; *) +(* both_prog_valid := {| *) +(* is_valid_code := valid_ret L I x ; *) +(* is_valid_both := both_valid_ret L x ; *) +(* |} ; *) +(* p_eq := r_ret _ _ _ _ _ ; *) +(* |}. *) +(* Fail Next Obligation. *) + +Ltac pattern_both Hx Hf Hg := + (match goal with + | [ |- context [ @is_state _ ?x : both _ _ _ ] ] => + set (Hx := x) + ; try change (@is_pure _ _) with (@is_pure _ Hx) + ; match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ bind _ ?fb ≈ ?os ⦃ _ ⦄ ] ] => + let H := fresh in + set (H := os) + ; pattern (@is_pure _ Hx) in H + ; subst H + ; set (Hf := fb) + ; match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ _ ≈ ?gb _ ⦃ _ ⦄ ] ] => + set (Hg := gb) + end + end + end). + +Ltac pattern_both_fresh := + let x := fresh in + let y := fresh in + let z := fresh in + pattern_both x y z. + +Theorem r_bind_trans : + forall {B C : choice_type} + (f : choice.Choice.sort B -> raw_code C) + (g : choice.Choice.sort B -> raw_code C) (x : raw_code B) (y : choice.Choice.sort B), + forall (P P_mid : precond) (Q : postcond (choice.Choice.sort C) (choice.Choice.sort C)), + forall (H_x_is_y : ⊢ ⦃ P ⦄ x ≈ ret y ⦃ pre_to_post_ret P_mid (y) ⦄), + (⊢ ⦃ P_mid ⦄ f (y) ≈ g y ⦃ Q ⦄) -> + ⊢ ⦃ P ⦄ temp ← x ;; f temp ≈ g y ⦃ Q ⦄. +Proof. + intros. + replace (g y) with (temp ← ret y ;; g temp) by reflexivity. + + pose @r_bind. + specialize r with (f₀ := f) (f₁ := fun x => g x). + specialize r with (m₀ := x) (m₁ := (ret y)). + specialize r with (pre := P) (mid := pre_to_post_ret P_mid y ) (post := Q). + apply r ; clear r. + + - apply H_x_is_y. + - intros. + eapply rpre_hypothesis_rule. + intros ? ? [[] ?]. subst. + eapply rpre_weaken_rule. + cbn in H2. + subst. + apply H. + intros ? ? []. subst. apply H2. +Qed. + +Theorem r_bind_trans_both : forall {B C : choice_type} {L I} {f : choice.Choice.sort B -> raw_code C} {g : choice.Choice.sort B -> raw_code C} (b : both L I B), + forall (P : precond) (Q : postcond _ _), + (⊢ ⦃ true_precond ⦄ f ((is_pure b)) ≈ g (is_pure b) ⦃ Q ⦄) -> + ⊢ ⦃ P ⦄ temp ← is_state b ;; f temp ≈ g (is_pure b) ⦃ Q ⦄. +Proof. + intros. + apply r_bind_trans with (P_mid := true_precond). + + eapply rpre_weaken_rule. + apply p_eq. + reflexivity. + + apply H. +Qed. + +Ltac match_bind_trans_both := + let Hx := fresh in + let Hf := fresh in + let Hg := fresh in + pattern_both Hx Hf Hg + ; apply (@r_bind_trans_both) with (b := Hx) (f := Hf) (g := Hg) + ; intros ; subst Hf ; subst Hg ; subst Hx ; hnf. + +Ltac r_bind_both a := + eapply r_bind ; [ apply (p_eq a) | ] ; + intros ; + apply rpre_hypothesis_rule ; + intros ? ? [[] []] ; subst ; + apply forget_precond. + +Ltac r_subst_both a := + let x := fresh in + let y := fresh in + let z := fresh in + pattern_both x y z ; + change (z _) with (temp ← ret (is_pure x) ;; z temp) ; + r_bind_both a ; + subst x y z ; hnf. + +Program Definition bind_both {L1 L2 I1 I2} {A B} (c : both L1 I1 A) (k : A -> both L2 I2 B) `{fsubset_loc : fsubset L1 L2} `{fsubset_opsig : fsubset I1 I2} : both L2 I2 B := + {| + both_prog := bind_raw_both (both_prog c) (fun x => both_prog (k x)) ; + both_prog_valid := valid_bind_both A B c k (both_prog_valid c) (fun x => both_prog_valid (k x)) _ _ ; + |}. +Next Obligation. + intros. + r_subst_both c. + apply (k (is_pure c)). +Qed. + +Lemma both_eq : forall {A : choice_type} {L I} (a b : both L I A), + both_prog a = both_prog b -> + a = b. +Proof. + intros. + destruct a , b. + cbn in *. subst. + f_equal ; apply proof_irrelevance. +Qed. + +Lemma bind_ret_both : forall {A B : choice_type} {L I} `{fsubset_loc : is_true (fsubset (fset []) L)} `{fsubset_opsig : is_true (fsubset (fset []) I)} (f : A -> both L I B) (x : A), + (bind_both (fsubset_loc := fsubset_loc) (fsubset_opsig := fsubset_opsig) (ret_both x) f) = f x. +Proof. + intros. + apply both_eq. + simpl. + unfold bind_raw_both. + simpl. + destruct (f x). simpl. + destruct both_prog0. simpl. + reflexivity. +Qed. + +Definition lift_both {L1 L2 I1 I2} {A} (x : both L1 I1 A) `{fsubset_loc : is_true (fsubset L1 L2)} `{fsubset_opsig : is_true (fsubset I1 I2)} : both L2 I2 A := + {| both_prog := x ; + both_prog_valid := valid_injectLocations_both A L1 L2 I2 x fsubset_loc (valid_injectMap_both A L1 I1 I2 x fsubset_opsig (both_prog_valid x)) ; + p_eq := p_eq x |}. + +Notation "'solve_lift' x" := (lift_both (* (L1 := _) (L2 := _) (I1 := _) (I2 := _) (A := _) *) x (* (fsubset_loc := _) (fsubset_opsig := _) *)) (at level 100). + +Equations lift1_both {A B : choice_type} {L : {fset Location}} {I : Interface} (f : A -> B) (x : both L I A) + (* `{H_loc_incl_x : is_true (fsubset L1 L2)} `{H_opsig_incl_x : is_true (fsubset I1 I2)} *) + : both L I B + := + lift1_both f x := bind_both x (fun x' => solve_lift (ret_both (f x'))). +Solve All Obligations with intros ; solve_in_fset. +Fail Next Obligation. + +Equations lift2_both {A B C : choice_type} {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} (f : A -> B -> C) (x : both L1 I1 A) (y : both L2 I2 B) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) + : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) C + := + lift2_both f x y := + bind_both x (fun x' => + bind_both y (fun y' => + solve_lift (ret_both (f x' y')))). +Solve All Obligations with intros ; solve_in_fset. +Fail Next Obligation. + +Equations lift3_both {A B C D : choice_type} {L1 L2 L3 (* L4 *) : {fset Location}} {I1 I2 I3 (* I4 *) : Interface} (f : A -> B -> C -> D) (x : both L1 I1 A) (y : both L2 I2 B) (z : both L3 I3 C) + (* `{H_loc_incl_x : is_true (fsubset L1 L4)} `{H_opsig_incl_x : is_true (fsubset I1 I4)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L4)} `{H_opsig_incl_y : is_true (fsubset I2 I4)} *) + (* `{H_loc_incl_z : is_true (fsubset L3 L4)} `{H_opsig_incl_z : is_true (fsubset I3 I4)} *) + : both (L1 :|: L2 :|: L3) (* L4 *) (I1 :|: I2 :|: I3) (* I4 *) D := + lift3_both f x y z := + bind_both x (fun x' => lift_both (lift2_both (f x') y z)). +Solve All Obligations with intros ; solve_in_fset. +Fail Next Obligation. + +(* Class both (L : {fset Location}) I (A : choice_type) := *) +(* { *) +(* is_pure : choice.Choice.sort A ; *) +(* is_state : code L I A ; *) +(* code_eq_proof_statement : *) +(* ⊢ ⦃ true_precond ⦄ is_state ≈ ret (is_pure) *) +(* ⦃ pre_to_post_ret true_precond (is_pure) ⦄ *) +(* }. *) + +(* Class both L I (A : choice_type) := *) +(* { *) +(* is_pure : choice.Choice.sort A ; *) +(* is_state : code L I A ; *) +(* code_eq_proof_statement : *) +(* ⊢ ⦃ true_precond ⦄ is_state ≈ ret (is_pure) *) +(* ⦃ pre_to_post_ret true_precond (is_pure) ⦄ *) +(* }. *) + +(* Arguments is_pure {_} {_} {_} both. *) +(* Arguments is_state {_} {_} {_} both. *) +(* Arguments code_eq_proof_statement {_} {_} {_} both. *) + +(* Coercion is_pure : both >-> choice.Choice.sort. *) +(* Coercion is_state : both >-> code. *) + +(* Definition both_fun (L : cfset) I (A B : choice_type) := *) +(* ∑ (is_pure_f : choice.Choice.sort A -> choice.Choice.sort B) (is_state_f : code L I A -> code L I B), *) +(* forall (x : both L I A), ⊢ ⦃ true_precond ⦄ is_state_f x ≈ ret (is_pure_f x) ⦃ pre_to_post_ret true_precond (is_pure_f (is_pure x)) ⦄. *) + +(* Lemma helper : *) +(* forall (o : opsigCE), *) +(* choice.Choice.sort (fst (snd o)) = choice.Choice.sort (src (opsigCE_opsig o)). *) +(* Proof. now intros [? []]. Qed. *) + +(* Lemma pack_helper : *) +(* forall {E : InterfaceCE} {o} (H : In o E), *) +(* is_true *) +(* (ssrbool.in_mem (opsigCE_opsig o) *) +(* (ssrbool.mem (IfToCEIf E))). *) +(* Proof. *) +(* intros. *) +(* apply (ssrbool.introT (xseq.InP _ _)). *) +(* unfold IfToCEIf. *) +(* apply -> (in_remove_fset (T:=opsig_ordType)). *) +(* apply in_map. *) +(* apply H. *) +(* Defined. *) + +(* Class both_package L I (E : InterfaceCE) := *) +(* { *) +(* pack_pure : forall o, List.In o E -> fst (snd o) -> snd (snd o) ; *) +(* pack_state : package L I (IfToCEIf E) ; *) +(* pack_eq_proof_statement : forall i s t (H : In (i,(s,t)) E), forall (v : s), *) +(* forall f, (pack pack_state) i = Some *) +(* (existT *) +(* (fun S0 : choice_type => {T0 : choice_type & choice.Choice.sort S0 -> raw_code T0}) *) +(* s (existT (fun T0 : choice_type => choice.Choice.sort s -> raw_code T0) t f)) -> *) +(* ⊢ ⦃ true_precond ⦄ *) +(* f v *) +(* ≈ lift_to_code (L := L) (I := I) (pack_pure (i,(s,t)) H v) *) +(* ⦃ pre_to_post_ret true_precond (T_ct (pack_pure (i,(s,t)) H v)) ⦄ *) +(* }. *) + +(* Arguments pack_pure {_} {_} {_} {_} {_} {_} both_package. *) +(* Arguments pack_state {_} {_} {_} both_package. *) + +(* Coercion pack_pure : both_package >-> Funclass. *) +(* Coercion pack_state : both_package >-> package. *) + +(* Instance package_both {L I} {x y z} (pkg : both_package L I ((x, (y, z)) :: nil)) (args : y) *) +(* : both L I (z). *) +(* Proof. *) +(* destruct pkg as [pure state eq_proof]. *) +(* pose (o := (x, (y, z)) : opsigCE). *) +(* refine {| is_pure := pure o (List.in_eq _ _) args ; *) +(* is_state := {code get_op_default state (opsigCE_opsig o) (args) #with valid_get_op_default _ _ _ state (opsigCE_opsig o) (args) _ (pack_helper (List.in_eq _ _)) } |}. *) +(* apply eq_proof. *) +(* cbn. *) +(* destruct (from_valid_package _ _ _ _ (pack_valid state) (opsigCE_opsig o) (pack_helper (List.in_eq _ _))) as [? []]. *) +(* rewrite H. *) +(* apply f_equal. *) +(* apply f_equal. *) +(* apply f_equal. *) +(* unfold get_op_default. *) +(* cbn. *) +(* rewrite H. *) +(* destruct choice_type_eqP ; [ | contradiction ]. *) +(* destruct choice_type_eqP ; [ | contradiction ]. *) +(* rewrite pkg_composition.cast_fun_K. *) +(* reflexivity. *) +(* Defined. *) + +(* Program Instance both_package' L I o (bf : T (fst (snd o)) -> both L I (snd (snd o))) *) +(* : both_package L I (o :: nil) := *) +(* {| *) +(* pack_pure := fun o0 H => ltac:((assert (o = o0) by now destruct H) ; subst ; apply bf ; apply X) ; *) +(* pack_state := (mkpackage (mkfmap ((fst o, pkg_composition.mkdef _ _ (fun x => bf (ct_T x))) :: nil)) (valid_package1 L I (fst o) (fst (snd o)) (snd (snd o)) (fun x => bf (ct_T x)) (fun x => prog_valid (is_state (bf (ct_T x)))))) ; *) +(* pack_eq_proof_statement := _ *) +(* |}. *) +(* Next Obligation. *) +(* intros. *) +(* destruct H ; [ subst | contradiction ]. *) +(* cbn in H0. *) +(* rewrite (ssrbool.introT ssrnat.eqnP eq_refl) in H0. *) +(* inversion H0. *) +(* do 2 apply Eqdep.EqdepTheory.inj_pair2 in H1. *) +(* subst. *) +(* cbn. *) +(* rewrite ct_T_id. *) +(* apply bf. *) +(* Defined. *) + +Definition choice_type_size (ce : choice_type) : nat. +Proof. + (* remember ce. *) + induction ce. + 1, 2, 3, 4, 8, 9: exact 1. + - refine (S (IHce1 + IHce2))%nat. + - refine (S (S (S (IHce1 + IHce2))))%nat. + - refine (S (IHce))%nat. + - refine (S (IHce))%nat. + - refine (S (IHce1 + IHce2))%nat. +Defined. + +Fixpoint ce_to_chElement_ordType_ce (ce : choice_type) (X : chElement_ordType ce) : ce := + match ce as A return chElement_ordType A -> A with + | 'unit | 'nat | 'int | 'bool | chFin _ | 'word _ => id + | Y × Z => fun '(y,z) => (ce_to_chElement_ordType_ce Y y, ce_to_chElement_ordType_ce Z z) + | chMap Y Z => fun y => mkfmap (seq.zip (seq.unzip1 (FMap.fmval y)) (List.map (ce_to_chElement_ordType_ce Z) (seq.unzip2 (FMap.fmval y)))) + | 'option Y => (fun y => match y with + | None => None + | Some z => Some (ce_to_chElement_ordType_ce Y z) + end) + | chList Y => List.map (ce_to_chElement_ordType_ce Y) + | Y ∐ Z => (fun y => match y with + | inl z => inl (ce_to_chElement_ordType_ce Y z) + | inr z => inr (ce_to_chElement_ordType_ce Z z) + end) + end X. + +Fixpoint chElement_ordType_ce_to_ce (ce : choice_type) (X : ce) : chElement_ordType ce := + match ce as A return A -> chElement_ordType A with + | 'unit | 'nat | 'int | 'bool | chFin _ | 'word _ => id + | Y × Z => fun '(y,z) => (chElement_ordType_ce_to_ce Y y, + chElement_ordType_ce_to_ce Z z) + | chMap Y Z => fun y => mkfmap (seq.zip (seq.unzip1 (FMap.fmval y)) (List.map (chElement_ordType_ce_to_ce Z) (seq.unzip2 (FMap.fmval y)))) + | 'option Y => (fun y => match y with + | None => None + | Some z => Some (chElement_ordType_ce_to_ce Y z) + end) + | chList Y => List.map (chElement_ordType_ce_to_ce Y) + | Y ∐ Z => (fun y => match y with + | inl z => inl (chElement_ordType_ce_to_ce Y z) + | inr z => inr (chElement_ordType_ce_to_ce Z z) + end) + end X. + +(* Equations? lift_to_code2 (ce : choice_type) {L I} (x : choice.Choice.sort ce) : code L I ce := *) +(* lift_to_code2 'unit x := {code ret x} ; *) +(* lift_to_code2 'nat x := {code ret x} ; *) +(* lift_to_code2 'int x := {code ret x} ; *) +(* lift_to_code2 'bool x := {code ret x} ; *) +(* lift_to_code2 (chFin _) x := {code ret x} ; *) +(* lift_to_code2 ('word _) x := {code ret x} ; *) +(* lift_to_code2 (Y × Z) (y, z) := *) +(* {code temp_y ← lift_to_code2 Y y ;; *) +(* temp_z ← lift_to_code2 Z z ;; *) +(* ret ((temp_y, temp_z) : Y × Z)} ; *) +(* lift_to_code2 (chMap Y Z) y := *) +(* {code *) +(* targets ← lift_to_code2 _ (seq.zip (List.map (ce_to_chElement_ordType_ce Y) (seq.unzip1 (FMap.fmval y))) (seq.unzip2 (FMap.fmval y)) : chList (Y × _)) ;; *) +(* ret (mkfmap (seq.zip (List.map (chElement_ordType_ce_to_ce Y) (seq.unzip1 targets)) (seq.unzip2 targets)))} ; *) +(* lift_to_code2 ('option Y) y := *) +(* {code match y with *) +(* | None => ret (None : 'option Y) *) +(* | Some y => (temp_y ← lift_to_code2 _ y ;; *) +(* ret (Some temp_y : 'option Y)) *) +(* end } ; *) +(* lift_to_code2 (chList Y) y := *) +(* {code (List.fold_right *) +(* (fun (a : Y) *) +(* (b : raw_code (chList Y)) => *) +(* temp_a ← lift_to_code2 _ a ;; *) +(* temp_b ← b ;; *) +(* ret (temp_a :: temp_b : chList Y)) *) +(* (ret (nil : chList Y)) (y : list Y)) #with _} ; *) +(* lift_to_code2 (Y ∐ Z) y := *) +(* fun y _ => *) +(* {code match y with *) +(* | inl y' => temp_y ← (lift_to_code2 y') ;; ret (inl temp_y : Y ∐ Z) *) +(* | inr y' => temp_y ← (lift_to_code2 y') ;; ret (inr temp_y : Y ∐ Z) *) +(* end} *) +(* . *) + +(* Program Fixpoint lift_to_code2 {ce : choice_type} {L I} (x : choice.Choice.sort ce) {measure (choice_type_size ce)} : code L I ce := *) +(* match ce as A return A -> A = ce -> code L I A with *) +(* | 'unit | 'nat | 'int | 'bool | chFin _ | 'word _ => fun y _ => {code ret y} *) +(* | Y × Z => fun yz H => *) +(* {code temp_y ← @lift_to_code2 _ _ _ (fst yz) (eq_ind (Y × Z) *) +(* (fun ce => choice_type_size Y < choice_type_size ce) *) +(* (eq_ind (S (choice_type_size Y) + choice_type_size Z)%nat *) +(* (fun n : nat => choice_type_size Y < n) *) +(* (lt_plus_trans (choice_type_size Y) (S (choice_type_size Y)) *) +(* (choice_type_size Z) (Nat.lt_succ_diag_r (choice_type_size Y))) *) +(* (S (choice_type_size Y + choice_type_size Z)) *) +(* (Nat.add_succ_l (choice_type_size Y) (choice_type_size Z))) ce H) ;; *) +(* temp_z ← lift_to_code2 (snd yz) ;; *) +(* ret ((temp_y, temp_z) : Y × Z) #with _} *) +(* | chMap Y Z => *) +(* fun y _ => *) +(* {code *) +(* targets ← lift_to_code2 (seq.zip (List.map (ce_to_chElement_ordType_ce Y) (seq.unzip1 (FMap.fmval y))) (seq.unzip2 (FMap.fmval y)) : chList (Y × _)) ;; *) +(* ret (mkfmap (seq.zip (List.map (chElement_ordType_ce_to_ce Y) (seq.unzip1 targets)) (seq.unzip2 targets))) #with _} *) +(* | 'option Y => *) +(* fun y _ => *) +(* {code match y with *) +(* | None => ret (None : 'option Y) *) +(* | Some y => (temp_y ← lift_to_code2 (L := L) (I := I) y ;; *) +(* ret (Some temp_y : 'option Y)) *) +(* end #with _} *) +(* | chList Y => *) +(* fun y _=> {code (List.fold_right *) +(* (fun (a : Y) *) +(* (b : raw_code (chList Y)) => *) +(* temp_a ← lift_to_code2 (L := L) (I := I) a ;; *) +(* temp_b ← b ;; *) +(* ret (temp_a :: temp_b : chList Y)) *) +(* (ret (nil : chList Y)) (y : list Y)) #with _} *) +(* | Y ∐ Z => *) +(* fun y _ => *) +(* {code match y with *) +(* | inl y' => temp_y ← (lift_to_code2 (L := L) (I := I) y') ;; ret (inl temp_y : Y ∐ Z) *) +(* | inr y' => temp_y ← (lift_to_code2 (L := L) (I := I) y') ;; ret (inr temp_y : Y ∐ Z) *) +(* end #with _} *) +(* end x eq_refl. *) +(* Next Obligation. *) +(* intros. *) +(* refine (eq_ind (Y × Z) *) +(* (fun ce => choice_type_size Z < choice_type_size ce) *) +(* (eq_ind ((choice_type_size Y) + S (choice_type_size Z))%nat *) +(* (fun n : nat => choice_type_size Z < n) *) +(* (lt_plus_trans (choice_type_size Z) (S (choice_type_size Z)) *) +(* (choice_type_size Z) (Nat.lt_succ_diag_r (choice_type_size Z))) *) +(* ((choice_type_size Y + S (choice_type_size Z)) *) +(* (Nat.add_succ_r (choice_type_size Y) (choice_type_size Z))) ce H)). *) +(* refine (eq_ind (Y × Z) *) +(* (fun ce0 : choice_type => choice_type_size Y < choice_type_size ce0) _ ce H). *) +(* simpl. *) +(* rewrite <- Nat.add_succ_l. *) +(* apply lt_plus_trans. *) +(* apply Nat.lt_succ_diag_r. *) +(* Show Proof. *) +(* Defined. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* simpl. *) +(* rewrite <- Nat.add_succ_r. *) +(* rewrite Nat.add_comm. *) +(* apply lt_plus_trans. *) +(* apply Nat.lt_succ_diag_r. *) +(* Defined. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* destruct y. *) +(* simpl. *) +(* ssprove_valid. *) +(* apply lift_to_code2. *) +(* apply valid_ret. *) +(* Defined. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* induction y. *) +(* simpl. *) +(* ssprove_valid. *) +(* simpl. *) +(* ssprove_valid. *) +(* apply lift_to_code2. *) +(* Defined. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* simpl. *) +(* rewrite <- Nat.add_succ_l. *) +(* apply lt_plus_trans. *) +(* apply Nat.lt_succ_diag_r. *) +(* Defined. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* simpl. *) +(* rewrite <- Nat.add_succ_r. *) +(* rewrite Nat.add_comm. *) +(* apply lt_plus_trans. *) +(* apply Nat.lt_succ_diag_r. *) +(* Defined. *) +(* Next Obligation. *) +(* intros. *) +(* subst. *) +(* simpl. *) +(* destruct y. *) +(* ssprove_valid. *) +(* apply lift_to_code2. *) +(* ssprove_valid. *) +(* apply lift_to_code2. *) +(* Defined. *) + +(* Program Fixpoint lift_to_both {ce : choice_type} {L I} (x : choice.Choice.sort ce) : both L I ce := *) +(* {| is_pure := x ; *) +(* is_state := lift_to_code x |}. *) +(* Next Obligation. *) +(* intros. *) +(* now apply r_ret. *) +(* Defined. *) + +(* Notation "'lift_to_both' x" := *) +(* ({| is_pure := x ; *) +(* is_state := {code ret x #with valid_ret _ _ x }; *) +(* code_eq_proof_statement := r_ret x x true_precond (pre_to_post_ret true_precond x) (fun (s₀ s₁ : heap) => conj (conj eq_refl eq_refl)) *) +(* |}) (at level 100). *) +(* Notation both0 := (both (fset []) [interface]). *) +(* Notation lift_to_both0 := (@lift_to_both _ fset.fset0 [interface]). *) + +(* Definition lift_code_scope {L1 L2 : {fset Location}} {I1 I2 : {fset opsig}} {A} (c : code L1 I1 A) `{H_loc_incl : List.incl L1 L2} `{H_opsig_incl : List.incl I1 I2} : code L2 I2 A := *) +(* {code (prog c) #with *) +(* (@valid_injectMap L2 A I1 I2 _ (proj2 (opsig_list_incl_fsubset _ _) H_opsig_incl) (@valid_injectLocations I1 A L1 L2 _ (proj2 (loc_list_incl_fsubset _ _) H_loc_incl) (prog_valid c))) }. *) + +(* Program Definition lift_scope {L1 L2 : {fset Location}} {I1 I2 : {fset opsig}} {A} (b : both L1 I1 A) : both L2 I2 A := *) +(* {| *) +(* both_prog := both_prog b ; *) +(* |}. *) +(* Next Obligation. *) +(* intros. *) +(* apply (@valid_injectMap L2 A I1 I2 _ ). *) + +(* {| *) +(* prog := {| is_pure := is_pure b ; prog (is_state b) |} ; *) +(* is_state := {code (prog (is_state b)) #with *) +(* (@valid_injectMap L2 A I1 I2 _ (proj2 (opsig_list_incl_fsubset _ _) H_opsig_incl) (@valid_injectLocations I1 A L1 L2 _ (proj2 (loc_list_incl_fsubset _ _) H_loc_incl) (prog_valid (is_state b)))) } ; *) +(* code_eq_proof_statement := code_eq_proof_statement b *) +(* |}. *) + +(* Definition lift_scope {L1 L2 : {fset Location}} {I1 I2 : {fset opsig}} {A} (b : both L1 I1 A) `{H_loc_incl : List.incl L1 L2} `{H_opsig_incl : List.incl I1 I2} : both L2 I2 A := *) +(* {| *) +(* is_pure := is_pure b ; *) +(* is_state := lift_code_scope (H_loc_incl := H_loc_incl) (H_opsig_incl := H_opsig_incl) (is_state b) ; *) +(* code_eq_proof_statement := code_eq_proof_statement b *) +(* |}. *) + +(* Definition lift_scopeI *) +(* {L1 L2 : {fset Location}} {I : {fset opsig}} {A} (b : both L1 I A) `{H_loc_incl : List.incl L1 L2} : both L2 I A := *) +(* {| *) +(* is_pure := is_pure b ; *) +(* is_state := lift_code_scope (H_loc_incl := H_loc_incl) (H_opsig_incl := incl_refl _) (is_state b) ; *) +(* code_eq_proof_statement := code_eq_proof_statement b *) +(* |}. *) + +(* Definition lift_scope0 {L I} {A} (b : both fset0 [interface] A) : both L I A := *) +(* lift_scope (H_loc_incl := incl_nil_l _) (H_opsig_incl := ltac:(rewrite <- fset0E ; apply incl_nil_l)) b. *) + +(* (* TODO: *) *) +(* Instance both_comparable {A : choice_type} `{Comparable (choice.Choice.sort A)} {L I} : Comparable (both L I A) := *) +(* {| *) +(* ltb x y := ltb (is_pure x) (is_pure y) ; *) +(* leb x y := leb (is_pure x) (is_pure y) ; *) +(* gtb x y := gtb (is_pure x) (is_pure y) ; *) +(* geb x y := geb (is_pure x) (is_pure y) *) +(* |}. *) + +(* Goal forall (L1 L2 : cfset), True. *) +(* intros. *) +(* assert (cfsetU L1 L2 = cfsetU L2 L1). *) + + +(* Theorem valid_cfsetUl : *) +(* forall A (L1 L2 : cfset) I (c : raw_code A), *) +(* valid_code L1 I c -> *) +(* valid_code (cfsetU L1 L2) I c. *) +(* Proof. *) +(* intros. *) +(* apply valid_injectLocations with (L1 := L1). *) +(* destruct L1. *) +(* unfold cfset_to_fset in *. *) +(* cbn. *) + + +(* intros. *) +(* destruct L2. *) +(* induction L0. *) +(* - unfold cfsetU. *) +(* cbn. *) + +Equations prod_both {ceA ceB : choice_type} {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : {fset _}} (a : both L1 I1 ceA) (b : both L2 I2 ceB) (* `{fsubset L1 L3} `{fsubset I1 I3} `{fsubset L2 L3} `{fsubset I2 I3} *) : both (L1 :|: L2) (I1 :|: I2) (ceA × ceB) := + prod_both a b := + bind_both a (fun a' => + bind_both b (fun b' => + solve_lift (ret_both ((a', b') : _ × _)))). +Solve All Obligations with intros ; solve_in_fset. +Fail Next Obligation. + +Notation "'prod_b' ( a , b )" := (prod_both a b) : hacspec_scope. +Notation "'prod_b' ( a , b , .. , c )" := (prod_both .. (prod_both a b) .. c) : hacspec_scope. + +(* Equations *) Program Definition prod_both0 {ceA ceB : choice_type} {L : {fset _}} {I : {fset _}} (a : both L I ceA) (b : both L I ceB) : both (L) (I) (ceA × ceB) := + (* prod_both0 a b := *) + prod_both a b. +Solve All Obligations with intros ; fset_equality. +Fail Next Obligation. + +(* Notation "prod_b0( a , b )" := (prod_both0 a b) : hacspec_scope. *) +(* Notation "prod_b0( a , b , .. , c )" := (prod_both0 .. (prod_both0 a b) .. c) : hacspec_scope. *) + +(* Ltac ssprove_valid_fset T := *) +(* apply (fset_compute (T:=T)) ; try apply -> (in_remove_fset (T:=T)) ; repeat (try (left ; reflexivity) ; right) ; try reflexivity. *) + +(* Ltac ssprove_valid_location := ssprove_valid_fset loc_ordType. *) +(* Ltac ssprove_valid_opsig := ssprove_valid_fset opsig_ordType. *) + +Ltac ssprove_valid_program := + try (apply prog_valid) ; + try (apply valid_scheme ; try rewrite <- fset.fset0E ; apply prog_valid). + +Ltac destruct_choice_type_prod := + try match goal with + | H : choice.Choice.sort (chElement (loc_type ?p)) |- _ => + unfold p in H ; + unfold loc_type in H ; + unfold projT1 in H + end ; + repeat match goal with + | H : (chProd _ _) |- _ => + destruct H + end ; + repeat match goal with + | H : choice.Choice.sort + (chElement + (choice.Choice.sort + (chProd _ _))) |- _ => + destruct H + end ; + repeat match goal with + | H : prod _ _ |- _ => destruct H + end ; + cbv zeta. + +(* Theorem single_mem : forall m, *) +(* Datatypes.is_true *) +(* (@ssrbool.in_mem *) +(* (Ord.sort (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType))) *) +(* m *) +(* (@ssrbool.mem *) +(* (Ord.sort *) +(* (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType))) *) +(* (fset_predType *) +(* (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType))) *) +(* (@fset (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType)) *) +(* (@cons (@sigT choice_type (fun _ : choice_type => nat)) m *) +(* (@nil (@sigT choice_type (fun _ : choice_type => nat))))))). *) +(* Proof. *) +(* intros. *) +(* rewrite <- (@fset1E (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType))). *) +(* rewrite (ssrbool.introT (fset1P _ _)) ; reflexivity. *) +(* Qed. *) + +Theorem tag_leq_simplify : + forall (a b : Location), + is_true (ssrfun.tag a <= ssrfun.tag b)%ord -> + is_true (ssrfun.tagged a <= ssrfun.tagged b)%ord -> + is_true (tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType) a b). +Proof. + intros [] []. + + unfold tag_leq. + unfold eqtype.tagged_as, ssrfun.tagged , ssrfun.tag , projT1 , projT2. + + intro. + rewrite Ord.leq_eqVlt in H. + rewrite is_true_split_or in H. + destruct H. + - apply Couplings.reflection_nonsense in H ; subst. + + rewrite Ord.ltxx. + rewrite Bool.orb_false_l. + rewrite eqtype.eq_refl. + rewrite Bool.andb_true_l. + + destruct eqtype.eqP. + + unfold eq_rect_r , eq_rect ; destruct eq_sym. + trivial. + + contradiction. + - rewrite H ; clear H. + reflexivity. +Qed. + +Theorem tag_leq_inverse : + forall a b, + tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType) a b + = + (negb (tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType) + b a) || + eqtype.eq_op (ssrfun.tag a) (ssrfun.tag b) && + eqtype.eq_op (ssrfun.tagged a) (ssrfun.tagged b))%bool. +Proof. + intros [a b] [c d]. + unfold tag_leq. + + rewrite Bool.negb_orb. + rewrite Bool.negb_andb. + rewrite Bool.andb_orb_distrib_r. + + unfold eqtype.tagged_as. + unfold ssrfun.tagged , ssrfun.tag , projT1 , projT2. + rewrite <- Bool.orb_assoc. + + f_equal. + - rewrite <- Bool.negb_orb. + rewrite <- Bool.orb_comm. + rewrite <- Ord.leq_eqVlt. + rewrite <- Ord.ltNge. + reflexivity. + - destruct (eqtype.eq_op a c) eqn:a_eq_c. + + apply Couplings.reflection_nonsense in a_eq_c. + subst. + do 2 rewrite Bool.andb_true_l. + + destruct eqtype.eqP. 2: contradiction. + + unfold eq_rect_r , eq_rect. + destruct eq_sym. + + rewrite Ord.leq_eqVlt. + rewrite Bool.orb_comm. + + f_equal. + rewrite <- Ord.ltNge. + rewrite Ord.ltxx. + reflexivity. + + do 2 rewrite Bool.andb_false_l. + rewrite Bool.orb_false_r. + symmetry. + + destruct eqtype.eqP. + { subst. rewrite eqtype.eq_refl in a_eq_c. discriminate a_eq_c. } + + rewrite Ord.eq_leq by reflexivity. + rewrite Bool.andb_false_r. + reflexivity. +Qed. + +(* Ltac loc_incl_compute := *) +(* now (try apply -> loc_list_incl_remove_fset ; apply loc_list_incl_expand ; (now repeat (split ; [ repeat ((left ; reflexivity) || (right)) | ]))). *) + +(* Ltac opsig_incl_compute := *) +(* now (try apply -> opsig_list_incl_remove_fset ; apply opsig_list_incl_expand ; (now repeat (split ; [ repeat ((left ; reflexivity) || (right)) | ]))). *) + +(* Lemma valid_subset_fset : *) +(* forall xs ys I {ct} c, *) +(* List.incl (xs) (ys) -> *) +(* ValidCode (fset xs) I c -> *) +(* @ValidCode (fset ys) I ct c. *) +(* Proof. *) +(* intros. *) +(* apply (valid_injectLocations) with (L1 := fset xs). *) +(* - apply loc_list_incl_fsubset. *) +(* apply -> loc_list_incl_remove_fset. *) +(* apply H. *) +(* - apply H0. *) +(* Qed. *) + +(* Lemma valid_subset : *) +(* forall (xs ys : {fset Location}) I {ct} c, *) +(* List.incl (xs) (ys) -> *) +(* ValidCode (xs) I c -> *) +(* @ValidCode (ys) I ct c. *) +(* Proof. *) +(* intros. *) +(* apply (valid_injectLocations) with (L1 := xs). *) +(* - apply loc_list_incl_fsubset. *) +(* apply H. *) +(* - apply H0. *) +(* Qed. *) + +Ltac valid_program := + apply prog_valid + || (apply valid_scheme ; try rewrite <- fset.fset0E ; apply prog_valid) + (* || (eapply (valid_subset_fset) ; [ | apply prog_valid ] ; loc_incl_compute) *). + + +Definition heap_ignore_post fset {A} : postcond A A := + pre_to_post (heap_ignore fset). + +Theorem heap_ignore_refl : + forall {fset} h, heap_ignore fset (h, h). +Proof. + intros fset h ℓ ?. + reflexivity. +Qed. + +Theorem heap_ignore_post_refl : + forall {fset A} (x : A * heap), heap_ignore_post fset x x. +Proof. + intros fset A []. + split. reflexivity. + apply heap_ignore_refl. +Qed. + +Lemma heap_ignore_weaken : + forall fset fset', is_true (fsubset fset fset') -> + forall x, heap_ignore fset x -> heap_ignore fset' x. +Proof. + intros. + destruct x as [h h0]. + pose (INV'_heap_ignore fset fset' fset0). + rewrite fsetU0 in i. + unfold INV' in i. + specialize (i H h h0). + destruct i as [? _]. + intros l ?. + specialize (H1 H0 l H2 ltac:(easy)). + rewrite H1. + reflexivity. +Qed. + +Lemma rpost_heap_ignore_weaken : + forall {A} fset fset', is_true (fsubset fset fset') -> + forall (x y : raw_code A), + ⊢ ⦃ (fun '(h0, h1) => heap_ignore fset (h0, h1)) ⦄ + x ≈ y + ⦃ heap_ignore_post fset ⦄ -> + ⊢ ⦃ (fun '(h0, h1) => heap_ignore fset (h0, h1)) ⦄ + x ≈ y + ⦃ heap_ignore_post fset' ⦄. +Proof. + intros. + eapply rpost_weaken_rule. + apply H0. + + intros [] [] []. subst. + split. reflexivity. + apply (heap_ignore_weaken fset) ; assumption. +Qed. + + +Lemma rpre_heap_ignore_weaken : + forall {A} fset fset', is_true (fsubset fset fset') -> + forall (x y : raw_code A), + ⊢ ⦃ (fun '(h0, h1) => heap_ignore fset' (h0, h1)) ⦄ + x ≈ y + ⦃ heap_ignore_post fset ⦄ -> + ⊢ ⦃ (fun '(h0, h1) => heap_ignore fset (h0, h1)) ⦄ + x ≈ y + ⦃ heap_ignore_post fset ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + apply H0. + intros. cbn. + apply (heap_ignore_weaken fset fset') ; assumption. +Qed. + +Theorem bind_rewrite : forall A B x f, @bind A B (ret x) f = f x. +Proof. + intros. + unfold bind. + reflexivity. +Qed. + +Theorem r_bind_eq : forall {B C : choice_type} (y : choice.Choice.sort B) (g : choice.Choice.sort B -> raw_code C), (temp ← ret y ;; g temp) = g y. +Proof. reflexivity. Qed. + +Theorem r_bind_trans' : + forall {B C : choice_type} + (f : choice.Choice.sort B -> raw_code C) + (g : choice.Choice.sort B -> raw_code C) (x : raw_code B) (y : choice.Choice.sort B), + forall (P : precond) (Q : postcond (choice.Choice.sort C) (choice.Choice.sort C)), + forall (H_x_is_y : ⊨ repr x ≈ repr (ret y) [{retW (y, y)}]), + (⊢ ⦃ P ⦄ f ( y) ≈ g y ⦃ Q ⦄) -> + ⊢ ⦃ P ⦄ temp ← x ;; f temp ≈ g y ⦃ Q ⦄. +Proof. + intros. + + replace (g y) with (temp ← ret y ;; g temp) by reflexivity. + + pose @r_bind. + specialize r with (f₀ := f) (f₁ := fun x => g x). + specialize r with (m₀ := x) (m₁ := (ret y)). + specialize r with (pre := P) (mid := fun s0 s1 => pre_to_post P s0 s1 /\ fst s1 = y) (post := Q). + apply r ; clear r. + + - eapply from_sem_jdg. + eapply (RulesStateProb.weaken_rule (retW (y , y))). + + apply H_x_is_y. + + unfold retW. + intros [] X [? πa1a2] ; cbn in X. + specialize (fun x => πa1a2 (x, s) (y, s0)). + + unfold proj1_sig. + + unfold RulesStateProb.WrelSt. + unfold θ. + unfold StateTransformingLaxMorph.rlmm_codomain ; simpl. + + apply πa1a2. + split. + cbn. + split. + reflexivity. + 2: { reflexivity. } + apply H0. + - intros. + eapply rpre_hypothesis_rule. + intros ? ? [[] ?]. subst. + eapply rpre_weaken_rule. + 2: { intros ? ? []. subst. apply H1. } + clear H1. + apply H. +Qed. + +(* Lemma heap_ignore_remove_set_heap : *) +(* forall {fset} {s₀ s₁ : heap} {ℓ v}, *) +(* is_true (ssrbool.in_mem ℓ (ssrbool.mem fset)) -> *) +(* heap_ignore (fset) (s₀, s₁) -> *) +(* heap_ignore (fset) (set_heap s₀ ℓ v, s₁). *) +(* Proof. *) +(* intros. *) +(* unfold heap_ignore. *) +(* intros. *) +(* unfold heap_ignore in H0. *) +(* specialize (H0 ℓ0 ltac:(assumption)). *) +(* rewrite <- H0. *) +(* rewrite <- get_heap_set_heap. *) +(* reflexivity. *) + +(* destruct (@eqtype.eq_op *) +(* (@eqtype.tag_eqType choice_type_eqType *) +(* (fun _ : choice_type => ssrnat.nat_eqType)) ℓ0 ℓ) eqn:ℓ_eq. *) +(* - apply (ssrbool.elimT eqtype.eqP) in ℓ_eq. *) +(* subst. *) +(* exfalso. *) +(* apply (ssrbool.elimT ssrbool.negP) in H. *) +(* + apply H. *) +(* + assumption. *) +(* - reflexivity. *) +(* Qed. *) + +(* Lemma isolate_mem_section : *) +(* forall (fset : {fset Location}) ℓ fset_head fset_tail, *) +(* is_true (ssrbool.in_mem ℓ (ssrbool.mem fset)) -> *) +(* is_true (ssrbool.in_mem ℓ (ssrbool.mem (fset_head :|: fset :|: fset_tail))). *) +(* Proof. *) +(* intros. *) +(* apply fset_compute. apply in_split_fset_cat ; left ; apply in_split_fset_cat ; right. *) +(* apply fset_compute. apply H. *) +(* Qed. *) + +(* Ltac solve_heap_ignore_remove_set_heap := *) +(* apply (heap_ignore_remove_set_heap) ; [ apply isolate_mem_section ; apply fset_compute ; apply -> in_remove_fset ; cbn ; repeat (left ; reflexivity || right || reflexivity) | assumption ]. *) + + +Ltac solve_post_from_pre := + let H := fresh in + intros ? ? H + ; split + ; [reflexivity | ] + ; ( assumption + || (apply restore_set_lhs in H + ; [ assumption + | intros ? ? + (* ; solve_heap_ignore_remove_set_heap *) ] )). + +Corollary better_r : + forall {A B : choice.Choice.type} + (r₀ : raw_code A) + (r₁ : raw_code B) (pre : precond) + (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ fun '(s₀, s₁) => pre (s₀, s₁) ⦄ r₀ ≈ r₁ ⦃ post ⦄ <-> + ⊢ ⦃ pre ⦄ r₀ ≈ r₁ ⦃ post ⦄. +Proof. + split ; intros ; (eapply rpre_hypothesis_rule ; intros ; eapply rpre_weaken_rule ; [ apply H | intros ? ? [] ; subst ; easy ]). +Qed. + +Corollary better_r_put_lhs : forall {A B : choice.Choice.type} (ℓ : Location) + (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) + (r₁ : raw_code B) (pre : precond) + (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ set_lhs ℓ v pre ⦄ r₀ ≈ r₁ ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ #put ℓ := v ;; r₀ ≈ r₁ ⦃ post ⦄. +Proof. + intros ; now apply better_r, r_put_lhs, better_r. +Qed. + +Corollary better_r_put_rhs : forall {A B : choice.Choice.type} (ℓ : Location) + (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) + (r₁ : raw_code B) (pre : precond) + (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ set_rhs ℓ v pre ⦄ r₀ ≈ r₁ ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ r₀ ≈ #put ℓ := v ;; r₁ ⦃ post ⦄. +Proof. + intros ; now apply better_r, r_put_rhs, better_r. +Qed. + +Corollary better_r_put_get_lhs : forall (A : choice.Choice.type) (B : choice.Choice.type) (ℓ : Location) (v : choice.Choice.sort ℓ) (r : choice.Choice.sort ℓ -> raw_code A) rhs (pre : precond) (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ pre ⦄ + #put ℓ := v ;; + r v ≈ rhs ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ + #put ℓ := v ;; + x ← get ℓ ;; + r x ≈ rhs ⦃ post ⦄. +Proof. + intros. + apply (r_transL (#put ℓ := v ;; r v )). + apply r_put_get. + apply H. +Qed. + +Corollary better_r_put_get_rhs : forall (A : choice.Choice.type) (B : choice.Choice.type) (ℓ : Location) (v : choice.Choice.sort ℓ) (r : choice.Choice.sort ℓ -> raw_code B) lhs (pre : precond) (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ pre ⦄ + lhs ≈ + #put ℓ := v ;; + r v ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ + lhs ≈ + #put ℓ := v ;; + x ← get ℓ ;; + r x ⦃ post ⦄. +Proof. + intros. + apply (r_transR _ (#put ℓ := v ;; r v )). + apply r_put_get. + apply H. +Qed. + +Corollary better_r_get_remind_lhs : forall {A B : choice.Choice.type} (ℓ : Location) + (v : choice.Choice.sort (Value (projT1 ℓ))) + (r₀ : choice.Choice.sort (Value (projT1 ℓ)) -> raw_code A) (r₁ : raw_code B) + (pre : precond) (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + Remembers_lhs ℓ v pre -> + ⊢ ⦃ pre ⦄ r₀ v ≈ r₁ ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ x ← get ℓ ;; r₀ x ≈ r₁ ⦃ post ⦄. +Proof. + intros. + apply better_r. + eapply r_get_remind_lhs. + apply H. + apply better_r. + apply H0. +Qed. + +Lemma getr_set_lhs : + forall {A B} ℓ v pre post (a : _ -> raw_code A) (b : raw_code B), + ⊢ ⦃ set_lhs ℓ v pre ⦄ + a v + ≈ + b + ⦃ post ⦄ -> + ⊢ ⦃ set_lhs ℓ v pre ⦄ + x ← get ℓ ;; + a x + ≈ + b + ⦃ post ⦄. +Proof. + clear. + intros. + + eapply better_r_get_remind_lhs. + unfold Remembers_lhs. + intros ? ? [? []]. subst. + unfold rem_lhs. + rewrite get_set_heap_eq. + reflexivity. + apply H. +Qed. + +Equations prod_to_prod {A B} {L I} (x : both L I (A × B)) : (both L I A * both L I B) := + prod_to_prod x := + (bind_both x (fun x' => solve_lift (ret_both (fst x'))) , + bind_both x (fun x' => solve_lift (ret_both (snd x')))). +Solve All Obligations with intros ; solve_in_fset. +Fail Next Obligation. + +(* Equations prod_to_prod {A B} {L I} (x : both L I (A × B)) : (both L I A * both L I B) := *) +(* prod_to_prod x := *) +(* (bind_both x (fun x' => solve_lift (ret_both (fst x'))) , *) +(* bind_both x (fun x' => solve_lift (ret_both (snd x')))). *) +(* Solve All Obligations with intros ; solve_in_fset. *) +(* Fail Next Obligation. *) + +Equations let_both {L1 L2 I1 I2 A B} (x : both L1 I1 A) (f : both L1 I1 A -> both L2 I2 B) `{fsubset_loc : is_true (fsubset L1 L2)} `{fsubset_opsig : is_true (fsubset I1 I2)} : both L2 I2 B := + let_both x f := f x. + +Notation "'letb' x ':=' y 'in' f" := + (let_both (* (L1 := _) (L2 := _) (I1 := _) (I2 := _) (A := _) (B := _) *) y (fun x => f) (* (fsubset_loc := _) (fsubset_opsig := _) *)) (* (let_both y (fun x => f)) *) (at level 100, x pattern, right associativity). +Notation "'letb' ''' x ':=' y 'in' f" := + (let_both (* (L1 := _) (L2 := _) (I1 := _) (I2 := _) (A := _) (B := _) *) y (fun x => f) (* (fsubset_loc := _) (fsubset_opsig := _) *)) (* (let_both y (fun x => f)) *) (at level 100, x pattern, right associativity). +(* (lift_scope (H_loc_incl := _) (H_opsig_incl := _) y) *) + +(* Equations split_both_func {A B : choice_type} {L1 L2 : {fset Location}} {I1 I2} *) +(* (f : both L1 I1 A -> both L2 I2 B) `{fsubset L1 L2} `{fsubset I1 I2} : (A -> B) * (code L1 I1 A -> code L2 I2 B) := *) +(* split_both_func f := *) +(* (fun y : A => is_pure ((fun temp : A => f (solve_lift (ret_both temp))) y), *) +(* fun y : code L1 I1 A => {code temp ← y ;; is_state (f (solve_lift (ret_both temp))) #with _}). *) +(* Solve All Obligations with intros ; solve_in_fset. *) +(* Next Obligation. *) +(* intros. *) +(* ssprove_valid. *) + +(* apply valid_injectLocations with (L1 := L1). apply fsubset2. *) +(* apply @valid_injectMap with (I1 := I1). apply fsubset3. *) +(* apply y. *) + +(* apply (f (solve_lift (ret_both x))). *) +(* Qed. *) +(* Fail Next Obligation. *) + +Equations let_mut_both {L1 L2 I1 I2 B} (x_loc : Location) `{loc_in : x_loc \in L2} (x : both L1 I1 x_loc) (f : both (fset [x_loc] :|: L1) I1 x_loc -> both L2 I2 B) `{fsubset_loc : is_true (fsubset L1 L2)} `{fsubset_opsig : is_true (fsubset I1 I2)} : both L2 I2 B := + let_mut_both x_loc x f := + bind_both x (fun y => + {| both_prog := + {| + is_pure := is_pure (f (solve_lift (ret_both y))) ; + is_state := putr x_loc y (getr x_loc (fun y => is_state (f (solve_lift (ret_both y))))) + |}; + both_prog_valid := (@valid_putr_getr_both L2 I2 B x_loc y (fun x => f (solve_lift (ret_both x))) loc_in (fun x => both_prog_valid (f (solve_lift (ret_both x))))) + |}). +Solve All Obligations with intros ; solve_in_fset. +Next Obligation. + intros. + apply better_r_put_lhs. + apply getr_set_lhs. + apply forget_precond. + apply f. +Qed. +Fail Next Obligation. + +Notation "'letb' x 'loc(' ℓ ')' ':=' y 'in' f" := + (let_mut_both ℓ y (fun x => f) (* (fsubset_loc := _) (fsubset_opsig := _) (loc_in := _) *)) (at level 100, x pattern, right associativity, format "'letb' x 'loc(' ℓ ')' ':=' y 'in' '//' f"). +Notation "'letb' ''' x 'loc(' ℓ ')' ':=' y 'in' f" := + (let_mut_both ℓ y (fun x => f) (* (fsubset_loc := _) (fsubset_opsig := _) (loc_in := _) *)) (at level 100, x pattern, right associativity, format "'letb' ''' x 'loc(' ℓ ')' ':=' y 'in' '//' f"). + +Fixpoint split_type (F : choice_type -> Type) (A : choice_type) : Type := + match A with + | C × D => split_type F C * split_type F D + | _ => F A + end. + +Fixpoint split_both {L I A} (x : both L I A) : (split_type (both L I) A) := + match A as c return (both L I c -> split_type (both L I) c) with + | _ × _ => fun y => (split_both (fst (prod_to_prod y)) , split_both (snd (prod_to_prod y))) + | _ => fun y : both L I _ => y + end x. + +Fixpoint unsplit_both {L I A} (s : split_type (both L I) A) : both L I A := + match A as c return (split_type (both L I) c -> both L I c) with + | _ × _ => + fun y => prod_both0 ( unsplit_both (fst y)) ((unsplit_both (snd y))) + | _ => fun y => y + end s. + +Notation "'unsplit_both_all' ( a , b , .. , c )" := ((.. ((unsplit_both a , unsplit_both b)) .. , unsplit_both c)). + + +(* Handle products of size 2 - 4 for letb *) + +Fixpoint prod_to_prod_n_ty (n : nat) (F : choice_type -> Type) (A : choice_type) : Type := + match n with + | O => F A + | S n' => + match A with + | B × C => (prod_to_prod_n_ty n' F B) * F C + | _ => F A + end + end. +Eval simpl in prod_to_prod_n_ty 2 (both fset0 fset0) ('nat × 'bool). + +(* TODO: Currently duplicates code, due to prod_to_prod, should only evaluate and project the result ! *) +Fixpoint prod_to_prod_n {L I A} (n : nat) (x : both L I A) : prod_to_prod_n_ty n (both L I) A := + match n as m return prod_to_prod_n_ty m (both L I) A with + | O => x + | S n' => + match A as B return both L I B -> prod_to_prod_n_ty (S n') (both L I) B with + | B × C => fun y => (prod_to_prod_n n' (fst (prod_to_prod y)), snd (prod_to_prod y)) + | _ => fun y => y + end x + end. + +Equations lift_n {L1 L2 I1 I2 A B} (n : nat) {fsubset_loc : is_true (fsubset L1 L2)} {fsubset_opsig : is_true (fsubset I1 I2)} (z : both L1 I1 A) (f : prod_to_prod_n_ty n (both L1 I1) A -> both L2 I2 B) : both L2 I2 B := + lift_n n z f := + (bind_both z (fun z' => f (prod_to_prod_n n (solve_lift (ret_both z'))))). +Solve All Obligations with intros ; solve_in_fset. +Fail Next Obligation. + +Notation "'letb' ' '(' a ',' b ')' ':=' z 'in' f" := + (lift_n 1 z (fun '(a, b) => f)) + (at level 100). + +Notation "'letb' ' '(' a ',' b ',' c ')' ':=' z 'in' f" := + (lift_n 2 z (fun '(a, b, c) => f)) + (at level 100). + +Notation "'letb' ' '(' a ',' b ',' c ',' d ')' ':=' z 'in' f" := + (lift_n 3 z (fun '(a, b, c, d) => f)) + (at level 100). + +(* Notation "'letb' ' '(' a ',' b ')' ':=' z 'in' f" := *) +(* (let '(a,b) := prod_to_prod_n 1 z in *) +(* f) (at level 100). *) + +(* Notation "'letb' ' '(' a ',' b ',' c ')' ':=' z 'in' f" := *) +(* (let '(a, b, c) := prod_to_prod_n 2 z in *) +(* f) (at level 100). *) + +(* Notation "'letb' ' '(' a ',' b ',' c ',' d ')' ':=' z 'in' f" := *) +(* ( let '(a, b, c, d) := prod_to_prod_n 3 z in *) +(* f) (at level 100). *) + +(* Locate prod_b( _ , _ ). *) + + +Equations let_both0 {A B} (x : both (fset []) (fset []) A) (f : both (fset []) (fset []) A -> both (fset []) (fset []) B) : both (fset []) (fset []) B := + let_both0 x f := f x. + +Notation "'letb0' x ':=' y 'in' f" := + (let_both0 (* (L1 := _) (L2 := _) (I1 := _) (I2 := _) (A := _) (B := _) *) y (fun x => f)) (* (let_both y (fun x => f)) *) (at level 100, x pattern, right associativity). +Notation "'letb0' ''' x ':=' y 'in' f" := + (let_both0 (* (L1 := _) (L2 := _) (I1 := _) (I2 := _) (A := _) (B := _) *) y (fun x => f)) (* (let_both y (fun x => f)) *) (at level 100, x pattern, right associativity). +(* (lift_scope (H_loc_incl := _) (H_opsig_incl := _) y) *) + +Notation "'letb0' ' '(' a ',' b ')' ':=' z 'in' f" := + (lift_n 1 z (fun '(a, b) => f)) + (at level 100). + +Notation "'letb0' ' '(' a ',' b ',' c ')' ':=' z 'in' f" := + (lift_n 2 z (fun '(a, b, c) => f)) + (at level 100). + +Notation "'letb0' ' '(' a ',' b ',' c ',' d ')' ':=' z 'in' f" := + (lift_n 3 z (fun '(a, b, c, d) => f)) + (at level 100). diff --git a/proof-libs/coq/ssprove/src/ConCertLib.v b/proof-libs/coq/ssprove/src/ConCertLib.v new file mode 100644 index 000000000..e590e13b9 --- /dev/null +++ b/proof-libs/coq/ssprove/src/ConCertLib.v @@ -0,0 +1,484 @@ +From Crypt Require Import choice_type . +From Jasmin Require Import word. +From Coq Require Import ZArith. +Open Scope Z_scope. + +From Hacspec Require Import Hacspec_Lib_Pre. + +Open Scope hacspec_scope. +Import choice.Choice.Exports. + +From ConCert.Execution Require Import Serializable. + +Program Definition serialize_by_other {A B} (f_to : B -> A) (f_from : A -> B) `(forall m, f_from (f_to m) = m) `{Serializable A} : Serializable B := + {| + serialize m := serialize (f_to m); + deserialize m := option_map f_from (deserialize m) ; + |}. +Next Obligation. + intros. hnf. rewrite deserialize_serialize. + unfold option_map. now f_equal. +Defined. + +Program Definition serialize_by_other_option {A B} (f_to : B -> Datatypes.option A) (f_from : Datatypes.option A -> Datatypes.option B) `(forall m, f_from (f_to m) = Some m) `{Serializable A} : Serializable B := + {| + serialize m := serialize (f_to m); + deserialize m := match (deserialize m) with + | Some m => f_from m + | None => None + end; + |}. +Next Obligation. + intros. hnf. simpl. rewrite deserialize_serialize. now f_equal. +Defined. + +#[global] Instance hacspec_int_serializable {ws : wsize} : Serializable (int ws) := serialize_by_other (unsigned) (@repr ws) (@wrepr_unsigned ws). + +Lemma eqtype_ord_ext : + forall n, forall x y : fintype.ordinal n, (@eqtype.eq_op + (ord.Ord.eqType + (@ord.Ord.clone _ + (ord.ordinal_ordType n) + _ + id)) x y) = (@eqtype.eq_op ssrnat.nat_eqType (fintype.nat_of_ord x) (fintype.nat_of_ord y)). +Proof. + intros. + destruct x. + simpl. + destruct y. + simpl. + reflexivity. +Qed. + +Theorem lift_set_commute : + forall {A : choice_type} {len} (a : nseq_ A (S len)) (b : fintype.ordinal (S len)) (c : A), + @lift_nseq A (S _) (fmap.setm a b c) = + fmap.setm (@lift_nseq A (S _) a) (lift_ordinal _ b) c. +Proof. + clear ; intros ; fold chElement in *. + simpl in b. + unfold lift_nseq. + apply fmap.eq_fmap. intros x ; simpl in x. + rewrite fmap.setmE. + unfold fmap.getm. + simpl fmap.FMap.fmval. + destruct a ; induction fmval ; simpl lift_fval. + - now rewrite (lift_fval_equation_2 _ (len) (b, c) nil). + - { + destruct x , b. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl eqtype.eq_op. + destruct eqtype.eq_op eqn:eq_o at 2. + + apply (ssrbool.elimT eqtype.eqP) in eq_o. + subst. + destruct ord.Ord.lt. + * simpl. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S ( len)))). + simpl. + rewrite eqtype.eq_refl. + reflexivity. + * rewrite (eqtype_ord_ext (S (len))). + simpl. + set (eqtype.eq_op _ _). + destruct b eqn:eq_b_o ; subst b. + -- apply (ssrbool.elimT eqtype.eqP) in eq_b_o. + subst. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + rewrite eqtype.eq_refl. + reflexivity. + -- rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + destruct (fst _). + simpl in *. + rewrite ssrnat.eqSS. + rewrite eq_b_o. + + rewrite IHfmval. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + rewrite eqtype.eq_refl. + reflexivity. + + (* apply (path_sorted_tl _). *) + { + intros. + destruct fmval. reflexivity. + - cbn. + cbn in i. + destruct (seq.unzip1 fmval). + + reflexivity. + + cbn in i. + now rewrite LocationUtility.is_true_split_and in i. + } + + destruct ord.Ord.lt. + * simpl. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + rewrite eq_o. + reflexivity. + * rewrite (eqtype_ord_ext (S (len))). + simpl. + set (eqtype.eq_op _ _). + destruct b eqn:eq_b_o ; subst b. + -- apply (ssrbool.elimT eqtype.eqP) in eq_b_o. + subst. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + rewrite eq_o. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + unfold lift_ordinal. + destruct (fst _). + simpl. + simpl in eq_o. + rewrite eq_o. + reflexivity. + -- rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + destruct a. + destruct s. + simpl in *. + set (b := eqtype.eq_op _ _) ; destruct b eqn:eq_m_o ; subst b. + ++ apply (ssrbool.elimT eqtype.eqP) in eq_m_o. + subst. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + now rewrite eqtype.eq_refl. + ++ rewrite IHfmval. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + rewrite eq_o. + rewrite (lift_fval_equation_2 _ (len)). + simpl. + rewrite (eqtype_ord_ext (S (S (len)))). + simpl. + rewrite eq_m_o. + reflexivity. + (* apply (path_sorted_tl _). *) + { + intros. + destruct fmval. reflexivity. + - cbn. + cbn in i. + destruct (seq.unzip1 fmval). + + reflexivity. + + cbn in i. + now rewrite LocationUtility.is_true_split_and in i. + } + } +Qed. + +Theorem array_from_list_helper_inverse : forall {A} len (m : nseq_ A (S len)), + array_from_option_list_helper + (nseq_hd_option m) + (array_to_option_list (nseq_tl m)) len = m. +Proof. + intros. + induction len. + - unfold nseq_tl. + unfold nseq_hd_option. + rewrite array_to_option_list_equation_1. + destruct m, fmval. + + now apply fmap.eq_fmap. + + apply fmap.eq_fmap. intros x ; simpl in x. + + unfold fmap.getm at 2 ; simpl. + destruct (fst _), m ; [ | discriminate ] ; simpl. + rewrite array_from_option_list_helper_equation_1. + unfold setm_option. + rewrite fmap.setmE. + now destruct x , m ; [ | discriminate ] ; simpl. + - rewrite array_to_option_list_equation_2. + + assert (forall (T : ord.Ord.type) (S : choice_type) + (m : @fmap.FMap.fmap_of T S + (ssreflect.Phant (ord.Ord.sort T -> S))) + (k : ord.Ord.sort T) (v : chOption S) (k' : ord.Ord.sort T), + @fmap.getm T S (setm_option m k v) k' = + match v with + | Some v => @fmap.getm T S (fmap.setm m k v) k' + | None => @fmap.getm T S m k' + end) by now destruct v. + + rewrite array_from_option_list_helper_equation_3. + rewrite (IHlen (nseq_tl m)). + + clear. + + apply fmap.eq_fmap. + intros x ; simpl in x. + destruct m ; induction fmval. + + now unfold fmap.getm ; cbn ; rewrite lift_fval_equation_1. + + { + specialize (IHfmval (path_sorted_tl i)). + unfold nseq_hd_option in *. + simpl. + destruct a. + destruct s. + unfold fmap.getm at 2. + simpl. + destruct m. + { + setoid_rewrite <- IHfmval ; clear. + + setoid_rewrite fmap.setmE. + rewrite !(eqtype_ord_ext (S (S len))). + simpl eqtype.eq_op. + replace (_ - _)%nat with O by (set (temp := nseq_tl _) ; rewrite <- (array_to_length_option_list_is_len A len temp) at 1; now rewrite Nat.sub_diag). + + destruct x , m ; [ reflexivity | ]. + rewrite tl_fmap_equation_2. + unfold setm_option. + destruct fmval ; [reflexivity | ]. + simpl. + destruct p, s. + simpl. + destruct m0 ; [ discriminate | ]. + + rewrite tl_fmap_equation_3. + + unfold fmap.getm. + simpl. + + set (@fmap.getm_def _ _). + set (lift_fval _). + set (lift_fval _). + assert (l = l0) ; [ subst l l0 | now rewrite H ]. + f_equal. + + now apply lower_fval_ext_list. + } + { + setoid_rewrite <- IHfmval ; clear. + unfold setm_option. + unfold fmap.getm. + simpl. + + rewrite tl_fmap_equation_3. + destruct (eqtype.eq_op _ _) eqn:eq_o. + - apply (ssrbool.elimT eqtype.eqP) in eq_o. + rewrite eq_o. + + subst. + simpl. + + rewrite lower_fval_equation_2. + rewrite lift_fval_equation_2. + simpl. + + rewrite !(eqtype_ord_ext (S (S len))). + simpl. + rewrite eqtype.eq_refl. + reflexivity. + - unfold setm_option. + destruct fmval. + + (* discriminate. *) + rewrite tl_fmap_equation_1. + simpl. + + rewrite lower_fval_equation_2. + rewrite lift_fval_equation_2. + simpl. + + rewrite lower_fval_equation_1. + simpl. + + rewrite !(eqtype_ord_ext (S (S len))). + simpl. + rewrite !(eqtype_ord_ext (S (S len))) in eq_o. + simpl in eq_o. + rewrite eq_o. + simpl. + reflexivity. + + destruct p , s. + destruct m0 ; [ discriminate | ]. + simpl. + + rewrite lower_fval_equation_2. + rewrite lift_fval_equation_2. + simpl. + + rewrite lower_fval_equation_2. + rewrite lift_fval_equation_2. + simpl. + + rewrite tl_fmap_equation_3. + simpl. + + rewrite lower_fval_equation_2. + rewrite lift_fval_equation_2. + simpl. + + rewrite !(eqtype_ord_ext (S (S len))). + simpl. + + rewrite (eqtype_ord_ext (S (S len))) in eq_o. + simpl in eq_o. + rewrite eq_o. + + apply (ssrbool.elimF eqtype.eqP) in eq_o. + + destruct (eqtype.eq_op _ _) eqn:eq_o2 ; [ reflexivity | ]. + + + simpl. + + set (@fmap.getm_def _ _). + set (lift_fval _). + set (lift_fval _). + assert (l = l0) ; [ subst l l0 | now rewrite H ]. + f_equal. + apply lower_fval_ext_list. + apply (path_sorted_tl (path_sorted_tl i)). + apply (path_sorted_tl (path_sorted_tl i)). + reflexivity. + } + } +Qed. + +Theorem array_from_list_to_list_unit : forall {A} len (m : nseq_ A len), + array_from_option_list' (array_to_option_list m) len = m. +Proof. + intros. + induction len. + - now destruct m. (* unit element equailty *) + - simpl. + pose (resize_to_length_idemp (array_to_option_list m)). + rewrite (array_to_length_option_list_is_len A (S len) m) in e. + rewrite <- e ; clear e. + rewrite array_to_option_list_equation_2. + specialize (IHlen (nseq_tl m)). + apply array_from_list_helper_inverse. +Qed. + +Definition defaulted_nseq {A len} (m : nseq_ A (S len)) := + forall i, match fmap.getm m i with + | Some x => x <> chCanonical A + | None => True + end. + +#[global] Instance nseq_serializable {A : choice_type} {len} `{Serializable A} : Serializable (nseq_ A len) := + serialize_by_other (array_to_option_list) (fun x => array_from_option_list' x len) (array_from_list_to_list_unit len). + +Ltac serialize_enum := intros ; autounfold ; repeat apply @product_serializable ; fold chElement. + +From ConCert.Execution Require Import Blockchain. + +#[global] Instance BaseTypes : ConCert.Execution.Blockchain.ChainBase := + {| + Address := nat; + address_eqb := Nat.eqb ; + address_eqb_spec := Nat.eqb_spec; + address_is_contract := Nat.even; + |}. + +From Hacspec Require Import ChoiceEquality. +From Hacspec Require Import Hacspec_Lib. + +Theorem both_ext_prog : + forall {L I A} (x y : both L I A), both_prog x = both_prog y <-> x = y. +Proof. + intros L I A [both_x valid_x eq_x] [both_y valid_y eq_y] ; simpl. + split. + - intros ; subst. + f_equal ; easy. + - easy. +Qed. + +Print pkg_core_definition.typed_raw_function. + +Instance serializable_code {L I} {A : choice_type} `{Serializable A} : Serializable (pkg_core_definition.code L I A). +Proof. +Admitted. + +Instance serializable_both {L I} {A : choice_type} `{Serializable A} : Serializable (both L I A). +Proof. + (* refine {| serialize *) + (* '{| both_prog := *) + (* {| *) + (* is_state := is_state; *) + (* is_pure := is_pure *) + (* |} ; *) + (* both_prog_valid := *) + (* {| *) + (* is_valid_code := is_valid_code ; *) + (* is_valid_both := is_valid_both *) + (* |} ; *) + (* p_eq := p_eq |} := *) + (* serialize *) + (* (is_pure, *) + (* {| *) + (* pkg_core_definition.prog := is_state; *) + (* pkg_core_definition.prog_valid := is_valid_code |}, *) + (* is_valid_both, *) + (* p_eq) ; *) + (* deserialize x := *) + (* option_map (fun y => solve_lift ret_both y) (deserialize x) *) + (* |}. *) + (* Unshelve. *) + (* 2:{ *) + (* eapply product_serializable. *) + (* Unshelve. *) + (* eapply product_serializable. *) + (* Unshelve. *) + (* simpl. *) + (* eapply product_serializable. *) + (* Unshelve. *) + (* } *) + + (* eapply (@serialize_by_other *) + (* (A * pkg_core_definition.code L I A * valid_both) *) + (* (both L I A) *) + (* (fun x => (is_pure x, {| pkg_core_definition.prog := is_state x; pkg_core_definition.prog_valid := is_valid_code (both_prog_valid x) |})) *) + (* (fun '(z , {| pkg_core_definition.prog := y ; pkg_core_definition.prog_valid := x |}) => *) + (* _ *) + (* )). *) + (* Unshelve. *) + (* 3:{ *) + (* epose {| is_pure := z ; is_state := y |}. *) + (* assert (y = is_state r) by reflexivity. *) + (* rewrite H0 in *. *) + (* eapply {| *) + (* both_prog := r ; *) + (* both_prog_valid := {| is_valid_code := x |} *) + (* |}. *) + (* } *) + + (* intros. *) + (* destruct m. *) + (* apply both_ext_prog. *) + (* simpl. *) + (* destruct both_prog. *) + (* simpl. *) + (* reflexivity. *) + (* apply product_serializable. *) + (* Unshelve. *) + + (* - apply y. *) + (* - destruct y. *) + (* simpl. *) + (* destruct prog. *) + (* simpl. *) + (* eapply both_valid_ret. *) + + (* apply both *) + +Admitted. +Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. diff --git a/proof-libs/coq/ssprove/src/Hacspec_Lib.v b/proof-libs/coq/ssprove/src/Hacspec_Lib.v new file mode 100644 index 000000000..17f193709 --- /dev/null +++ b/proof-libs/coq/ssprove/src/Hacspec_Lib.v @@ -0,0 +1,3506 @@ +Global Set Warnings "-ambiguous-paths". +Global Set Warnings "-uniform-inheritance". +Global Set Warnings "-auto-template". +Global Set Warnings "-disj-pattern-notation". +Global Set Warnings "-notation-overridden,-ambiguous-paths". + +Require Import Lia. +Require Import Coq.Logic.FunctionalExtensionality. +Require Import Sumbool. + +From mathcomp Require Import fintype. + +From Crypt Require Import choice_type Package Prelude. +Import PackageNotation. +From extructures Require Import ord fset fmap. + +From mathcomp Require Import ssrZ word. +From Jasmin Require Import word. + +From Coq Require Import ZArith List. +Import List.ListNotations. + +(********************************************************) +(* Implementation of all Hacspec library functions *) +(* for Both types. *) +(********************************************************) + +(*** Integers *) + +Declare Scope hacspec_scope. + +Require Import ChoiceEquality. +Require Import LocationUtility. +Require Import Hacspec_Lib_Comparable. +Require Import Hacspec_Lib_Pre. + +Open Scope bool_scope. +Open Scope hacspec_scope. +Open Scope nat_scope. +Open Scope list_scope. + +Import choice.Choice.Exports. + + + +(* Definition lift3_both_ {A B C D : choice_type} {L} {I} (f : A -> B -> C -> D) (x : both L I A) (y : both L I B) (z : both L I C) := *) +(* bind_both_ x (fun x' => *) +(* bind_both_ y (fun y' => *) +(* bind_both_ z (fun z' => *) +(* ret_both (f x' y' z')))). *) + +Equations int_add {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_add := lift2_both (Hacspec_Lib_Pre.int_add). + Fail Next Obligation. + + Equations int_sub {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_sub := (lift2_both (Hacspec_Lib_Pre.int_sub)). + Fail Next Obligation. + + Equations int_opp {L (* L2 *) : {fset Location}} {I (* I2 *) : Interface} {WS} + (x : both L I (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L L2)} `{H_opsig_incl_x : is_true (fsubset I I2)} *) : both L I (int WS) := + int_opp := (lift1_both (Hacspec_Lib_Pre.int_opp)). + Fail Next Obligation. + + Equations int_mul {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_mul := (lift2_both (Hacspec_Lib_Pre.int_mul)). + Fail Next Obligation. + + Equations int_div {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_div := (lift2_both (Hacspec_Lib_Pre.int_div : int _ -> int _ -> int _)). + Fail Next Obligation. + + Equations int_mod {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_mod := (lift2_both (Hacspec_Lib_Pre.int_mod : int _ -> int _ -> int _)). + Fail Next Obligation. + + Equations int_xor {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_xor := (lift2_both (Hacspec_Lib_Pre.int_xor : int _ -> int _ -> int _)). + Fail Next Obligation. + + Equations int_and {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_and := (lift2_both (Hacspec_Lib_Pre.int_and : int _ -> int _ -> int _)). + Fail Next Obligation. + + Equations int_or {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} {WS} + (x : both L1 I1 (int WS)) (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) (int WS) := + int_or := (lift2_both (Hacspec_Lib_Pre.int_or : int _ -> int _ -> int _)). + Fail Next Obligation. + + Equations int_not {L (* L2 *) : {fset Location}} {I (* I2 *) : Interface} {WS} + (x : both L I (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L2)} `{H_opsig_incl_x : is_true (fsubset I1 I2)} *) : both L I (int WS) := + int_not := (lift1_both (Hacspec_Lib_Pre.int_not : int _ -> int _)). + Fail Next Obligation. + + Equations cast_int {L (* L2 *) : {fset Location}} {I (* I2 *) : Interface} {WS1 WS2} + (x : both L I (int WS1)) + (* `{H_loc_incl_x : is_true (fsubset L1 L2)} `{H_opsig_incl_x : is_true (fsubset I1 I2)} *) : both L I (int WS2) := + cast_int := (lift1_both (fun (n : int _) => repr _ (unsigned n))). + Fail Next Obligation. +(* End IntType. *) + +Notation secret := (lift1_both secret). + +Infix ".%%" := int_modi (at level 40, left associativity) : Z_scope. +Infix ".+" := int_add (at level 77) : hacspec_scope. +Infix ".-" := int_sub (at level 77) : hacspec_scope. +Notation "-" := int_opp (at level 77) : hacspec_scope. +Infix ".*" := int_mul (at level 77) : hacspec_scope. +Infix "./" := int_div (at level 77) : hacspec_scope. +Infix ".%" := int_mod (at level 77) : hacspec_scope. +Infix ".^" := int_xor (at level 77) : hacspec_scope. +Infix ".&" := int_and (at level 77) : hacspec_scope. +Infix ".|" := int_or (at level 77) : hacspec_scope. +Notation "'not'" := int_not (at level 77) : hacspec_scope. + +(* Section Uint. *) + Notation uint8_declassify := (lift1_both uint8_declassify). + Notation int8_declassify := (lift1_both int8_declassify). + Notation uint16_declassify := (lift1_both uint16_declassify). + Notation int16_declassify := (lift1_both int16_declassify). + Notation uint32_declassify := (lift1_both uint32_declassify). + Notation int32_declassify := (lift1_both int32_declassify). + Notation uint64_declassify := (lift1_both uint64_declassify). + Notation int64_declassify := (lift1_both int64_declassify). + Notation uint128_declassify := (lift1_both uint128_declassify). + Notation int128_declassify := (lift1_both int128_declassify). + + Notation uint8_classify := (lift1_both uint8_classify). + Notation int8_classify := (lift1_both int8_classify). + Notation uint16_classify := (lift1_both uint16_classify). + Notation int16_classify := (lift1_both int16_classify). + Notation uint32_classify := (lift1_both uint32_classify). + Notation int32_classify := (lift1_both int32_classify). + Notation uint64_classify := (lift1_both uint64_classify). + Notation int64_classify := (lift1_both int64_classify). + Notation uint128_classify := (lift1_both uint128_classify). + Notation int128_classify := (lift1_both int128_classify). + + (* CompCert integers' signedness is only interpreted through 'signed' and 'unsigned', + and not in the representation. Therefore, uints are just names for their respective ints. + *) + + Notation declassify_usize_from_uint8 := (lift1_both declassify_usize_from_uint8). + Notation declassify_u32_from_uint32 := (lift1_both declassify_u32_from_uint32). + + Notation uint8_rotate_left := (lift2_both uint8_rotate_left). + + Notation uint8_rotate_right := (lift2_both uint8_rotate_right). + + Notation uint16_rotate_left := (lift2_both uint16_rotate_left). + + Notation uint16_rotate_right := (lift2_both uint16_rotate_right). + + Notation uint32_rotate_left := (lift2_both uint32_rotate_left). + + Notation uint32_rotate_right := (lift2_both uint32_rotate_right). + + Notation uint64_rotate_left := (lift2_both uint64_rotate_left). + + Notation uint64_rotate_right := (lift2_both uint64_rotate_right). + + Notation uint128_rotate_left := (lift2_both uint128_rotate_left). + + Notation uint128_rotate_right := (lift2_both uint128_rotate_right). + Notation usize_shift_right_ := (lift2_both (fun u s => u usize_shift_right s)). + + Notation usize_shift_left_ := + (fun (u: both (fset []) ([interface]) uint_size) (s: both (fset []) ([interface]) int32) => + {| + is_pure := (is_pure u) usize_shift_left (is_pure s) ; + is_state := + {code + temp_u ← is_state u ;; + temp_s ← is_state s ;; + ret (temp_u usize_shift_left temp_s) + } + |}). + (* Next Obligation. *) + (* intros. *) + (* pattern_both Hb Hf Hg. *) + (* apply (@r_bind_trans_both (uint_size) (uint_size)). *) + (* subst Hf Hg Hb ; hnf. *) + (* pattern_both Hb Hf Hg. *) + (* apply (@r_bind_trans_both (int32)). *) + (* subst Hf Hg Hb ; hnf. *) + (* apply r_ret. *) + (* easy. *) + (* Qed. *) + + (**** Operations *) + + Notation shift_left_ := (lift2_both shift_left_). + Notation shift_right_ := (lift2_both shift_right_). + +(* End Uint. *) + +Infix "usize_shift_right" := (usize_shift_right_) (at level 77) : hacspec_scope. +Infix "usize_shift_left" := (usize_shift_left_) (at level 77) : hacspec_scope. + +Infix "shift_left" := (shift_left_) (at level 77) : hacspec_scope. +Infix "shift_right" := (shift_right_) (at level 77) : hacspec_scope. + +(*** Loops *) + +Section Loops. + + Program Fixpoint foldi_ + {acc : choice_type} + (fuel : nat) + {L L2 I I2} + (i : both L2 I2 uint_size) + (f: both L2 I2 uint_size -> both L I acc -> both L I (acc)) + (cur : both L I acc) + `{fsubset_loc : is_true (fsubset L2 L)} + `{fsubset_opsig : is_true (fsubset I2 I)} + {struct fuel} : both L I (acc) := + match fuel with + | 0 => lift_both cur + | S n' => foldi_ n' (int_add i (ret_both one)) f (f i cur) + end. + Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). + Fail Next Obligation. + + (* Obligation Tactic := (intros ; (fset_equality || solve_in_fset)). *) + Equations foldi_both_ + {acc : choice_type} + (fuel : nat) + {L1 L2 I1 I2} + (i : both L2 I2 uint_size) + {L I} + `{is_true (fsubset L1 L)} `{is_true (fsubset I1 I)} + `{is_true (fsubset L2 L)} `{is_true (fsubset I2 I)} + (f: both L2 I2 (uint_size) -> both L I acc -> both L I (acc)) + (cur : both L1 I1 acc) : both L I (acc) := + foldi_both_ fuel i f cur := + match fuel with + | 0 => lift_both cur + | S n' => solve_lift foldi_both_ n' (int_add i (ret_both one)) (fun x y => solve_lift f (solve_lift x) y) (f i (solve_lift cur)) + end. + Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). + Fail Next Obligation. + + Equations foldi + {acc: choice_type} + {L1 L2 L3 I1 I2 I3} + (lo: both L2 I2 uint_size) + (hi: both L3 I3 uint_size) (* {lo <= hi} *) + {L I} + `{is_true (fsubset L1 L)} `{is_true (fsubset I1 I)} + `{is_true (fsubset L2 L)} `{is_true (fsubset I2 I)} + `{is_true (fsubset L3 L)} `{is_true (fsubset I3 I)} + (f: both (L2 :|: L3) (I2 :|: I3) (uint_size) -> both L I acc -> both L I (acc)) (* {i < hi} *) + (init: both L1 I1 acc) : both L I (acc) := + foldi lo hi f init := + bind_both lo (fun lo => + bind_both hi (fun hi => + match Z.sub (unsigned hi) (unsigned lo) with + | Z0 => lift_both init + | Zneg p => lift_both init + | Zpos p => foldi_both_ (Pos.to_nat p) (solve_lift (ret_both lo)) (@f) init (* (fsubset_loc1 := fsubset_loc1) (fsubset_opsig1 := fsubset_opsig1) *) + end)) + . + Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). + Fail Next Obligation. + + (* Fold done using natural numbers for bounds *) + Fixpoint foldi_nat_ + {acc : choice_type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> raw_code (acc)) + (cur : acc) : raw_code (acc) := + match fuel with + | O => ret (cur) + | S n' => + cur' ← f i cur ;; + foldi_nat_ n' (S i) f (cur') + end. + Definition foldi_nat + {acc: choice_type} + (lo: nat) + (hi: nat) (* {lo <= hi} *) + (f: nat -> acc -> raw_code (acc)) (* {i < hi} *) + (init: acc) : raw_code (acc) := + match Nat.sub hi lo with + | O => ret (init) + | S n' => foldi_nat_ (S n') lo f init + end. + + (* Lemma foldi__move_S : *) + (* forall {acc: choice_type} *) + (* (fuel : nat) *) + (* (i : uint_size) *) + (* {L I} *) + (* (f : uint_size -> acc -> both L I (acc)) *) + (* (cur : acc), *) + (* (bind_both (f i cur) (fun cur' => (bind_both (both_ret (Hacspec_Lib_Pre.int_add i one)) (fun Si => foldi_both_ fuel Si f (cur')))) = foldi_both_ (S fuel) i f cur). *) + (* Proof. reflexivity. Qed. *) + + Lemma foldi__nat_move_S : + forall {acc: choice_type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> raw_code (acc)) + (cur : acc), + (cur' ← f i cur ;; foldi_nat_ fuel (S i) f (cur')) = foldi_nat_ (S fuel) i f cur. + Proof. reflexivity. Qed. + + Lemma foldi__nat_move_S_append : + forall {acc: choice_type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> raw_code (acc)) + (cur : acc), + (cur' ← foldi_nat_ fuel i f (cur) ;; f (i + fuel) (cur')) = foldi_nat_ (S fuel) i f cur. + Proof. + + induction fuel ; intros. + - rewrite <- foldi__nat_move_S. + unfold foldi_nat_. + replace (fun cur' => @ret acc ((cur'))) with (fun cur' => @ret acc cur'). + 2: { + apply functional_extensionality. + reflexivity. + } + rewrite bind_ret. + unfold bind at 1. + rewrite Nat.add_0_r. + reflexivity. + - rewrite <- foldi__nat_move_S. + rewrite <- foldi__nat_move_S. + rewrite bind_assoc. + f_equal. + apply functional_extensionality. + intros. + replace (i + S fuel) with (S i + fuel) by lia. + rewrite IHfuel. + reflexivity. + Qed. + + Lemma foldi__nat_move_to_function : + forall {acc: choice_type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> raw_code (acc)) + (cur : acc), + foldi_nat_ fuel i (fun x => f (S x)) (cur) = foldi_nat_ fuel (S i) f cur. + Proof. + induction fuel ; intros. + - reflexivity. + - cbn. + f_equal. + apply functional_extensionality. + intros. + rewrite IHfuel. + reflexivity. + Qed. + + Lemma foldi__nat_move_to_function_add : + forall {acc: choice_type} + (fuel : nat) + (i j : nat) + (f : nat -> acc -> raw_code (acc)) + (cur : acc), + foldi_nat_ fuel i (fun x => f (x + j)) (cur) = foldi_nat_ fuel (i + j) f cur. + Proof. + intros acc fuel i j. generalize dependent i. + induction j ; intros. + - rewrite Nat.add_0_r. + replace (fun x : nat => f (x + 0)) with f. + reflexivity. + apply functional_extensionality. + intros. + now rewrite Nat.add_0_r. + - replace (i + S j) with (S i + j) by lia. + rewrite <- IHj. + rewrite <- foldi__nat_move_to_function. + f_equal. + apply functional_extensionality. + intros. + f_equal. + lia. + Qed. + + (* Lemma raw_code_type_from_choice_type_id : *) + (* forall (acc : choice_type) (x : raw_both (acc)), *) + (* (bind_both x (fun cur' => *) + (* both_ret ((cur')))) *) + (* = *) + (* x. *) + (* Proof. *) + (* intros. *) + (* unfold bind_both. *) + (* rewrite @bind_cong with (v := is_state x) (g := @ret (acc)). *) + (* rewrite bind_ret. *) + (* destruct x. *) + (* reflexivity. *) + (* reflexivity. *) + + (* apply functional_extensionality. *) + (* intros. *) + (* reflexivity. *) + (* Qed. *) + + Lemma bind_raw_both_ret : + forall {A B : choice_type} {L I} (x : A) (f : A -> both L I B), bind_raw_both (both_ret x) f = f x. + Proof. + intros. + unfold bind_raw_both. + simpl. + destruct (f x). + destruct both_prog. + simpl. + reflexivity. + Qed. + + Lemma bind_raw_both_assoc : + forall {A B C : choice_type} (v : raw_both A) (k1 : A -> raw_both B) (k2 : B -> raw_both C), + (bind_raw_both (bind_raw_both v k1) k2 = (bind_raw_both v (fun x => bind_raw_both (k1 x) k2))). + Proof. + intros. + unfold bind_raw_both. + simpl. + rewrite bind_assoc. + reflexivity. + Qed. + + (* (* You can do one iteration of the fold by burning a unit of fuel *) *) + (* Lemma foldi__move_S_fuel : *) + (* forall {acc: choice_type} *) + (* (fuel : nat) *) + (* (i : uint_size) *) + (* {L I} *) + (* (f : uint_size -> acc -> both L I (acc)) *) + (* (cur : acc), *) + (* (0 <= Z.of_nat fuel <= @wmax_unsigned U32)%Z -> *) + (* (bind_both (foldi_both_ fuel i f cur) (fun cur' => *) + (* bind_both (both_ret (Hacspec_Lib_Pre.int_add (repr _ (Z.of_nat fuel)) i)) (fun fuel_add_i => *) + (* f fuel_add_i (cur')) *) + (* )) = foldi_both_ (S (fuel)) i f cur. *) + (* Proof. *) + (* intros acc fuel. *) + (* induction fuel ; intros. *) + (* - cbn. *) + (* replace (repr _ 0%Z) with (@zero U32) by (apply word_ext ; reflexivity). *) + (* (* unfold Hacspec_Lib_Pre.int_add. *) *) + (* unfold Hacspec_Lib_Pre.int_add. *) + (* rewrite add0w. *) + (* rewrite raw_code_type_from_choice_type_id. *) + (* setoid_rewrite (bind_both_ret cur). *) + (* simpl. *) + (* reflexivity. *) + (* - unfold foldi_. *) + (* fold (@foldi_ acc fuel). *) + + (* simpl. *) + (* rewrite (bind_both_assoc). *) + (* f_equal. *) + (* apply functional_extensionality. *) + (* intros. *) + + (* (* unfold Hacspec_Lib_Pre.int_add at 1 3. *) *) + (* (* unfold ret_both, is_state at 1 3. *) *) + (* unfold prog, lift_to_code. *) + (* (* do 2 setoid_rewrite bind_rewrite. *) *) + + (* specialize (IHfuel (Hacspec_Lib_Pre.int_add i one) L I f (x)). *) + + + + (* replace (Hacspec_Lib_Pre.int_add (repr _ (Z.of_nat (S fuel))) _) *) + (* with (Hacspec_Lib_Pre.int_add (repr _ (Z.of_nat fuel)) (Hacspec_Lib_Pre.int_add i one)). *) + (* 2 : { *) + (* (* unfold int_add. *) *) + (* unfold Hacspec_Lib_Pre.int_add. *) + (* rewrite <- addwC. *) + (* rewrite <- addwA. *) + (* rewrite addwC. *) + (* f_equal. *) + (* apply word_ext. *) + (* rewrite Z.add_1_l. *) + (* rewrite Nat2Z.inj_succ. *) + + (* f_equal. *) + (* f_equal. *) + (* apply Zmod_small. *) + (* unfold wmax_unsigned in H. *) + (* unfold wbase in H. *) + (* lia. *) + (* } *) + + (* setoid_rewrite IHfuel. *) + (* reflexivity. *) + (* lia. *) + (* Qed. *) + + (* (* You can do one iteration of the fold by burning a unit of fuel *) *) + (* Lemma foldi__nat_move_S_fuel : *) + (* forall {acc: choice_type} *) + (* (fuel : nat) *) + (* (i : nat) *) + (* (f : nat -> acc -> raw_both (acc)) *) + (* (cur : acc), *) + (* (0 <= Z.of_nat fuel <= @wmax_unsigned U32)%Z -> *) + (* (cur' ← foldi_nat_ fuel i f cur ;; f (fuel + i)%nat (cur')) = foldi_nat_ (S fuel) i f cur. *) + (* Proof. *) + (* induction fuel ; intros. *) + (* - cbn. *) + (* rewrite raw_code_type_from_choice_type_id. *) + (* reflexivity. *) + (* - unfold foldi_nat_. *) + (* fold (@foldi_nat_ acc fuel). *) + (* rewrite bind_assoc. *) + (* f_equal. *) + (* apply functional_extensionality. *) + (* intros. *) + (* replace (S fuel + i)%nat with (fuel + (S i))%nat by (symmetry ; apply plus_Snm_nSm). *) + (* rewrite IHfuel. *) + (* + reflexivity. *) + (* + lia. *) + (* Qed. *) + + (* (* folds and natural number folds compute the same thing *) *) + (* Lemma foldi_to_foldi_nat : *) + (* forall {acc: choice_type} *) + (* (lo: uint_size) *) + (* (hi: uint_size) (* {lo <= hi} *) *) + (* {L I} *) + (* (f: (uint_size) -> acc -> code L I (acc)) (* {i < hi} *) *) + (* (init: acc), *) + (* (unsigned lo <= unsigned hi)%Z -> *) + (* foldi_pre lo hi f init = foldi_nat (Z.to_nat (unsigned lo)) (Z.to_nat (unsigned hi)) (fun x => f (repr _ (Z.of_nat x))) init. *) + (* Proof. *) + (* intros. *) + + (* unfold foldi_pre. *) + (* unfold foldi_nat. *) + + (* destruct (uint_size_as_nat hi) as [ hi_n [ hi_eq hi_H ] ] ; subst. *) + (* rewrite (@unsigned_repr_alt U32 _ hi_H) in *. *) + (* rewrite Nat2Z.id. *) + + (* destruct (uint_size_as_nat lo) as [ lo_n [ lo_eq lo_H ] ] ; subst. *) + (* rewrite (@unsigned_repr_alt U32 _ lo_H) in *. *) + (* rewrite Nat2Z.id. *) + + (* remember (hi_n - lo_n)%nat as n. *) + (* apply f_equal with (f := Z.of_nat) in Heqn. *) + (* rewrite (Nat2Z.inj_sub) in Heqn by (apply Nat2Z.inj_le ; apply H). *) + (* rewrite <- Heqn. *) + + (* assert (H_bound : (Z.pred 0 < Z.of_nat n < @modulus U32)%Z) by lia. *) + + (* clear Heqn. *) + (* induction n. *) + (* - reflexivity. *) + (* - pose proof (H_max_bound := modulus_range_helper _ (range_of_nat_succ _ H_bound)). *) + (* rewrite <- foldi__nat_move_S_fuel by apply H_max_bound. *) + (* cbn. *) + (* rewrite SuccNat2Pos.id_succ. *) + (* rewrite <- foldi__move_S_fuel by apply H_max_bound. *) + + (* destruct n. *) + (* + cbn. *) + (* replace (repr _ 0%Z) with (@zero U32) by (apply word_ext ; reflexivity). *) + (* unfold Hacspec_Lib_Pre.int_add. *) + (* rewrite add0w. *) + (* reflexivity. *) + (* + assert (H_bound_pred: (Z.pred 0 < Z.pos (Pos.of_succ_nat n) < @modulus U32)%Z) by lia. *) + (* rewrite <- (IHn H_bound_pred) ; clear IHn. *) + (* f_equal. *) + (* * cbn in *. *) + (* setoid_rewrite foldi__move_S. *) + (* f_equal. *) + (* lia. *) + (* * apply functional_extensionality. *) + (* intros. *) + + (* (* unfold int_add. *) *) + + (* setoid_rewrite bind_rewrite. *) + (* replace (Hacspec_Lib_Pre.int_add _ _) with (@repr U32 (Z.of_nat (Init.Nat.add (S n) lo_n))). reflexivity. *) + + (* apply word_ext. *) + + (* replace (urepr _) with (@unsigned U32 (repr _ (Z.of_nat (S n)))) by reflexivity. *) + (* replace (urepr _) with (@unsigned U32 (repr _ (Z.of_nat lo_n))) by reflexivity. *) + (* do 2 rewrite unsigned_repr_alt by lia. *) + (* rewrite Nat2Z.inj_add. *) + (* reflexivity. *) + (* Qed. *) + + (* Lemma foldi_nat_to_foldi : *) + (* forall {acc: choice_type} *) + (* (lo: nat) *) + (* (hi: nat) (* {lo <= hi} *) *) + (* {L I} *) + (* (f: nat -> acc -> code L I (acc)) (* {i < hi} *) *) + (* (init: acc), *) + (* (lo <= hi) -> *) + (* (Z.of_nat hi < @modulus U32)%Z -> *) + (* (forall x, f x = f (from_uint_size (repr _ (Z.of_nat x)))) -> *) + (* foldi_nat lo hi f init = *) + (* foldi_pre (usize lo) (usize hi) (fun x => f (from_uint_size x)) init. *) + (* Proof. *) + (* intros. *) + (* rewrite foldi_to_foldi_nat. *) + (* 2: { *) + (* unfold nat_uint_sizeable. *) + (* unfold usize, is_pure. *) + (* unfold Hacspec_Lib_Pre.usize. *) + + (* do 2 rewrite wunsigned_repr. *) + (* rewrite Zmod_small by (split ; [ lia | apply Z.le_lt_trans with (m := Z.of_nat hi) ; try apply inj_le ; assumption ]). *) + (* rewrite Zmod_small by (split ; try easy ; lia). *) + (* lia. *) + (* } *) + + (* unfold nat_uint_sizeable. *) + (* unfold usize, is_pure. *) + (* unfold Hacspec_Lib_Pre.usize. *) + + (* do 2 rewrite wunsigned_repr. *) + (* rewrite Zmod_small by (split ; [ lia | apply Z.le_lt_trans with (m := Z.of_nat hi) ; try apply inj_le ; assumption ]). *) + (* rewrite Zmod_small by (split ; try easy ; lia). *) + (* do 2 rewrite Nat2Z.id. *) + + (* f_equal. *) + (* apply functional_extensionality. intros. *) + (* rewrite <- H1. *) + (* reflexivity. *) + (* Qed. *) + + (* (* folds can be computed by doing one iteration and incrementing the lower bound *) *) + (* Lemma foldi_nat_split_S : *) + (* forall {acc: choice_type} *) + (* (lo: nat) *) + (* (hi: nat) (* {lo <= hi} *) *) + (* (f: nat -> acc -> raw_code (acc)) (* {i < hi} *) *) + (* (init: acc), *) + (* (lo < hi)%nat -> *) + (* foldi_nat lo hi f init = (cur' ← foldi_nat lo (S lo) f init ;; foldi_nat (S lo) hi f (cur')). *) + (* Proof. *) + (* unfold foldi_nat. *) + (* intros. *) + + (* assert (succ_sub_diag : forall n, (S n - n = 1)%nat) by lia. *) + (* rewrite (succ_sub_diag lo). *) + + (* induction hi ; [ lia | ]. *) + (* destruct (S hi =? S lo)%nat eqn:hi_eq_lo. *) + (* - apply Nat.eqb_eq in hi_eq_lo ; rewrite hi_eq_lo in *. *) + (* rewrite (succ_sub_diag lo). *) + (* rewrite Nat.sub_diag. *) + + (* rewrite raw_code_type_from_choice_type_id. *) + (* reflexivity. *) + (* - apply Nat.eqb_neq in hi_eq_lo. *) + (* apply Nat.lt_gt_cases in hi_eq_lo. *) + (* destruct hi_eq_lo. *) + (* + lia. *) + (* + rewrite (Nat.sub_succ_l (S lo)) by apply (Nat.lt_le_pred _ _ H0). *) + (* rewrite Nat.sub_succ_l by apply (Nat.lt_le_pred _ _ H). *) + (* replace ((S (hi - S lo))) with (hi - lo)%nat by lia. *) + + (* unfold foldi_nat_. *) + (* fold (@foldi_nat_ acc). *) + (* rewrite raw_code_type_from_choice_type_id. *) + (* reflexivity. *) + (* Qed. *) + + (* (* folds can be split at some valid offset from lower bound *) *) + (* Lemma foldi_nat_split_add : *) + (* forall (k : nat), *) + (* forall {acc: choice_type} *) + (* (lo: nat) *) + (* (hi: nat) (* {lo <= hi} *) *) + (* (f: nat -> acc -> raw_code (acc)) (* {i < hi} *) *) + (* (init: acc), *) + (* forall {guarantee: (lo + k <= hi)%nat}, *) + (* foldi_nat lo hi f init = (cur' ← foldi_nat lo (k + lo) f init ;; foldi_nat (k + lo) hi f (cur')). *) + (* Proof. *) + (* induction k ; intros. *) + (* - cbn. *) + (* unfold foldi_nat. *) + (* rewrite Nat.sub_diag. *) + (* cbn. *) + (* reflexivity. *) + (* - rewrite foldi_nat_split_S by lia. *) + (* replace (S k + lo)%nat with (k + S lo)%nat by lia. *) + (* specialize (IHk acc (S lo) hi f). *) + + (* rewrite bind_cong with (v := foldi_nat lo (S lo) (fun (x : nat) (x0 : acc) => f x x0) init) (g := fun v => (cur' ← foldi_nat (S lo) (k + S lo) (fun (x : nat) (x0 : acc) => f x x0) (v) ;; *) + (* foldi_nat (k + S lo) hi (fun (x : nat) (x0 : acc) => f x x0) *) + (* (cur'))). *) + + (* rewrite <- bind_assoc. *) + (* f_equal. *) + + (* rewrite <- foldi_nat_split_S by lia. *) + (* reflexivity. *) + + (* reflexivity. *) + + (* apply functional_extensionality. intros. rewrite IHk by lia. reflexivity. *) + (* Qed. *) + + (* (* folds can be split at some midpoint *) *) + (* Lemma foldi_nat_split : *) + (* forall (mid : nat), (* {lo <= mid <= hi} *) *) + (* forall {acc: choice_type} *) + (* (lo: nat) *) + (* (hi: nat) (* {lo <= hi} *) *) + (* (f: nat -> acc -> raw_code (acc)) (* {i < hi} *) *) + (* (init: acc), *) + (* forall {guarantee: (lo <= mid <= hi)%nat}, *) + (* foldi_nat lo hi f init = (cur' ← foldi_nat lo mid f init ;; foldi_nat mid hi f (cur')). *) + (* Proof. *) + (* intros. *) + (* assert (mid_is_low_plus_constant : {k : nat | (mid = lo + k)%nat}) by (exists (mid - lo)%nat ; lia). *) + (* destruct mid_is_low_plus_constant ; subst. *) + (* rewrite Nat.add_comm. *) + (* pose foldi_nat_split_add. *) + (* apply foldi_nat_split_add. *) + (* apply guarantee. *) + (* Qed. *) + + (* (* folds can be split at some midpoint *) *) + (* Lemma foldi_split : *) + (* forall (mid : uint_size), (* {lo <= mid <= hi} *) *) + (* forall {acc: choice_type} *) + (* (lo: uint_size) *) + (* (hi: uint_size) (* {lo <= hi} *) *) + (* {L I} *) + (* (f: uint_size -> acc -> code L I (acc)) (* {i < hi} *) *) + (* (init: acc), *) + (* forall {guarantee: (unsigned lo <= unsigned mid <= unsigned hi)%Z}, *) + (* foldi_pre lo hi f init = (cur' ← foldi_pre lo mid f init ;; foldi_pre mid hi f (cur')). *) + (* Proof. *) + (* intros. *) + (* rewrite foldi_to_foldi_nat by lia. *) + (* rewrite foldi_to_foldi_nat by lia. *) + + (* pose @foldi_to_foldi_nat. *) + + (* rewrite bind_cong with (v := foldi_nat (Z.to_nat (unsigned lo)) (Z.to_nat (unsigned mid)) *) + (* (fun x : nat => f (repr _ (Z.of_nat x))) init) (g := fun init => foldi_nat (Z.to_nat (unsigned mid)) (Z.to_nat (unsigned hi)) *) + (* (fun x : nat => f (repr _ (Z.of_nat x))) (init)). *) + + (* apply foldi_nat_split ; lia. *) + (* reflexivity. *) + (* apply functional_extensionality. *) + (* intros. *) + + (* rewrite foldi_to_foldi_nat by lia. *) + (* reflexivity. *) + (* Qed. *) + + + (* Lemma valid_foldi_pre : *) + (* forall {acc : choice_type} (lo hi : int _) {L : {fset Location}} {I : Interface} (f : int _ -> _ -> both L I (_)), *) + (* forall init : (_), *) + (* ValidBoth L I (foldi_pre (acc := acc) lo hi f init). *) + (* Proof. *) + (* intros. *) + (* unfold foldi_pre. *) + (* destruct (unsigned hi - unsigned lo)%Z. *) + (* - apply both_ret_valid. *) + (* - apply valid_foldi_. *) + (* - apply both_ret_valid. *) + (* Qed. *) + + (* Program Definition foldi *) + (* {acc: choice_type} *) + (* (lo: uint_size) *) + (* (hi: uint_size) (* {lo <= hi} *) *) + (* {L} *) + (* {I} *) + (* (f: (uint_size) -> acc -> both L I (acc)) *) + (* (init: acc) *) + (* : *) + (* both L I (acc) := *) + (* {| both_prog := foldi_pre lo hi f init; both_prog_valid := valid_foldi_pre lo hi f init |}. *) + (* Next Obligation. *) + (* intros. *) + (* unfold foldi_pre. *) + (* destruct (unsigned _ - _)%Z. *) + (* - now apply r_ret. *) + (* - generalize dependent lo. *) + (* generalize dependent init. *) + (* induction (Pos.to_nat p) ; intros. *) + (* + now apply r_ret. *) + (* + simpl. *) + (* pattern_both_fresh. *) + (* change (H1 (is_pure H)) with (temp_x ← ret (is_pure H) ;; H1 temp_x). *) + (* r_bind_both (f lo init). *) + (* subst H H0 H1. hnf. *) + (* apply IHn. *) + (* - now apply r_ret. *) + (* Qed. *) + (* (* Definition foldi' *) *) + (* (* {acc: choice_type} *) *) + (* (* (lo: uint_size) *) *) + (* (* (hi: uint_size) (* {lo <= hi} *) *) *) + (* (* {L1 L2 : {fset Location}} {H_loc_incl : List.incl L1 L2} *) *) + (* (* {I1 I2 : Interface} {H_opsig_incl : List.incl I1 I2} *) *) + (* (* (f: (uint_size) -> acc -> code L1 I1 (acc)) *) *) + (* (* (init: acc) *) *) + (* (* : *) *) + (* (* code L2 I2 (acc) *) *) + (* (* . *) *) + + (* eapply lift_code_scope. *) + (* apply (foldi lo hi f init). *) + (* apply H_loc_incl. *) + (* apply H_opsig_incl. *) + (* Defined. *) + + Lemma valid_remove_back : + forall x (xs : {fset Location}) I {ct} c, + ValidCode (fset xs) I c -> + @ValidCode (fset (xs ++ [x])) I ct c. + Proof. + intros. + apply (valid_injectLocations) with (L1 := fset xs). + - rewrite fset_cat. + apply fsubsetUl. + - apply H. + Qed. + + Lemma list_constructor : forall {A : Type} (x : A) (xs : list A) (l : list A) (H : (x :: xs) = l), (l <> []). + Proof. + intros. + subst. + easy. + Qed. + + Definition pop_back {A : Type} (l : list A) := + match (rev l) with + | [] => [] + | (x :: xs) => rev xs ++ [x] + end. + + Theorem pop_back_ignore_front : forall {A} (a : A) (l : list A), pop_back (a :: l) = a :: pop_back l. + Proof. + intros. + induction l ; intros. + - reflexivity. + - unfold pop_back. + destruct (rev (a :: a0 :: l)) eqn:orev. + { apply f_equal with (f := @rev A) in orev. + rewrite (rev_involutive) in orev. + discriminate orev. + } + cbn in orev. + + destruct (rev (a0 :: l)) eqn:orev2. + { apply f_equal with (f := @rev A) in orev2. + rewrite (rev_involutive) in orev2. + discriminate orev2. + } + cbn in orev2. + rewrite orev2 in orev ; clear orev2. + + inversion_clear orev. + rewrite rev_unit. + reflexivity. + Qed. + + Theorem pop_back_is_id : forall {A} (l : list A), l = pop_back l. + Proof. + intros. + induction l. + - reflexivity. + - destruct l. + + reflexivity. + + rewrite pop_back_ignore_front. + rewrite <- IHl. + reflexivity. + Qed. + + Ltac valid_remove_back' := + match goal with + | _ : _ |- (ValidCode (fset (?l)) _ _) => + rewrite (@pop_back_is_id _ l) + end ; + apply valid_remove_back. + + + Lemma valid_remove_front : + forall x xs I {ct} c, + ValidCode (fset xs) I c -> + @ValidCode (fset (x :: xs)) I ct c. + Proof. + intros. + apply (@valid_injectLocations) with (L1 := fset xs). + - replace (x :: xs) with (seq.cat [x] xs) by reflexivity. + rewrite fset_cat. + apply fsubsetUr. + - apply H. + Qed. + +Theorem for_loop_unfold : + forall c n, + for_loop (fun m : nat => c m) (S n) = + (c 0 ;; for_loop (fun m : nat => c (S m)) (n) ). + cbn. + induction n ; intros. + - reflexivity. + - unfold for_loop ; fold for_loop. + cbn. + rewrite IHn. + rewrite bind_assoc. + reflexivity. +Qed. + +End Loops. + +(*** Seq *) + +(* Section Seqs. *) + + (**** Unsafe functions *) + + Notation seq_new_ := (lift2_both seq_new_). + Notation seq_new := (lift1_both seq_new). + Equations seq_len {L (* L2 *) : {fset Location}} {I (* I2 *) : Interface} {A : choice_type} (x : both L I (seq A)) (* `{H_loc_incl_x : is_true (fsubset L1 L2)} `{H_opsig_incl_x : is_true (fsubset I1 I2)} *) : both L I (uint_size) := + seq_len := (lift1_both Hacspec_Lib_Pre.seq_len). + Fail Next Obligation. + Notation seq_index := (lift2_both seq_index). + +(**** Seq manipulation *) + +(* Notation seq_slice := (lift3_both seq_slice). *) + +Notation seq_slice_range := + (lift2_both seq_slice_range). + +(* updating a subsequence in a sequence *) +Definition seq_update + {a: choice_type} + (s: ((seq a))) + (start: uint_size) + (input: ((seq a))) + : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_update s start input). + +(* updating only a single value in a sequence*) +Definition seq_upd + {a: choice_type} + + (s: ((seq a))) + (start: uint_size) + (v: ((a))) + : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_upd s start v). + +Definition seq_update_start + {a: choice_type} + + (s: ( (seq a))) + (start_s: ( (seq a))) + : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_update_start s start_s). + +Definition seq_update_slice + {A : choice_type} + (out: ( (seq A))) + (start_out: nat) + (input: ( (seq A))) + (start_in: nat) + (len: nat) + : both (fset []) ([interface]) ((seq A)) := + ret_both (seq_update_slice out start_out input start_in len). + +Definition seq_concat + {a : choice_type} + + (s1 :( (seq a))) + (s2: ( (seq a))) + : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_concat s1 s2). + +Notation seq_push := (lift2_both seq_push). + +Definition seq_from_slice + {a: choice_type} + + (input: ( (seq a))) + (start_fin: uint_size × uint_size) + : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_from_slice input start_fin). + +Definition seq_from_slice_range + {a: choice_type} + + (input: ( (seq a))) + (start_fin: uint_size × uint_size) + : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_from_slice_range input start_fin). + +Definition seq_from_seq {A} (l : (seq A)) : both (fset []) ([interface]) (seq A) := + ret_both (seq_from_seq l). + +(**** Chunking *) + +Definition seq_num_chunks {a: choice_type} (s: ( (seq a))) (chunk_len: uint_size) : both (fset []) ([interface]) (uint_size) := + ret_both (seq_num_chunks s chunk_len). + +Definition seq_chunk_len + {a: choice_type} + (s: ( (seq a))) + (chunk_len: nat) + (chunk_num: nat) + : both (fset []) ([interface]) (('nat)) := + ret_both (seq_chunk_len s chunk_len chunk_num). + +Definition seq_get_chunk + {a: choice_type} + + (s: ( (seq a))) + (chunk_len: uint_size) + (chunk_num: uint_size) + : both (fset []) ([interface]) (((uint_size × seq a))) := + ret_both (seq_get_chunk s chunk_len chunk_num). + +Definition seq_set_chunk + {a: choice_type} + + (s: ( (seq a))) + (chunk_len: uint_size) + (chunk_num: uint_size) + (chunk: ( (seq a)) ) : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_set_chunk s chunk_len chunk_num chunk). + + +Definition seq_num_exact_chunks {a} (l : ( (seq a))) (chunk_size : ( (uint_size))) : (both (fset []) ([interface]) uint_size) := + ret_both (seq_num_exact_chunks l chunk_size). + +Definition seq_get_exact_chunk {a : choice_type} (l : ( (seq a))) (chunk_size chunk_num: ( (uint_size))) : + both (fset []) ([interface]) ((seq a)) := + ret_both (seq_get_exact_chunk l chunk_size chunk_num). + +Definition seq_set_exact_chunk {a : choice_type} := + @seq_set_chunk a. + +Definition seq_get_remainder_chunk {a : choice_type} (l : (seq a)) (chunk_size : (uint_size)) : both (fset []) ([interface]) ((seq a)) := + ret_both (seq_get_remainder_chunk l chunk_size). + +Definition seq_xor_ {WS} (x y : seq (@int WS)) : both (fset []) ([interface]) (seq (@int WS)) := + ret_both (seq_xor_ x y). + +Definition seq_truncate {a : choice_type} (x : seq a) (n : nat) : both (fset []) ([interface]) (seq a) := + ret_both (seq_truncate x n). + +(* End Seqs. *) +Infix "seq_xor" := seq_xor_ (at level 33) : hacspec_scope. + +(* Section Arrays. *) + (**** types *) + + (***** prelude.rs *) + Definition uint128_word_t : choice_type := nseq_ uint8 16. + Definition uint64_word_t : choice_type := nseq_ uint8 8. + Definition uint32_word_t : choice_type := nseq_ uint8 4. + Definition uint16_word_t : choice_type := nseq_ uint8 2. + + (**** Array manipulation *) + Equations array_new_ {A: choice_type} {L I} (init: both L I A) `(len: uint_size) : both L I (nseq A len) := + array_new_ init len := lift1_both (fun x => Hacspec_Lib_Pre.array_new_ x (from_uint_size len)) init. + + Equations array_index {L1 L2 (* L3 *) : {fset Location}} {I1 I2 (* I3 *) : Interface} + {A: choice_type} {len : nat} (x : both L1 I1 (nseq_ A len)) {WS} (y : both L2 I2 (int WS)) + (* `{H_loc_incl_x : is_true (fsubset L1 L3)} `{H_opsig_incl_x : is_true (fsubset I1 I3)} *) + (* `{H_loc_incl_y : is_true (fsubset L2 L3)} `{H_opsig_incl_y : is_true (fsubset I2 I3)} *) : both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) A := + array_index x (WS := WS) y := lift2_both (fun x y => Hacspec_Lib_Pre.array_index x y) x y. + Fail Next Obligation. + + Equations array_upd {L1 L2 L3} {I1 I2 I3} {A : choice_type} {len} (s: both L1 I1 (nseq_ A len)) (i: both L2 I2 (@int U32)) (new_v: both L3 I3 A) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (nseq_ A len) := + array_upd s i new_v := + (lift3_both (fun (s : nseq_ A len) i new_v => Hacspec_Lib_Pre.array_upd s i new_v) s i new_v). + + (* substitutes a sequence (seq) into an array (nseq), given index interval *) + Definition update_sub {A : choice_type} {len slen} (v : (nseq_ A len)) (i : nat) (n : nat) (sub : (nseq_ A slen)) : both (fset []) ([interface]) ((nseq_ A len)) := + ret_both (update_sub v i n sub). + + Program Fixpoint array_from_list_helper {A: choice_type} {L I} (x : both L I A) (xs: list (both L I A)) (k : nat) {measure (length xs)} : both L I (nseq_ A (S k)) := + match xs with + | [] => lift1_both (* (H_loc_incl_x := fsubsetxx L) *) (* (H_opsig_incl_x := fsubsetxx I) *) (fun x => setm emptym (Ordinal (ssrbool.introT ssrnat.ltP (lt_succ_diag_r_sub k O))) x : nseq_ A (S k)) x + | y :: ys => + bind_both x (fun temp_x => + bind_both (array_from_list_helper y ys k) (fun temp_y => + lift_both (fsubset_loc := _) (fsubset_opsig := _) (ret_both (setm (temp_y : nseq_ A (S k)) (Ordinal (ssrbool.introT ssrnat.ltP (lt_succ_diag_r_sub k (length (y :: ys))))) temp_x : nseq_ A (S k)))) (fsubset_loc := _) (fsubset_opsig := _)) (fsubset_loc := _) (fsubset_opsig := _) + end. + Solve All Obligations with (intros ; (* time *) (fset_equality || solve_in_fset)). + Fail Next Obligation. + + Equations array_from_list {A: choice_type} {L I} (l: list (both L I A)) + : both L I (nseq_ A (length l)) := + array_from_list l := + match l as k return both L I (nseq_ A (length k)) with + [] => solve_lift (ret_both (tt : nseq_ A 0)) + | (x :: xs) => array_from_list_helper x xs (length xs) + end. + Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). + Fail Next Obligation. + + Program Definition array_from_seq {A: choice_type} {L I} (out_len: nat) (input: both L I (seq A)) : both L I (nseq_ A out_len) := + lift1_both (* (H_loc_incl_x := fsubsetxx _) (H_opsig_incl_x := fsubsetxx _) *) (array_from_seq out_len) input. + + Equations array_to_seq {L (* L2 *) : {fset Location}} {I (* I2 *) : Interface} + {A : choice_type} {n} (f : both L I (nseq_ A n)) + (* `{H_loc_incl_x : is_true (fsubset L1 L2)} `{H_opsig_incl_x : is_true (fsubset I1 I2)} *) : both L I (seq A) := + array_to_seq := (lift1_both Hacspec_Lib_Pre.array_to_seq). + Fail Next Obligation. + + Definition array_from_slice + {a: choice_type} + + (default_value: ( a)) + (out_len: nat) + (input: (seq a)) + (start: uint_size) + (slice_len: uint_size) : both (fset []) ([interface]) ((nseq_ a out_len)) := + ret_both (array_from_slice default_value out_len input (from_uint_size start) (from_uint_size slice_len)). + + Definition array_slice + {a: choice_type} + + (input: (seq a)) + (start: nat) + (slice_len: nat) + : both (fset []) ([interface]) ((nseq_ a slice_len)) := + ret_both (array_slice input start slice_len). + + Definition array_from_slice_range + {a: choice_type} + + (default_value: a) + (out_len: nat) + (input: (seq a)) + (start_fin: (uint_size × uint_size)) + : both (fset []) ([interface]) ((nseq_ a out_len)) := + ret_both (array_from_slice_range default_value out_len input start_fin). + + Definition array_slice_range + {a: choice_type} + + {len : nat} + (input: (nseq_ a len)) + (start_fin:(uint_size × uint_size)) + : both (fset []) ([interface]) ((seq a)) := + ret_both (array_slice_range input start_fin). + + Definition array_update + {a: choice_type} + + {len: nat} + (s: (nseq_ a len)) + (start : uint_size) + (start_s: (seq a)) + : both (fset []) ([interface]) ((nseq_ a len)) := + ret_both (array_update s start start_s). + + Definition array_update_start + {a: choice_type} + + {len: nat} + (s: (nseq_ a len)) + (start_s: (seq a)) + : both (fset []) ([interface]) ((nseq_ a len)) := + ret_both (array_update_start s start_s). + + Definition array_len {a: choice_type} {len: nat} (s: (nseq_ a len)) : both (fset []) ([interface]) (uint_size) := ret_both (array_len s). + (* May also come up as 'length' instead of 'len' *) + Definition array_length {a: choice_type} {len: nat} (s: (nseq_ a len)) : both (fset []) ([interface]) (uint_size) := ret_both (array_length s). + + Definition array_update_slice + {a : choice_type} + + {l : nat} + (out: ( (nseq_ a l))) + (start_out: uint_size) + (input: ( (seq a))) + (start_in: uint_size) + (len: uint_size) + : both (fset []) ([interface]) ((nseq_ a _)) := + ret_both (array_update_slice (l := l) out start_out input start_in (from_uint_size len)). + + (**** Numeric operations *) + +(* End Arrays. *) + + +(**** Integers to arrays *) +Definition uint32_to_le_bytes (n : int32) : both (fset []) ([interface]) ((nseq_ int8 4)) := ret_both (uint32_to_le_bytes n). +Definition uint32_to_be_bytes (n : int32) : both (fset []) ([interface]) ((nseq_ int8 4)) := ret_both (uint32_to_be_bytes n). +Definition uint32_from_le_bytes (n : (nseq_ int8 4)) : both (fset []) ([interface]) ((int32)) := ret_both (uint32_from_le_bytes n). +Definition uint32_from_be_bytes (n : (nseq_ int8 4)) : both (fset []) ([interface]) ((int32)) := ret_both (uint32_from_be_bytes n). +Definition uint64_to_le_bytes (n : int64) : both (fset []) ([interface]) ((nseq_ int8 8)) := ret_both (uint64_to_le_bytes n). +Definition uint64_to_be_bytes (n : int64) : both (fset []) ([interface]) ((nseq_ int8 8)) := ret_both (uint64_to_be_bytes n). +Definition uint64_from_le_bytes (n : (nseq_ int8 8)) : both (fset []) ([interface]) ((int64)) := ret_both (uint64_from_le_bytes n). +Definition uint64_from_be_bytes (n : (nseq_ int8 8)) : both (fset []) ([interface]) ((int64)) := ret_both (uint64_from_be_bytes n). +Definition uint128_to_le_bytes (n : int128) : both (fset []) ([interface]) ((nseq_ int8 16)) := ret_both (uint128_to_le_bytes n). +Definition uint128_to_be_bytes (n : int128) : both (fset []) ([interface]) ((nseq_ int8 16)) := ret_both (uint128_to_be_bytes n). +Definition uint128_from_le_bytes (n : (nseq_ int8 16)) : both (fset []) ([interface]) (int128) := ret_both (uint128_from_le_bytes n). +Definition uint128_from_be_bytes (n : (nseq_ int8 16)) : both (fset []) ([interface]) ((int128)) := ret_both (uint128_from_be_bytes n). +Definition u32_to_le_bytes (n : int32) : both (fset []) ([interface]) ((nseq_ int8 4)) := ret_both (u32_to_le_bytes n). +Definition u32_to_be_bytes (n : int32) : both (fset []) ([interface]) ((nseq_ int8 4)) := ret_both (u32_to_be_bytes n). +Definition u32_from_le_bytes (n : (nseq_ int8 4)) : both (fset []) ([interface]) ((int32)) := ret_both (u32_from_le_bytes n). +Definition u32_from_be_bytes (n : (nseq_ int8 4)) : both (fset []) ([interface]) ((int32)) := ret_both (u32_from_be_bytes n). +Definition u64_to_le_bytes (n : int64) : both (fset []) ([interface]) ((nseq_ int8 8)) := ret_both (u64_to_le_bytes n). +Definition u64_from_le_bytes (n : (nseq_ int8 8)) : both (fset []) ([interface]) ((int64)) := ret_both (u64_from_le_bytes n). +Definition u128_to_le_bytes (n : int128) : both (fset []) ([interface]) ((nseq_ int8 16)) := ret_both (u128_to_le_bytes n). +Definition u128_to_be_bytes (n : int128) : both (fset []) ([interface]) ((nseq_ int8 16)) := ret_both (u128_to_be_bytes n). +Definition u128_from_le_bytes (n : (nseq_ int8 16)) : both (fset []) ([interface]) ((int128)) := ret_both (u128_from_le_bytes n). +Definition u128_from_be_bytes (n : (nseq_ int8 16)) : both (fset []) ([interface]) ((int128)) := ret_both (u128_from_be_bytes n). + +(*** Nats *) + + +Section Todosection. + +Definition nat_mod_equal {p} (a b : nat_mod p) : both (fset []) ([interface]) 'bool := + ret_both (@eqtype.eq_op (ordinal_eqType (S (Init.Nat.pred (Z.to_nat p)))) a b : 'bool). + +Definition nat_mod_equal_reflect {p} {a b} : Bool.reflect (a = b) (is_pure (@nat_mod_equal p a b)) := + @eqtype.eqP (ordinal_eqType (S (Init.Nat.pred (Z.to_nat p)))) a b. + +Definition nat_mod_zero {p} : both (fset []) ([interface]) ((nat_mod p)) := ret_both (nat_mod_zero). +Definition nat_mod_one {p} : both (fset []) ([interface]) ((nat_mod p)) := ret_both (nat_mod_one). +Definition nat_mod_two {p} : both (fset []) ([interface]) ((nat_mod p)) := ret_both (nat_mod_two). + +Definition nat_mod_add {n : Z} (a : nat_mod n) (b : nat_mod n) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_add a b). +Definition nat_mod_mul {n : Z} (a:nat_mod n) (b:nat_mod n) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_mul a b). +Definition nat_mod_sub {n : Z} (a:nat_mod n) (b:nat_mod n) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_sub a b). +Definition nat_mod_div {n : Z} (a:nat_mod n) (b:nat_mod n) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_div a b). + +Definition nat_mod_neg {n : Z} (a:nat_mod n) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_neg a). + +Definition nat_mod_inv {n : Z} (a:nat_mod n) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_inv a). + +Definition nat_mod_exp_def {p : Z} (a:nat_mod p) (n : nat) : both (fset []) ([interface]) (nat_mod p) := + ret_both (nat_mod_exp_def a n). + +Definition nat_mod_exp {WS} {p} a n := @nat_mod_exp_def p a (Z.to_nat (@unsigned WS n)). +Definition nat_mod_pow {WS} {p} a n := @nat_mod_exp_def p a (Z.to_nat (@unsigned WS n)). +Definition nat_mod_pow_felem {p} (a n : nat_mod p) := @nat_mod_exp_def p a (Z.to_nat (nat_of_ord n)). +Definition nat_mod_pow_self {p} (a n : nat_mod p) := nat_mod_pow_felem a n. + +Close Scope nat_scope. + +Definition nat_mod_from_secret_literal {m : Z} (x:int128) : both (fset []) ([interface]) (nat_mod m) := + ret_both (@nat_mod_from_secret_literal m x). + +Definition nat_mod_from_literal (m : Z) (x:int128) : both (fset []) ([interface]) ((nat_mod m)) := nat_mod_from_secret_literal x. + +Definition nat_mod_to_byte_seq_le {n : Z} (m : nat_mod n) : both (fset []) ([interface]) (seq int8) := ret_both (nat_mod_to_byte_seq_le m). +Definition nat_mod_to_byte_seq_be {n : Z} (m : nat_mod n) : both (fset []) ([interface]) (seq int8) := ret_both (nat_mod_to_byte_seq_be m). +Definition nat_mod_to_public_byte_seq_le (n : Z) (m : nat_mod n) : both (fset []) ([interface]) (seq int8) := ret_both (nat_mod_to_public_byte_seq_le n m). +Definition nat_mod_to_public_byte_seq_be (n : Z) (m : nat_mod n) : both (fset []) ([interface]) (seq int8) := ret_both (nat_mod_to_public_byte_seq_be n m). + +Definition nat_mod_bit {n : Z} (a : nat_mod n) (i : uint_size) : both (fset []) ([interface]) 'bool := + ret_both (nat_mod_bit a i). + +(* Alias for nat_mod_bit *) +Definition nat_get_mod_bit {p} (a : nat_mod p) (i : uint_size) : both (fset []) ([interface]) 'bool := ret_both (nat_get_mod_bit a i). +Definition nat_mod_get_bit {p} (a : nat_mod p) n : both (fset []) ([interface]) (nat_mod p) := + ret_both (nat_mod_get_bit a n). + +Definition array_declassify_eq {A l} (x : nseq_ A l) (y : nseq_ A l) : both (fset []) ([interface]) 'bool := ret_both (array_declassify_eq x y). +Definition array_to_le_uint32s {A l} (x : nseq_ A l) : both (fset []) ([interface]) (seq uint32) := ret_both (array_to_le_uint32s x). +Definition array_to_be_uint32s {l} (x : nseq_ uint8 l) : both (fset []) ([interface]) (seq uint32) := ret_both (array_to_be_uint32s x). +Definition array_to_le_uint64s {A l} (x : nseq_ A l) : both (fset []) ([interface]) (seq uint64) := ret_both (array_to_le_uint64s x). +Definition array_to_be_uint64s {l} (x : nseq_ uint8 l) : both (fset []) ([interface]) (seq uint64) := ret_both (array_to_be_uint64s x). +Definition array_to_le_uint128s {A l} (x : nseq_ A l) : both (fset []) ([interface]) (seq uint128) := ret_both (array_to_le_uint128s x). +Definition array_to_be_uint128s {l} (x : nseq_ uint8 l) : both (fset []) ([interface]) (seq uint128) := ret_both (array_to_be_uint128s x). +Definition array_to_le_bytes {A l} (x : nseq_ A l) : both (fset []) ([interface]) (seq uint8) := ret_both (array_to_le_bytes x). +Definition array_to_be_bytes {A l} (x : nseq_ A l) : both (fset []) ([interface]) (seq uint8) := ret_both (array_to_be_bytes x). +Definition nat_mod_from_byte_seq_le {A n} (x : seq A) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_from_byte_seq_le x). +Definition most_significant_bit {m} (x : nat_mod m) (n : uint_size) : both (fset []) ([interface]) (uint_size) := ret_both (most_significant_bit x n). + + +(* We assume 2^x < m *) + +Definition nat_mod_pow2 (m : Z) {WS} (x : (@int WS)) : both (fset []) ([interface]) ((nat_mod m)) := + ret_both (nat_mod_pow2 m (Z.to_nat (unsigned x))). + +End Todosection. + +Infix "+%" := nat_mod_add (at level 33) : hacspec_scope. +Infix "*%" := nat_mod_mul (at level 33) : hacspec_scope. +Infix "-%" := nat_mod_sub (at level 33) : hacspec_scope. +Infix "/%" := nat_mod_div (at level 33) : hacspec_scope. + +(*** Casting *) + +Section TodoSection2. + +Definition uint128_from_usize (n : uint_size) : both (fset []) ([interface]) int128 := ret_both (repr _ (unsigned n)). +Definition uint64_from_usize (n : uint_size) : both (fset []) ([interface]) int64 := ret_both (repr _ (unsigned n)). +Definition uint32_from_usize (n : uint_size) : both (fset []) ([interface]) int32 := ret_both (repr _ (unsigned n)). +Definition uint16_from_usize (n : uint_size) : both (fset []) ([interface]) int16 := ret_both (repr _ (unsigned n)). +Definition uint8_from_usize (n : uint_size) : both (fset []) ([interface]) int8 := ret_both (repr _ (unsigned n)). + +Definition uint128_from_uint8 (n : int8) : both (fset []) ([interface]) int128 := ret_both (repr _ (unsigned n)). +Definition uint64_from_uint8 (n : int8) : both (fset []) ([interface]) int64 := ret_both (repr _ (unsigned n)). +Definition uint32_from_uint8 (n : int8) : both (fset []) ([interface]) int32 := ret_both (repr _ (unsigned n)). +Definition uint16_from_uint8 (n : int8) : both (fset []) ([interface]) int16 := ret_both (repr _ (unsigned n)). +Definition usize_from_uint8 (n : int8) : both (fset []) ([interface]) uint_size := ret_both (repr _ (unsigned n)). + +Definition uint128_from_uint16 (n : int16) : both (fset []) ([interface]) int128 := ret_both (repr _ (unsigned n)). +Definition uint64_from_uint16 (n : int16) : both (fset []) ([interface]) int64 := ret_both (repr _ (unsigned n)). +Definition uint32_from_uint16 (n : int16) : both (fset []) ([interface]) int32 := ret_both (repr _ (unsigned n)). +Definition uint8_from_uint16 (n : int16) : both (fset []) ([interface]) int8 := ret_both (repr _ (unsigned n)). +Definition usize_from_uint16 (n : int16) : both (fset []) ([interface]) uint_size := ret_both (repr _ (unsigned n)). + +Definition uint128_from_uint32 (n : int32) : both (fset []) ([interface]) int128 := ret_both (repr _ (unsigned n)). +Definition uint64_from_uint32 (n : int32) : both (fset []) ([interface]) int64 := ret_both (repr _ (unsigned n)). +Definition uint16_from_uint32 (n : int32) : both (fset []) ([interface]) int16 := ret_both (repr _ (unsigned n)). +Definition uint8_from_uint32 (n : int32) : both (fset []) ([interface]) int8 := ret_both (repr _ (unsigned n)). +Definition usize_from_uint32 (n : int32) : both (fset []) ([interface]) uint_size := ret_both (repr _ (unsigned n)). + +Definition uint128_from_uint64 (n : int64) : both (fset []) ([interface]) int128 := ret_both (repr _ (unsigned n)). +Definition uint32_from_uint64 (n : int64) : both (fset []) ([interface]) int32 := ret_both (repr _ (unsigned n)). +Definition uint16_from_uint64 (n : int64) : both (fset []) ([interface]) int16 := ret_both (repr _ (unsigned n)). +Definition uint8_from_uint64 (n : int64) : both (fset []) ([interface]) int8 := ret_both (repr _ (unsigned n)). +Definition usize_from_uint64 (n : int64) : both (fset []) ([interface]) uint_size := ret_both (repr _ (unsigned n)). + +Definition uint64_from_uint128 (n : int128) : both (fset []) ([interface]) int64 := ret_both (repr _ (unsigned n)). +Definition uint32_from_uint128 (n : int128) : both (fset []) ([interface]) int32 := ret_both (repr _ (unsigned n)). +Definition uint16_from_uint128 (n : int128) : both (fset []) ([interface]) int16 := ret_both (repr _ (unsigned n)). +Definition uint8_from_uint128 (n : int128) : both (fset []) ([interface]) int8 := ret_both (repr _ (unsigned n)). +Definition usize_from_uint128 (n : int128) : both (fset []) ([interface]) uint_size := ret_both (repr _ (unsigned n)). + + +(* Comparisons, boolean equality, and notation *) + +Global Instance int_eqdec `{WS : wsize}: EqDec (@int WS) := { + eqb := eqtype.eq_op ; + eqb_leibniz := int_eqb_eq ; +}. + +Global Instance int_comparable `{WS : wsize} : Comparable (@int WS) := + eq_dec_lt_Comparable (wlt Unsigned). + +Definition uint8_equal (x y : int8) : both (fset []) ([interface]) 'bool := ret_both (eqb x y : 'bool). + +Theorem nat_mod_eqb_spec : forall {p} (a b : nat_mod p), + is_pure (nat_mod_equal a b) = true <-> a = b. +Proof. + symmetry ; apply (ssrbool.rwP nat_mod_equal_reflect). +Qed. + +Global Instance nat_mod_eqdec {p} : EqDec (nat_mod p) := { + eqb a b := is_pure (nat_mod_equal a b); + eqb_leibniz := nat_mod_eqb_spec; +}. + +Global Instance nat_mod_comparable `{p : Z} : Comparable (nat_mod p) := + eq_dec_lt_Comparable (@order.Order.lt order.Order.OrdinalOrder.ord_display (order.Order.OrdinalOrder.porderType _)). + +Definition nat_mod_rem {n : Z} (a:nat_mod n) (b:nat_mod n) : both (fset []) ([interface]) (nat_mod n) := + ret_both (nat_mod_rem a b). + + +Infix "rem" := nat_mod_rem (at level 33) : hacspec_scope. + +Global Instance bool_eqdec : EqDec bool := { + eqb := Bool.eqb; + eqb_leibniz := Bool.eqb_true_iff; +}. + +Global Instance string_eqdec : EqDec String.string := { + eqb := String.eqb; + eqb_leibniz := String.eqb_eq ; +}. + +Fixpoint list_eqdec {A} `{EqDec A} (l1 l2 : list A) : bool := + match l1, l2 with + | x::xs, y::ys => if eqb x y then list_eqdec xs ys else false + | [], [] => true + | _,_ => false + end. + +Lemma list_eqdec_refl : forall {A} `{EqDec A} (l1 : list A), list_eqdec l1 l1 = true. +Proof. + intros ; induction l1 ; cbn ; try rewrite eqb_refl ; easy. +Qed. + +Lemma list_eqdec_sound : forall {A} `{EqDec A} (l1 l2 : list A), list_eqdec l1 l2 = true <-> l1 = l2. +Proof. + intros A H l1. + induction l1 ; induction l2 ; split ; intros ; simpl in * ; try easy ; try inversion H0. + - (* inductive case *) + apply Field_theory.if_true in H0; destruct H0. + f_equal. + (* show heads are equal *) + + apply (proj1 (eqb_leibniz a a0) H0). + (* show tails are equal using induction hypothesis *) + + apply IHl1. assumption. + - rewrite eqb_refl. + apply list_eqdec_refl. +Qed. + +Global Instance List_eqdec {A} `{EqDec A} : EqDec (list A) := { + eqb := list_eqdec; + eqb_leibniz := list_eqdec_sound; +}. + +Lemma vector_eqb_sound : forall {A : Type} {n : nat} `{EqDec A} (v1 v2 : VectorDef.t A n), Vector.eqb _ eqb v1 v2 = true <-> v1 = v2. +Proof. + intros. + apply Vector.eqb_eq. + intros. + apply eqb_leibniz. +Qed. + +Global Program Instance Vector_eqdec {A n} `{EqDec A}: EqDec (VectorDef.t A n) := { + eqb := Vector.eqb _ eqb; + eqb_leibniz := vector_eqb_sound; +}. + +Global Program Instance Dec_eq_prod (A B : Type) `{EqDec A} `{EqDec B} : EqDec (A * B) := { + eqb '(a0, b0) '(a1, b1) := andb (eqb a0 a1) (eqb b0 b1) +}. +Next Obligation. + split ; intros ; destruct x ; destruct y. + - (* symmetry in H1. *) + (* apply Bool.andb_true_eq in H1. destruct H1. *) + rewrite is_true_split_and in H1. destruct H1. + rewrite (eqb_leibniz) in H1. + rewrite (eqb_leibniz) in H2. now subst. + - inversion_clear H1. now do 2 rewrite eqb_refl. +Defined. + +End TodoSection2. + + +(*** Monad / Bind *) + +Definition result_unwrap {a b} (x : result b a) : both (fset []) ([interface]) (a) := + ret_both (result_unwrap x). +Definition result_unwrap_safe {a b} (x : result b a) `{match x with inl _ => True | inr _ => False end} : both (fset []) ([interface]) (a) := + ret_both (result_unwrap_safe x (H := H)). + +Module choice_typeMonad. + + Class BindCode := + { + mnd :> choice_typeMonad.CEMonad ; + (* bind_code {L : {fset Location}} {I} {A B : choice_type} (x : code L I (choice_typeMonad.M A)) (f : A -> code L I (choice_typeMonad.M B)) : code L I (choice_typeMonad.M B) ; *) + monad_bind_both {L0 L1 : {fset Location}} {I0 I1} {A B : choice_type} (x : both L0 I0 (choice_typeMonad.M (CEMonad := mnd) A)) (f : both L0 I0 A -> both L1 I1 (choice_typeMonad.M (CEMonad := mnd) B)) `{fsubset_loc : is_true (fsubset L0 L1)} `{fsubset_opsig : is_true (fsubset I0 I1)} : both L1 I1 (choice_typeMonad.M (CEMonad := mnd) B) ; + }. + + + (* Definition both_to_code {L I A} : both L I A -> code L I A := *) + (* fun x => {| prog := is_state x ; prog_valid := is_valid_code (both_prog_valid x) |}. *) + + (* Program Definition monad_bind_both `{BindCode} [L : {fset Location}] {I} {A B : choice_type} (x : both L I (choice_typeMonad.M A)) (f : both L I A -> both L I (choice_typeMonad.M B)) : both L I (choice_typeMonad.M B) := *) + (* {| *) + (* both_prog := *) + (* {| *) + (* is_pure := @choice_typeMonad.bind mnd A B (is_pure x) (fun x => is_pure (f (solve_lift (ret_both x)))) ; *) + (* is_state := prog (bind_code (both_to_code x) (fun a => both_to_code (f (solve_lift ret_both a)))) ; *) + (* |} ; *) + (* both_prog_valid := {| *) + (* is_valid_code := prog_valid _ ; *) + (* is_valid_both := _ ; *) + (* |}; *) + (* |}. *) + (* Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). *) + (* Next Obligation. *) + (* intros. *) + (* destruct x. *) + (* simpl. *) + (* unfold both_to_code. *) + (* simpl. *) + + (* unfold choice_typeMonad.bind. *) + (* destruct is_valid_both. *) + (* epose choice_typeMonad.monad_law1. *) + (* epose choice_typeMonad.monad_law2. *) + (* epose choice_typeMonad.monad_law3. *) + + (* simpl. *) + + + (* simpl. *) + + + (* rewrite choice_typeMonad.monad_law1. *) + + (* rewrite bind_ret. *) + + (* apply both_valid_ret. *) + (* simpl. *) + (* apply *) + (* eapply bind_both. *) + (* apply x. *) + (* intros. *) + (* refine (f _). *) + (* epose (choice_typeMonad.bind X (fun a => f _)). *) + (* refine (solve_lift ret_both (choice_typeMonad.bind X (fun a' => f))). *) + + (* intros. *) + (* refine (). *) + + (* epose (bind_code (is_state x) f). *) + (* eapply s. *) + (* apply x. *) + (* apply f. *) + (* apply x. *) + + (* Class BindBoth (M : choice_type -> choice_type) `{mnd : @choice_typeMonad.CEMonad M} `{H_bind_code : @BindCode M mnd} := *) + (* { *) + (* code_eq : forall [L : {fset Location}] {I} {A B : choice_type} (x : both L I (M A)) (f : A -> both L I (M B)), ⊢ ⦃ true_precond ⦄ *) + (* bind_code x (fun x0 : A => f x0) *) + (* ≈ *) + (* ret (y m(M) ⇠ x ;; f y) *) + (* ⦃ pre_to_post_ret true_precond ((y m(M) ⇠ x ;; f y)) ⦄ ; *) + (* bind_both [L : {fset Location}] {I} {A B : choice_type} (x : both L I (M A)) (f : A -> both L I (M B)) := *) + (* {| *) + (* is_state := bind_code x f ; *) + (* is_pure := y m(M) ⇠ x ;; f y ; *) + (* code_eq_proof_statement := code_eq x f *) + (* |} *) + (* }. *) + + (* Theorem bind_both_proj_code : forall `{H_bind_code : BindCode} `{@BindBoth M mnd H_bind_code} {L : {fset Location}} {I} {A B : choice_type} (x : both L I (M A)) (y : code L I (M A)) (f : A -> both L I (M B)) (g : A -> code L I (M B)), *) + (* (prog (is_state x) = prog y) -> *) + (* (forall v, prog (is_state (f v)) = prog (g v)) -> *) + (* is_state (choice_typeMonad.bind_both x f) = choice_typeMonad.bind_code (BindCode := H_bind_code) y g. *) + (* intros. *) + (* unfold bind_both. *) + (* unfold is_state at 1, lift_scope, is_state at 1. *) + (* f_equal. *) + (* apply code_ext. apply H0. *) + (* apply Coq.Logic.FunctionalExtensionality.functional_extensionality. intros. *) + (* apply code_ext. apply H1. *) + (* Qed. *) + + #[global] Program Instance result_bind_code C : BindCode := + {| + mnd := (@choice_typeMonad.result_monad C) ; + monad_bind_both _ _ _ _ _ _ x f _ _ := bind_both x (fun x => match x with + | inl s => f (solve_lift ret_both s) + | inr s => solve_lift ret_both (Err s) + end) + |}. + Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). + Fail Next Obligation. + + (* #[global] Program Instance result_bind_both C : BindBoth (result C). *) + (* Next Obligation. *) + (* intros. *) + + (* pattern_both_fresh. *) + (* subst H. *) + (* apply (@r_bind_trans_both) with (b := x) (C := result C B). *) + (* intros ; subst H0 H1 ; hnf. *) + + (* destruct (is_pure x). *) + (* - exact (code_eq_proof_statement (f s)). *) + (* - now apply r_ret. *) + (* Qed. *) + + #[global] Program Instance option_bind_code : BindCode := + {| mnd := choice_typeMonad.option_monad; + monad_bind_both _ _ _ _ A B x f _ _ := + bind_both x (fun t_x => + match t_x with + | Some s => f (solve_lift ret_both s) + | None => solve_lift ret_both (@None B : option B) + end) |}. + Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). + Fail Next Obligation. + + (* #[global] Program Instance option_bind_both : BindBoth (option). *) + (* Next Obligation. *) + (* intros. *) + + (* pattern_both_fresh. *) + (* subst H. *) + (* apply (@r_bind_trans_both) with (b := x) (C := option B). *) + (* intros ; subst H0 H1 ; hnf. *) + + (* destruct (is_pure x). *) + (* - exact (code_eq_proof_statement (f s)). *) + (* - now apply r_ret. *) + (* Qed. *) + +End choice_typeMonad. + +(* Notation "'bind_exception' t' x ':=' y 'in' z" := ( *) +(* choice_typeMonad.bind_code (BindCode := t) *) +(* (A := _) (B := _) (L := _) *) +(* (y) (fun x => z)) (at level 99). *) +(* Notation Result t := (@choice_typeMonad.result_monad t). *) + +(* Definition run (x : Exception A B) : Result A B. *) + +(* Definition run (x : result B A). *) + +(*** Result *) + +Definition Ok {L I} {a b : choice_type} : both L I a -> both L I (result b a) := lift1_both Ok. +Definition Err {L I} {a b : choice_type} : both L I b -> both L I (result b a) := lift1_both Err. + +(* Arguments Ok {_ _}. *) +(* Arguments Err {_ _}. *) + + +(*** Notation *) + +(* Notation "'bnd(' M ',' A ',' B ',' L ')' x '⇠' y 'in' f" := (choice_typeMonad.bind_code (BindCode := M) (A := A) (B := B) (L := L) (lift_code_scope (H_loc_incl := _) (H_opsig_incl := _) y) (fun x => f)) (at level 100, x pattern, right associativity). *) +(* Notation "'bnd(' M ',' A ',' B ',' L ')' ' x '⇠' y 'in' f" := (choice_typeMonad.bind_code (BindCode := M) (A := A) (B := B) (L := L) (lift_code_scope (H_loc_incl := _) (H_opsig_incl := _) y) (fun x => f)) (at level 100, x pattern, right associativity). *) + +(* Notation "'letbnd(' M ')' x ':=' y 'in' f" := (choice_typeMonad.bind_both (BindBoth := M) (lift_scope (H_loc_incl := _) (H_opsig_incl := _) y) (fun x => f)) (at level 100, x pattern, right associativity). *) +(* Notation "'letbnd(' M ')' ' x ':=' y 'in' f" := (choice_typeMonad.bind_both (BindBoth := M) (lift_scope (H_loc_incl := _) (H_opsig_incl := _) y) (fun x => f)) (at level 100, x pattern, right associativity). *) + +(* Program Definition bind_code_mut {L : {fset Location}} {I} `{H_bind_code : choice_typeMonad.BindCode} {B : choice_type} (x_loc : Location) {A : choice_type} `{H_loc : M A = (x_loc)} `{H_in: is_true (ssrbool.in_mem (x_loc) (ssrbool.mem L))} (x : code L I (x_loc)) (f : A -> code L I (M B)) : code L I (M B) . *) +(* Proof. *) +(* destruct x_loc as [? n]. *) +(* cbn in *. subst. *) +(* refine ({code choice_typeMonad.bind_code x (fun temp => {code *) +(* #put ((M A) ; n) := (choice_typeMonad.ret temp) ;; *) +(* f temp}) }). *) +(* Defined. *) + +(* Notation "'bndm(' M ',' A ',' B ',' L ')' x 'loc(' ℓ ')' '⇠' y 'in' f" := (bind_code_mut (H_bind_code := M) (A := A) (B := B) (L := L) (H_loc := eq_refl) ℓ y (fun x => f)) (at level 100, x pattern, right associativity). *) +(* Notation "'bndm(' M ',' A ',' B ',' L ')' ' x 'loc(' ℓ ')' '⇠' y 'in' f" := (bind_code_mut (H_bind_code := M) (A := A) (B := B) (L := L) (H_loc := eq_refl) ℓ y (fun x => f)) (at level 100, x pattern, right associativity). *) + + +(* Definition bind_both_mut {L : {fset Location}} {I} {A B : choice_type} (x_loc : Location) `{H_in: is_true (ssrbool.in_mem (x_loc) (ssrbool.mem L))} `{H_bind_both : choice_typeMonad.BindBoth} {H_loc : M A = (x_loc)} (x : both L I (x_loc)) (f : A -> both L I (M B)) : both L I (M B). *) +(* Proof. *) +(* destruct x_loc as [C n] eqn:x_loc_eq. *) +(* cbn in *. *) +(* rewrite <- H_loc in x , H_in. *) +(* refine {| *) +(* is_pure := 'y m(M) ⇠ is_pure x ;; is_pure (f y); *) +(* is_state := bind_code_mut ((M A ; n) : Location ) (is_state x) (fun x => is_state (f x)) (H_in := H_in) *) +(* |}. *) + +(* Unshelve. *) +(* 2: apply eq_refl. *) + +(* intros. *) +(* subst. *) + +(* unfold bind_code_mut. *) +(* unfold eq_rect. *) +(* unfold prog. *) + +(* refine (code_eq_proof_statement (@choice_typeMonad.bind_both _ _ _ H_bind_both L I A B x (fun temp => {| is_state := {code #put (((M A); n) : Location) := choice_typeMonad.ret temp ;; f temp } |}))). *) +(* unfold prog. *) +(* apply better_r_put_lhs. *) +(* eapply rpre_weaken_rule with (pre := true_precond). *) +(* apply (code_eq_proof_statement (f temp)). *) +(* easy. *) +(* Defined. *) + +(* Notation "'bndm(' M ',' A ',' B ',' L ')' x '⇠' y 'in' f" := (choice_typeMonad.bind_code (BindCode := M) (A := A) (B := B) (L := L) y (fun x => f)) (at level 100, x pattern, right associativity). *) +(* Notation "'bndm(' M ',' A ',' B ',' L ')' ' x '⇠' y 'in' f" := (choice_typeMonad.bind_code (BindCode := M) (A := A) (B := B) (L := L) y (fun x => f)) (at level 100, x pattern, right associativity). *) + +(* Notation "'letbndm(' M ')' x ':=' y 'in' f" := (choice_typeMonad.bind_both (BindBoth := M) (lift_scope (H_loc_incl := _) (H_opsig_incl := _) y) (fun x => f)) (at level 100, x pattern, right associativity). *) +(* Notation "'letbndm(' M ')' ' x ':=' y 'in' f" := (choice_typeMonad.bind_both (BindBoth := M) (lift_scope (H_loc_incl := _) (H_opsig_incl := _) y) (fun x => f)) (at level 100, x pattern, right associativity). *) + +(* Program Definition foldi_bind_code' {A : choice_type} {L : {fset Location}} {I} `{H_bind_code : choice_typeMonad.BindCode} (a : uint_size) (b : uint_size) (f : uint_size -> A -> code (L) I ((M A))) (init : A) : code (L) I (M A) := *) +(* {code *) +(* foldi *) +(* a b *) +(* (fun x y => *) +(* choice_typeMonad.bind_code *) +(* (lift_to_code y) *) +(* (f x)) *) +(* (choice_typeMonad.ret init) *) +(* }. *) + +(* Program Definition foldi_bind_code {A : choice_type} {L : {fset Location}} {I} `{H_bind_code : choice_typeMonad.BindCode} (lo : uint_size) (hi : uint_size) (f : uint_size -> A -> code (L) I ((M A))) (init : code (L) I (M A)) : code (L) I (M A) := *) +(* {code *) +(* t ← init ;; *) +(* foldi lo hi *) +(* (fun x y => *) +(* choice_typeMonad.bind_code *) +(* (lift_to_code y) *) +(* (f x)) (t) *) +(* }. *) + +(* Program Definition foldi_both *) +(* {acc: choice_type} *) +(* {L} *) +(* {I} *) +(* (lo: uint_size) *) +(* (hi: uint_size) (* {lo <= hi} *) *) +(* (init: both L I acc) *) +(* (f: (both L I uint_size) -> (both L I) acc -> both L I acc) *) +(* : both L I acc := *) +(* {| both_prog := *) +(* bind_both init (fun temp => {| *) +(* is_pure := Hacspec_Lib_Pre.foldi lo hi (fun x y => is_pure (f (ret_both x) (ret_both y))) temp ; *) +(* is_state := *) +(* foldi lo hi (fun x y => let temp := (f (ret_both x) ((ret_both y))) in {code is_state temp #with is_valid_code (both_prog_valid temp)}) temp *) +(* |}) *) +(* (* {| *) *) +(* (* is_pure := Hacspec_Lib_Pre.foldi lo hi (fun x y => is_pure (f (ret_both x) (ret_both y))) (is_pure init) ; *) *) +(* (* is_state := *) *) +(* (* temp ← is_state init ;; *) *) +(* (* foldi lo hi (fun x y => let temp := (f (ret_both x) ((ret_both y))) in {code is_state temp #with is_valid_code (both_prog_valid temp)}) temp *) *) +(* (* |} *) |}. *) +(* Next Obligation. *) +(* intros. *) +(* constructor ; simpl. *) +(* - apply valid_bind. apply init. intros. *) +(* apply foldi. *) +(* - eapply valid_bind_both. apply init. intros. *) +(* unfold foldi_pre. unfold Hacspec_Lib_Pre.foldi. simpl. *) +(* destruct (unsigned hi - unsigned lo)%Z ; try apply both_ret_valid. *) +(* induction (Pos.to_nat p) ; intros ; cbn. *) +(* * apply both_ret_valid. *) +(* * replace _ with (bind_both (f (ret_both lo) (ret_both x)) _). *) + + + + +(* Next Obligation. *) +(* intros. *) +(* unfold foldi_pre. *) +(* unfold Hacspec_Lib_Pre.foldi. *) + +(* (* set (b_lo := lo). *) *) +(* (* set (b_hi := hi). *) *) +(* (* destruct lo as [lo ? ?]. *) *) +(* (* destruct hi as [hi ? ?]. *) *) + +(* simpl. *) + +(* destruct ((_ - unsigned lo)%Z) ; [ apply r_ret ; easy | | apply r_ret ; easy ]. *) + +(* generalize dependent lo. *) +(* clear. *) +(* generalize dependent init. *) + +(* induction (Pos.to_nat p) ; intros. *) +(* - cbn. *) +(* apply r_ret ; easy. *) +(* - rewrite <- foldi__move_S. *) +(* rewrite <- Hacspec_Lib_Pre.foldi__move_S. *) + +(* set (b' := f _ _). (* TODO: This should not use ret_both !! *) *) + +(* pose @r_bind_trans_both. *) +(* specialize r with (b := b'). *) + +(* pattern_both_fresh. *) +(* apply r. *) +(* subst H H0 H1. hnf. *) + +(* rewrite bind_rewrite. *) + +(* apply IHn. *) +(* Qed. *) + +(* Program Definition foldi_both' *) +(* {acc: choice_type} *) +(* {L1} {L2} {L3} {L} *) +(* {I1} {I2} {I3} {I} *) +(* (lo: both L1 I1 uint_size) *) +(* (hi: both L2 I2 uint_size) (* {lo <= hi} *) *) +(* (f: both L I (uint_size) -> both L I acc -> both L I acc) *) +(* (init: both L3 I3 acc) *) +(* : both L I acc := *) +(* {| both_prog := *) +(* bind_both lo (fun lo => *) +(* bind_both hi (fun hi => *) +(* bind_both init (fun init => *) +(* foldi (L := L) (I := I) lo hi (fun x y => f (ret_both x) (ret_both y)) init))) *) +(* |}. *) +(* Next Obligation. *) +(* intros. *) +(* apply f. *) +(* apply (ret_both H). *) + +(* Program Definition foldi_bind_both {A : choice_type} {L1 L2 L3 : {fset Location}} {I1 I2 I3} `{H_bind_both : choice_typeMonad.BindBoth} (lo : both L1 I1 uint_size) (hi : both L2 I2 uint_size) (init : both L3 I3 (M A)) (f : uint_size -> A -> both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (M A)) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (M A) := *) +(* let_both init (fun init' => *) +(* foldi_both' lo hi init' (fun x y => choice_typeMonad.bind_both (y) (f x))). *) + +(* Theorem foldi_bind_both_proj_code' : forall {A : choice_type} {L1 L2 L : {fset Location}} {I1 I2 I} `{H_bind_both : choice_typeMonad.BindBoth} (lo : both L1 I1 uint_size) (hi : both L2 I2 uint_size) (init : A) (f_both : uint_size -> A -> both L I (M A)) (a : uint_size) (b : uint_size) (f_code : uint_size -> A -> code (L) I ((M A))), *) +(* (forall i x, is_state (f_both i x) = f_code i x) -> *) +(* is_pure lo = a -> is_pure hi = b -> *) +(* is_state (foldi_bind_both' lo hi init f_both) = foldi_bind_code' a b init f_code. *) +(* Proof. *) +(* intros. *) +(* unfold foldi_bind_both'. *) +(* unfold foldi_bind_code'. *) + +(* apply code_ext. *) + +(* subst. *) + +(* unfold is_state. *) +(* unfold foldi_both. *) +(* unfold prog. *) + +(* set ((fun (x0 : uint_size) (y : M A) => _)). *) +(* set ((fun (x0 : uint_size) (y : (M A)) => _)). *) + +(* enough (y0 = y). *) +(* + now rewrite H0. subst y y0 ; hnf. *) +(* apply functional_extensionality. intros. *) +(* apply functional_extensionality. intros. *) +(* cbn. *) +(* f_equal. *) +(* apply functional_extensionality. intros. *) +(* now rewrite H. *) +(* Qed. *) + +(* Theorem foldi_bind_both_proj_code : forall {A : choice_type} {L : {fset Location}} {I} `{H_bind_both : choice_typeMonad.BindBoth} (lo : uint_size) (hi : uint_size) (init_both : both L I (M A)) (f_both : uint_size -> A -> both L I (M A)) (init_code : code (L) I (M A)) (f_code : uint_size -> A -> code (L) I ((M A))), *) +(* is_state (init_both) = init_code -> *) +(* (forall i x, is_state (f_both i x) = f_code i x) -> *) +(* is_state (foldi_bind_both lo hi init_both f_both) = foldi_bind_code lo hi init_code f_code. *) +(* Proof. *) +(* intros. *) +(* unfold foldi_bind_both. *) +(* unfold let_both. *) +(* unfold is_state at 1. *) +(* unfold foldi_bind_code. *) +(* apply code_ext. *) +(* unfold prog. *) +(* f_equal. *) +(* - now rewrite H. *) +(* - apply functional_extensionality. intros. *) +(* unfold is_state. *) +(* unfold foldi_both. *) +(* unfold prog. *) + +(* set ((fun (x0 : uint_size) (y : M A) => _)). *) +(* set ((fun (x0 : uint_size) (y : M A) => _)). *) +(* enough (y0 = y). *) +(* + now rewrite H1. subst y y0 ; hnf. *) +(* apply functional_extensionality. intros. *) +(* apply functional_extensionality. intros. *) +(* cbn. *) +(* f_equal. *) +(* apply functional_extensionality. intros. *) +(* symmetry. *) +(* apply H0. *) +(* Qed. *) + +Section TodoSection3. +Definition nat_mod_from_byte_seq_be {A n} (x : seq A) : both (fset []) ([interface]) (nat_mod n) := ret_both (nat_mod_from_byte_seq_be x). + +End TodoSection3. + +Definition neqb {A : choice_type} `{EqDec A} {L1 L2 I1 I2} : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun x y => negb (eqb x y) : 'bool). +Definition eqb {A : choice_type} `{EqDec A} {L1 L2 I1 I2} : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun x y => eqb x y : 'bool). + +Definition ltb {A : choice_type} `{Comparable A} {L1 L2 I1 I2} : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun x y => ltb x y : 'bool). +Definition leb {A : choice_type} `{Comparable A} {L1 L2 I1 I2} : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun x y => leb x y : 'bool). +Definition gtb {A : choice_type} `{Comparable A} {L1 L2 I1 I2} : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun x y => gtb x y : 'bool). +Definition geb {A : choice_type} `{Comparable A} {L1 L2 I1 I2} : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun x y => geb x y : 'bool). + +Infix "=.?" := eqb (at level 40) : hacspec_scope. +Infix "!=.?" := neqb (at level 40) : hacspec_scope. +Infix "<.?" := ltb (at level 42) : hacspec_scope. +Infix "<=.?" := leb (at level 42) : hacspec_scope. +Infix ">.?" := gtb (at level 42) : hacspec_scope. +Infix ">=.?" := geb (at level 42) : hacspec_scope. + +(* Lemma foldi_nat_both : *) +(* forall {A : choice_type} {L : {fset Location}} {I} (lo hi : nat) *) +(* (b : nat -> A -> both L I A) *) +(* (v : A), *) +(* ⊢ ⦃ true_precond ⦄ *) +(* @foldi_nat _ lo hi b v *) +(* ≈ *) +(* ret_both (Hacspec_Lib_Pre.foldi_nat lo hi b v) : both L I A *) +(* ⦃ pre_to_post_ret true_precond ((Hacspec_Lib_Pre.foldi_nat lo hi b v)) ⦄. *) +(* Proof. *) +(* intros. *) +(* unfold prog, is_state at 2. *) +(* unfold foldi_nat. *) +(* unfold Hacspec_Lib_Pre.foldi_nat. *) + +(* destruct (_ - lo). *) +(* { apply r_ret ; intros ; subst. *) +(* split. *) +(* - easy. *) +(* - easy. *) +(* } *) + +(* generalize dependent lo. *) +(* clear. *) +(* generalize dependent v. *) + +(* induction n ; intros. *) +(* - cbn. *) +(* (* unfold repr. *) *) + +(* (* replace (fun cur' : choice.Choice.sort (chElement (A)) => *) *) +(* (* ret (cur')) with (@ret (chElement (A))) by (apply functional_extensionality ; intros ; now rewrite T_ct_id). *) *) +(* rewrite bind_ret. *) +(* apply (@code_eq_proof_statement). *) + +(* - rewrite <- foldi__nat_move_S. *) +(* rewrite <- Hacspec_Lib_Pre.foldi__nat_move_S. *) + +(* set (b' := b lo v). *) + +(* pose @r_bind_trans_both. *) +(* specialize r with (b := b'). *) + +(* specialize r with (g := fun temp => @ret (chElement (A)) *) +(* ( *) +(* (@Hacspec_Lib_Pre.foldi_nat_ ( A) (S n) (S lo) *) +(* (fun (n0 : nat) (v0 : A) => @is_pure L I A (b n0 v0)) *) +(* temp))). *) +(* apply r. *) +(* intros. *) + +(* apply IHn. *) +(* Qed. *) + +(* Lemma foldi_as_both : *) +(* forall {A : choice_type} {L I} (lo hi : both L I uint_size) *) +(* (state : uint_size -> A -> code L I (A)) *) +(* (pure : uint_size -> A -> A) *) +(* v, *) +(* (forall x y, *) +(* ⊢ ⦃ true_precond ⦄ *) +(* state x y ≈ lift_to_code (L := L) (I := I) (pure x y) *) +(* ⦃ pre_to_post_ret true_precond ((pure x y)) ⦄) -> *) +(* ⊢ ⦃ true_precond ⦄ *) +(* @foldi _ (is_pure lo) (is_pure hi) L I state v *) +(* ≈ *) +(* ret_both (Hacspec_Lib_Pre.foldi lo hi pure v) : both L I A *) +(* ⦃ pre_to_post_ret true_precond ((Hacspec_Lib_Pre.foldi (is_pure lo) (is_pure hi) pure v)) ⦄. *) +(* Proof. *) +(* intros. *) +(* pose (fun x y => Build_both L I A (pure x y) (state x y) (H x y)). *) +(* unfold is_state. *) +(* unfold prog. *) + +(* (* pose (code_eq_proof_statement (foldi_both lo hi (ret_both v) (fun x y => b x (y)))). *) *) +(* (* cbn in r. *) *) +(* (* cbn. *) *) + +(* (* apply (code_eq_proof_statement (foldi_both lo hi (ret_both v) (fun x y => b x (y)))). *) *) +(* (* Qed. *) *) + +(*** For loop again *) + +(* SSProve for loop is inclusive upperbound, while hacspec is exclusive upperbound *) +Definition for_loop_range + (lo: nat) + (hi: nat) + (f : nat -> raw_code 'unit) : raw_code 'unit := + match hi - lo with + | O => @ret 'unit tt + | S i => for_loop (fun n => f (n + lo)) i + end. + +Fixpoint list_types_ (l : list choice_type) (init : choice_type) : choice_type := + match l with + | (t :: ts) => list_types_ ts t × init + | [] => init + end. + +Definition list_types (l : list choice_type) : choice_type := + match l with + | [] => 'unit + | (t :: ts) => list_types_ ts t + end. + +Program Fixpoint vars_to_tuple (vars : list (∑ (t : choice_type), t)) {measure (length vars)} : list_types (seq.map (fun '(x ; y) => x) vars) := + match vars with + | [] => tt + | (x :: xs) => + match xs with + | [] => _ + | (s :: xs) => (vars_to_tuple (s :: xs) , _) + end + end. + +Fixpoint for_loop_return_ (ℓ : list Location) (vars : list (∑ (t : choice_type), t)) : raw_code (list_types (seq.cat (seq.map (fun '(x ; y) => x) vars) (seq.map (fun '(x ; y) => x) ℓ) )). + + destruct ℓ as [ | l ls ]. + - rewrite seq.cats0. + pose (ret (vars_to_tuple vars)). + replace (fun pat : ∑ t : choice_type, t => _) with + (fun pat : @sigT choice_type + (fun t : choice_type => t) => + match pat return choice_type with + | @existT _ _ x _ => x + end) + in r by (apply functional_extensionality ; now intros []). + apply r. + - apply (getr (l)). + intros x. + destruct l. + cbn in x. + pose (for_loop_return_ ls (vars ++ [(x0 ; x)])). + rewrite seq.map_cat in r. + cbn in r. + rewrite <- seq.catA in r. + cbn in r. + apply r. +Defined. + +Definition for_loop_return (ℓ : list Location) : raw_code (list_types (seq.map (fun '(x ; y) => x) ℓ)) := for_loop_return_ ℓ []. + +Definition for_loop_locations + (lo: nat) + (hi: nat) + (ℓ : list Location) + (f : nat -> raw_code 'unit) := + match hi - lo with + | O => @ret 'unit tt + | S i => for_loop (fun n => f (n + lo)) i + end ;; for_loop_return ℓ. + +Theorem r_bind_trans_as_both : forall {B C : choice_type} {L I} (f : choice.Choice.sort B -> raw_code C) (g : B -> raw_code C) (state : code L I (B)) + (pure : B), + forall (P : precond) (Q : postcond _ _), + (⊢ ⦃ true_precond ⦄ + state ≈ lift_to_code (L := L) (I := I) (pure) + ⦃ pre_to_post_ret true_precond (pure) ⦄) -> + (⊢ ⦃ true_precond ⦄ f (pure) ≈ g pure ⦃ Q ⦄) -> + (⊢ ⦃ P ⦄ temp ← state ;; f temp ≈ g (pure) ⦃ Q ⦄). +Proof. + intros. + eapply r_bind_trans with (P_mid := true_precond). + + eapply rpre_weaken_rule. + apply H. + + reflexivity. + + intros. + apply H0. +Qed. + +Ltac pattern_foldi_both Hx Hf Hg := + match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ bind _ (foldi _ _ _ ?fb) ≈ ?os ⦃ _ ⦄ ] ] => + let H := fresh in + set (H := os) + ; set (Hx := Hacspec_Lib_Pre.foldi _ _ _ _) in H + ; pattern Hx in H + ; subst H + ; set (Hf := fb) + ; match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ _ ≈ ?gb _ ⦃ _ ⦄ ] ] => + set (Hg := gb) + end + | [ |- context [ ⊢ ⦃ _ ⦄ prog (foldi _ _ _ ?fb) ≈ ?os ⦃ _ ⦄ ] ] => + let H := fresh in + set (H := os) + ; set (Hx := Hacspec_Lib_Pre.foldi _ _ _ _) in H + ; pattern Hx in H + ; subst H + ; set (Hf := fb) + ; match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ _ ≈ ?gb _ ⦃ _ ⦄ ] ] => + set (Hg := gb) + end + end. + +Ltac pattern_foldi_both_fresh := + let Hx := fresh in + let Hf := fresh in + let Hg := fresh in + pattern_foldi_both Hx Hf Hg. + +Ltac progress_step_code := + match_foldi_both + || (match_bind_trans_both) + || match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ (#put ?l := ?x ;; (getr ?l ?a)) ≈ _ ⦃ _ ⦄ ]] => + apply better_r_put_get_lhs + end + || + match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ (#put ?l := ?x ;; (putr ?l ?y ?a)) ≈ _ ⦃ _ ⦄ ]] => + apply (r_transL (#put l := y ;; a )) ; + [ apply contract_put | ] + end + || + match goal with + | [ |- context [ ⊢ ⦃ _ ⦄ (#put ?l := ?x ;; ?a) ≈ ?b ⦃ _ ⦄ ]] => + apply (better_r_put_lhs l x a b) + end + || + (unfold lift_to_code ; apply r_ret) + || + (rewrite bind_assoc) + with + match_foldi_both := + let Hx := fresh in + let Hf := fresh in + let Hg := fresh in + pattern_foldi_both Hx Hf Hg + ; try (apply (@r_bind_trans_as_both) with (f := Hf) (g := Hg)) + ; intros ; subst Hf ; subst Hg ; subst Hx ; hnf + (* ; [apply foldi_as_both ; [ try (cbn ; Lia.lia) | intros ; unfold lift_to_code ; unfold prog ] | step_code] *) + with + step_code := + repeat (clear_bind || progress_step_code) ; try easy + with + clear_bind := + (unfold lift_to_code ; + match goal with + | [ |- context [ bind ?y (fun x => ret (_)) ] ] => + let H := fresh in + set (H := y) + + ; rewrite bind_ret + ; subst H + | [ |- context [ bind ?y (fun x => ret _) ] ] => + let H := fresh in + set (H := y) + + ; rewrite bind_ret + ; subst H + end) + || + (repeat (rewrite bind_assoc) + ; match goal with + | [ |- context [ bind (ret (?y)) (fun x => _) ] ] => + let H := fresh in + set (H := y) + + ; rewrite bind_rewrite + ; subst H + | [ |- context [ bind (ret ?y) (fun x => _) ] ] => + let H := fresh in + set (H := y) + ; rewrite bind_rewrite + ; subst H + end). + + +Theorem empty_put {B} ℓ v (k h : raw_code B) : + ⊢ ⦃ true_precond ⦄ k ≈ h ⦃ pre_to_post true_precond ⦄ -> + ⊢ ⦃ true_precond ⦄ #put ℓ := v ;; k ≈ h ⦃ pre_to_post true_precond ⦄. +Proof. + intros. + apply better_r_put_lhs. + eapply rpre_weaken_rule. + apply H. + intros. + reflexivity. +Qed. + + +Theorem length_merge_sort_pop : forall {A} leb (l1 : list (list A)) (l2 : list A), + length (path.merge_sort_pop leb l2 l1) = length (seq.cat (seq.flatten l1) l2). +Proof. + intros. + generalize dependent l2. + induction l1 ; intros. + - cbn. + reflexivity. + - cbn. + rewrite IHl1. + rewrite seq.size_cat. + rewrite seq.size_cat. + rewrite seq.size_cat. + rewrite path.size_merge. + rewrite seq.size_cat. + rewrite ssrnat.addnA. + f_equal. + rewrite ssrnat.addnC. + reflexivity. +Qed. + +Theorem length_sort_even : forall {A} leb a x (l1 : list (list A)) (l2 : list A), + length (path.merge_sort_rec leb l1 (a :: x :: l2)) = + length (path.merge_sort_rec leb + (path.merge_sort_push leb (if leb a x then [a; x] else [x; a]) l1) l2). +Proof. + reflexivity. +Qed. + +Theorem length_sort_is_length' : forall {A} leb (l1 : list (list A)), + length (path.merge_sort_rec leb l1 []) = length (seq.flatten l1). +Proof. + destruct l1. + + cbn. + reflexivity. + + cbn. + rewrite length_merge_sort_pop. + rewrite seq.size_cat. + rewrite seq.size_cat. + rewrite path.size_merge. + rewrite seq.cats0. + rewrite ssrnat.addnC. + reflexivity. +Qed. + +(* Definition andb (x y : 'bool) : both (fset []) ([interface]) 'bool := ret_both (andb x y : 'bool). *) + +Infix "&&" := andb : bool_scope. + +(* Definition orb (x y : 'bool) : both (fset []) ([interface]) 'bool := ret_both (orb x y : 'bool). *) + +Infix "||" := orb : bool_scope. + +(* Definition negb (x : 'bool) : both (fset []) ([interface]) 'bool := ret_both (negb x : 'bool). *) + +(* Program Definition ret_both {L : {fset Location}} {I} `{choice_typeMonad.CEMonad} {A : choice_type} (x : A) : both L I (M A) := ret_both (choice_typeMonad.ret x). *) + +Ltac init_both_proof b_state b_pure := + intros ; + unfold lift_to_code ; + cbv delta [b_state] ; + cbn beta ; + let H := fresh in + match goal with + | [ |- context [(prog {code ?x})] ] => + set (H := x) + end ; + unfold prog ; + cbv delta [b_pure] ; + subst H ; + cbn beta. + +(* Ltac foldi_state_eq_code := *) +(* erewrite <- @foldi_bind_both_proj_code' ; [ reflexivity | intros ; hnf | reflexivity | reflexivity ]. *) +(* Ltac bind_both_eq_code := *) +(* erewrite <- @choice_typeMonad.bind_both_proj_code ; [ reflexivity | hnf | reflexivity ]. *) + +(* Theorem letbm_proj_code : *) +(* forall (L1 L2 : {fset Location}) `{H_loc_incl : List.incl L1 L2}, *) +(* forall {I1 I2 : {fset opsig}} `{H_opsig_incl : List.incl I1 I2}, *) +(* forall B (i : Location), *) +(* forall `{H_in : is_true (ssrbool.in_mem (i) (ssrbool.mem L2))}, *) +(* forall (x : both L1 I1 (i)) (f : (i) -> both (L1 :|: L2) (I1 :|: I2) B), *) +(* forall (y : code L1 I1 (i)) (g : (i) -> code (L1 :|: L2) (I1 :|: I2) B), *) +(* is_state x = y -> *) +(* (forall x, is_state (f x) = (g x)) -> *) +(* is_state ((let_mut_both i (H_in := H_in) x f)) = *) +(* let_mut_code i (H_in := H_in) (lift_code_scope (H_loc_incl := H_loc_incl) (H_opsig_incl := H_opsig_incl) y) g *) +(* . *) +(* Proof. *) +(* intros L1 L2 H_loc_incl I1 I2 H_opsig_incl B [A n]. *) +(* intros H_in x f y g H_var_eq H_fun_eq. *) +(* apply code_ext. unfold prog. *) +(* unfold let_mut_both, is_state at 1. *) +(* unfold lift_scope. unfold is_state at 1. *) +(* rewrite let_mut_code_equation_1. *) +(* unfold prog. *) +(* unfold lift_code_scope. *) +(* rewrite H_var_eq. *) +(* apply f_equal. *) +(* apply functional_extensionality. intros. *) +(* apply f_equal. *) +(* apply f_equal. *) +(* apply functional_extensionality. intros. *) +(* now rewrite H_fun_eq. *) +(* Qed. *) + +(* Ltac letbm_eq_code := *) +(* match goal with *) +(* | [ |- context [let_mut_both _ (lift_scope ?k) ?f] ] => *) +(* erewrite letbm_proj_code with (g := f) (y := k) ; [ hnf | reflexivity | reflexivity ] *) +(* end. *) +Ltac f_equal_fun_ext := + repeat (apply f_equal ; try (apply Coq.Logic.FunctionalExtensionality.functional_extensionality ; intros)). + +Definition u32_word_t := nseq_ uint8 4. +Definition u128_word_t := nseq_ uint8 16. + +(* Lemma letbm_ret_r : *) +(* forall {A : choice.Choice.type} {B : choice_type} *) +(* (r₁ : raw_code A) (pre : precond) *) +(* (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)) *) +(* (ℓ : Location) *) +(* (L : {fset Location}) *) +(* (I : Interface) *) +(* v (f : _ -> both L I B) (H_in : is_true (ssrbool.in_mem (ℓ) (ssrbool.mem L))), *) +(* ⊢ ⦃ (set_rhs (@existT choice_type (fun _ : choice_type => nat) ((projT1 ℓ)) (projT2 ℓ)) v pre) ⦄ r₁ ≈ f v ⦃ post ⦄ -> *) +(* ⊢ ⦃ pre ⦄ r₁ ≈ let_mut_both ℓ (H_in := H_in) (ret_both (v)) f ⦃ post ⦄. *) +(* Proof. *) +(* intros. *) +(* cbn. *) +(* unfold let_mut_code. *) +(* unfold lift_to_code. *) +(* (* unfold Hacspec_Lib.let_mut_both_obligation_1. *) *) +(* cbn. *) +(* destruct ℓ. *) +(* cbn. *) +(* apply better_r_put_get_rhs. *) +(* apply better_r, r_put_rhs. *) +(* apply H. *) +(* Qed. *) + +(* Lemma letbm_ret_l : *) +(* forall {A : choice_type} {B : choice.Choice.type} *) +(* (r₀ : raw_code A) *) +(* (r₁ : raw_code B) (pre : precond) *) +(* (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)) *) +(* (ℓ : Location) *) +(* (L : {fset Location}) *) +(* (I : Interface) *) +(* v (f : _ -> both L I A) (H_in : is_true (ssrbool.in_mem (ℓ) (ssrbool.mem L))), *) +(* ⊢ ⦃ (set_lhs (@existT choice_type (fun _ : choice_type => nat) ((projT1 ℓ)) (projT2 ℓ)) v pre) ⦄ f v ≈ r₁ ⦃ post ⦄ -> *) +(* ⊢ ⦃ pre ⦄ let_mut_both ℓ (H_in := H_in) (ret_both (v)) f ≈ r₁ ⦃ post ⦄. *) +(* Proof. *) +(* intros. *) +(* cbn. *) +(* unfold let_mut_code. *) +(* unfold lift_to_code. *) +(* (* unfold Hacspec_Lib.let_mut_both_obligation_1. *) *) +(* cbn. *) +(* destruct ℓ. *) +(* apply better_r_put_get_lhs. *) +(* apply better_r_put_lhs. *) +(* apply H. *) +(* Qed. *) + + +(* Program Definition let_both_prod {L : {fset Location}} {I} {A B C : choice_type} *) +(* (x : both L I (A × B)) *) +(* (f : both L I A -> both L I B -> both L I C) *) +(* : both L I C. *) +(* Proof. *) +(* refine {| both_prog := (bind_both x (fun temp => (f (ret_both (fst temp)) (ret_both (snd temp))))) |}. *) + +(* {| both_prog := {| *) +(* is_state := temp ← is_state x ;; is_state (f (ret_both (fst temp)) (ret_both (snd temp))) ; *) +(* is_pure := is_pure (f (ret_both (fst (is_pure x))) (ret_both (snd (is_pure x)))) ; *) +(* |} |}. *) +(* Next Obligation. *) +(* intros. *) +(* cbn. *) +(* replace (ret _) with (temp ← ret (is_pure x) ;; ret ((is_pure (f ((ret_both (fst temp))) ((ret_both (snd temp))))))) by reflexivity. *) + +(* eapply r_bind. *) +(* apply x. *) + +(* intros. *) +(* apply rpre_hypothesis_rule. *) +(* intros ? ? [[] []]. subst. *) +(* eapply rpre_weaken_rule. *) +(* apply f. *) +(* reflexivity. *) +(* Qed. *) + +(* Definition both_LL_II_to_both_L_I {L I A} : both (L :|: L) (I :|: I) A -> both L I A. *) +(* Proof. *) +(* now do 2 rewrite fsetUid. *) +(* Defined. *) + +(* Definition both_L0_I0_to_both_L_I {L I A} : both (L :|: fset0) (I :|: fset []) A -> both L I A. *) +(* Proof. *) +(* rewrite <- fset0E. *) +(* now do 2 rewrite fsetU0. *) +(* Defined. *) + + (* takes two nseq's and joins them using a function op : a -> a -> a *) + (* Definition array_join_map *) + (* {a: choice_type} *) + (* {len: uint_size} *) + (* {L1 L2 I1 I2} *) + (* (op: forall {L1 L2 I1 I2}, ( (both L1 I1 a)) -> (both L2 I2 a) -> ( (both (L1 :|: L2) (I1 :|: I2) a))) *) + (* (s1: (both L1 I1 (nseq a len))) *) + (* (s2 : (both L2 I2 (nseq a len))) : both (L1 :|: L2) (I1 :|: I2) ((nseq a len)) := @foldi_both' _ L1 L2 L1 (L1 :|: L2) I1 I2 I1 (I1 :|: I2) (ret_both (usize 0)) (ret_both len) *) + (* (fun x y => *) + (* let b1 := *) + (* eq_rect (L1 :|: (L1 :|: L2)) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both f (I1 :|: (I1 :|: I2)) a) (array_index s1 x) (L1 :|: L1 :|: L2) *) + (* (fsetUA *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) L1 L1 L2) in *) + (* let b2 := *) + (* eq_rect (I1 :|: (I1 :|: I2)) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L1 :|: L2) f a) b1 (I1 :|: I1 :|: I2) *) + (* (fsetUA *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) I1 *) + (* I1 I2) in *) + (* let b3 := *) + (* eq_rect (L1 :|: L1) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both (f :|: L2) (I1 :|: I1 :|: I2) a) b2 L1 *) + (* (fsetUid *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) L1) in *) + (* let b4 := *) + (* eq_rect (I1 :|: I1) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) (f :|: I2) a) b3 I1 *) + (* (fsetUid *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) I1) *) + (* in *) + (* let b5 := *) + (* eq_rect (L2 :|: (L1 :|: L2)) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both f (I2 :|: (I1 :|: I2)) a) (array_index s2 x) (L1 :|: L2 :|: L2) *) + (* (fsetUC *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) L2 *) + (* (L1 :|: L2)) in *) + (* let b6 := *) + (* eq_rect_r *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both f (I2 :|: (I1 :|: I2)) a) b5 *) + (* (fsetUA *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) L1 L2 L2) in *) + (* let b7 := *) + (* eq_rect (L2 :|: L2) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both (L1 :|: f) (I2 :|: (I1 :|: I2)) a) b6 L2 *) + (* (fsetUid *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) L2) in *) + (* let b8 := *) + (* eq_rect (I2 :|: (I1 :|: I2)) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) f a) b7 (I1 :|: I2 :|: I2) *) + (* (fsetUC *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) I2 *) + (* (I1 :|: I2)) in *) + (* let b9 := *) + (* eq_rect_r *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) f a) b8 *) + (* (fsetUA *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) I1 *) + (* I2 I2) in *) + (* let b10 := *) + (* eq_rect (I2 :|: I2) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) (I1 :|: f) a) b9 I2 *) + (* (fsetUid *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) I2) *) + (* in *) + (* let b11 := @op (L1 :|: L2) (L1 :|: L2) (I1 :|: I2) (I1 :|: I2) b4 b10 in *) + (* let b12 := *) + (* eq_rect (L1 :|: L2 :|: (L1 :|: L2)) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both f (I1 :|: I2 :|: (I1 :|: I2)) a) b11 *) + (* (L1 :|: L2) *) + (* (fsetUid *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) *) + (* (L1 :|: L2)) in *) + (* let b13 := *) + (* eq_rect (I1 :|: I2 :|: (I1 :|: I2)) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) f a) b12 (I1 :|: I2) *) + (* (fsetUid *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) *) + (* (I1 :|: I2)) in *) + (* let b14 := array_upd y x b13 in *) + (* let b15 := *) + (* eq_rect (L1 :|: L2 :|: (L1 :|: L2)) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both (f :|: (L1 :|: L2)) *) + (* (I1 :|: I2 :|: (I1 :|: I2) :|: (I1 :|: I2)) *) + (* (nseq_ a (from_uint_size len))) b14 (L1 :|: L2) *) + (* (fsetUid *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) *) + (* (L1 :|: L2)) in *) + (* let b16 := *) + (* eq_rect (L1 :|: L2 :|: (L1 :|: L2)) *) + (* (fun *) + (* f : {fset tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)} => *) + (* both f (I1 :|: I2 :|: (I1 :|: I2) :|: (I1 :|: I2)) *) + (* (nseq_ a (from_uint_size len))) b15 (L1 :|: L2) *) + (* (fsetUid *) + (* (T:=tag_ordType (I:=choice_type_ordType) *) + (* (fun _ : choice_type => nat_ordType)) *) + (* (L1 :|: L2)) in *) + (* let b17 := *) + (* eq_rect (I1 :|: I2 :|: (I1 :|: I2)) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) (f :|: (I1 :|: I2)) *) + (* (nseq_ a (from_uint_size len))) b16 (I1 :|: I2) *) + (* (fsetUid *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) *) + (* (I1 :|: I2)) in *) + (* let b18 := *) + (* eq_rect (I1 :|: I2 :|: (I1 :|: I2)) *) + (* (fun *) + (* f : {fset prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType *) + (* choice_type_ordType)} => *) + (* both (L1 :|: L2) f (nseq_ a (from_uint_size len))) b17 *) + (* (I1 :|: I2) *) + (* (fsetUid *) + (* (T:=prod_ordType nat_ordType *) + (* (prod_ordType choice_type_ordType choice_type_ordType)) *) + (* (I1 :|: I2)) in *) + (* b18) s1. *) + + Fixpoint array_eq_ + {a: choice_type} + {len: nat} + (eq: ( (a)) -> ( (a)) -> bool) + (s1: ( (nseq_ a len))) + (s2 : ( (nseq_ a len))) + {struct len} + : bool. + Proof. + destruct len ; cbn in *. + - exact true. + - destruct (getm s1 (fintype.Ordinal (m := len) (ssrnat.ltnSn _))) as [s | ]. + + destruct (getm s2 (fintype.Ordinal (m := len) (ssrnat.ltnSn _))) as [s0 | ]. + * exact (eq s s0). + * exact false. + + exact false. + Defined. + +Infix "array_xor" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_xor)) (at level 33) : hacspec_scope. +Infix "array_add" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_add)) (at level 33) : hacspec_scope. +Infix "array_minus" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_sub)) (at level 33) : hacspec_scope. +Infix "array_mul" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_mul)) (at level 33) : hacspec_scope. +Infix "array_div" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_div)) (at level 33) : hacspec_scope. +Infix "array_or" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_or)) (at level 33) : hacspec_scope. +Infix "array_and" := (@array_join_map (int _) _ _ _ _ _ (fun _ _ _ _ => int_and)) (at level 33) : hacspec_scope. + +Infix "array_eq" := (array_eq_ eq) (at level 33) : hacspec_scope. +Infix "array_neq" := (fun s1 s2 => negb (array_eq_ eq s1 s2)) (at level 33) : hacspec_scope. + + +(* Handle products of size 1 - 4 for foldi_both' *) +Notation "'ssp' ( 'fun' a => f )" := + (((fun (a : both _ _ _) => f)) (* : both _ _ uint_size -> both _ _ _ -> both _ _ _ *)) (at level 100, f at next level, a at next level). + +Notation "'ssp' ( 'fun' ' ( a , b ) => f )" := + (fun (temp : both _ _ (_ × _)) => lift_n 1 temp (fun '(a, b) => f)) (at level 100, f at next level, a at next level, b at next level). + +Notation "'ssp' ( 'fun' ' ( a , b , c ) => f )" := + (fun (temp : both _ _ (_ × _ × _)) => lift_n 2 temp (fun '(a, b, c) => f)) (at level 100, f at next level, a at next level, b at next level, c at next level). + +Notation "'ssp' ( 'fun' ' ( a , b , c , d ) => f )" := + (fun (temp : both _ _ (_ × _ × _ × _)) => lift_n 3 temp (fun '(a, b, c, d) => f)) (at level 100, f at next level, a at next level, b at next level, c at next level, d at next level). + +(* eq_fset *) +(* finmap.finSet *) +(* https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/aac-tactics.2C.20fset.20automation.2C.20universes *) +(* Display map / exponenetial maps *) + + +Ltac ssprove_valid_step := + (progress + ( + cbv zeta + || unfold prog + || (match goal with | [ |- context[ @bind ?A ?B (ret ?x) ?f ]] => rewrite bind_rewrite end) + || match goal with + | [ |- context[match ?x with | true => _ | false => _ end] ] => + destruct x + end + || match goal with + | [ |- context[match ?x with | tt => _ end] ] => + destruct x + end + || match goal with + | [ |- context[match ?x with | inl _ => _ | inr _ => _ end] ] => + destruct x + end + || (match goal with | [ |- context[bind (bind ?v ?k1) ?k2] ] => rewrite bind_assoc end) + || (apply valid_bind ; [apply valid_scheme ; try rewrite <- fset.fset0E ; apply prog_valid | intros]) + || (apply valid_bind ; [valid_program | intros]) + || (apply valid_bind ; [repeat ssprove_valid_step | intros]) + || (apply valid_opr ; [ (* ssprove_valid_opsig *) | intros ] ) + || match goal with + | [ |- context [ putr _ _ _ ] ] => (apply valid_putr ; [ (* ssprove_valid_location *) | ]) + + end + + || match goal with + | [ |- context [ getr _ _ ] ] => (apply valid_getr ; [ (* ssprove_valid_location *) | intros]) + end + || (match goal with + | [ |- context [ValidCode (fset ?ys) _ (@prog _ _ _ (@foldi _ ?lo ?hi (fset ?xs) _ ?f ?v))] ] => + simpl (* !! TODO !! *) + (* eapply (valid_subset_fset xs ys) ; [ | apply foldi ] *) + (* ; loc_incl_compute *) + end) + || apply valid_ret + || (hnf in * ; destruct_choice_type_prod) + )). + + +Ltac ssprove_valid'_2 := + repeat ssprove_valid_step + ; ssprove_valid_program + (* ; try ssprove_valid_location *). + +Ltac ssprove_valid_package := + (repeat apply valid_package_cons ; [ apply valid_empty_package | .. | try (rewrite <- fset0E ; setoid_rewrite @imfset0 ; rewrite in_fset0 ; reflexivity) ] ; intros ; progress unfold prog). + +Ltac solve_zero := + match goal with + | [ |- context [ (_ <= _)%Z ] ] => + cbn ; + match goal with + | [ |- context [ (0 <= toword ?x)%Z ] ] => + let H := fresh in + let H_zero := fresh in + let H_succ := fresh in + set (H := x) + ; destruct_uint_size_as_nat_named H H_zero H_succ + ; [ reflexivity | cbn in H_succ ; cbn ; try rewrite H_succ ; Lia.lia ] + end + end. + +(* Ltac ssprove_package_obligation := *) +(* setoid_rewrite (ssrbool.elimT (@fsetUidPl _ _ _)) ; [ reflexivity | ] ; *) +(* repeat rewrite fsubUset ; *) +(* repeat rewrite (ssrbool.introT (@ssrbool.andP _ _)) ; *) +(* repeat split ; *) +(* try reflexivity ; *) +(* try apply -> loc_list_incl_remove_fset ; *) +(* pose loc_list_incl_expand ; *) +(* rewrite loc_list_incl_fsubset ; *) +(* loc_incl_compute. *) + +Ltac solve_in_mem := + (* match goal with *) + (* | [ |- context [ ssrbool.in_mem _ (ssrbool.mem _) ] ] => *) + (* rewrite is_true_split_or *) + (* repeat (rewrite (@in_fsetU loc_ordType) ; rewrite Bool.orb_true_intro) ; try rewrite <- !fset1E ; try rewrite (ssrbool.introT (fset1P _ _) eq_refl) ; repeat (reflexivity || (left ; reflexivity) || right) *) + normalize_fset ; + repeat (rewrite (@in_fsetU loc_ordType) ; rewrite (is_true_split_or_)) ; try rewrite <- !fset1E ; try rewrite (ssrbool.introT (fset1P _ _) eq_refl) ; repeat (reflexivity || (left ; reflexivity) || right) + (* end *). + +Ltac solve_ssprove_obligations := + repeat ( + intros ; autounfold ; normalize_fset ; + (now solve_in_mem) (* TODO: add match goal *) + || (now fset_equality) (* TODO: add match goal *) + || (now solve_in_fset) (* TODO: add match goal *) + (* || (now solve_foldi_fsubset_trans) *) + (* || (ssprove_valid_location || loc_incl_compute || opsig_incl_compute || ssprove_package_obligation) || *) + (* (apply fsubsetxx || rewrite <- !fset0E ; apply fsub0set || now (try rewrite <- !fset0E ; try rewrite !fset0U ; try rewrite !fsetU0 ; try rewrite !fsetUA)) *) + (* || (match goal with *) + (* | [ |- context [ pkg_composition.Parable _ _ ]] => *) + (* unfold pkg_composition.Parable, fdisjoint, fsetI, fset_filter, *) + (* fmap.domm, fmap.FMap.fmval, fmap.mkfmap, fmap.setm, fmap.fmap, fset *) + (* ; now rewrite ssreflect.locked_withE *) + (* end) *) + (* || now repeat rewrite <- fset_cat *) + (* || (ssprove_valid_package ; ssprove_valid'_2) *) + || (ssprove_valid'_2) + || ((now (* try *) (Tactics.program_simpl; fail)))). + +Ltac solve_fsubset_trans := + now (solve_match || (refine (fsubset_trans _ _) ; [ | eassumption ] ; solve_ssprove_obligations)). + +Ltac solve_foldi_fsubset_trans := + normalize_fset ; + repeat (rewrite is_true_split_and || rewrite fsubUset) ; + repeat (try rewrite andb_true_intro ; split) ; + repeat (solve_fsubset_trans || apply fsubsetU ; rewrite is_true_split_or ; ((left ; solve_fsubset_trans) || right)). + (* rewrite <- (ssrbool.elimT fsetUidPr i0). *) + + +(* Equations foldi_both *) +(* {acc: choice_type} *) +(* {L1 L2 L3 I1 I2 I3} *) +(* (lo_hi: both L2 I2 uint_size * both L3 I3 uint_size) *) +(* (f: forall {L I} `{fsubset_loc : is_true (fsubset (L1 :|: (L2 :|: L3)) L)} `{fsubset_opsig : is_true (fsubset (I1 :|: (I2 :|: I3)) I)}, both (L2 :|: L3) (I2 :|: I3) uint_size -> both L I acc -> both ((L1 :|: (L2 :|: L3))) ((I1 :|: (I2 :|: I3))) (acc)) (* {i < hi} *) *) +(* (init: both L1 I1 acc) *) +(* : both (L1 :|: (L2 :|: L3)) (I1 :|: (I2 :|: I3)) (acc) := *) +(* foldi_both lo_hi f init := *) +(* solve_lift (@foldi acc (L1 :|: (L2 :|: L3)) L2 L3 (I1 :|: (I2 :|: I3)) I2 I3 (fst lo_hi) (snd lo_hi) (fun L I H0 H1 x y => solve_lift @f L I H0 H1 x y)) (solve_lift init). *) +(* Solve All Obligations with intros ; (now solve_foldi_fsubset_trans || solve_ssprove_obligations). *) + +Equations foldi_both + {acc: choice_type} + {L1 L2 L3 I1 I2 I3} + (lo_hi: both L2 I2 uint_size * both L3 I3 uint_size) + {L I} + (f: both (L2 :|: L3) (I2 :|: I3) uint_size -> + both L I acc -> + both L I acc) + (init: both L1 I1 acc) + `{is_true (fsubset (L1 :|: L2 :|: L3) L)} `{is_true (fsubset (I1 :|: I2 :|: I3) I)} + : both L I (acc) := + foldi_both lo_hi f init := + foldi (fst lo_hi) (snd lo_hi) (@f) (init). +Solve All Obligations with intros ; solve_ssprove_obligations ; solve_fsubset_trans. +Fail Next Obligation. + +Notation "'fold'" := + (fun lo_hi init f => foldi_both (L1 := _) (L2 := _) (L3 := _) (I1 := _) (I2 := _) (I3 := _) lo_hi f init). + +Equations foldi_both_list + {acc B: choice_type} + {L1 L2 I1 I2} + (l : both L2 I2 (chList B)) + {L I} + (f: both (L2) (I2) B -> + both L I acc -> + both L I acc) + (init: both L1 I1 acc) + `{is_true (fsubset (L1 :|: L2) L)} `{is_true (fsubset (I1 :|: I2) I)} + : both L I (acc) := + foldi_both_list l f init := + bind_both l (fun l' => List.fold_left (fun x y => solve_lift @f (solve_lift ret_both y) (x) : both L I _) l' (solve_lift init)). +Solve All Obligations with intros ; solve_ssprove_obligations ; solve_fsubset_trans. +Fail Next Obligation. + +(* Equations foldi_both_list *) +(* {acc B: choice_type} *) +(* `{H : Default B} *) +(* {L1 L2 I1 I2} *) +(* (l : both L2 I2 (chList B)) *) +(* (f: forall {L I} `{fsubset_loc : is_true (fsubset L1 L)} `{fsubset_opsig : is_true (fsubset I1 I)}, both (L2) (I2) B -> both L I acc -> both (L :|: (L2)) (I :|: (I2)) (acc)) (* {i < hi} *) *) +(* (init: both L1 I1 acc) *) +(* : both (L1 :|: (L2)) (I1 :|: (I2)) (acc) := *) +(* foldi_both_list l f init := *) +(* (solve_lift bind_both l (fun l' => (foldi (ret_both (repr _ 0)) (solve_lift ret_both (repr _ (length l')) : both L2 I2 _) (fun {L I H0 H1} => fun i v => solve_lift bind_both i (fun i' => @f _ _ _ _ (solve_lift ret_both (List.nth (Z.to_nat (unsigned i')) l' default)) v)) init))). *) +(* Solve Obligations with intros ; (assumption || solve_in_fset). *) +(* Fail Next Obligation. *) + +Program Definition if_both {L1 L2 L3 I1 I2 I3} {A} (c : both L1 I1 'bool) (e_then : both L2 I2 A) (e_else : both L3 I3 A) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) A := + bind_both (fsubset_loc := _) (fsubset_opsig := _) c (fun b => if b then lift_both (fsubset_loc := _) (fsubset_opsig := _) e_then else lift_both (fsubset_loc := _) (fsubset_opsig := _) e_else). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Notation "'ifb' b 'then' et 'else' ee" := + (if_both b et ee) (at level 100). + +Equations match_both_option {L1 L2 L3 I1 I2 I3} {A B} (x : both L3 I3 (option A)) (fa : both L3 I3 A -> both L1 I1 B) (fb : both L2 I2 B) `{fsubset_loc1 : is_true (fsubset L3 L1)} `{fsubset_loc2 : is_true (fsubset L3 L2)} `{fsubset_opsig1 : is_true (fsubset I3 I1)} `{fsubset_opsig2 : is_true (fsubset I3 I2)} : both (L1 :|: L2) (I1 :|: I2) B := + match_both_option x fa fb := + bind_both x (fun y => match y with + | Some a => solve_lift (fa (solve_lift (ret_both a))) + | None => solve_lift fb + end). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Notation "'matchb' x 'with' '|' 'Option_Some' a '=>' va '|' 'Option_None' '=>' vb 'end'" := + (match_both_option x (fun a => va) vb (fsubset_loc1 := _) (fsubset_loc2 := _) (fsubset_opsig1 := _) (fsubset_opsig2 := _)). + +Notation "'matchb' x 'with' '|' 'Option_Some' a '=>' va '|' '_' '=>' vb 'end'" := + (match_both_option x (fun a => va) vb (fsubset_loc1 := _) (fsubset_loc2 := _) (fsubset_opsig1 := _) (fsubset_opsig2 := _)). + +Program Definition foldi_both0_ + {acc : choice_type} + (fuel : nat) + (i : both (fset []) (fset []) uint_size) + (f: both (fset []) (fset []) (uint_size) -> both (fset []) (fset []) acc -> both (fset []) (fset []) (acc)) + (cur : both (fset []) (fset []) acc) : both (fset []) (fset []) (acc) := + foldi_ fuel i (@f) (lift_both cur (fsubset_loc := _) (fsubset_opsig := _)) (fsubset_loc := _) (fsubset_opsig := _). +Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). +Fail Next Obligation. + +Equations foldi0 + {acc: choice_type} + (lo: both (fset []) (fset []) uint_size) + (hi: both (fset []) (fset []) uint_size) (* {lo <= hi} *) + (f: both (fset []) (fset []) (uint_size) -> both (fset []) (fset []) acc -> both (fset []) (fset []) (acc)) (* {i < hi} *) + (init: both (fset []) (fset []) acc) : both (fset []) (fset []) (acc) := + foldi0 lo hi f init := + bind_both lo (fun lo => + bind_both hi (fun hi => + match Z.sub (unsigned hi) (unsigned lo) with + | Z0 => lift_both init + | Zneg p => lift_both init + | Zpos p => foldi_both0_ (Pos.to_nat p) (solve_lift (ret_both lo)) (@f) init + end)) +. +Solve All Obligations with (intros ; (fset_equality || solve_in_fset)). +Fail Next Obligation. + +Definition foldi_both0 + {acc: choice_type} + (lo_hi: both (fset []) (fset []) uint_size * both (fset []) (fset []) uint_size) + (f: both (fset []) (fset []) uint_size -> both (fset []) (fset []) acc -> both (fset []) (fset []) (acc)) (* {i < hi} *) + (init: both (fset []) (fset []) acc) + : both (fset []) (fset []) (acc) := + foldi0 (fst lo_hi) (snd lo_hi) f init. + +Equations foldi_both0_list + {acc B: choice_type} + (l : both (fset []) (fset []) (chList B)) + (f: both ((fset [])) ((fset [])) B -> both(fset []) (fset []) acc -> both (fset []) (fset []) (acc)) (* {i < hi} *) + (init: both (fset []) (fset []) acc) + : both (fset []) (fset []) (acc) := + foldi_both0_list l f init := + bind_both l (fun l' => List.fold_left (fun x y => solve_lift @f (solve_lift ret_both y) (x) : both (fset []) (fset []) _) l' (solve_lift init : both (fset []) (fset []) _)). +Solve Obligations with intros ; (assumption || solve_in_fset). +Fail Next Obligation. + + +Program Definition if_both0 {A} (c : both (fset []) (fset []) 'bool) (e_then : both (fset []) (fset []) A) (e_else : both (fset []) (fset []) A) : both (fset []) (fset []) A := + bind_both (fsubset_loc := _) (fsubset_opsig := _) c (fun b => if b then lift_both (fsubset_loc := _) (fsubset_opsig := _) e_then else lift_both (fsubset_loc := _) (fsubset_opsig := _) e_else). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Notation "'ifb0' b 'then' et 'else' ee" := + (if_both0 b et ee) (at level 100). + +(* Definition Exception t := (@choice_typeMonad.result_monad t). *) + +Notation "'letm[' bind_code_mnd ']' x ':=' y 'in' z" := (choice_typeMonad.monad_bind_both (BindCode := bind_code_mnd) y (fun x => z)) (at level 100, x pattern). +Notation "'letm[' bind_code_mnd ']' ( x : t ) ':=' y 'in' z" := (choice_typeMonad.monad_bind_both (BindCode := bind_code_mnd) y (fun x => z)) (at level 100, x pattern). + +Check letm[ @choice_typeMonad.result_bind_code ('bool) ] y := solve_lift ret_both (choice_typeMonad.ret _) in _. + +(*** Hacspec-v2 specific fixes *) + +(* From Hacspec Require Import Hacspec_Lib. *) + +(* From Coq Require Import ZArith. *) +(* Import List.ListNotations. *) +(* Open Scope Z_scope. *) +(* Open Scope bool_scope. *) + +(* Require Import Lia. *) +(* Require Import Coq.Logic.FunctionalExtensionality. *) +(* Require Import Sumbool. *) + +(* From mathcomp Require Import fintype. *) + +(* From Crypt Require Import choice_type Package Prelude. *) +(* Import PackageNotation. *) +(* From extructures Require Import ord fset fmap. *) + +(* From mathcomp Require Import ssrZ word. *) +(* From Jasmin Require Import word. *) + +(* From Coq Require Import ZArith List. *) +(* Import ListNotations. *) + +(* From Hacspec Require Import ChoiceEquality. *) +(* From Hacspec Require Import LocationUtility. *) +(* From Hacspec Require Import Hacspec_Lib_Comparable. *) +(* From Hacspec Require Import Hacspec_Lib_Pre. *) +(* From Hacspec Require Import Hacspec_Lib. *) + +(* Declare Scope hacspec_scope. *) + +(* Open Scope list_scope. *) +(* Open Scope hacspec_scope. *) +(* Open Scope nat_scope. *) + +(* Require Import Hacspec_Lib_Comparable. *) + +Import choice.Choice.Exports. +Obligation Tactic := (* try timeout 8 *) solve_ssprove_obligations. + +(** Should be moved to Hacspec_Lib.v **) +Program Definition int_xI {WS : wsize} (a : (* both (fset []) ([interface]) *)(@int WS)) : (* both (fset []) ([interface]) *) (@int WS) := + Hacspec_Lib_Pre.int_add (Hacspec_Lib_Pre.int_mul a ((* lift_to_both (fset []) ([interface]) *) (@repr WS 2))) ((* lift_to_both (fset []) ([interface]) *) (@one WS)). +(* Next Obligation. intros ; now do 2 rewrite fsetU0. Defined. *) +(* Next Obligation. intros ; rewrite <- fset0E ; now do 2 rewrite fsetU0. Defined. *) + +Program Definition int_xO {WS : wsize} (a : int WS) : int WS := + Hacspec_Lib_Pre.int_mul a (@repr WS 2). +(* Next Obligation. intros ; now rewrite fsetU0. Defined. *) +(* Next Obligation. intros ; rewrite <- fset0E ; now rewrite fsetU0. Defined. *) + +Definition both_int_one {WS : wsize} : both (fset []) ([interface]) (@int WS) := ret_both (one). + +Open Scope hacspec_scope. +Definition int_num {WS : wsize} := int WS. +Number Notation int_num Pos.of_num_int Pos.to_num_int (via positive mapping [[int_xI] => xI, [int_xO] => xO , [one] => xH]) : hacspec_scope. + +Notation "0" := (repr _ 0%Z) : hacspec_scope. + +(* Notation U8_t := int8. *) +(* Notation U8 := id. *) +(* Notation U16_t := int16. *) +(* Notation U16 := id. *) +(* Notation U32_t := int32. *) +(* Notation U32 := id. *) +(* Notation U64_t := int64. *) +(* Notation U64 := id. *) +(* Notation U128_t := int128. *) +(* Notation U128 := id. *) + +Class Addition L1 L2 (* L3 *) I1 I2 (* I3 *) (A : choice_type) (* `(H_loc_fsubset13 : is_true (fsubset L1 L3)) `(H_opsig_fsubset13 : is_true (fsubset I1 I3)) `(H_loc_fsubset23 : is_true (fsubset L2 L3)) `(H_opsig_fsubset23 : is_true (fsubset I2 I3)) *) := + add : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) A. +Notation "a .+ b" := (add a b). +(* Instance array_add_inst {ws : wsize} {len: uint_size} {L1 L2 I1 I2} : Addition L1 L2 I1 I2 (nseq (int ws) len) := { add a b := a array_add b }. *) +Instance int_add_inst {ws : wsize} {L1 L2 (* L3 *) I1 I2 (* I3 *)} (* `{H_loc_fsubset13 : is_true (fsubset L1 L3)} `{H_opsig_fsubset13 : is_true (fsubset I1 I3)} `{H_loc_fsubset23 : is_true (fsubset L2 L3)} `{H_opsig_fsubset23 : is_true (fsubset I2 I3)} *) : Addition L1 L2 (* L3 *) I1 I2 (* I3 *) (@int ws) (* H_loc_fsubset13 H_opsig_fsubset13 H_loc_fsubset23 H_opsig_fsubset23 *) := { add a b := int_add (* (H_loc_incl_x := H_loc_fsubset13) (H_opsig_incl_x := H_opsig_fsubset13) (H_loc_incl_y := H_loc_fsubset23) (H_opsig_incl_y := H_opsig_fsubset23) *) a b }. + +Class Subtraction L1 L2 (* L3 *) I1 I2 (* I3 *) (A : choice_type) (* `(H_loc_fsubset13 : is_true (fsubset L1 L3)) `(H_opsig_fsubset13 : is_true (fsubset I1 I3)) `(H_loc_fsubset23 : is_true (fsubset L2 L3)) `(H_opsig_fsubset23 : is_true (fsubset I2 I3)) *) := + sub : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) A. +Notation "a .- b" := (sub a b (Subtraction := _)). +(* Instance array_sub_inst {ws : wsize} {len: uint_size} {L1 L2 I1 I2} : Subtraction L1 L2 I1 I2 (nseq (@int ws) len) := { sub a b := a array_minus b }. *) +Instance int_sub_inst {ws : wsize} {L1 L2 (* L3 *) I1 I2 (* I3 *)} (* `{H_loc_fsubset13 : is_true (fsubset L1 L3)} `{H_opsig_fsubset13 : is_true (fsubset I1 I3)} `{H_loc_fsubset23 : is_true (fsubset L2 L3)} `{H_opsig_fsubset23 : is_true (fsubset I2 I3)} *) : Subtraction L1 L2 (* L3 *) I1 I2 (* I3 *) (@int ws) (* H_loc_fsubset13 H_opsig_fsubset13 H_loc_fsubset23 H_opsig_fsubset23 *) := { sub a b := int_sub (* (H_loc_incl_x := H_loc_fsubset13) (H_opsig_incl_x := H_opsig_fsubset13) (H_loc_incl_y := H_loc_fsubset23) (H_opsig_incl_y := H_opsig_fsubset23) *) a b }. + +Class Multiplication (L1 L2 (* L3 *) : {fset Location}) (I1 I2 (* I3 *) : Interface) A (* `(H_loc_incl1 : is_true (fsubset L1 L3)) (H_opsig_incl1 : is_true (fsubset I1 I3)) (H_loc_incl2 : is_true (fsubset L2 L3)) (H_opsig_incl2 : is_true (fsubset I2 I3)) *) := mul : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) A. +Notation "a .* b" := (mul a b). +(* Instance array_mul_inst {ws : wsize} {len: uint_size} { L1 L2 I1 I2} : Multiplication L1 L2 I1 I2 (nseq (@int ws) len) := { mul a b := a array_mul b }. *) +Program Instance int_mul_inst {ws : wsize} { L1 L2 (* L3 *) : {fset Location} } { I1 I2 (* I3 *) : Interface} (* `{H_loc_incl1 : is_true (fsubset L1 L3)} `{H_opsig_incl1 : is_true (fsubset I1 I3)} `{H_loc_incl2 : is_true (fsubset L2 L3)} `{H_opsig_incl2 : is_true (fsubset I2 I3)} *) : Multiplication L1 L2 (* L3 *) I1 I2 (* I3 *) (@int ws) (* H_loc_incl1 H_opsig_incl1 H_loc_incl2 H_opsig_incl2 *) := { mul a b := int_mul a b }. +Fail Next Obligation. + +Class Xor (L1 L2 (* L3 *) : {fset Location}) (I1 I2 (* I3 *) : Interface) A (* `(H_loc_incl1 : is_true (fsubset L1 L3)) (H_opsig_incl1 : is_true (fsubset I1 I3)) (H_loc_incl2 : is_true (fsubset L2 L3)) (H_opsig_incl2 : is_true (fsubset I2 I3)) *) := xor : both L1 I1 A -> both L2 I2 A -> both (L1 :|: L2) (* L3 *) (I1 :|: I2) (* I3 *) A. +Notation "a .^ b" := (xor a b). + +(* Instance array_xor_inst {ws : wsize} {len: uint_size} {L1 L2 I1 I2} : Xor L1 L2 I1 I2 (nseq (@int ws) len) := { xor a b := a array_xor b }. *) +Program Instance int_xor_inst {ws : wsize} {L1 L2 (* L3 *) I1 I2 (* I3 *)} (* `{H_loc_incl1 : is_true (fsubset L1 L3)} `{H_opsig_incl1 : is_true (fsubset I1 I3)} `{H_loc_incl2 : is_true (fsubset L2 L3)} `{H_opsig_incl2 : is_true (fsubset I2 I3)} *) : Xor L1 L2 (* L3 *) I1 I2 (* I3 *) (@int ws) (* H_loc_incl1 H_opsig_incl1 H_loc_incl2 H_opsig_incl2 *) := { xor a b := int_xor a b }. +Fail Next Obligation. + +(* Definition new {A : choice_type} {len} : nseq A len := array_new_ default _. *) + +(* (* Axiom conv : A -> B. *) *) +(* (* Coercion conv : A >-> B. *) *) +(* (* Check (fun x : A => x : B). *) *) + +(* Record mixin_of A := *) +(* Mixin { *) +(* as_nseq :> both A ; *) +(* as_seq :> both A ; *) +(* }. *) +(* (* Check choice_type_class_of. *) *) +(* Record class_of (A : choice_type) := { *) +(* base : choice.Choice.sort A ; *) +(* mixin : mixin_of A *) +(* }. *) +(* Structure type := Pack {sort : choice_type ; _ : class_of sort }. *) + +(* Coercion mixin : class_of >-> mixin_of. *) +(* Coercion sort : type >-> choice_type. *) + +Structure array_or_seq A L I (len : nat) := + { as_nseq :> both L I (nseq_ A len) ; + as_seq :> both L I (seq A) ; + as_list :> both L I (chList A) + }. +Print as_seq. +Print as_nseq. + +Print Graph. + +(* Check (fun x : array_or_seq 'nat 25 => x : (* both_seq *) seq 'nat). *) +(* Check (fun x : array_or_seq 'nat 25 => x : (* both_nseq *) (nseq 'nat 25)). *) + +Arguments as_seq {_} {_} {_} {_}. (* array_or_seq. *) +Arguments as_nseq {_} {_} {_} {_}. (* array_or_seq. *) +Arguments as_list {_} {_} {_} {_}. (* array_or_seq. *) +(* Coercion as_seq : array_or_seq >-> both. *) +(* Coercion as_nseq : array_or_seq >-> both. *) + + + +(* Check (fun x : array_or_seq 'nat fset0 (fset []) 25 => x : both (fset []) ([interface]) (nseq 'nat 25)). *) + +(* Definition nseq_array_or_seq {A L I len} (a : both L I (nseq A len)) := *) +(* Build_array_or_seq A L I len (array_to_seq a) a. *) +(* Canonical (* Structure *) nseq_array_or_seq. *) + +Definition array_to_list {L I A n} := lift1_both (L := L) (I := I) (fun x => (@array_to_list A n x) : chList _). + +Definition seq_to_list {L I A} := lift1_both (L := L) (I := I) (fun x => (@seq_to_list A x) : chList _). + +Definition seq_from_list {L I A} := lift1_both (L := L) (I := I) (fun (x : chList _) => seq_from_list A (x : list _)). + +Definition array_from_list' {L I A} {n : nat} := lift1_both (L := L) (I := I) (fun (x : chList A) => @array_from_list' A x n : nseq_ _ _). + +Equations nseq_array_or_seq {A L I len} (val : both L I (nseq_ A len)) : array_or_seq A L I len := + nseq_array_or_seq val := {| as_seq := array_to_seq val ; as_nseq := val ; as_list := array_to_list val |}. +Fail Next Obligation. + +Arguments nseq_array_or_seq {A} {L} {I} {len}. +Check nseq_array_or_seq. +Coercion nseq_array_or_seq : both >-> array_or_seq. +Canonical Structure nseq_array_or_seq. + +(* Check (fun (x : both (fset []) ([interface]) (nseq 'nat 25)) => x : array_or_seq 'nat fset0 (fset []) 25). *) + +(* (* TODO: use of is pure here is an issue!! *) *) +(* Definition seq_array_or_seq {A : choice_type} {L I} (a : both L I (seq A)) : array_or_seq A L I (is_pure (seq_len (* (H_loc_incl_x := fsubsetxx _) (H_opsig_incl_x := fsubsetxx _) *) a : both L I _)) := *) +(* {| as_seq := a ; as_nseq := array_from_seq _ a ; |}. *) + +(* Coercion seq_array_or_seq : both >-> array_or_seq. *) +(* Canonical Structure seq_array_or_seq. *) + +(* Definition seq_array_or_seq {A L I len} (a : both L I (seq A)) := *) +(* Build_array_or_seq A L I len a (array_from_seq (from_uint_size len) a). *) +(* Canonical (* Structure *) seq_array_or_seq. *) +(* Print Canonical Projections . *) + +(* Program Definition (* Equations *) array_index {A: choice_type} {len : nat} {L1 L2 I1 I2} (s: array_or_seq A L1 I1 len) {WS} (i : both L2 I2 (@int WS)) : both (L1 :|: L2) (I1 :|: I2) A := *) +(* (* array_index s i := *)Hacspec_Lib.array_index (as_nseq s) i. *) +(* Fail Next Obligation. *) + +(* Definition array_index {A: choice_type} {len : uint_size} {L I} (s: both L I (nseq A len)) {WS} (i : both L I (@int WS)) := array_index s i. *) + +(* Definition size : forall {L I A len} {B} (H : {B = nseq A len} + {(B = seq A)}) (x : both L I B) `{len : match H with left _ => True | right b => len = eq_rect_r (fun B0 : choice_type => both L I B0 -> uint_size) (fun x' => is_pure (seq_len x')) b x end}, uint_size. *) +(* Proof. *) +(* intros. *) +(* destruct H ; subst. *) +(* refine len. *) +(* refine (is_pure (seq_len x)). *) +(* Show Proof. *) +(* Show Proof. *) +(* Qed. *) + +(* Close Scope hacspec_scope. *) +(* Print Prelude.positive. *) +(* Definition len_of_nseq (H : choice_type) `{contra : match H with *) +(* | chUnit => True *) +(* | chMap (chFin (mkpos (S n) cond_pos) ) (A) => True *) +(* | _ => False *) +(* end} : nat. *) +(* refine *) +(* (match H as K return match K with *) +(* | chUnit => True *) +(* | chMap (chFin (mkpos (S n) cond_pos)) (A) => True *) +(* | _ => False *) +(* end -> nat with *) +(* | chUnit => fun _ => 0%nat *) +(* | chMap (chFin (mkpos pos cond_pos)) A => *) +(* match pos as n return *) +(* match n with *) +(* | O => False *) +(* | _ => True *) +(* end -> nat *) +(* with *) +(* | O => fun m_contra => False_rect nat m_contra *) +(* | S n => fun _ => S n *) +(* end *) +(* | _ => fun m_contra => False_rect nat m_contra *) +(* end contra). *) + +Definition n_seq_array_or_seq {L I A} {B} (x : both L I B) + `(contra : match B with + | chUnit => True + | chMap (chFin (@mkpos (S n) _)) (C) => C = A + | chMap 'nat (C) => C = A + | chList C => C = A + | _ => False + end) : + let len := (match B as K return + match K with + | chUnit => True + | chMap (chFin (@mkpos (S n) _)) (C) => C = A + | chMap 'nat (C) => C = A + | chList C => C = A + | _ => False + end -> nat + with + | chUnit => fun _ => 0%nat + | chMap (chFin (@mkpos p _)) C => + fun m_contra => + match p as p_ return match p_ with + | O => False + | _ => C = A + end -> nat + with + | O => fun m_contra => False_rect nat m_contra + | S n => fun _ => S n + end m_contra + | chMap 'nat C => + fun m_contra => 3%nat + | chList C => fun m_contra => 4%nat + | _ => fun m_contra => False_rect nat m_contra + end contra) in + array_or_seq A L I len. +Proof. + intros. + destruct B ; try contradiction contra. + - change 'unit with (nseq_ A len) in x. + exact {| as_seq := array_to_seq x ; as_nseq := x; as_list := array_to_list x |}. + - destruct B1 ; try contradiction contra ; simpl in *. + + subst. + change (chMap 'nat A) with (seq A) in x. + exact ({| as_seq := x ; as_nseq := array_from_seq _ x ; as_list := seq_to_list x |}). + + destruct n. + destruct pos. + * contradiction. + * subst. + replace (chMap (chFin _) A) with (nseq_ A len) in x. + 2:{ + simpl. + f_equal. + f_equal. + apply (ssrbool.elimT (positive_eqP _ _)). + unfold positive_eq. + apply eqtype.eq_refl. + } + exact {| as_seq := array_to_seq x ; as_nseq := x; as_list := array_to_list x |}. + - subst. + exact {| as_seq := seq_from_list x ; as_nseq := array_from_list' x ; as_list := x |}. +Defined. + +Notation " x '.a[' a ']'" := (array_index (n_seq_array_or_seq x _) a) (at level 40). + +(* Program Definition (* Equations *) array_upd {A: choice_type} {len : uint_size} {L1 L2 L3 I1 I2 I3} (s: both L1 I1 (nseq A len)) {WS} (i: both L2 I2 (@int WS)) (new_v: both L3 I3 A) : both (L1 :|: L2 :|: L3) (I1 :|: I2 :|: I3) (nseq A len) := *) +(* (* array_upd s i new_v := *) Hacspec_Lib.array_upd s i new_v. *) +Fail Next Obligation. +Notation " x '.a[' i ']<-' a" := (array_upd x i a) (at level 40). + +Notation update_at := array_upd. + +(* Definition update {A : Type} `{Default A} {len slen} (s : nseq A len) {WS} (start : @int WS) (start_a : array_or_seq A slen) : nseq A len := *) +(* array_update (a := A) (len := len) s (unsigned start) (as_seq start_a). *) + +(* Definition to_le_U32s {A l} := array_to_le_uint32s (A := A) (l := l). *) +(* Axiom to_le_bytes : forall {ws : wsize} {len}, nseq (@int ws) len -> seq int8. *) +(* Definition from_seq {A : Type} `{Default A} {len slen} (s : array_or_seq A slen) : nseq A len := array_from_seq _ (as_seq s). *) + +Notation t_Seq := seq. +(* Notation len := (fun s => seq_len s : int32). *) + +(* Definition array_slice {a: Type} `{Default a} {len : nat} (input: nseq a len) {WS} (start: @int WS) (slice_len: @int WS) : seq a := slice (array_to_seq input) (unsigned start) (unsigned (start .+ slice_len)). *) +(* Notation slice := array_slice. *) +(* Definition seq_new {A: Type} `{Default A} {WS} (len: @int WS) : seq A := seq_new (unsigned len). *) +(* Notation new := seq_new. *) +Notation num_exact_chunks := seq_num_exact_chunks. +Notation get_exact_chunk := seq_get_exact_chunk. +(* Definition set_chunk {a: Type} `{Default a} {len} (s: seq a) {WS} (chunk_len: @int WS) (chunk_num: @int WS) (chunk: array_or_seq a len) : seq a := seq_set_chunk s (unsigned chunk_len) (unsigned chunk_num) (as_seq chunk). *) +(* Definition set_exact_chunk {a} `{H : Default a} {len} s {WS} := @set_chunk a H len s WS. *) +Notation get_remainder_chunk := seq_get_remainder_chunk. +Notation "a <> b" := (negb (eqb a b)). + +Notation from_secret_literal := nat_mod_from_secret_literal. +(* Definition pow2 {m} (x : @int wsize32) := nat_mod_pow2 m (unsigned x). *) +(* Instance nat_mod_addition {n} : Addition (nat_mod n) := { add a b := a +% b }. *) +(* Instance nat_mod_subtraction {n} : Subtraction (nat_mod n) := { sub a b := a -% b }. *) +(* Instance nat_mod_multiplication {n} : Multiplication (nat_mod n) := { mul a b := a *% b }. *) +(* Definition from_slice {a: Type} `{Default a} {len slen} (x : array_or_seq a slen) {WS} (start: @int WS) (slice_len: @int WS) := array_from_slice default len (as_seq x) (unsigned start) (unsigned slice_len). *) +Notation zero := nat_mod_zero. +Notation to_byte_seq_le := nat_mod_to_byte_seq_le. +Notation U128_to_le_bytes := u128_to_le_bytes. +Notation U64_to_le_bytes := u64_to_le_bytes. + Notation from_byte_seq_le := nat_mod_from_byte_seq_le. +Definition from_literal {m} := nat_mod_from_literal m. +Notation inv := nat_mod_inv. +Notation update_start := array_update_start. +Notation pow := nat_mod_pow_self. +Notation bit := nat_mod_bit. + +(* Definition int_to_int {ws1 ws2} (i : @int ws1) : @int ws2 := repr (unsigned i). *) +(* Coercion int_to_int : int >-> int. *) +(* Notation push := seq_push. *) +Notation Build_secret := secret. +Notation "a -× b" := +(prod a b) (at level 80, right associativity) : hacspec_scope. +Notation Result_t := result. +Axiom TODO_name : Type. +Notation ONE := nat_mod_one. +Notation exp := nat_mod_exp. +(* Notation nat_mod := GZnZ.znz. *) +(* Instance nat_mod_znz_addition {n} : Addition (GZnZ.znz n) := { add a b := a +% b }. *) +(* Instance nat_mod_znz_subtraction {n} : Subtraction (GZnZ.znz n) := { sub a b := a -% b }. *) +(* Instance nat_mod_znz_multiplication {n} : Multiplication (GZnZ.znz n) := { mul a b := a *% b }. *) +Notation TWO := nat_mod_two. +Notation ne := (fun x y => negb (eqb x y)). +Notation eq := (eqb). +Notation rotate_right := (ror). +Notation to_be_U32s := array_to_be_uint32s. +Notation get_chunk := seq_get_chunk. +Notation num_chunks := seq_num_chunks. +Notation U64_to_be_bytes := uint64_to_be_bytes. +Notation to_be_bytes := array_to_be_bytes. +Notation U8_from_usize := uint8_from_usize. +Notation concat := seq_concat. +Notation declassify := id. +Notation U128_from_be_bytes := uint128_from_be_bytes. +Notation U128_to_be_bytes := uint128_to_be_bytes. +Notation slice_range := array_slice_range. +Notation truncate := seq_truncate. +(* Axiom array_to_be_uint64s : forall {A l}, nseq A l -> seq uint64. *) +Notation to_be_U64s := array_to_be_uint64s. +Notation classify := id. +Notation U64_from_U8 := uint64_from_uint8. +(* Definition Build_Range_t (a b : nat) := (a,b). (* match (b - a)%nat with O => [] | S n => match b with | O => [] | S b' => Build_Range_t a b' ++ [b] end end. *) *) + +Definition Build_t_Range {WS L1 L2 I1 I2} {f_start : both L1 I1 (int WS)} {f_end : both L2 I2 (int WS)} := prod_b (f_start,f_end). +Notation Build_Range := Build_t_Range. + +Notation declassify_eq := eq. +Notation String_t := String.string. + +Notation "'i8(' v ')'" := (ret_both (v : int8) : both (fset []) ([interface]) _). +Notation "'i16(' v ')'" := (ret_both (v : int16) : both (fset []) ([interface]) _). +Notation "'i32(' v ')'" := (ret_both (v : int32) : both (fset []) ([interface]) _). +Notation "'i64(' v ')'" := (ret_both (v : int64) : both (fset []) ([interface]) _). +Notation "'i128(' v ')'" := (ret_both (v : int128) : both (fset []) ([interface]) _). + +Definition (* vec_ *)len {L I A ws} := lift1_both (L := L) (I := I) (fun (x : chList A) => repr ws (List.length x)). + +Definition andb {L1 L2 I1 I2} (x : both L1 I1 'bool) (y : both L2 I2 'bool) : both (L1 :|: L2) (I1 :|: I2) 'bool := lift2_both (fun (x y : 'bool) => Datatypes.andb x y : 'bool) x y. +Definition negb {L1 I1} (x : both L1 I1 'bool) : both (L1) (I1) 'bool := lift1_both (fun (x : 'bool) => Datatypes.negb x : 'bool) x. +Notation "a <> b" := (negb (eqb a b)). +Notation "'not'" := (negb). +Notation "x ':of:' y" := (x : both _ _ y) (at level 100). +Notation "x ':of0:' y" := (x : both (fset []) (fset []) y) (at level 100). + +Class t_Serialize (Self : choice_type). +Class t_Deserial (Self : choice_type). +Class t_Serial (Self : choice_type). +Notation "'t_Eq'" := (EqDec). +(** end of: Should be moved to Hacspec_Lib.v **) + +Definition t_Result A B := result B A. + +(** Should be part of core.V **) + +Class t_Sized (A : choice_type) := Sized : A -> A. +Class t_TryFrom (A : choice_type) := TryFrom : A -> A. +Class t_Into (A : choice_type) := Into : A -> A. +Class t_PartialEq (A : choice_type) := PartialEq : A -> A. +Class t_Copy (A : choice_type) := Copy : A -> A. +Class t_Clone (A : choice_type) := Clone : A -> A. +Definition t_Option : choice_type -> choice_type := chOption. +Inductive vec_typ := +| t_Global. +Definition t_Vec : choice_type -> vec_typ -> choice_type := fun A _ => chList A. + +Notation t_Default := Default. +(* Class t_Default A := { default : A }. *) + +#[global] Instance bool_copy : t_Copy 'bool := {Copy x := x}. +#[global] Instance bool_clone : t_Clone 'bool := {Clone x := x}. +#[global] Instance bool_sized : t_Sized 'bool := {Sized x := x}. + +Definition ilog2 {WS} {L I} (x : both L I (int WS)) : both L I (int WS) := x. (* TODO *) + +Definition collect {A} {L I} (x : both L I (chList A)) : both L I (t_Vec A t_Global) := x. + + +Equations swap_both_list {A L I} (x : list (both L I A)) : both L I (chList A) := + swap_both_list x := + (List.fold_left (fun (x : both L I (chList A)) y => + bind_both x (fun x' => + bind_both y (fun y' => + solve_lift (ret_both ((y' :: x') : chList A))))) x (solve_lift (ret_both ([] : chList A)))). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Equations match_list {A B : choice_type} {L I} (x : both L I (chList A)) (f : list A -> B) : both L I B := + match_list x f := + bind_both x (fun x' => solve_lift (ret_both (f x'))). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Equations map {A B} {L I} (x : both L I (chList A)) (f : both L I A -> both L I B) : both L I (chList B) := + map x f := + bind_both x (fun x' => swap_both_list (List.map (fun y => f (solve_lift (ret_both y))) x')). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Definition cloned {A} {L I} (x : both L I (chList A)) : both L I (chList A) := x. + +Equations iter {A L I} (x : both L I (seq A)) : both L I (chList A) := + iter x := + bind_both x (fun x' => solve_lift (ret_both (Hacspec_Lib_Pre.seq_to_list _ x' : chList A))). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Definition dedup {A} {L I} (x : both L I (t_Vec A t_Global)) : both L I (t_Vec A t_Global) := x. + +Definition t_String := Coq.Strings.String.string. +Equations new {A L I} : both L I (t_Vec A t_Global) := + new := solve_lift (ret_both ([] : chList A)). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Definition enumerate {A} {L I} (x : both L I (t_Vec A t_Global)) : both L I (t_Vec A t_Global) := x. + +(* Inductive ControlFlow {L I} (A : choice_type) (B : choice_type) := *) +(* | ControlFlow_Continue (val : both L I A) *) +(* | ControlFlow_Break (val : both L I B). *) + +(* Definition run {A B : choice_type} {L I} (x : ControlFlow A B) : both L I (t_Result A B) := *) +(* match x with *) +(* | ControlFlow_Continue v => Ok v *) +(* | ControlFlow_Break v => Err v *) +(* end. *) + +(* Program Definition build_under_impl_1 {A B} : (t_Result A B) := *) +(* run (letb layers := (match branch (build_tree_under_impl_1 partial_layers depth) with *) +(* | ControlFlow_Break residual => letb hoist1 := (v_Break (from_residual residual)) : both _ _ (t_Never) in *) +(* ControlFlow_Continue (never_to_any hoist1) *) +(* | ControlFlow_Continue val => ControlFlow_Continue val *) +(* end) in *) +(* ControlFlow_Continue (Result_Ok (Build_PartialTree layers))). *) +(* Fail Next Obligation. *) + +(*** More functions *) +Definition t_Drain : choice_type -> vec_typ -> choice_type := t_Vec. +Inductive t_Range := RangeFull. +Equations drain : forall {L I A}, both L I (t_Vec A t_Global) -> t_Range -> both L I (t_Drain A t_Global × t_Vec A t_Global) := + drain x _ := + bind_both x (fun x' => solve_lift (ret_both ((x', []) : (t_Drain A t_Global × t_Vec A t_Global)))). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. +Notation t_Rev := id. +Equations rev {L I A} (x : both L I (chList A)) : both L I (chList A) := rev x := bind_both x (fun x => solve_lift (ret_both (List.rev x : chList _))). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. + +Definition pop {L I A} : both L I (chList A) -> both L I (chOption A × t_Vec A (t_Global)) := + lift1_both (fun (x : chList A) => (List.hd_error x , List.tl x) : (chOption A × t_Vec A (t_Global))). + +Definition push {L1 L2 I1 I2 A} : both L1 I1 (t_Vec A t_Global) -> both L2 I2 A -> both (L1 :|: L2) (I1 :|: I2) (t_Vec A (t_Global)) := + lift2_both (fun (x : chList A) y => y :: x : chList A). + +Notation Option_Some := Some. +Definition append {L1 L2 I1 I2} {A : choice_type} (l : both L1 I1 (chList A)) (x : both L2 I2 (chList A)) : both (L2 :|: L1) (I2 :|: I1) (chList A × chList A) := + lift2_both (fun (x : chList A) (y : chList A) => (app y x, []) : chList A × chList A) x l. + +Notation f_clone := id. +Definition seq_unzip {A B} (s : chList (A × B)) : chList A × chList B := (seq.unzip1 s, seq.unzip2 s). +Definition unzip {L I} {A B} : both L I (chList (A × B)) -> both L I (chList A × chList B) := lift1_both seq_unzip. +Equations deref {L I A} : both L I (t_Vec A t_Global) -> both L I (seq A) := + deref X := bind_both X (fun x : t_Vec A t_Global => solve_lift (ret_both (Hacspec_Lib_Pre.seq_from_list A x))). +Solve All Obligations with solve_ssprove_obligations. +Fail Next Obligation. +Definition t_Never : choice_type := 'unit. +Definition abort : both (fset []) (fset []) t_Never := ret_both (tt : 'unit). + +(* Notation v_Break := id. *) +Notation Result_Err := Err. +Notation Result_Ok := Ok. + +Notation "'ret_both' 'tt'" := (ret_both (tt : 'unit)). + +(** Should be part of concordium.v **) +Class HasInitContext (Self : choice_type). +Class t_HasInitContext (Self : choice_type) (something : choice_type). +Class t_HasActions (Self : choice_type) := {f_accept : forall {L I}, both L I Self}. +Class HasReceiveContext (Self : choice_type). +Definition t_ParamType := 'unit. +Definition t_ParseError := 'unit. +(* (t_RegisterParam) *) +Class t_HasReceiveContext (Self : choice_type) (something : choice_type) := { f_get : forall {Ctx L I}, both L I (t_ParamType × t_Result Ctx (t_ParseError)) }. +Arguments f_get {Self} {something} (t_HasReceiveContext) {Ctx} {L} {I}. + +Definition f_parameter_cursor {T : _} `{ t_Sized (T)} `{ t_HasReceiveContext (T) ('unit)} `{ t_Sized (T)} `{ t_HasReceiveContext (T) ('unit)} {L1 : {fset Location}} {I1 : Interface} (ctx : both L1 I1 (T)) : t_HasReceiveContext (T) ('unit) := _. + +(* Section ExceptionMonad. *) +(* Definition exception (A R : choice_type) := (A -> R) -> R. *) +(* Definition exception_bind {A B R} (c : (exception A R)) (f : A -> (exception B R)) : (exception B R) := (fun k => (c (fun t => f t k))). *) +(* Definition exception_ret {A R : choice_type} (a : A) : (exception A R) := *) +(* fun f => f a. *) +(* (* Cannot be monad, as we are missing chArrow ! *) *) +(* End ExceptionMonad. *) + +(* Program Definition run {L I} {A} {R : choice_type} `{Default R} (e : exception A (both L I R)) : (both L I R) := *) +(* e (fun _ => solve_lift (ret_both Hacspec_Lib_Comparable.default)). *) + +(* Definition exception (A R : Type) := (A -> R) -> R. *) +(* Definition exception_bind {A B R} (c : (exception A R)) (f : A -> (exception B R)) : (exception B R) := (fun k => (c (fun t => f t k))). *) +(* Definition exception_ret {A R : choice_type} (a : A) : (exception A R) := *) +(* fun f => f a. *) +(* (* Cannot be monad, as we are missing chArrow ! *) *) +(* (* Definition run {T T' R} : ((T -> exception T' R) -> exception T R) -> exception T R := fun f k => f (fun t x => k t) k. *) *) +(* Program Definition run {L I} {R : choice_type} (e : exception (both L I R) (both L I R)) : (both L I R) := e id. *) + +(* Definition v_Break {L I A R} (v : both L I R) : exception A (both L I R) := (fun f => v). *) + +(* Notation "'lete' x ':=' y 'in' z" := (exception_bind y (fun x => z)) (at level 100, x pattern). *) +(* Equations exception_test {L : {fset Location}} {I : Interface} : both L I (int8) := *) +(* exception_test := *) +(* solve_lift (run (lete _ := v_Break (ret_both (1 : int8)) in *) +(* ControlFlow_Continue (ret_both (0 : int8)))) : both L I (int8). *) +(* Next Obligation. *) +(* apply nat. *) +(* Qed. *) +(* Fail Next Obligation. *) + +Notation ControlFlow_Continue := Result_Ok. +Notation v_Break := Result_Err. +Notation never_to_any := id. +Equations run {L I A} (x : both L I (choice_typeMonad.M (CEMonad := (@choice_typeMonad.mnd (choice_typeMonad.result_bind_code A))) A)) : both L I A := + run x := + bind_both x (fun y => match y with + | inl r | inr r => solve_lift ret_both r + end). +Fail Next Obligation. + + +Notation "'matchb' x 'with' '|' a '=>' b 'end'" := + (bind_both x (fun y => match y with + | a => b end)) (at level 100, a pattern). + +Notation "'matchb' x 'with' '|' a '=>' b '|' c '=>' d 'end'" := + (bind_both x (fun y => match y with + | a => b + | c => d end)) (at level 100, a pattern, c pattern). + +Notation "'matchb' x 'with' '|' a '=>' b '|' c '=>' d '|' e '=>' f 'end'" := + (bind_both x (fun y => match y with + | a => b + | c => d + | e => f end)) (at level 100, a pattern, c pattern, e pattern). + +Notation "'matchb' x 'with' '|' a '=>' b '|' c '=>' d '|' e '=>' f '|' g '=>' h 'end'" := + (bind_both x (fun y => match y with + | a => b + | c => d + | e => f + | g => h end)) (at level 100, a pattern, c pattern, e pattern, g pattern). + +Notation f_branch := id. +Notation ControlFlow_Break_case := inr. +Notation ControlFlow_Continue_case := inl. + +Notation f_from_residual := Result_Err. + +Ltac remove_duplicate_pair := + normalize_fset ; + repeat match goal with + | |- context G [(?a :|: (?a :|: ?c))] => + replace (a :|: (a :|: c)) with (a :|: a :|: c) by (now rewrite <- fsetUA) ; rewrite fsetUid + end. + + +Axiom t_Reject : choice_type. +Equations repeat {L1 L2 I1 I2} {A} (e : both L1 I1 A) (n : both L2 I2 uint_size) : both (L1 :|: L2) (I1 :|: I2) (nseq A (is_pure n)) := + repeat e n := + (eq_rect + (Datatypes.length (List.repeat (solve_lift e) (Z.to_nat (unsigned (is_pure n))))) + (fun n0 : nat => both (L1 :|: L2) (I1 :|: I2) (nseq_ A n0)) (bind_both e + (fun _ : A => + array_from_list (List.repeat (solve_lift e) (Z.to_nat (unsigned (is_pure n))))) +) + (Z.to_nat (unsigned (is_pure n))) + (List.repeat_length (solve_lift e) (Z.to_nat (unsigned (is_pure n))))). +Fail Next Obligation. + +Class iterable (A B : choice_type) := {f_into_iter : forall {L I}, both L I A -> both L I (chList B)}. +Instance nseq_iterable : iterable (nseq int32 20) int32 := {| f_into_iter := fun _ _ => array_to_list |}. +Program Instance range_iterable {WS} : iterable ((int WS) × (int WS)) (int WS) := + {| f_into_iter := + fun _ _ x => + bind_both x (fun '((a, b) : int WS × int WS) => solve_lift (ret_both (List.map (fun x => repr WS (Z.of_nat x)) (List.seq (Z.to_nat (unsigned a)) (Z.to_nat (unsigned (b))-Z.to_nat (unsigned a))) : chList (int WS) ))) + |}. +Fail Next Obligation. +Notation t_IntoIter := (chList _). + diff --git a/proof-libs/coq/ssprove/src/Hacspec_Lib_Comparable.v b/proof-libs/coq/ssprove/src/Hacspec_Lib_Comparable.v new file mode 100644 index 000000000..799cee947 --- /dev/null +++ b/proof-libs/coq/ssprove/src/Hacspec_Lib_Comparable.v @@ -0,0 +1,81 @@ +From Coq Require Import ZArith List. +From Crypt Require Import Package. + +(************************************************) +(* Implementation of comparision functions *) +(************************************************) + +(* Typeclass handling of default elements, for use in sequences/arrays. + We provide instances for the library integer types *) +Class Default (A : Type) := { + default : A +}. +Global Arguments default {_} {_}. + +Class EqDec (A : Type) := + { eqb : A -> A -> bool ; + eqb_leibniz : forall x y, is_true (eqb x y) <-> x = y }. + +Infix "=.?" := eqb (at level 40) : hacspec_scope. +Infix "!=.?" := (fun a b => negb (eqb a b)) (at level 40) : hacspec_scope. + +Class Comparable (A : Type) := { + ltb : A -> A -> bool; + leb : A -> A -> bool; + gtb : A -> A -> bool; + geb : A -> A -> bool; +}. +Infix "<.?" := ltb (at level 42) : hacspec_scope. +Infix "<=.?" := leb (at level 42) : hacspec_scope. +Infix ">.?" := gtb (at level 42) : hacspec_scope. +Infix ">=.?" := geb (at level 42) : hacspec_scope. + +Instance eq_dec_lt_Comparable {A : Type} `{EqDec A} (ltb : A -> A -> bool) : Comparable A := { + ltb := ltb; + leb a b := if eqb a b then true else ltb a b ; + gtb a b := ltb b a; + geb a b := if eqb a b then true else ltb b a; + }. + +Instance eq_dec_le_Comparable {A : Type} `{EqDec A} (leb : A -> A -> bool) : Comparable A := { + ltb a b := if eqb a b then false else leb a b; + leb := leb ; + gtb a b := if eqb a b then false else leb b a; + geb a b := leb b a; + }. + +Theorem eqb_refl : forall {A} {H : EqDec A} (x : A), (@eqb A H x x) = true. +Proof. + intros. + now apply eqb_leibniz. +Qed. + +Theorem eqbP : forall {A} {H : EqDec A} (x y : A), ssrbool.reflect (x = y) (@eqb A H x y). +Proof. + intros. + apply Bool.iff_reflect. + rewrite <- eqb_leibniz. + reflexivity. +Qed. + +Theorem neqb_leibniz : forall {A} {H : EqDec A} x y, eqb x y = false <-> x <> y . +Proof. + intros. + rewrite (ssrbool.rwP ssrbool.negPf). + rewrite <- (ssrbool.rwP (@ssrbool.negP (eqb x y))). + apply not_iff_compat. + apply eqb_leibniz. +Qed. + + +Global Program Instance nat_eqdec : EqDec nat := { + eqb := Nat.eqb; + eqb_leibniz := Nat.eqb_eq ; +}. + +Global Instance nat_comparable : Comparable nat := { + ltb := Nat.ltb; + leb := Nat.leb; + gtb a b := Nat.ltb b a; + geb a b := Nat.leb b a; +}. diff --git a/proof-libs/coq/ssprove/src/Hacspec_Lib_Pre.v b/proof-libs/coq/ssprove/src/Hacspec_Lib_Pre.v new file mode 100644 index 000000000..d6c906375 --- /dev/null +++ b/proof-libs/coq/ssprove/src/Hacspec_Lib_Pre.v @@ -0,0 +1,3431 @@ +Global Set Warnings "-ambiguous-paths". +Global Set Warnings "-uniform-inheritance". +Global Set Warnings "-auto-template". +Global Set Warnings "-disj-pattern-notation". +Global Set Warnings "-notation-overridden,-ambiguous-paths". + +Require Import Lia. +Require Import Coq.Logic.FunctionalExtensionality. +Require Import Sumbool. + +From mathcomp Require Import fintype. + +From Crypt Require Import choice_type Package Prelude. +Import PackageNotation. +From extructures Require Import ord fset fmap. + +Require Import ChoiceEquality. + +From mathcomp Require Import ssrZ word. +From Jasmin Require Import word. + +From Coq Require Import ZArith List. +Import ListNotations. + +(*****************************************************) +(* Implementation of all Hacspec library functions *) +(* for choice_type types. *) +(*****************************************************) + +(*** Integers *) +Declare Scope hacspec_scope. + +Open Scope list_scope. +Open Scope hacspec_scope. +Open Scope nat_scope. + +Require Import Hacspec_Lib_Comparable. + +Import choice.Choice.Exports. + +(* Section IntType. *) + + Notation int := chWord. + + Notation unsigned := wunsigned. + Notation signed := wsigned. + Notation repr := (fun WS x => wrepr WS x : int WS). + + Notation rol := (fun u s => wrol u (unsigned s)). + Notation ror := (fun u s => wror u (unsigned s)). + + Notation int8 := (@int U8). + Notation int16 := (@int U16). + Notation int32 := (@int U32). + Notation int64 := (@int U64). + Notation int128 := (@int U128). + + Notation int_modi := wmodi. + Definition int_add {WS} : @int WS -> @int WS -> @int WS := @add_word WS. + Definition int_sub {WS} : @int WS -> @int WS -> @int WS := @sub_word WS. + Definition int_opp {WS} : @int WS -> @int WS := @opp_word WS. + Definition int_mul {WS} : @int WS -> @int WS -> @int WS := @mul_word WS. + Notation int_div := wdiv. + Notation int_mod := wmod. + Notation int_xor := wxor. + Notation int_and := wand. + Notation int_or := wor. + + Definition int_not {WS : wsize} : (@int WS) -> (@int WS) := wnot. + + Definition zero {WS : wsize} : ((@int WS)) := @word0 WS. + Definition one {WS : wsize} : ((@int WS)) := @word1 (pred WS). + + Lemma add_zero_l : forall {WS : wsize} n, int_add (@zero WS) n = n. + Proof. + intros. + apply add0w. + Defined. + + Lemma add_one_l : forall {WS : wsize} n, int_add one (repr WS n) = repr _ (Z.succ n). + Proof. + intros. + setoid_rewrite wrepr_add. + rewrite urepr_word. + replace (urepr one) with 1%Z by reflexivity. + replace toword with urepr by reflexivity. + setoid_rewrite ureprK. + now rewrite ssralg.GRing.addrC. + Defined. + + Lemma repr0_is_zero : forall {WS : wsize}, repr WS 0%Z = zero. + Proof. + intros. + now rewrite wrepr0. + Qed. + + Lemma add_repr : forall {WS : wsize} (n m : Z), int_add (repr WS n) (repr WS m) = (repr WS (n + m)%Z). + Proof. intros ; now rewrite wrepr_add. Qed. + +(* End IntType. *) + +Axiom secret : forall {WS : wsize}, ((@int WS)) -> ((@int WS)). + +Infix ".%%" := int_modi (at level 40, left associativity) : Z_scope. +Infix ".+" := int_add (at level 77) : hacspec_scope. +Infix ".-" := int_sub (at level 77) : hacspec_scope. +Notation "-" := int_opp (at level 77) : hacspec_scope. +Infix ".*" := int_mul (at level 77) : hacspec_scope. +Infix "./" := int_div (at level 77) : hacspec_scope. +Infix ".%" := int_mod (at level 77) : hacspec_scope. +Infix ".^" := int_xor (at level 77) : hacspec_scope. +Infix ".&" := int_and (at level 77) : hacspec_scope. +Infix ".|" := int_or (at level 77) : hacspec_scope. + +Notation "'not'" := int_not (at level 77) : hacspec_scope. + +(* Comparisons, boolean equality, and notation *) + +Global Program Instance nat_eqdec : EqDec nat := { + eqb := Nat.eqb; + eqb_leibniz := Nat.eqb_eq ; + }. + +Global Instance nat_comparable : Comparable nat := { + ltb := Nat.ltb; + leb := Nat.leb; + gtb a b := Nat.ltb b a; + geb a b := Nat.leb b a; + }. + +Global Instance N_eqdec : EqDec N := { + eqb := N.eqb; + eqb_leibniz := N.eqb_eq ; + }. + +Global Instance N_comparable : Comparable N := { + ltb := N.ltb; + leb := N.leb; + gtb a b := N.ltb b a; + geb a b := N.leb b a; + }. + +Global Instance Z_eqdec : EqDec Z := { + eqb := Z.eqb; + eqb_leibniz := Z.eqb_eq ; + }. + +Global Instance Z_comparable : Comparable Z := { + ltb := Z.ltb; + leb := Z.leb; + gtb a b := Z.ltb b a; + geb a b := Z.leb b a; + }. + +Lemma int_eqb_eq : forall {WS : wsize} (a b : (@int WS)), eqtype.eq_op a b = true <-> a = b. +Proof. + symmetry ; exact (ssrbool.rwP (@eqtype.eqP _ a b)). +Qed. + +Global Instance int_eqdec `{WS : wsize}: EqDec ((@int WS)) := { + eqb := eqtype.eq_op; + eqb_leibniz := int_eqb_eq ; + }. + +Global Instance int_comparable `{WS : wsize} : Comparable ((@int WS)) := + eq_dec_lt_Comparable (wlt Unsigned). + +Axiom uint8_declassify : int8 -> int8. +Axiom int8_declassify : int8 -> int8. +Axiom uint16_declassify : int16 -> int16. +Axiom int16_declassify : int16 -> int16. +Axiom uint32_declassify : int32 -> int32. +Axiom int32_declassify : int32 -> int32. +Axiom uint64_declassify : int64 -> int64. +Axiom int64_declassify : int64 -> int64. +Axiom uint128_declassify : int128 -> int128. +Axiom int128_declassify : int128 -> int128. + +Axiom uint8_classify : int8 -> int8. +Axiom int8_classify : int8 -> int8. +Axiom uint16_classify : int16 -> int16. +Axiom int16_classify : int16 -> int16. +Axiom uint32_classify : int32 -> int32. +Axiom int32_classify : int32 -> int32. +Axiom uint64_classify : int64 -> int64. +Axiom int64_classify : int64 -> int64. +Axiom uint128_classify : int128 -> int128. +Axiom int128_classify : int128 -> int128. + + +(* CompCert integers' signedness is only interpreted through 'signed' and 'unsigned', + and not in the representation. Therefore, uints are just names for their respective ints. + *) + +Notation uint8 := int8. +Notation uint32 := int32. +Notation uint64 := int64. +Notation uint128 := int128. + +Definition uint_size : choice_type := int32. +Definition int_size : choice_type := int32. + +Axiom declassify_usize_from_uint8 : uint8 -> uint_size. +Axiom declassify_u32_from_uint32 : uint32 -> uint32. + +(* Represents any type that can be converted to uint_size and back *) +Class UInt_sizeable (A : Type) := { + usize : A -> uint_size; + from_uint_size :> uint_size -> A; + }. +Arguments usize {_} {_}. +Arguments from_uint_size {_} {_}. + +Definition from_uint_size_int (x : uint_size) : @int U32 := x. +Coercion from_uint_size_int : choice.Choice.sort >-> choice.Choice.sort. + +Global Instance nat_uint_sizeable : UInt_sizeable nat := { + usize n := repr _ (Z.of_nat n); + from_uint_size n := Z.to_nat (unsigned n); + }. + +Global Instance N_uint_sizeable : UInt_sizeable N := { + usize n := repr _ (Z.of_N n); + from_uint_size n := Z.to_N (unsigned n); + }. + +Global Instance Z_uint_sizeable : UInt_sizeable Z := { + usize n := repr _ n; + from_uint_size n := unsigned n; + }. + + +(* Same, but for int_size *) +Class Int_sizeable (A : Type) := { + isize : A -> int_size; + from_int_size : int_size -> A; + }. + +Arguments isize {_} {_}. +Arguments from_int_size {_} {_}. + +Global Instance nat_Int_sizeable : Int_sizeable nat := { + isize n := repr _ (Z.of_nat n); + from_int_size n := Z.to_nat (signed n); + }. + +Global Instance N_Int_sizeable : Int_sizeable N := { + isize n := repr _ (Z.of_N n); + from_int_size n := Z.to_N (signed n); + }. + +Global Instance Z_Int_sizeable : Int_sizeable Z := { + isize n := repr _ n; + from_int_size n := signed n; + }. + +(**** Public integers *) + +Definition pub_u8 (n : uint_size) : int8 := repr _ (unsigned n). +Definition pub_i8 (n : uint_size) : int8 := repr _ (unsigned n). +Definition pub_u16 (n : uint_size) : int16 := repr _ (unsigned n). +Definition pub_i16 (n : uint_size) : int16 := repr _ (unsigned n). +Definition pub_u32 (n : uint_size) : int32 := repr _ (unsigned n). +Definition pub_i32 (n : uint_size) : int32 := repr _ (unsigned n). +Definition pub_u64 (n : uint_size) : int64 := repr _ (unsigned n). +Definition pub_i64 (n : uint_size) : int64 := repr _ (unsigned n). +Definition pub_u128 (n : uint_size) : int128 := repr _ (unsigned n). +Definition pub_i128 (n : uint_size) : int128 := repr _ (unsigned n). + +(**** Operations *) + +Definition uint8_rotate_left (u: int8) (s: int8) : int8 := rol u s. + +Definition uint8_rotate_right (u: int8) (s: int8) : int8 := ror u s. + +Definition uint16_rotate_left (u: int16) (s: int16) : int16 := + rol u s. + +Definition uint16_rotate_right (u: int16) (s: int16) : int16 := + ror u s. + +Definition uint32_rotate_left (u: int32) (s: int32) : int32 := + rol u s. + +Definition uint32_rotate_right (u: int32) (s: int32) : int32 := + ror u s. + +Definition uint64_rotate_left (u: int64) (s: int64) : int64 := + rol u s. + +Definition uint64_rotate_right (u: int64) (s: int64) : int64 := + ror u s. + +Definition uint128_rotate_left (u: int128) (s: int128) : int128 := + rol u s. + +Definition uint128_rotate_right (u: int128) (s: int128) : int128 := + ror u s. + +Definition usize_shift_right (u: uint_size) (s: int32) : uint_size := + wshr u (unsigned (@repr U32 (from_uint_size s))). +Infix "usize_shift_right" := (usize_shift_right) (at level 77) : hacspec_scope. + +Definition usize_shift_left (u: uint_size) (s: int32) : uint_size := + (rol u s). +Infix "usize_shift_left" := (usize_shift_left) (at level 77) : hacspec_scope. + +Definition pub_uint128_wrapping_add (x y: int128) : int128 := + x .+ y. + +Definition shift_left_ `{WS : wsize} (i : (@int WS)) (j : uint_size) : (@int WS) := + wshl i (unsigned (@repr WS (from_uint_size j))). + +Definition shift_right_ `{WS : wsize} (i : (@int WS)) (j : uint_size) : (@int WS):= + wshr i (unsigned (@repr WS (from_uint_size j))) . + +Infix "shift_left" := (shift_left_) (at level 77) : hacspec_scope. +Infix "shift_right" := (shift_right_) (at level 77) : hacspec_scope. + +(*** Positive util *) + +Section Util. + + Fixpoint binary_representation_pre (n : nat) {struct n}: positive := + match n with + | O => 1 + | S O => 1 + | S n => Pos.succ (binary_representation_pre n) + end%positive. + Definition binary_representation (n : nat) `(n <> O) := binary_representation_pre n. + + Theorem positive_is_succs : forall n, forall (H : n <> O) (K : S n <> O), + @binary_representation (S n) K = Pos.succ (@binary_representation n H). + Proof. induction n ; [contradiction | reflexivity]. Qed. + + (* Conversion of positive to binary representation *) + Theorem positive_to_positive_succs : forall p, binary_representation (Pos.to_nat p) (Nat.neq_sym _ _ (Nat.lt_neq _ _ (Pos2Nat.is_pos p))) = p. + Proof. + intros p. + generalize dependent (Nat.neq_sym 0 (Pos.to_nat p) (Nat.lt_neq 0 (Pos.to_nat p) (Pos2Nat.is_pos p))). + + destruct Pos.to_nat eqn:ptno. + - contradiction. + - generalize dependent p. + induction n ; intros. + + cbn. + apply Pos2Nat.inj. + symmetry. + apply ptno. + + rewrite positive_is_succs with (H := Nat.neq_succ_0 n). + rewrite IHn with (p := Pos.of_nat (S n)). + * rewrite <- Nat2Pos.inj_succ by apply Nat.neq_succ_0. + rewrite <- ptno. + apply Pos2Nat.id. + * apply Nat2Pos.id. + apply Nat.neq_succ_0. + Qed. + + (*** Uint size util *) + + (* If a natural number is in bound then a smaller natural number is still in bound *) + Lemma range_of_nat_succ : + forall {WS : wsize}, + forall i, (Z.pred 0 < Z.of_nat (S i) < modulus WS)%Z -> (Z.pred 0 < Z.of_nat i < modulus WS)%Z. + Proof. lia. Qed. + + (* Conversion to equivalent bound *) + Lemma modulus_range_helper : + forall {WS : wsize}, + forall i, (Z.pred 0 < i < modulus WS)%Z -> (0 <= i <= wmax_unsigned WS)%Z. + Proof. + intros. + unfold wmax_unsigned. + unfold wbase. + unfold nat_of_wsize in H. + lia. + Qed. + + Definition unsigned_repr_alt {WS : wsize} (a : Z) `((Z.pred 0 < a < modulus WS)%Z) : + unsigned (@repr WS a) = a. + Proof. + apply wunsigned_repr_small. + intros. + unfold wbase. + unfold nat_of_wsize in H. + lia. + Qed. + + Theorem zero_always_modulus {WS : wsize} : (Z.pred 0 < 0 < modulus WS)%Z. + Proof. easy. Qed. + + (* any uint_size can be represented as a natural number and a bound *) + (* this is easier for proofs, however less efficient for computation *) + (* as Z uses a binary representation *) + + Theorem uint_size_as_nat : + forall (us: uint_size), + { n : nat | + us = repr _ (Z.of_nat n) /\ (Z.pred 0 < Z.of_nat n < @modulus U32)%Z}. + Proof. + intros. + exists (Z.to_nat (unsigned us)). + rewrite Z2Nat.id by apply (ssrbool.elimT (word_ssrZ.leZP _ _) (urepr_ge0 us)). + split. + - rewrite wrepr_unsigned. + reflexivity. + - pose (wunsigned_range us). + unfold wbase in a. + unfold nat_of_wsize. + cbn in *. + lia. + Qed. + + (* destruct uint_size as you would a natural number *) + Definition destruct_uint_size_as_nat (a : uint_size) : forall (P : uint_size -> Prop), + forall (zero_case : P (repr _ 0%Z)), + forall (succ_case : forall (n : nat), (Z.pred 0 < Z.of_nat n < @modulus U32)%Z -> P (repr _ (Z.of_nat n))), + P a. + Proof. + intros. + destruct (uint_size_as_nat a) as [ n y ] ; destruct y as [ya yb] ; subst. + destruct n. + - apply zero_case. + - apply succ_case. + apply yb. + Qed. + + + (* induction for uint_size as you would do for a natural number *) + Definition induction_uint_size_as_nat : + forall (P : uint_size -> Prop), + (P (repr _ 0%Z)) -> + (forall n, + (Z.pred 0 < Z.succ (Z.of_nat n) < @modulus U32)%Z -> + P (repr _ (Z.of_nat n)) -> + P (repr _ (Z.succ (Z.of_nat n)))) -> + forall (a : uint_size), P a. + Proof. + intros P H_zero H_ind a. + destruct (uint_size_as_nat a) as [ n y ] ; destruct y as [ya yb] ; subst. + induction n. + - apply H_zero. + - rewrite Nat2Z.inj_succ. + apply H_ind. + + rewrite <- Nat2Z.inj_succ. + apply yb. + + apply IHn. + lia. + Qed. + + (* conversion of usize to positive or zero and the respective bound *) + Theorem uint_size_as_positive : + forall (us: uint_size), + { pu : unit + positive | + match pu with + | inl u => us = repr _ Z0 + | inr p => us = repr _ (Z.pos p) /\ (Z.pred 0 < Z.pos p < @modulus U32)%Z + end + }. + Proof. + intros. + + destruct us as [val H_]. + pose proof (H := H_). + apply Bool.andb_true_iff in H as [lt gt]. + apply (ssrbool.elimT (word_ssrZ.leZP _ _)) in lt. + apply (ssrbool.elimT (word_ssrZ.ltZP _ _)) in gt. + + destruct val. + - exists (inl tt). apply word_ext. reflexivity. + - exists (inr p). + split. + + apply word_ext. + rewrite Zmod_small by (unfold nat_of_wsize in gt ; lia). + reflexivity. + + lia. + - contradiction. + Defined. + + (* destruction of uint_size as positive *) + Definition destruct_uint_size_as_positive (a : uint_size) : forall (P : uint_size -> Prop), + (P (repr _ 0%Z)) -> + (forall b, (Z.pred 0 < Z.pos b < @modulus U32)%Z -> P (repr _ (Z.pos b))) -> + P a. + Proof. + intros P H_zero H_succ. + destruct (uint_size_as_positive a) as [ [ _ | b ] y ] ; [ subst | destruct y as [ya yb] ; subst ]. + - apply H_zero. + - apply H_succ. + apply yb. + Qed. + + (* induction of uint_size as positive *) + Definition induction_uint_size_as_positive : + forall (P : uint_size -> Prop), + (P (repr _ 0%Z)) -> + (P (repr _ 1%Z)) -> + (forall b, + (Z.pred 0 < Z.succ (Z.pos b) < @modulus U32)%Z -> + P (repr _ (Z.pos b)) -> + P (repr _ (Z.succ (Z.pos b)))) -> + forall (a : uint_size), P a. + Proof. + intros P H_zero H_one H_ind a. + + destruct (uint_size_as_positive a) as [ [ _ | b ] y ] ; [ subst | destruct y as [ya yb] ; subst ]. + - apply H_zero. + - pose proof (pos_succ_b := positive_to_positive_succs b) + ; symmetry in pos_succ_b + ; rewrite pos_succ_b in * + ; clear pos_succ_b. + + generalize dependent (Nat.neq_sym 0 (Pos.to_nat b) (Nat.lt_neq 0 (Pos.to_nat b) (Pos2Nat.is_pos b))). + + induction (Pos.to_nat b). + + contradiction. + + intros n_neq yb. + destruct n. + * apply H_one. + * rewrite (positive_is_succs _ (Nat.neq_succ_0 n) n_neq) in *. + rewrite Pos2Z.inj_succ in *. + apply H_ind. + -- apply yb. + -- apply IHn. + lia. + Qed. + +End Util. + +Global Ltac destruct_uint_size_as_nat_named a H_zero H_succ := + generalize dependent a ; + intros a ; + apply (destruct_uint_size_as_nat a) ; [ pose proof (H_zero := @unsigned_repr_alt U32 0 zero_always_modulus) | let n := fresh in let H := fresh in intros n H ; pose proof (H_succ := @unsigned_repr_alt U32 _ H)] ; intros. + +Global Ltac destruct_uint_size_as_nat a := + let H_zero := fresh in + let H_succ := fresh in + destruct_uint_size_as_nat_named a H_zero H_succ. + +Global Ltac induction_uint_size_as_nat var := + generalize dependent var ; + intros var ; + apply induction_uint_size_as_nat with (a := var) ; [ pose proof (@unsigned_repr_alt U32 0 zero_always_modulus) | let n := fresh in let IH := fresh in intros n IH ; pose proof (@unsigned_repr_alt U32 _ IH)] ; intros. + + + +(*** Loops *) + +Open Scope nat_scope. +Fixpoint foldi_ + {acc : Type} + (fuel : nat) + (i : uint_size) + (f : uint_size -> acc -> acc) + (cur : acc) : acc := + match fuel with + | 0 => cur + | S n' => foldi_ n' (i .+ one) f (f i cur) + end. +Close Scope nat_scope. +Definition foldi + {acc: Type} + (lo: uint_size) + (hi: uint_size) (* {lo <= hi} *) + (f: (uint_size) -> acc -> acc) (* {i < hi} *) + (init: acc) + : acc := + match Z.sub (unsigned hi) (unsigned lo) with + | Z0 => init + | Zneg p => init + | Zpos p => foldi_ (Pos.to_nat p) lo f init + end. + +(* Fold done using natural numbers for bounds *) +Fixpoint foldi_nat_ + {acc : Type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> acc) + (cur : acc) : acc := + match fuel with + | O => cur + | S n' => foldi_nat_ n' (S i) f (f i cur) + end. + + +Fixpoint for_loop_ + {acc : Type} + (fuel : nat) + (f : nat -> acc -> acc) + (cur : acc) : acc := + match fuel with + | O => cur + | S n' => f n' (for_loop_ n' f cur) + end. + +Definition foldi_nat + {acc: Type} + (lo: nat) + (hi: nat) (* {lo <= hi} *) + (f: nat -> acc -> acc) (* {i < hi} *) + (init: acc) : acc := + match Nat.sub hi lo with + | O => init + | S n' => foldi_nat_ (S n') lo f init + end. + +Definition for_loop_range + {acc: Type} + (lo: nat) + (hi: nat) (* {lo <= hi} *) + (f: nat -> acc -> acc) (* {i < hi} *) + (init: acc) : acc := + match Nat.sub hi lo with + | O => init + | S n' => for_loop_ (S n') (fun x => f (x + lo)%nat) init + end. + +Definition for_loop_usize {acc : Type} (lo hi : uint_size) (f : uint_size -> acc -> acc) init : acc := + for_loop_range (from_uint_size lo) (from_uint_size hi) (fun x => f (usize x)) init. + + +Lemma foldi__move_S : + forall {acc: Type} + (fuel : nat) + (i : uint_size) + (f : uint_size -> acc -> acc) + (cur : acc), + foldi_ fuel (i .+ one) f (f i cur) = foldi_ (S fuel) i f cur. +Proof. reflexivity. Qed. + +Lemma foldi__nat_move_S : + forall {acc: Type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> acc) + (cur : acc), + foldi_nat_ fuel (S i) f (f i cur) = foldi_nat_ (S fuel) i f cur. +Proof. reflexivity. Qed. + +Lemma foldi__nat_move_S_append : + forall {acc: Type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> acc) + (cur : acc), + f (i + fuel)%nat (foldi_nat_ fuel i f cur) = foldi_nat_ (S fuel) i f cur. +Proof. + induction fuel ; intros. + - rewrite <- foldi__nat_move_S. + unfold foldi_nat_. + rewrite Nat.add_0_r. + reflexivity. + - rewrite <- foldi__nat_move_S. + rewrite <- foldi__nat_move_S. + replace (i + S fuel)%nat with (S i + fuel)%nat by lia. + rewrite IHfuel. + reflexivity. +Qed. + +Theorem foldi_for_loop_eq : + forall {acc} fuel f (cur : acc), + foldi_nat_ fuel 0 f cur + = + for_loop_ fuel f cur. +Proof. + induction fuel ; intros. + - reflexivity. + - unfold for_loop_ ; fold (@for_loop_ acc). + rewrite <- foldi__nat_move_S_append. + rewrite <- IHfuel. + reflexivity. +Qed. + +Lemma foldi__nat_move_to_function : + forall {acc: choice_type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> acc) + (cur : acc), + foldi_nat_ fuel i (fun x => f (S x)) (cur) = foldi_nat_ fuel (S i) f cur. +Proof. + induction fuel ; intros. + - reflexivity. + - cbn. + rewrite IHfuel. + reflexivity. +Qed. + +Lemma foldi__nat_move_to_function_add : + forall {acc: choice_type} + (fuel : nat) + (i j : nat) + (f : nat -> acc -> acc) + (cur : acc), + foldi_nat_ fuel i (fun x => f (x + j)%nat) (cur) = foldi_nat_ fuel (i + j) f cur. +Proof. + intros acc fuel i j. generalize dependent i. + induction j ; intros. + - rewrite Nat.add_0_r. + replace (fun x : nat => f (x + 0)%nat) with f. + reflexivity. + apply functional_extensionality. + intros. + now rewrite Nat.add_0_r. + - replace (i + S j)%nat with (S i + j)%nat by lia. + rewrite <- IHj. + rewrite <- foldi__nat_move_to_function. + f_equal. + apply functional_extensionality. + intros. + f_equal. + lia. +Qed. + +Theorem foldi_for_loop_range_eq : + forall {acc : choice_type} lo hi f (cur : acc), + foldi_nat lo hi f cur + = + for_loop_range lo hi f cur. +Proof. + unfold foldi_nat. + unfold for_loop_range. + intros. + + destruct (hi - lo)%nat. + - reflexivity. + - rewrite <- foldi_for_loop_eq. + induction lo. + + f_equal. + apply functional_extensionality. + intros. + now rewrite Nat.add_0_r. + + replace (fun x : nat => f (x + S lo)%nat) with (fun x : nat => f (S (x + lo))%nat). + 2:{ + apply functional_extensionality. + intros. + f_equal. + lia. + } + + rewrite (foldi__nat_move_to_function (S n) 0 (fun x => f (x + lo)%nat)). + rewrite foldi__nat_move_to_function_add. + reflexivity. +Qed. + +(* You can do one iteration of the fold by burning a unit of fuel *) +Lemma foldi__move_S_fuel : + forall {acc: Type} + (fuel : nat) + (i : uint_size) + (f : uint_size -> acc -> acc) + (cur : acc), + (0 <= Z.of_nat fuel <= wmax_unsigned U32)%Z -> + f ((repr _ (Z.of_nat fuel)) .+ i) (foldi_ (fuel) i f cur) = foldi_ (S (fuel)) i f cur. +Proof. + intros acc fuel. + induction fuel ; intros. + - cbn. + replace (repr _ 0%Z) with (@zero U32) by (rewrite wrepr0 ; reflexivity). + rewrite add_zero_l. + reflexivity. + - do 2 rewrite <- foldi__move_S. + replace (int_add (repr _ (Z.of_nat (S fuel))) i) + with (int_add (repr _ (Z.of_nat fuel)) (int_add i one)). + 2 : { + unfold int_add. + setoid_rewrite addwA. + rewrite addwC. + rewrite addwA. + f_equal. + + rewrite Nat2Z.inj_succ. + (* unfold repr. *) + unfold add_word. + unfold wrepr. + f_equal. + rewrite urepr_word. + + replace (toword one)%Z with 1%Z by reflexivity. + + unfold urepr. + unfold eqtype.val. + unfold word_subType. + unfold toword. + unfold mkword. + rewrite Zmod_small. + + rewrite Z.add_1_l. + reflexivity. + + clear -H. + unfold modulus. + unfold two_power_nat. + cbn in *. + lia. + } + rewrite IHfuel. + reflexivity. + lia. +Qed. + +(* You can do one iteration of the fold by burning a unit of fuel *) +Lemma foldi__nat_move_S_fuel : + forall {acc: Type} + (fuel : nat) + (i : nat) + (f : nat -> acc -> acc) + (cur : acc), + (0 <= Z.of_nat fuel <= @wmax_unsigned U32)%Z -> + f (fuel + i)%nat (foldi_nat_ fuel i f cur) = foldi_nat_ (S fuel) i f cur. +Proof. + induction fuel ; intros. + - reflexivity. + - do 2 rewrite <- foldi__nat_move_S. + replace (S fuel + i)%nat with (fuel + (S i))%nat by (symmetry ; apply plus_Snm_nSm). + rewrite IHfuel. + + reflexivity. + + lia. +Qed. + +(* folds and natural number folds compute the same thing *) +Lemma foldi_to_foldi_nat : + forall {acc: Type} + (lo: uint_size) + (hi: uint_size) (* {lo <= hi} *) + (f: (uint_size) -> acc -> acc) (* {i < hi} *) + (init: acc), + (unsigned lo <= unsigned hi)%Z -> + foldi lo hi f init = foldi_nat (Z.to_nat (unsigned lo)) (Z.to_nat (unsigned hi)) (fun x => f (repr _ (Z.of_nat x))) init. +Proof. + intros. + + unfold foldi. + unfold foldi_nat. + + destruct (uint_size_as_nat hi) as [ hi_n [ hi_eq hi_H ] ] ; subst. + rewrite (@unsigned_repr_alt U32 _ hi_H) in *. + rewrite Nat2Z.id. + + destruct (uint_size_as_nat lo) as [ lo_n [ lo_eq lo_H ] ] ; subst. + rewrite (@unsigned_repr_alt U32 _ lo_H) in *. + rewrite Nat2Z.id. + + remember (hi_n - lo_n)%nat as n. + apply f_equal with (f := Z.of_nat) in Heqn. + rewrite (Nat2Z.inj_sub) in Heqn by (apply Nat2Z.inj_le ; apply H). + rewrite <- Heqn. + + assert (H_bound : (Z.pred 0 < Z.of_nat n < @modulus U32)%Z) by lia. + + clear Heqn. + induction n. + - reflexivity. + - pose proof (H_max_bound := modulus_range_helper _ (range_of_nat_succ _ H_bound)). + rewrite <- foldi__nat_move_S_fuel by apply H_max_bound. + cbn. + rewrite SuccNat2Pos.id_succ. + rewrite <- foldi__move_S_fuel by apply H_max_bound. + + destruct n. + + cbn. + replace (repr _ 0%Z) with (@zero U32) by (rewrite wrepr0 ; reflexivity). + rewrite add_zero_l. + reflexivity. + + cbn in *. + assert (H_bound_pred: (Z.pred 0 < Z.pos (Pos.of_succ_nat n) < @modulus U32)%Z) by lia. + rewrite <- (IHn H_bound_pred) ; clear IHn. + f_equal. + * rewrite add_repr. + do 2 rewrite Zpos_P_of_succ_nat. + rewrite Z.add_succ_l. + rewrite Nat2Z.inj_add. + reflexivity. + * rewrite SuccNat2Pos.id_succ. + rewrite foldi__move_S. + reflexivity. +Qed. + +(* folds can be computed by doing one iteration and incrementing the lower bound *) +Lemma foldi_nat_split_S : + forall {acc: Type} + (lo: nat) + (hi: nat) (* {lo <= hi} *) + (f: nat -> acc -> acc) (* {i < hi} *) + (init: acc), + (lo < hi)%nat -> + foldi_nat lo hi f init = foldi_nat (S lo) hi f (foldi_nat lo (S lo) f init). +Proof. + unfold foldi_nat. + intros. + + assert (succ_sub_diag : forall n, (S n - n = 1)%nat) by lia. + rewrite (succ_sub_diag lo). + + induction hi ; [ lia | ]. + destruct (S hi =? S lo)%nat eqn:hi_eq_lo. + - apply Nat.eqb_eq in hi_eq_lo ; rewrite hi_eq_lo in *. + rewrite (succ_sub_diag lo). + rewrite Nat.sub_diag. + reflexivity. + - apply Nat.eqb_neq in hi_eq_lo. + apply Nat.lt_gt_cases in hi_eq_lo. + destruct hi_eq_lo. + + lia. + + rewrite (Nat.sub_succ_l (S lo)) by apply (Nat.lt_le_pred _ _ H0). + rewrite Nat.sub_succ_l by apply (Nat.lt_le_pred _ _ H). + replace ((S (hi - S lo))) with (hi - lo)%nat by lia. + reflexivity. +Qed. + +(* folds can be split at some valid offset from lower bound *) +Lemma foldi_nat_split_add : + forall (k : nat), + forall {acc: Type} + (lo: nat) + (hi: nat) (* {lo <= hi} *) + (f: nat -> acc -> acc) (* {i < hi} *) + (init: acc), + forall {guarantee: (lo + k <= hi)%nat}, + foldi_nat lo hi f init = foldi_nat (k + lo) hi f (foldi_nat lo (k + lo) f init). +Proof. + induction k ; intros. + - cbn. + unfold foldi_nat. + rewrite Nat.sub_diag. + reflexivity. + - rewrite foldi_nat_split_S by lia. + replace (S k + lo)%nat with (k + S lo)%nat by lia. + specialize (IHk acc (S lo) hi f (foldi_nat lo (S lo) f init)). + rewrite IHk by lia. + f_equal. + rewrite <- foldi_nat_split_S by lia. + reflexivity. +Qed. + +(* folds can be split at some midpoint *) +Lemma foldi_nat_split : + forall (mid : nat), (* {lo <= mid <= hi} *) + forall {acc: Type} + (lo: nat) + (hi: nat) (* {lo <= hi} *) + (f: nat -> acc -> acc) (* {i < hi} *) + (init: acc), + forall {guarantee: (lo <= mid <= hi)%nat}, + foldi_nat lo hi f init = foldi_nat mid hi f (foldi_nat lo mid f init). +Proof. + intros. + assert (mid_is_low_plus_constant : {k : nat | (mid = lo + k)%nat}) by (exists (mid - lo)%nat ; lia). + destruct mid_is_low_plus_constant ; subst. + rewrite Nat.add_comm. + apply foldi_nat_split_add. + apply guarantee. +Qed. + +(* folds can be split at some midpoint *) +Lemma foldi_split : + forall (mid : uint_size), (* {lo <= mid <= hi} *) + forall {acc: Type} + (lo: uint_size) + (hi: uint_size) (* {lo <= hi} *) + (f: uint_size -> acc -> acc) (* {i < hi} *) + (init: acc), + forall {guarantee: (unsigned lo <= unsigned mid <= unsigned hi)%Z}, + foldi lo hi f init = foldi mid hi f (foldi lo mid f init). +Proof. + intros. + do 3 rewrite foldi_to_foldi_nat by lia. + apply foldi_nat_split ; lia. +Qed. + +(*** Path / Sorted util *) + +Lemma path_sorted_tl : + forall {T : ordType} {A} {e} {fmval : list (T * A)}, + is_true (path.sorted e (seq.unzip1 fmval)) -> + is_true (path.sorted e (seq.unzip1 (tl fmval))). +Proof. + intros. + destruct fmval. + - easy. + - cbn. + cbn in H. + destruct (seq.unzip1 fmval). + + reflexivity. + + cbn in H. + now rewrite LocationUtility.is_true_split_and in H. +Qed. + +Corollary path_path_tl : + forall {T : ordType} {A} {e} {x : T} {fmval : list (T * A)}, + is_true (path.path e x (seq.unzip1 fmval)) -> + is_true (path.sorted e (seq.unzip1 (fmval))). +Proof. + intros. + destruct fmval. reflexivity. + apply (path_sorted_tl (fmval := (x, snd p) :: p :: fmval)). + apply H. +Qed. + +Lemma path_sorted_remove : + forall {A : ordType} {B} {e} (x y : A * B) (l : list (A * B)), + ssrbool.transitive e -> + is_true + (path.sorted e + (seq.unzip1 + (x :: y :: l))) -> + is_true + (path.sorted e + (seq.unzip1 + (x :: l))). +Proof. + intros. + cbn. + induction l. + reflexivity. + cbn. + cbn in *. + rewrite !LocationUtility.is_true_split_and in H0. + destruct H0 as [? []]. + rewrite H0 in IHl. + + rewrite !LocationUtility.is_true_split_and. + split. + - eapply H. + apply H0. + apply H1. + - apply H2. +Qed. + +Corollary path_path_remove : + forall {A : ordType} {B} {e} (x : A) (y : A * B) (l : list (A * B)), + ssrbool.transitive (T:=A) e -> + is_true (path.path e (x) (seq.unzip1 (y :: l))) -> + is_true (path.path e (x) (seq.unzip1 l)). +Proof. + intros. + apply (path_sorted_remove (x, snd y) y l H). + apply H0. +Qed. + +Lemma path_sorted_rev_last : + forall {A : ordType} {B} {e} (a0 : A * B) (l : list (A * B)), + is_true (path.sorted e (seq.unzip1 (seq.rev (a0 :: l)))) -> + is_true (path.sorted e (seq.unzip1 (seq.rev l))). +Proof. + intros. + + unfold seq.unzip1 ; rewrite seq.map_rev ; fold (seq.unzip1 l). + rewrite path.rev_sorted. + apply (path_sorted_tl (fmval := (a0 :: l))). + rewrite <- path.rev_sorted. + unfold seq.unzip1 ; rewrite <- seq.map_rev ; fold (seq.unzip1 (seq.rev (a0 :: l))). + assumption. +Qed. + +(*** Seq *) + +Definition nseq_ (A: choice_type) (len : nat) : choice_type := + match len with + | O => chUnit + | S n => chMap ('fin (S n)) (A) + end. +Notation "'nseq'" := (fun (A: choice_type) (len : choice.Choice.sort uint_size) => nseq_ A (from_uint_size (UInt_sizeable := nat_uint_sizeable) len)). + +(* Definition nseq_type (A: choice_type) (len : nat) : Type := *) +(* match len with *) +(* | 0%nat => unit *) +(* | S n => { fmap ('I_len) -> A } *) +(* end. *) + +Definition seq (A : choice_type) : choice_type := chMap 'nat (A). +(* Definition seq_type (A : choice_type) : Type := FMap.fmap_type nat_ordType (A). *) + +Definition public_byte_seq := seq int8. +Definition byte_seq := seq int8. +Definition list_len := length. + +Definition seq_index_nat {A: choice_type} (s: (seq A)) (i : nat) : A := + match getm s i with + | Some a => a + | None => chCanonical A + end. + +Definition seq_index {A: choice_type} (s: (seq A)) (i : uint_size) : A := + seq_index_nat s (from_uint_size i). + +Definition seq_len_nat {A: choice_type} (s: (seq A)) : nat := + match (FMap.fmval s) with + | [] => 0 + | (x :: xs) => S (fst (seq.last x xs)) + end. + +Definition seq_len {A: choice_type} (s: (seq A)) : (uint_size) := + usize (seq_len_nat s). + +Definition seq_to_list (A: choice_type) (s : (seq A)) : list (A) := + seq.map (fun n => seq_index_nat s n) (seq.iota 0 (seq_len_nat s)). + +Definition seq_from_list (A : choice_type) (l : list (A)) : (seq A) := + fmap_of_seq l. + +Lemma seq_from_list_cat : forall A l a, seq_from_list A (l ++ [a]) = setm (seq_from_list A l) (seq.size l) a. +Proof. + clear ; intros. + unfold seq_from_list. + apply eq_fmap. + + intros i. + rewrite fmap_of_seqE. + rewrite setmE. + + destruct eqtype.eq_op eqn:i_size_l. + - apply (ssrbool.elimT eqtype.eqP) in i_size_l. + subst. + + rewrite (seq.nth_map a). + 2:{ + rewrite seq.size_cat. + now rewrite ssrnat.addn1. + } + rewrite seq.nth_cat. + rewrite ssrnat.ltnn. + rewrite ssrnat.subnn. + reflexivity. + - rewrite fmap_of_seqE. + destruct (ssrnat.leq (seq.size (l ++ [a])) i) eqn:i_in_l. + + rewrite seq.nth_default. + 2:{ + rewrite seq.size_map. + apply i_in_l. + } + rewrite seq.nth_default. + 2:{ + rewrite seq.size_map. + eapply ssrnat.leq_trans. + apply ssrnat.leqnSn. + rewrite seq.size_cat in i_in_l. + rewrite ssrnat.addn1 in i_in_l. + apply i_in_l. + } + reflexivity. + + assert (is_true (ssrnat.leq (S i) (seq.size l))). + { + rewrite ssrnat.leqNgt. + rewrite ssrnat.ltnS. + rewrite ssrnat.leq_eqVlt. + rewrite Bool.negb_orb. + rewrite eqtype.eq_sym. + setoid_rewrite i_size_l. + rewrite seq.size_cat in i_in_l. + rewrite ssrnat.addn1 in i_in_l. + rewrite i_in_l. + reflexivity. + } + + rewrite <- (@seq.nth_take (seq.size l) (option (A)) None i H (seq.map (fun x : A => Some x) (l ++ [a]))). + rewrite <- seq.map_take. + rewrite seq.take_size_cat ; [ | reflexivity ]. + reflexivity. +Qed. + +Lemma sorted_last_leq : + forall {A : ordType }{B} (a0 : A * B) (l : list (A * B)), + is_true (path.sorted Ord.lt (seq.unzip1 (a0 :: l))) -> + is_true (fst a0 <= (fst (seq.last a0 l)))%ord. +Proof. + intros ? ? a0 fmval i. + + generalize dependent a0. + induction fmval ; intros. + - apply Ord.leqxx. + - simpl. + specialize (IHfmval a0 (path_sorted_remove (e := Ord.lt) _ _ _ (@Ord.lt_trans _) i)). + erewrite Ord.leq_trans. + reflexivity. + apply IHfmval. + destruct fmval. + + simpl. + simpl in i. + rewrite Bool.andb_true_r in i. + unfold Ord.lt in i. + rewrite LocationUtility.is_true_split_and in i. + apply i. + + simpl. + apply Ord.leqxx. +Qed. + +Corollary sorted_last_nat_lt : + forall {B} (a0 : nat * B) (l : list (nat * B)), + is_true (path.sorted Ord.lt (seq.unzip1 (a0 :: l))) -> + is_true (fst a0 < S (fst (seq.last a0 l)))%ord. +Proof. + intros. + pose (sorted_last_leq a0 l H). + rewrite Ord.lt_neqAle. + rewrite (Ord.leq_trans i) ; [ | easy ]. + + destruct (eqtype.eq_op _ _) eqn:p_eq_last. + - apply (ssrbool.elimT eqtype.eqP) in p_eq_last. + setoid_rewrite p_eq_last in i. + cbn in i. + rewrite <- ssrnat.subnE in i. + rewrite ssrnat.subSnn in i. + discriminate. + - easy. +Qed. + +Theorem ord_lt_nleq_and_neq : + forall {A : ordType} {a b : A}, + is_true (a < b)%ord -> (b < a)%ord = false /\ (eqtype.eq_op b a) = false. +Proof. + intros. + + rewrite Ord.ltNge in H. + rewrite Ord.leq_eqVlt in H. + rewrite Bool.negb_orb in H. + rewrite LocationUtility.is_true_split_and in H. + destruct H. + apply ssrbool.negbTE in H. + apply ssrbool.negbTE in H0. + rewrite H , H0 ; clear H H0. + easy. +Qed. + +Corollary sorted_last_is_last : + forall {B} (a0 : nat * B) (l : list (nat * B)), + is_true (path.sorted Ord.lt (seq.unzip1 (a0 :: l))) -> + (S (fst (seq.last a0 l)) < fst a0)%ord = false /\ + (@eqtype.eq_op nat_ordType (S (fst (seq.last a0 l))) (fst a0) = false). +Proof. + intros. + + pose (i0 := sorted_last_nat_lt a0 l H). + destruct (ord_lt_nleq_and_neq i0). + rewrite H0 , H1 ; clear H0 H1. + easy. +Qed. + +Theorem ord_leq_lt_trans : + forall {A : ordType} {a b c : A}, is_true (a <= b)%ord -> is_true (b < c)%ord -> is_true (a < c)%ord. +Proof. + intros. + pose proof (Ord.leq_trans H (Ord.ltW H0)). + rewrite Ord.leq_eqVlt in H1. + rewrite LocationUtility.is_true_split_or in H1. + destruct H1. + - apply (ssrbool.elimT eqtype.eqP) in H1. + subst. + rewrite Ord.leq_eqVlt in H. + rewrite LocationUtility.is_true_split_or in H. + destruct H. + + apply (ssrbool.elimT eqtype.eqP) in H. + subst. + now rewrite Ord.ltxx in H0. + + pose proof (Ord.lt_trans H H0). + now rewrite Ord.ltxx in H1. + - apply H1. +Qed. + +Theorem ord_lt_leq_trans : + forall {A : ordType} {a b c : A}, is_true (a < b)%ord -> is_true (b <= c)%ord -> is_true (a < c)%ord. +Proof. + intros. + pose proof (Ord.leq_trans (Ord.ltW H) H0). + rewrite Ord.leq_eqVlt in H1. + rewrite LocationUtility.is_true_split_or in H1. + destruct H1. + - apply (ssrbool.elimT eqtype.eqP) in H1. + subst. + rewrite Ord.leq_eqVlt in H0. + rewrite LocationUtility.is_true_split_or in H0. + destruct H0. + + apply (ssrbool.elimT eqtype.eqP) in H0. + subst. + now rewrite Ord.ltxx in H. + + pose proof (Ord.lt_trans H H0). + now rewrite Ord.ltxx in H1. + - apply H1. +Qed. + +Theorem ord_lt_is_leq : + forall {a b : nat}, is_true (a < b)%ord -> is_true (S a <= b)%ord. +Proof. + intros. + generalize dependent a. + induction b ; intros. + - destruct a ; easy. + - destruct a ; [ easy | ]. + cbn. + cbn in IHb. + apply IHb. + apply H. +Qed. + +Theorem seq_len_nat_setm : forall {A} (l : (seq A)) a, + forall x, is_true (seq_len_nat l <= x)%ord -> + seq_len_nat (setm l x a) = S x. +Proof. + intros. + destruct l. + destruct fmval. + - reflexivity. + - unfold seq_len_nat. + simpl. + destruct (ord_lt_nleq_and_neq (ord_lt_leq_trans (sorted_last_nat_lt p fmval i) H)). + setoid_rewrite H0. + setoid_rewrite H1. + clear H0 H1. + + generalize dependent p. + induction fmval ; intros. + * reflexivity. + * simpl. + + destruct (ord_lt_nleq_and_neq (ord_lt_leq_trans (sorted_last_nat_lt a0 fmval (path_sorted_tl i)) H)). + setoid_rewrite H0. + setoid_rewrite H1. + clear H0 H1. + simpl. + + rewrite (IHfmval a0 (path_sorted_tl i)). + reflexivity. + apply H. +Qed. + +Corollary seq_len_nat_setm_len : forall {A} (l : (seq A)) a, + seq_len_nat (setm l (seq_len_nat l) a) = S (seq_len_nat l). +Proof. + intros. + apply seq_len_nat_setm. + easy. +Qed. + +Theorem seq_from_list_size : forall A l, + seq.size l = seq_len_nat (seq_from_list A l). +Proof. + intros. + rewrite <- (rev_involutive l). + induction (rev l). + - reflexivity. + - simpl. + rewrite seq_from_list_cat. + rewrite seq.size_cat. + rewrite IHl0 ; clear IHl0. + rewrite ssrnat.addn1. + + now erewrite (seq_len_nat_setm (seq_from_list A (rev l0))). +Qed. + + +Lemma destruct_fmap_last : + forall {A : ordType} {B} (a0 : A * B) (l : list (A * B)) i, + (FMap.FMap (fmval:=seq.rev (a0 :: l)) i = setm (FMap.FMap (fmval:=seq.rev l) (path_sorted_rev_last a0 l i)) (fst a0) (snd a0)). +Proof. + intros. + apply eq_fmap. + intros v. + rewrite setmE. + + destruct (eqtype.eq_op v (fst a0)) eqn:v_eq_a0. + - apply (ssrbool.elimT eqtype.eqP) in v_eq_a0. + subst. + + generalize dependent l. + intros l. + rewrite seq.rev_cons. + intros. + unfold getm ; simpl. + + induction (seq.rev l). + + simpl. now rewrite eqtype.eq_refl. + + simpl. + rewrite IHl0 ; clear IHl0. + * simpl in i. + unfold seq.unzip1 in i. + rewrite seq.map_rcons in i. + rewrite path.rcons_path in i. + rewrite LocationUtility.is_true_split_and in i. + destruct i. + pose (H1 := sorted_last_leq a l0 H). + rewrite seq.last_map in H0. + epose (ord_leq_lt_trans H1 H0). + rewrite Ord.lt_neqAle in i. + rewrite LocationUtility.is_true_split_and in i. + destruct i. + apply ssrbool.negbTE in H2. + rewrite eqtype.eq_sym. + rewrite H2. + reflexivity. + + destruct l0. + -- reflexivity. + -- simpl. + simpl in i. + rewrite LocationUtility.is_true_split_and in i. + apply i. + * unfold getm. + simpl. + unfold seq.rev at 1. + simpl. + rewrite seq.catrevE. + induction (seq.rev l) ; simpl. + -- now rewrite v_eq_a0. + -- now rewrite IHl0. +Qed. + +Lemma seq_to_list_setm : forall {A : choice_type} (l : (seq A)) a, + seq_to_list A (setm l (seq_len_nat l) a) = seq_to_list A l ++ [a]. +Proof. + intros. + + unfold seq_to_list. + rewrite seq_len_nat_setm. + rewrite <- ssrnat.addn1. + rewrite seq.iotaD. + rewrite ssrnat.add0n. + simpl. + rewrite seq.map_cat. + simpl. + unfold seq_index_nat. + rewrite setmE. + rewrite eqtype.eq_refl. + + set (seq.map _ _). + set (seq.map _ _). + + assert (l0 = l1) ; subst l0 l1. + { + set (seq_len_nat l) at 1. + assert (seq_len_nat l <= n)%nat by reflexivity. + generalize dependent n. + induction (seq_len_nat l) ; intros. + - reflexivity. + - rewrite <- ssrnat.addn1. + rewrite seq.iotaD. + rewrite <- ssrnat.addn1. + rewrite seq.iotaD. + rewrite !ssrnat.add0n. + rewrite !ssrnat.addn0. + simpl. + rewrite seq.map_cat. + rewrite seq.map_cat. + + f_equal. + { + setoid_rewrite IHn. + reflexivity. + lia. + } + { + simpl. + rewrite setmE. + replace (eqtype.eq_op _ _) with false. + 2:{ + clear -H. + cbn. + generalize dependent n0. + induction n ; intros. + - destruct n0 ; easy. + - destruct n0 ; [ easy | ]. + simpl. + specialize (IHn n0). + rewrite IHn. + reflexivity. + lia. + } + reflexivity. + } + } + + now rewrite H. + easy. +Qed. + +Definition seq_from_list_id : forall {A : choice_type} (t : list (A)), + seq_to_list A (seq_from_list A t) = t. +Proof. + intros. + rewrite <- (seq.revK t). + induction (seq.rev t). + - reflexivity. + - simpl. + rewrite seq.rev_cons. + set (h := seq.rev l) at 1 ; rewrite <- IHl ; subst h. clear IHl. + rewrite <- !seq.cats1. + rewrite seq_from_list_cat. + rewrite seq_from_list_size. + rewrite seq_to_list_setm. + reflexivity. +Qed. + +Definition seq_to_list_size : + forall {A : choice_type} (t : (seq A)), + seq.size (seq_to_list A t) = seq_len_nat t. +Proof. + intros. + destruct t. + generalize dependent fmval. + intros fmval. + rewrite <- (seq.revK fmval). + intros. + + induction (seq.rev fmval). + - reflexivity. + - rewrite destruct_fmap_last. + + intros. + + unfold seq_to_list in *. + rewrite seq_len_nat_setm. + + rewrite <- ssrnat.addn1. + rewrite seq.iotaD. + rewrite ssrnat.add0n. + simpl. + rewrite seq.map_cat. + simpl. + + rewrite ssrnat.addn1. + + unfold seq_index_nat. + + rewrite setmE. + rewrite eqtype.eq_refl. + + rewrite seq.size_cat. + rewrite seq.size_map. + rewrite seq.size_iota. + simpl. + rewrite ssrnat.addn1. + reflexivity. + + unfold seq_len_nat. + simpl. + + clear -i. + + rewrite seq.rev_cons in i. + rewrite <- seq.cats1 in i. + + set seq.rev in i ; unfold Ord.sort, nat_ordType in l0 ; subst l0. + destruct (seq.rev _). + + easy. + + generalize dependent p. + induction l0 ; intros. + * simpl. + simpl in i. + rewrite Bool.andb_true_r in i. + now apply ord_lt_is_leq. + * simpl. + apply IHl0. + apply (path_sorted_tl i). +Qed. + +Definition seq_new_ {A: choice_type} (init : A) (len: uint_size) : (seq A) := + fmap_of_seq (repeat init (Z.to_nat (unsigned len))). + +Definition seq_new {A: choice_type} (len: uint_size) : (seq A) := + seq_new_ (chCanonical A) len. + +Definition seq_create {A: choice_type} (len: uint_size) : (seq A) := + seq_new len. + +Definition repr_Z_succ : forall WS z, @repr WS (Z.succ z) = (repr _ z .+ one). +Proof. + intros. + replace one with (@repr WS 1%Z) by (unfold one ; now rewrite word1_zmodE). + now rewrite add_repr. +Qed. + +Lemma lt_succ_diag_r_sub : forall x k, (x - k < S x)%nat. +Proof. + intros. + generalize dependent x. + induction k ; intros. + - rewrite Nat.sub_0_r. + apply Nat.lt_succ_diag_r. + - destruct x. + + apply Nat.lt_succ_diag_r. + + cbn. + apply Nat.lt_lt_succ_r. + apply (IHk x). +Qed. + +Definition setm_leave_default {T : ordType} {S : choice_type} + (m : {fmap T -> S}) (i : T) (e : S) : {fmap T -> S} := + if eqtype.eq_op e (chCanonical S) + then m + else setm m i e. + +Equations array_from_list_helper {A: choice_type} (x : A) (xs: list (A)) (k : nat) : (nseq_ A (S k)) := + array_from_list_helper x [] k := + setm + emptym + (Ordinal (ssrbool.introT ssrnat.ltP (lt_succ_diag_r_sub k O))) + x ; + array_from_list_helper x (y :: ys) k := + setm + (array_from_list_helper y ys k) + (Ordinal (ssrbool.introT ssrnat.ltP (lt_succ_diag_r_sub k (length (y :: ys))))) + x. + +Definition array_from_list {A: choice_type} (l: list (A)) + : (nseq_ A (length l)) := + match l with + nil => tt + | (x :: xs) => array_from_list_helper x xs (length xs) + end. + +Definition resize_to_k {A : choice_type} (l : list A) k := List.rev (seq.drop (length l - k) (List.rev l)) ++ (List.repeat (chCanonical A) (k - length l)). + +Theorem length_resize_to_k : forall {A : choice_type} (l : list A) k, List.length (resize_to_k l k) = k. +Proof. + intros. + unfold resize_to_k. + rewrite List.app_length. + rewrite List.rev_length. + rewrite seq.size_drop. + rewrite List.repeat_length. + rewrite List.rev_length. + Lia.lia. +Defined. + +Theorem resize_to_length_idemp : forall {A : choice_type} (l : list A), l = resize_to_k l (length l). +Proof. + intros. + induction l. + - reflexivity. + - unfold resize_to_k. + rewrite (Nat.sub_diag). + rewrite seq.drop0. + rewrite List.rev_involutive. + now rewrite List.app_nil_r. +Qed. + +Definition array_from_list' {A: choice_type} (l: list (A)) (k : nat) + : (nseq_ A k) := + match k with + | O => (tt : (nseq_ A O)) + | S k' => + match resize_to_k l (S k') with + nil => fmap.emptym + | (x :: xs) => array_from_list_helper x xs k' + end + end. + +Definition lift_ordinal n (x : 'I_n) : 'I_(S n). +Proof. + destruct x. + apply (Ordinal (m := S m)). + apply i. +Defined. + +Equations lift_fval {A : choice_type} {n} (a : list ('I_(S n) * (A))) : list ('I_(S(S n)) * (A)) := + lift_fval [] := [] ; + lift_fval (x :: xs) := + (lift_ordinal (S n) (fst x) , snd x) :: lift_fval xs. + +Lemma lift_is_sorted : forall {A : choice_type} {n} (a : {fmap 'I_(S n) -> (A)}), is_true (path.sorted Ord.lt (seq.unzip1 (lift_fval a))). +Proof. + intros. + destruct a. + simpl. + + induction fmval. + - reflexivity. + - destruct a. + simpl. + intros. + rewrite lift_fval_equation_2 ; simpl. + destruct fmval. + + reflexivity. + + pose proof i. + rewrite lift_fval_equation_2 ; simpl. + + simpl in H. + rewrite LocationUtility.is_true_split_and in H. + destruct H. + + rewrite LocationUtility.is_true_split_and. + split ; [ | ]. + 2:{ + apply IHfmval. + apply H0. + } + + unfold lift_ordinal. + destruct s. + destruct (fst _). + apply H. +Qed. + +Definition lift_nseq {A: choice_type} {len : nat} (x: nseq_ A len) : (nseq_ A (S len)) := + match len as k return nseq_ A k -> nseq_ A (S k) with + | O => fun _ => emptym + | S n => + fun x => @FMap.FMap _ _ (lift_fval (FMap.fmval x)) (lift_is_sorted x) + end x. + +Definition setm_option {T : ordType} {S : choice_type} + (m : {fmap T -> S}) (i : T) (e : chOption S) : {fmap T -> S} := + match e with + | Some x => setm m i x + | None => m + end. + +Equations array_from_option_list_helper {A: choice_type} (x : chOption A) (xs: list (chOption A)) (k : nat) : (nseq_ A (S k)) := + array_from_option_list_helper x (y :: ys) O := + emptym ; + array_from_option_list_helper x [] k := + setm_option + emptym + (Ordinal (ssrbool.introT ssrnat.ltP (lt_succ_diag_r_sub k O))) + x ; + array_from_option_list_helper x (y :: ys) (S k) := + setm_option + (lift_nseq (array_from_option_list_helper y ys k)) + (Ordinal (ssrbool.introT ssrnat.ltP (lt_succ_diag_r_sub (S k) (length (y :: ys))))) + x. +Fail Next Obligation. + +Definition array_from_option_list' {A: choice_type} (l: list (chOption A)) (k : nat) + : (nseq_ A k) := + match k with + | O => (tt : (nseq_ A O)) + | S k' => + match resize_to_k l (S k') with + nil => fmap.emptym + | (x :: xs) => array_from_option_list_helper x xs k' + end + end. + +Theorem list_rev_is_seq_rev : forall T (x : list T), List.rev x = seq.rev x. +Proof. + intros. + induction x. + - reflexivity. + - simpl. + rewrite IHx. + replace (a :: nil) with (seq.rev (a :: nil)) by reflexivity. + now rewrite <- seq.rev_cat. +Qed. + +Theorem simple0_array_from_list : forall (A : choice_type) (x : list A), array_from_list' x (List.length x) = array_from_list x. +Proof. + intros. + subst. + simpl. + induction x. + - reflexivity. + - simpl. + unfold resize_to_k. + simpl. + rewrite (Nat.sub_diag (length x)). + setoid_rewrite seq.drop0. + change (List.rev _ ++ _ :: nil) with (List.rev (a :: x)). + rewrite List.rev_involutive. + now rewrite List.app_nil_r. +Defined. + +Theorem simple_array_from_list : forall (A : choice_type) (x : list A) len (H : List.length x = len), array_from_list' x len = (eq_rect (length x) (fun n : nat => nseq_ A n) (array_from_list x) len H). +Proof. + intros. + subst. + apply simple0_array_from_list. +Defined. + +(**** Array manipulation *) + +Definition array_new_ {A: choice_type} (init:A) (len: nat) : (nseq_ A len) := + match len with + O => (tt : (nseq_ A 0)) + | (S n') => array_from_list_helper init (repeat init n') n' + end. + +Equations array_index {A: choice_type} {len : nat} (s: (nseq_ A len)) {WS} (i: (@int WS)) : A := + array_index (len := 0) s i := (chCanonical A) ; + array_index (len := (S n)) s i with le_lt_dec (S n) (Z.to_nat (unsigned i)) := { + | right a with (@getm _ _ s (fintype.Ordinal (n := S n) (m := Z.to_nat (unsigned i)) ((ssrbool.introT ssrnat.ltP a)))) => { + | Some f => f + | None => (chCanonical A) + } + | left b => (chCanonical A) + }. + +Equations array_upd {A: choice_type} {len : nat} (s: (nseq_ A len)) {WS} (i: (@int WS)) (new_v: A) : (nseq_ A len) := + array_upd s i new_v with len := + { + array_upd s i new_v n with lt_dec (Z.to_nat (unsigned i)) n := { + array_upd s i new_v O (left l) => ltac:(apply Nat.ltb_lt in l ; discriminate) ; + array_upd s i new_v (S n) (left l) => (setm s (fintype.Ordinal (n := S n) (m := Z.to_nat (unsigned i)) (ssrbool.introT ssrnat.ltP l)) new_v) ; + array_upd s i new_v n (right _) => s + } + }. + +Definition array_upd2 {A: choice_type} {len : nat} (s: (nseq_ A len)) {WS} (i: (@int WS)) (new_v: A) : (nseq_ A len). +Proof. + destruct (Z.to_nat (unsigned i) acc + | S x => rec x (array_upd acc (usize (i+x)%nat) (array_index sub (usize x))) + end in + rec (n - i + 1)%nat v. + +Definition array_from_seq + {A: choice_type} + (out_len:nat) + (input: (seq A)) + : (nseq_ A out_len) := + let out := array_new_ (chCanonical A) out_len in + update_sub out 0 (out_len - 1) (@array_from_list A (@seq_to_list A input)). + +Definition slice {A} (l : list A) (i j : nat) : list A := + if (j <=? i)%nat then [] else firstn (j-i+1) (skipn i l). + +Definition lower_ordinal n (x : 'I_(S n)) (H: is_true (ord0 < x)%ord) : 'I_n. +Proof. + destruct x. + apply (Ordinal (m := Nat.pred m)). + apply ssrnat.ltnSE. + rewrite (Nat.lt_succ_pred 0). + - apply i. + - destruct m. + + discriminate. + + lia. +Defined. + + + +Equations lower_fval {A : choice_type} {n} (a : list ('I_(S(S n)) * (A))) (H : forall x, In x a -> is_true (ord0 < fst x)%ord ) : list ('I_(S n) * (A)) := + lower_fval [] H := [] ; + lower_fval (x :: xs) H := + (lower_ordinal (S n) (fst x) (H x (or_introl eq_refl)) , snd x) + :: lower_fval xs (fun y H0 => H y (in_cons x y xs H0)). + +Lemma lower_keeps_value : forall {A : choice_type} {n} (a : {fmap 'I_(S(S n)) -> (A)}) H, (seq.map snd a = seq.map snd (lower_fval a H)). +Proof. + intros. + destruct a. + simpl in *. + induction fmval. + - cbn. + reflexivity. + - destruct a. + rewrite seq.map_cons. + erewrite IHfmval. + rewrite lower_fval_equation_2 ; simpl. + f_equal. + apply (path_sorted_tl i). +Qed. + +Lemma lower_is_sorted : forall {A : choice_type} {n} (a : {fmap 'I_(S(S n)) -> (A)}) H, is_true (path.sorted Ord.lt (seq.unzip1 (lower_fval a H))). +Proof. + intros. + destruct a. + simpl. + induction fmval. + - reflexivity. + - destruct a. + simpl. + intros. + rewrite lower_fval_equation_2 ; simpl. + destruct fmval. + + reflexivity. + + pose proof i. + rewrite lower_fval_equation_2 ; simpl. + simpl in H0 |- *. + rewrite LocationUtility.is_true_split_and in H0 |- *. + + destruct H0. + split ; [ | ]. + destruct p. + simpl. + destruct s, s1. + + pose proof (H (Ordinal (n:=S (S n)) (m:=m) i0, s0) (or_introl eq_refl)). + pose proof (H (Ordinal (n:=S (S n)) (m:=m0) i1, s2) + (in_cons (Ordinal (n:=S (S n)) (m:=m) i0, s0) + (Ordinal (n:=S (S n)) (m:=m0) i1, s2) + ((Ordinal (n:=S (S n)) (m:=m0) i1, s2) :: fmval) + (or_introl eq_refl))). + + unfold Ord.lt in H0 |- *. + unfold Ord.leq in H0 |- *. + cbn. + + clear -H0 H2 H3. + rewrite LocationUtility.is_true_split_and in H0 |- *. + destruct H0. + cbn in H , H0. + destruct m, m0 ; easy. + + specialize (IHfmval (path_sorted_tl i) ( fun x H2 => H x (in_cons _ _ _ H2))). + rewrite lower_fval_equation_2 in IHfmval ; simpl in IHfmval. + simpl. + apply IHfmval. +Qed. + +Corollary lower_list_is_sorted : forall {A : choice_type} {n} (a : list ('I_(S(S n)) * (A))) H, is_true (path.sorted Ord.lt (seq.unzip1 a)) -> is_true (path.sorted Ord.lt (seq.unzip1 (lower_fval a H))). +Proof. + intros. + refine (lower_is_sorted (@FMap.FMap _ _ a _) _). + apply H0. +Qed. + +Lemma ord_ext : forall {n} m0 m1 {H1 H2}, m0 = m1 <-> Ordinal (n := S n) (m := m0) H1 = Ordinal (n := S n) (m := m1) H2. +Proof. + intros. + rewrite <- (inord_val (Ordinal H1)). + rewrite <- (inord_val (Ordinal H2)). + split. intros. subst. reflexivity. + intros. cbn in H. + unfold inord in H. + unfold eqtype.insubd in H. + unfold eqtype.insub in H. + destruct ssrbool.idP in H. + destruct ssrbool.idP in H. + cbn in H. + inversion H. + reflexivity. + contradiction. + contradiction. +Qed. + +Lemma lower_fval_ext : forall {A : choice_type} {n} (a b : {fmap 'I_(S(S n)) -> A}) H1 H2, a = b <-> lower_fval a H1 = lower_fval b H2. +Proof. + intros. + split. + - intros. + subst. + destruct b. + simpl. + induction fmval. + + reflexivity. + + simpl. + destruct a, s. + rewrite !lower_fval_equation_2. + f_equal. + * f_equal. + apply ord_ext. reflexivity. + * apply IHfmval. + apply (path_sorted_tl i). + - intros. + apply eq_fmap. + intros i. + + destruct a. + destruct b. + cbn in H. + cbn. + + f_equal. + + generalize dependent fmval0. + induction fmval as [ | p ] ; intros ; destruct fmval0 as [ | p0 ] ; try rewrite !lower_fval_equation_2 in H ; try rewrite !lower_fval_equation_1 in H ; try easy. + + inversion H. + epose (H1 p (or_introl eq_refl)). + epose (H2 p0 (or_introl eq_refl)). + + destruct p. + destruct p0. + cbn in H4. + subst. + destruct s. + destruct s1. + apply ord_ext in H3. + f_equal. + { + f_equal. + apply ord_ext. + destruct m, m0 ; try discriminate. + cbn in H3. + now rewrite H3. + } + { + eapply IHfmval. + apply H5. + + Unshelve. + apply (path_sorted_tl i0). + apply (path_sorted_tl i1). + } +Qed. + + +Lemma lower_fval_ext_list : forall {A : choice_type} {n} (a b : list ('I_(S(S n)) * (A))) (Ha : is_true (path.sorted Ord.lt (seq.unzip1 a))) (Hb : is_true (path.sorted Ord.lt (seq.unzip1 b))) H1 H2, a = b <-> lower_fval a H1 = lower_fval b H2. +Proof. + intros. + epose (lower_fval_ext (@FMap.FMap _ _ a Ha) (@FMap.FMap _ _ b Hb) H1 H2). + simpl in i. + rewrite <- i. + split. + intros. + apply fmap.eq_fmap. + intros x. + subst. + reflexivity. + intros. + now inversion H. +Qed. + + +Lemma gt_smallest_sorted : forall {A} {n} {p : 'I_n * A} {fmval}, is_true (path.sorted Ord.lt (seq.unzip1 (p :: fmval))) -> (forall x, In x fmval -> is_true (fst p < fst x)%ord). + intros. + induction fmval. + - contradiction. + - cbn in H. + rewrite LocationUtility.is_true_split_and in H. + destruct H. + destruct H0. + + subst. + apply H. + + apply IHfmval. + cbn. + eapply path.path_le. + apply (@Ord.lt_trans _). + apply H. + apply H1. + apply H0. +Qed. + +Corollary tl_gt_0_sorted : forall {A} {n} {p : 'I_(S n) * A} {fmval}, is_true (path.sorted Ord.lt (seq.unzip1 (p :: fmval))) -> (forall x, In x fmval -> is_true (ord0 < fst x)%ord). + intros. + induction fmval ; [ easy | ]. + pose proof H. + simpl in H1. + rewrite LocationUtility.is_true_split_and in H1. + destruct H1. + destruct H0. + - subst. + destruct p, o. + destruct m. + + apply H1. + + eapply Ord.lt_trans. 2: apply (gt_smallest_sorted H) ; now left. + easy. + - refine (IHfmval _ H0). + cbn. + eapply path.path_le. + apply Ord.lt_trans. + apply H1. + apply H2. +Qed. + +Lemma in_nseq_tl_gt_zero {A} {n} {m'} {i3} {k} fmval (i : + is_true (path.path Ord.lt (fst (@Ordinal _ (S m') i3, k)) (seq.unzip1 fmval))) : + (forall x : 'I_(S (S n)) * A, + In x ((@Ordinal _ (S m') i3, k) :: fmval) -> + is_true (ord0 < fst x)%ord). +Proof. + intros. + destruct H. + - subst. reflexivity. + - eapply tl_gt_0_sorted. + apply i. + apply H. +Qed. + +Equations tl_fmap {A : choice_type} {n} (a : {fmap 'I_(S(S n)) -> A}) : {fmap 'I_(S n) -> A} := + tl_fmap (@FMap.FMap _ _ [] i) := emptym ; + tl_fmap (@FMap.FMap _ _ ((@Ordinal _ 0 i3, k) :: fmval) i) := + @FMap.FMap _ _ (lower_fval fmval (gt_smallest_sorted i)) (lower_list_is_sorted _ _ (path_path_tl i)) ; + tl_fmap (@FMap.FMap _ _ ((@Ordinal _ (S m') i3, k) :: fmval) i) := + @FMap.FMap _ _ (lower_fval ((Ordinal (n:=S (S n)) (m:=S m') i3, k) :: fmval) (in_nseq_tl_gt_zero fmval i)) (lower_list_is_sorted _ _ i). +Fail Next Obligation. + +Definition nseq_hd {A : choice_type} {n} (a : (nseq_ A (S n))) : A := + match a with + | @FMap.FMap _ _ [] _ => (chCanonical A) + | @FMap.FMap _ _ (p :: _) _ => + match nat_of_ord (fst p) with + | O => snd p + | S _ => (chCanonical A) + end + end. + +Definition nseq_hd_option {A : choice_type} {n} (a : (nseq_ A (S n))) : chOption A := + match a with + | @FMap.FMap _ _ [] _ => None + | @FMap.FMap _ _ (p :: _) _ => + match nat_of_ord (fst p) with + | O => Some (snd p) + | S _ => None + end + end. + +Definition nseq_tl {A : choice_type} {n} (a : (nseq_ A (S n))) : (nseq_ A n). +Proof. destruct n ; [exact tt | apply (tl_fmap a) ]. Defined. + +Definition split_nseq_ {A : choice_type} {n} (a : (nseq_ A (S n))) : A * (nseq_ A n) := (nseq_hd a, nseq_tl a). + + +Lemma lower_fval_smaller_length {A : choice_type} {n} (a : {fmap 'I_(S(S n)) -> A}) : (length (FMap.fmval a) <= S (length (FMap.fmval (tl_fmap a))))%nat. +Proof. + destruct a. + induction fmval. + - cbn ; lia. + - simpl. + simpl in IHfmval. + destruct a, s. destruct m. + + apply Nat.eq_le_incl. + f_equal. + rewrite tl_fmap_equation_2. + (* rewrite mkfmapK ; [ | apply (lower_is_sorted (@FMap.FMap _ _ fmval (path_sorted_tl i)))]. *) + epose (lower_keeps_value (FMap.FMap (T:=ordinal_ordType (S (S n))) (fmval:=fmval) (path_sorted_tl i))). + simpl in e. + rewrite <- (map_length snd). + rewrite <- (map_length snd). + assert (forall {A B} (f : A -> B) (l : list A), seq.map f l = map f l). + { + clear ; intros. + induction l. + - reflexivity. + - cbn. + f_equal. + } + setoid_rewrite <- H. + erewrite e. + reflexivity. + + rewrite tl_fmap_equation_3. + apply le_n_S. + eapply le_trans ; [ apply (IHfmval (path_sorted_tl i)) | ]. + apply Nat.eq_le_incl. + (* rewrite mkfmapK ; [ | apply (lower_is_sorted (@FMap.FMap _ _ ((Ordinal (n:=S (S n)) (m:=S m) i0, s0) :: fmval) i)) ]. *) + simpl. + f_equal. + f_equal. + clear. + + induction fmval. + * reflexivity. + * destruct a, s. + destruct m0 ; [ discriminate | ]. + rewrite tl_fmap_equation_3. + simpl. + erewrite (proj1 (lower_fval_ext (@FMap.FMap _ _ ((Ordinal (n:=S (S n)) (m:=S m0) i1, s1) :: fmval) (path_sorted_tl i)) _ _ _) eq_refl). + reflexivity. +Qed. + + +Lemma ord_gt : (forall {A : ordType} {x y : A}, ((x < y)%ord = false) -> eqtype.eq_op x y = false -> is_true (y < x)%ord). +Proof. + clear ; intros. + rewrite Ord.ltNge in H. + apply ssrbool.negbFE in H. + rewrite Ord.leq_eqVlt in H. + rewrite LocationUtility.is_true_split_or in H. + + rewrite eqtype.eq_sym in H0. + cbn in H. + cbn in H0. + rewrite H0 in H. + destruct H ; [ discriminate | ]. + apply H. +Qed. + +Lemma path_path_setm_move_lowerbound : + forall {A : ordType} B v (y z : A * B) (l : list (A * B)), + is_true (fst y < fst z)%ord -> + is_true + (path.sorted Ord.lt (seq.unzip1 (y :: l))) -> + is_true + (path.sorted Ord.lt (seq.unzip1 ((setm_def l (fst z) v)))) -> + is_true + (path.sorted Ord.lt (seq.unzip1 (y :: (setm_def l (fst z) v)))). +Proof. + intros. + generalize dependent y. + destruct l ; intros. + - cbn. + now rewrite H. + - cbn. + cbn in H1. + pose proof (path_sorted_tl H1). + cbn in H1. + set (fst z < fst p)%ord in *. + destruct b eqn:b_lt ; subst b ; cbn in H1. + + cbn. + rewrite H. + rewrite b_lt. + cbn. + rewrite H2. + reflexivity. + + destruct eqtype.eq_op eqn:b_eq ; cbn in H1. + * cbn. + rewrite H. + cbn. + rewrite H1. + reflexivity. + * pose proof (ord_gt b_lt b_eq). + clear b_lt b_eq. + cbn. + rewrite H1. + + cbn in H0. + rewrite LocationUtility.is_true_split_and in H0. + destruct H0. + rewrite H0. + reflexivity. +Qed. + +Lemma setm_def_cons : + forall (A : ordType) B (a : A * B) s (k : A) v, + setm_def (a :: s) k v = ((if (fst a < k)%ord + then a + else (k, v) + ) :: if (k < fst a)%ord + then a :: s + else + if eqtype.eq_op k (fst a) + then s + else setm_def (T:=A) s k v). +Proof. + intros. + cbn. + destruct (k < fst a)%ord eqn:k_lt_a. + - unfold Ord.lt in k_lt_a. + apply (ssrbool.rwP ssrbool.andP) in k_lt_a. + destruct k_lt_a. + rewrite Ord.leqNgt in H. + apply ssrbool.negbTE in H. + rewrite H. + reflexivity. + - destruct eqtype.eq_op eqn:k_eq_a. + + unfold Ord.lt. + rewrite eqtype.eq_sym in k_eq_a. + rewrite k_eq_a. + cbn. + rewrite Bool.andb_false_r. + reflexivity. + + rewrite Ord.ltNge in k_lt_a. + apply ssrbool.negbFE in k_lt_a. + unfold Ord.lt. + rewrite k_lt_a. + rewrite eqtype.eq_sym in k_eq_a. + rewrite k_eq_a. + reflexivity. +Qed. + +Lemma setm_cons : + forall (A : ordType) B (a : A * B) s (k : A) v H, + setm (FMap.FMap (fmval:=(a :: s)) H) k v = + setm (setm (FMap.FMap (fmval:=s) (path_sorted_tl H)) (fst a) (snd a)) k v. +Proof. + intros. + apply eq_fmap. + intros t. + rewrite !setmE. + reflexivity. +Qed. + +Lemma array_is_max_length {A : choice_type} {n} (a : (nseq_ A (S n))) : (length (FMap.fmval a) <= S n)%nat. +Proof. + induction n. + - destruct a. + cbn. + destruct fmval. + + cbn. lia. + + destruct fmval. + * cbn. lia. + * cbn in i. + destruct p , p0. + destruct s , s1. + cbn in i. + destruct m , m0 ; discriminate. + - cbn in *. + specialize (IHn (tl_fmap a)). + apply le_n_S in IHn. + refine (le_trans (length (FMap.fmval a)) _ (S (S n)) _ IHn). + apply lower_fval_smaller_length. +Qed. + + +Definition nth_nseq_ {A : choice_type} {n} (a : (nseq_ A (S n))) (i : nat) (H : (i <= n)%nat) : A. +Proof. + generalize dependent i. + induction n ; intros. + - apply (nseq_hd a). + - destruct i. + + apply (nseq_hd a). + + apply (IHn (nseq_tl a) i). + apply le_S_n. + apply H. +Defined. + +Equations array_to_list {A : choice_type} {n} (f : (nseq_ A n)) : list (A) := + array_to_list (n:=O%nat) f := [] ; + array_to_list (n:=S _%nat) f := nseq_hd f :: array_to_list (nseq_tl f). +Fail Next Obligation. + +Theorem array_to_length_list_is_len : forall (A : choice_type) len (x : nseq_ A len), List.length (array_to_list x) = len. +Proof. + intros. + induction len. + - reflexivity. + - rewrite array_to_list_equation_2. + simpl. + rewrite IHlen. + reflexivity. +Defined. + +Equations array_to_option_list {A : choice_type} {n} (f : (nseq_ A n)) : list (chOption A) := + array_to_option_list (n:=O%nat) f := [] ; + array_to_option_list (n:=S _%nat) f := nseq_hd_option f :: array_to_option_list (nseq_tl f). +Fail Next Obligation. + +Theorem array_to_length_option_list_is_len : forall (A : choice_type) len (x : nseq_ A len), List.length (array_to_option_list x) = len. +Proof. + intros. + induction len. + - reflexivity. + - rewrite array_to_option_list_equation_2. + simpl. + rewrite IHlen. + reflexivity. +Defined. + +Lemma nseq_hd_ord0 : + forall A n (a : (nseq_ A (S n))) (x : A), + @nseq_hd A (n) (setm a ord0 x) = x. +Proof. + intros. + cbn. + destruct a. + destruct fmval. + + reflexivity. + + cbn. + destruct negb eqn:O_p. + * reflexivity. + * apply ssrbool.negbFE in O_p. + rewrite O_p. + reflexivity. +Qed. + +Lemma nseq_tl_ord0 : + forall A n (a : (nseq_ A (S n))) (x : A), + @nseq_tl A n (setm a ord0 x) = nseq_tl a. +Proof. + intros. + destruct n. + + reflexivity. + + destruct a. + induction fmval as [ | p ]. + * apply eq_fmap. intros ?. + reflexivity. + * destruct p, s. + unfold setm. + unfold fmap. + unfold ord0. + cbn. + destruct m. + + -- cbn. + rewrite !tl_fmap_equation_2. + apply eq_fmap. intros ?. + cbn. + f_equal. + now erewrite (proj1 (lower_fval_ext (@FMap.FMap _ _ fmval (path_sorted_tl i)) _ _ _) eq_refl). + -- cbn. + rewrite tl_fmap_equation_2. + rewrite tl_fmap_equation_3. + apply eq_fmap. intros ?. + cbn. + f_equal. + now erewrite (proj1 (lower_fval_ext (@FMap.FMap _ _ ((Ordinal (n:=S (S n)) (m:=S m) i0, s0) :: fmval) i) _ _ _) eq_refl). +Qed. + +Lemma array_to_list_ord0 : + forall A n (a : (nseq_ A (S n))) (x : A), + @array_to_list A (S n) (setm a ord0 x) = x :: array_to_list (nseq_tl a). +Proof. + intros. + rewrite array_to_list_equation_2. + f_equal. + - apply nseq_hd_ord0. + - f_equal. + apply nseq_tl_ord0. +Qed. + +Lemma split_nseq_correct {A : choice_type} {n} (a : (nseq_ A (S n))) : nseq_hd a :: array_to_list (nseq_tl a) = array_to_list a. +Proof. + reflexivity. +Qed. + +Definition array_to_seq {A : choice_type} {n} (f : (nseq_ A n)) : (seq A) := + seq_from_list _ (array_to_list f). + +Definition positive_slice {A : choice_type} {n} `{H: Positive n} (l : (nseq_ A n)) (i j : nat) `{H1: (i < j)%nat} `{(j - i < length (array_to_list l) - i)%nat} : Positive (length (slice (array_to_list l) i j)). +Proof. + unfold slice. + rewrite (proj2 (Nat.leb_gt j i) H1). + rewrite firstn_length_le. + - unfold Positive. + apply (ssrbool.introT ssrnat.ltP). + lia. + - rewrite skipn_length. + apply lt_n_Sm_le. + lia. +Defined. + +Theorem slice_length : + forall A (l : list A) (i j : nat), + length (slice l i j) = + if (j <=? i)%nat then @length A ([]) else length (firstn (j - i + 1) (skipn i l)). +Proof. + intros. + unfold slice. + destruct (j <=? i)%nat. + - reflexivity. + - reflexivity. +Qed. + +Definition lseq_slice {A : choice_type} {n} (l : (nseq_ A n)) (i j : nat) : + (@nseq_ A (length (slice (array_to_list l) (i) (j)))) := + array_from_list (slice (array_to_list l) (i) (j)). + +Definition seq_sub {A : choice_type} (s : seq A) (start n : nat) := + lseq_slice (array_from_seq (from_uint_size (seq_len s)) s) start (start + n)%nat. + +Definition array_update_slice + {A : choice_type} + {l : nat} + (out: ((nseq_ A l))) + (start_out: uint_size) + (input: seq A) + (start_in: uint_size) + (len: nat) + : nseq_ A l := + update_sub out (from_uint_size start_out) (len) (seq_sub input (from_uint_size start_in) len). + +Definition array_from_slice + {A: choice_type} + (default_value: A) + (out_len: nat) + (input: (seq A)) + (start: nat) + (slice_len: nat) + : (nseq_ A out_len) := + let out := array_new_ default_value out_len in + array_from_seq out_len input. + +Definition array_slice + {A: choice_type} + (input: (seq A)) + (start: nat) + (slice_len: nat) + : (nseq_ A slice_len) := + array_from_slice (chCanonical A) (slice_len) input (slice_len) (slice_len). + +Definition array_from_slice_range + {a: choice_type} + (default_value: a) + (out_len: nat) + (input: (seq a)) + (start_fin: (uint_size * uint_size)) + : (nseq_ a out_len). +Proof. + pose (out := array_new_ default_value (out_len)). + destruct start_fin as [start fin]. + refine (update_sub out 0 ((from_uint_size fin) - (from_uint_size start)) _). + + apply (@lseq_slice a ((from_uint_size fin) - (from_uint_size start)) (array_from_seq ((from_uint_size fin) - (from_uint_size start)) input) (from_uint_size start) (from_uint_size fin)). +Defined. + +Definition array_slice_range + {a: choice_type} + {len : nat} + (input: (nseq_ a len)) + (start_fin:(uint_size * uint_size)) + : (seq a) := + array_to_seq (lseq_slice input (from_uint_size (fst start_fin)) (from_uint_size (snd start_fin))). + +Definition array_update + {a: choice_type} + {len: nat} + (s: (nseq_ a len)) + (start : uint_size) + (start_s: (seq a)) + : (nseq_ a len) := + update_sub s (from_uint_size start) (from_uint_size (seq_len start_s)) (array_from_seq (from_uint_size (seq_len start_s)) (start_s)). + +Definition array_update_start + {a: choice_type} + {len: nat} + (s: (nseq_ a len)) + (start_s: (seq a)) + : (nseq_ a len) := + update_sub s 0 (from_uint_size (seq_len start_s)) (array_from_seq (from_uint_size (seq_len start_s)) start_s). + + +Definition array_len {a: choice_type} {len: nat} (s: (nseq_ a len)) : uint_size := usize len. +(* May also come up as 'length' instead of 'len' *) +Definition array_length {a: choice_type} {len: nat} (s: (nseq_ a len)) : uint_size := usize len. + +(**** Seq manipulation *) + +Definition seq_slice + {a: choice_type} + (s: ((seq a))) + (start: (uint_size)) + (len: (uint_size)) + : (seq a) := + array_to_seq (lseq_slice (array_from_seq (from_uint_size (seq_len s)) s) (from_uint_size start) ((from_uint_size start) + (from_uint_size len))). + +Definition seq_slice_range + {a: choice_type} + (input: ((seq a))) + (start_fin:(((uint_size)) * ((uint_size)))) + : ((seq a)) := + seq_slice input (fst start_fin) (snd start_fin). + + + +Equations seq_update_sub {A : choice_type} (v : (seq A)) (i : nat) (n : nat) (sub : (seq A)) : (seq A) := + seq_update_sub v i 0 sub := v ; + seq_update_sub v i (S n) sub := + seq_update_sub (setm v (i+n)%nat match getm sub n with + | Some y => y + | None => (chCanonical A) + end) i n sub. + +(* updating a subsequence in a sequence *) +Definition seq_update + {a: choice_type} + (s: ((seq a))) + (start: uint_size) + (input: ((seq a))) + : ((seq a)) := + seq_update_sub s (from_uint_size start) (from_uint_size (seq_len input)) input. + +Definition old_seq_update + {a: choice_type} + (s: ((seq a))) + (start: uint_size) + (input: ((seq a))) + : ((seq a)) := + array_to_seq (update_sub (array_from_seq (from_uint_size (seq_len s)) s) (from_uint_size start) (from_uint_size (seq_len input)) (array_from_seq (from_uint_size (seq_len input)) input)). + +(* updating only a single value in a sequence*) +Definition seq_upd + {a: choice_type} + (s: ((seq a))) + (start: uint_size) + (v: ((a))) + : ((seq a)) := + seq_update s start (setm emptym 0%nat v). + +Definition seq_update_start + {a: choice_type} + (s: ((seq a))) + (start_s: ((seq a))) + : ((seq a)) := + array_to_seq (update_sub (array_from_seq (from_uint_size (seq_len s)) s) 0 (from_uint_size (seq_len start_s)) (array_from_seq (from_uint_size (seq_len start_s)) start_s)). + +Definition seq_update_slice + {A : choice_type} + (out: seq A) + (start_out: nat) + (input: seq A) + (start_in: nat) + (len: nat) + : ((seq A)) + := + array_to_seq (update_sub (array_from_seq (from_uint_size (seq_len out)) out) start_out len (seq_sub input start_in len)). + +Definition seq_concat + {A : choice_type} + (s1 :seq A) + (s2: seq A) + : ((seq A)) := + seq_from_list _ (seq_to_list _ s1 ++ seq_to_list _ s2). + +Definition seq_concat_owned + {A : choice_type} + (s1 :seq A) + (s2: seq A) + : ((seq A)) := seq_concat s1 s2. + +Definition seq_push + {A : choice_type} + (s1 :seq A) + (s2: ((A))) + : ((seq A)) := + setm s1 (seq_len_nat s1) s2. + +Theorem seq_push_list_app : forall {A : choice_type} (t : (seq A)) (s : A), + (seq_to_list A (Hacspec_Lib_Pre.seq_push t s) = seq_to_list A t ++ [s]). +Proof. + intros. + + unfold seq_push. + rewrite seq_to_list_setm. + reflexivity. +Qed. + +Definition seq_push_owned + {a : choice_type} + (s1 :((seq a))) + (s2: ((a))) + : ((seq a)) := seq_push s1 s2. + +Definition seq_from_slice + {A: choice_type} + (input: ((seq A))) + (start_fin: (((uint_size)) * ((uint_size)))) + : ((seq A)) := + let out := array_new_ ((chCanonical A)) (from_uint_size (seq_len input)) in + let (start, fin) := start_fin in + array_to_seq (update_sub out 0 ((from_uint_size fin) - (from_uint_size start)) ((lseq_slice (array_from_seq (from_uint_size (seq_len input)) input) (from_uint_size start) (from_uint_size fin)))). + +Definition seq_from_slice_range + {A: choice_type} + (input: ((seq A))) + (start_fin: (((uint_size)) * ((uint_size)))) + : ((seq A)) := + let out := array_new_ (chCanonical A) (from_uint_size (seq_len input)) in + let (start, fin) := start_fin in + array_to_seq (update_sub out 0 ((from_uint_size fin) - (from_uint_size start)) ((lseq_slice (array_from_seq (from_uint_size (seq_len input)) input) (from_uint_size start) (from_uint_size fin)))). + +Definition seq_from_seq {A} (l : (seq A)) : (seq A) := l. + +(**** Chunking *) + +Definition seq_num_chunks {a: choice_type} (s: ((seq a))) (chunk_len: uint_size) : uint_size := + ((seq_len s .+ chunk_len .- one) ./ chunk_len)%nat. + +Definition seq_chunk_len + {a: choice_type} + (s: ((seq a))) + (chunk_len: nat) + (chunk_num: nat) + : 'nat := + let idx_start := (chunk_len * chunk_num)%nat in + if ((from_uint_size (seq_len s)) <.? (idx_start + chunk_len))%nat then + ((from_uint_size (seq_len s)) - idx_start)%nat + else + chunk_len. + +Definition seq_get_chunk + {a: choice_type} + (s: ((seq a))) + (chunk_len: uint_size) + (chunk_num: uint_size) + : (((uint_size × seq a))) + := + let idx_start := (from_uint_size chunk_len * from_uint_size chunk_num)%nat in + let out_len := seq_chunk_len s (from_uint_size chunk_len) (from_uint_size chunk_num) in + (usize out_len, array_to_seq (lseq_slice (array_from_seq (from_uint_size (seq_len s)) s) idx_start (idx_start + seq_chunk_len s (from_uint_size chunk_len) (from_uint_size chunk_num)))). + +Definition seq_set_chunk + {a: choice_type} + (s: ((seq a))) + (chunk_len: uint_size) + (chunk_num: uint_size) + (chunk: ((seq a)) ) : ((seq a)) := + let idx_start := (from_uint_size chunk_len * from_uint_size chunk_num)%nat in + let out_len := seq_chunk_len s (from_uint_size chunk_len) (from_uint_size chunk_num) in + array_to_seq (update_sub (array_from_seq (from_uint_size (seq_len s)) s) idx_start out_len (array_from_seq (from_uint_size (seq_len chunk)) chunk)). + + +Definition seq_num_exact_chunks {a} (l : ((seq a))) (chunk_size : ((uint_size))) : ((uint_size)) := + (repr _ (Z.of_nat (length l))) ./ chunk_size. + +Definition seq_get_exact_chunk {a : choice_type} (l : ((seq a))) (chunk_size chunk_num: ((uint_size))) : ((seq a)) := + let '(len, chunk) := seq_get_chunk l chunk_size chunk_num in + if eqtype.eq_op len chunk_size then emptym else chunk. + +Definition seq_set_exact_chunk {A : choice_type} := + @seq_set_chunk A. + +Definition seq_get_remainder_chunk {a : choice_type} (l : (seq a)) (chunk_size : uint_size) : (seq a) := + let chunks := seq_num_chunks l chunk_size in + let last_chunk := if (zero <.? chunks) + then (chunks .- one)%nat + else zero in + let (len, chunk) := seq_get_chunk l chunk_size last_chunk in + if eqtype.eq_op len chunk_size + then emptym + else chunk. + +Fixpoint list_xor_ {WS} (x y : list ((@int WS))) : list ((@int WS)) := + match x, y with + | (x :: xs), (y :: ys) => (int_xor x y) :: (list_xor_ xs ys) + | [] , _ => y + | _, [] => x + end. + +Definition seq_xor_ {WS} (x y : (seq (@int WS))) : (seq (@int WS)) := + seq_from_list _ (list_xor_ (seq_to_list _ x) (seq_to_list _ y)). +Infix "seq_xor" := seq_xor_ (at level 33) : hacspec_scope. + +Fixpoint list_truncate {a} (x : list a) (n : nat) : list a := + match x, n with + | _, O => [] + | [], _ => [] + | (x :: xs), S n' => x :: (list_truncate xs n') + end. +Definition seq_truncate {a : choice_type} (x : (seq a)) (n : nat) : (seq a) := + seq_from_list _ (list_truncate (seq_to_list _ x) n). + +(**** Numeric operations *) + +(* takes two nseq's and joins them using a function op : a -> a -> a *) +Definition array_join_map + {a: choice_type} + {len: nat} + (op: ((a)) -> ((a)) -> ((a))) + (s1: ((nseq_ a len))) + (s2 : ((nseq_ a len))) := + let out := s1 in + foldi (usize 0%nat) (usize len) (fun i out => + array_upd out i (op (array_index s1 i) (array_index s2 i)) + ) out. + +Infix "array_xor" := (array_join_map (a := int _) int_xor) (at level 33) : hacspec_scope. +Infix "array_add" := (array_join_map (a := int _) int_add) (at level 33) : hacspec_scope. +Infix "array_minus" := (array_join_map (a := int _) int_sub) (at level 33) : hacspec_scope. + +Infix "array_mul" := (array_join_map (a := int _) int_mul) (at level 33) : hacspec_scope. +Infix "array_div" := (array_join_map (a := int _) int_div) (at level 33) : hacspec_scope. +Infix "array_or" := (array_join_map (a := int _) int_or) (at level 33) : hacspec_scope. +Infix "array_and" := (array_join_map (a := int _) int_and) (at level 33) : hacspec_scope. + +Fixpoint array_eq_ + {a: choice_type} + {len: nat} + (eq: ((a)) -> ((a)) -> bool) + (s1: ((nseq_ a len))) + (s2 : ((nseq_ a len))) + {struct len} + : bool. +Proof. + destruct len ; cbn in *. + - exact true. + - destruct (getm s1 (fintype.Ordinal (m := len) (ssrnat.ltnSn _))) as [s | ]. + + destruct (getm s2 (fintype.Ordinal (m := len) (ssrnat.ltnSn _))) as [s0 | ]. + * exact (eq s s0). + * exact false. + + exact false. +Defined. + +Infix "array_eq" := (array_eq_ eq) (at level 33) : hacspec_scope. +Infix "array_neq" := (fun s1 s2 => negb (array_eq_ eq s1 s2)) (at level 33) : hacspec_scope. + + + + +(*** Nats *) + + +Definition nat_mod (p : Z) : choice_type := 'fin (S (Init.Nat.pred (Z.to_nat p))). +(* Definition nat_mod_type {p : Z} : Type := 'I_(S (Init.Nat.pred (Z.to_nat p))). *) +Definition mk_natmod {p} (z : Z) : (nat_mod p) := @zmodp.inZp (Init.Nat.pred (Z.to_nat p)) (Z.to_nat z). + +Definition nat_mod_equal {p} (a b : (nat_mod p)) : bool := + @eqtype.eq_op (ordinal_eqType (S (Init.Nat.pred (Z.to_nat p)))) a b. + +Definition nat_mod_equal_reflect {p} {a b} : Bool.reflect (a = b) (@nat_mod_equal p a b) := + @eqtype.eqP (ordinal_eqType (S (Init.Nat.pred (Z.to_nat p)))) a b. + +Definition nat_mod_zero {p} : (nat_mod p) := zmodp.Zp0. +Definition nat_mod_one {p} : (nat_mod p) := zmodp.Zp1. +Definition nat_mod_two {p} : (nat_mod p) := zmodp.inZp 2. + +Definition nat_mod_add {n : Z} (a : (nat_mod n)) (b : (nat_mod n)) : (nat_mod n) := zmodp.Zp_add a b. + +Infix "+%" := nat_mod_add (at level 33) : hacspec_scope. + +Definition nat_mod_mul {n : Z} (a:(nat_mod n)) (b:(nat_mod n)) : (nat_mod n) := zmodp.Zp_mul a b. +Infix "*%" := nat_mod_mul (at level 33) : hacspec_scope. + +Definition nat_mod_sub {n : Z} (a:(nat_mod n)) (b:(nat_mod n)) : (nat_mod n) := zmodp.Zp_add a (zmodp.Zp_opp b). +Infix "-%" := nat_mod_sub (at level 33) : hacspec_scope. + +Definition nat_mod_div {n : Z} (a:(nat_mod n)) (b:(nat_mod n)) : (nat_mod n) := zmodp.Zp_mul a (zmodp.Zp_inv b). +Infix "/%" := nat_mod_div (at level 33) : hacspec_scope. + +Definition nat_mod_neg {n : Z} (a:(nat_mod n)) : (nat_mod n) := zmodp.Zp_opp a. + +Definition nat_mod_inv {n : Z} (a:(nat_mod n)) : (nat_mod n) := zmodp.Zp_inv a. + +Definition nat_mod_exp_def {p : Z} (a:(nat_mod p)) (n : nat) : (nat_mod p) := + let fix exp_ (e : (nat_mod p)) (n : nat) := + match n with + | 0%nat => nat_mod_one + | S n => nat_mod_mul a (exp_ a n) + end in + exp_ a n. + +Definition nat_mod_exp {WS} {p} a n := @nat_mod_exp_def p a (Z.to_nat (@unsigned WS n)). +Definition nat_mod_pow {WS} {p} a n := @nat_mod_exp_def p a (Z.to_nat (@unsigned WS n)). +Definition nat_mod_pow_felem {p} a n := @nat_mod_exp_def p a (Z.to_nat (from_uint_size n)). +Definition nat_mod_pow_self {p} a n := @nat_mod_pow_felem p a n. + +Close Scope nat_scope. + +Definition nat_mod_from_secret_literal {m : Z} (x:int128) : (nat_mod m) := @zmodp.inZp (Init.Nat.pred (Z.to_nat m)) (Z.to_nat (unsigned x)). + +Definition nat_mod_from_literal (m : Z) (x:int128) : (nat_mod m) := nat_mod_from_secret_literal x. + +Axiom nat_mod_to_byte_seq_le : forall {n : Z}, (nat_mod n) -> (seq int8). +Axiom nat_mod_to_byte_seq_be : forall {n : Z}, (nat_mod n) -> (seq int8). +Axiom nat_mod_to_public_byte_seq_le : forall (n : Z), (nat_mod n) -> (seq int8). +Axiom nat_mod_to_public_byte_seq_be : forall (n : Z), (nat_mod n) -> (seq int8). + +Definition nat_mod_val (p : Z) (a : (nat_mod p)) : Z := Z.of_nat (nat_of_ord a). + +Definition nat_mod_bit {n : Z} (a : (nat_mod n)) (i : uint_size) : 'bool := + Z.testbit (nat_mod_val _ a) (from_uint_size i). + +(* Alias for nat_mod_bit *) +Definition nat_get_mod_bit {p} (a : (nat_mod p)) := nat_mod_bit a. +Definition nat_mod_get_bit {p} (a : (nat_mod p)) n := + if (nat_mod_bit a n) + then @nat_mod_one p + else @nat_mod_zero p. + +Axiom array_declassify_eq : forall {A l}, (nseq_ A l) -> (nseq_ A l) -> 'bool. +Axiom array_to_le_uint32s : forall {A l}, (nseq_ A l) -> (seq uint32). +Axiom array_to_be_uint32s : forall {l}, (nseq_ uint8 l) -> (seq uint32). +Axiom array_to_le_uint64s : forall {A l}, (nseq_ A l) -> (seq uint64). +Axiom array_to_be_uint64s : forall {l}, (nseq_ uint8 l) -> (seq uint64). +Axiom array_to_le_uint128s : forall {A l}, (nseq_ A l) -> (seq uint128). +Axiom array_to_be_uint128s : forall {l}, (nseq_ uint8 l) -> (seq uint128). +Axiom array_to_le_bytes : forall {A l}, (nseq_ A l) -> (seq uint8). +Axiom array_to_be_bytes : forall {A l}, (nseq_ A l) -> (seq uint8). +Axiom nat_mod_from_byte_seq_le : forall {A n}, (seq A) -> (nat_mod n). +Axiom most_significant_bit : forall {m}, (nat_mod m) -> uint_size -> uint_size. + + +(* We assume 2^x < m *) +Definition nat_mod_pow2 (m : Z) (x : N) : (nat_mod m) := mk_natmod (Z.pow 2 (Z.of_N x)). + + +Section Casting. + + (* Type casts, as defined in Section 4.5 in https://arxiv.org/pdf/1106.3448.pdf *) + Class Cast A B := cast : A -> B. + + Arguments cast {_} _ {_}. + + Notation "' x" := (cast _ x) (at level 20) : hacspec_scope. + + (* Casting to self is always possible *) + Global Instance cast_self {A} : Cast A A := { + cast a := a + }. + + Global Instance cast_transitive {A B C} `{Hab: Cast A B} `{Hbc: Cast B C} : Cast A C := { + cast a := Hbc (Hab a) + }. + + Global Instance cast_prod {A B C D} `{Cast A B} `{Cast C D} : Cast (A * C) (B * D) := { + cast '(a, c) := (cast _ a, cast _ c) + }. + + Global Instance cast_option {A B} `{Cast A B} : Cast (option A) (option B) := { + cast a := match a with Some a => Some (cast _ a) | None => None end + }. + + Global Instance cast_option_b {A B} `{Cast A B} : Cast A (option B) := { + cast a := Some (cast _ a) + }. + + (* Global Instances for common types *) + + Global Instance cast_nat_to_N : Cast nat N := { + cast := N.of_nat + }. + + Global Instance cast_N_to_Z : Cast N Z := { + cast := Z.of_N + }. + + Global Instance cast_Z_to_int {WORDSIZE} : Cast Z ((@int WORDSIZE)) := { + cast n := repr _ n + }. + + Global Instance cast_natmod_to_Z {p} : Cast ((nat_mod p)) Z := { + cast n := nat_mod_val _ n + }. + + (* Note: should be aware of typeclass resolution with int/uint since they are just aliases of each other currently *) + Global Instance cast_int8_to_uint32 : Cast (int8) (uint32) := { + cast n := repr _ (unsigned n) + }. + Global Instance cast_int8_to_int32 : Cast (int8) (int32) := { + cast n := repr _ (signed n) + }. + + Global Instance cast_uint8_to_uint32 : Cast (uint8) (uint32) := { + cast n := repr _ (unsigned n) + }. + + Global Instance cast_int_to_nat `{WS : wsize} : Cast (int _) nat := { + cast n := Z.to_nat (@signed WS n) + }. + + Close Scope hacspec_scope. +End Casting. + + +Global Arguments pair {_ _} & _ _. + +Section Coercions. + (* First, in order to have automatic coercions for tuples, we add bidirectionality hints: *) + + Global Coercion N.to_nat : N >-> nat. + Global Coercion Z.of_N : N >-> Z. + + Definition Z_to_int `{WS : wsize} (n : Z) : (int WS) := repr _ n. + Global Coercion Z_to_int : Z >-> choice.Choice.sort. + + Definition Z_to_uint_size (n : Z) : uint_size := repr _ n. + Global Coercion Z_to_uint_size : Z >-> choice.Choice.sort. + Definition Z_to_int_size (n : Z) : int_size := repr _ n. + Global Coercion Z_to_int_size : Z >-> choice.Choice.sort. + + Definition N_to_int `{WS : wsize} (n : N) : (@int WS) := repr _ (Z.of_N n). + Global Coercion N.of_nat : nat >-> N. + Global Coercion N_to_int : N >-> choice.Choice.sort. + Definition N_to_uint_size (n : Z) : uint_size := repr _ n. + Global Coercion N_to_uint_size : Z >-> choice.Choice.sort. + Definition nat_to_int `{WS : wsize} (n : nat) : (@int WS) := repr _ (Z.of_nat n). + Global Coercion nat_to_int : nat >-> choice.Choice.sort. + + Definition uint_size_to_nat (n : uint_size) : nat := from_uint_size n. + Global Coercion uint_size_to_nat : choice.Choice.sort >-> nat. + + Definition uint_size_to_Z (n : uint_size) : Z := from_uint_size n. + Global Coercion uint_size_to_Z : choice.Choice.sort >-> Z. + + Definition uint32_to_nat (n : uint32) : nat := Z.to_nat (unsigned n). + Global Coercion uint32_to_nat : choice.Choice.sort >-> nat. + + Definition int8_to_nat (n : int8) : nat := Z.to_nat (unsigned n). + Global Coercion int8_to_nat : choice.Choice.sort >-> nat. + Definition int16_to_nat (n : int16) : nat := Z.to_nat (unsigned n). + Global Coercion int16_to_nat : choice.Choice.sort >-> nat. + Definition int32_to_nat (n : int32) : nat := Z.to_nat (unsigned n). + Global Coercion int32_to_nat : choice.Choice.sort >-> nat. + Definition int64_to_nat (n : int64) : nat := Z.to_nat (unsigned n). + Global Coercion int64_to_nat : choice.Choice.sort >-> nat. + Definition int128_to_nat (n : int128) : nat := Z.to_nat (unsigned n). + Global Coercion int128_to_nat : choice.Choice.sort >-> nat. + + Definition int8_to_int16 (n : int8) : int16 := (repr _ (unsigned n)). + Global Coercion int8_to_int16 : choice.Choice.sort >-> choice.Choice.sort. + + Definition int8_to_int32 (n : int8) : int32 := repr _ (unsigned n). + Global Coercion int8_to_int32 : choice.Choice.sort >-> choice.Choice.sort. + + Definition int16_to_int32 (n : int16) : int32 := repr _ (unsigned n). + Global Coercion int16_to_int32 : choice.Choice.sort >-> choice.Choice.sort. + + Definition int32_to_int64 (n : int32) : int64 := repr _ (unsigned n). + Global Coercion int32_to_int64 : choice.Choice.sort >-> choice.Choice.sort. + + Definition int64_to_int128 (n : int64) : int128 := repr _ (unsigned n). + Global Coercion int64_to_int128 : choice.Choice.sort >-> choice.Choice.sort. + + Definition int32_to_int128 (n : int32) : int128 := repr _ (unsigned n). + Global Coercion int32_to_int128 : choice.Choice.sort >-> choice.Choice.sort. + + Definition uint_size_to_int64 (n : uint_size) : int64 := repr _ (unsigned n). + Global Coercion uint_size_to_int64 : choice.Choice.sort >-> choice.Choice.sort. + + Definition Z_in_nat_mod {m : Z} (x:Z) : (@nat_mod m) := @mk_natmod m x. + + Definition int_in_nat_mod {m : Z} `{WS : wsize} (x:(@int WS)) : (@nat_mod m) := mk_natmod (unsigned x). + Global Coercion int_in_nat_mod : choice.Choice.sort >-> choice.Choice.sort. + + Definition nat_mod_in_int {m : Z} `{WS : wsize} (x:(@nat_mod m)) : (@int WS) := (repr _ (nat_mod_val _ x)). + Global Coercion nat_mod_in_int : choice.Choice.sort >-> choice.Choice.sort. + + Definition nat_mod_in_Z {m : Z} `{WS : wsize} (x:(@nat_mod m)) : Z := (nat_mod_val _ x). + Global Coercion nat_mod_in_Z : choice.Choice.sort >-> Z. + + Definition uint_size_in_nat_mod (n : uint_size) : (@nat_mod 16) := (int_in_nat_mod n). + Global Coercion uint_size_in_nat_mod : choice.Choice.sort >-> choice.Choice.sort. + +End Coercions. + + +(*** Casting *) + +Definition uint128_from_usize (n : uint_size) : int128 := repr _ (unsigned n). +Definition uint64_from_usize (n : uint_size) : int64 := repr _ (unsigned n). +Definition uint32_from_usize (n : uint_size) : int32 := repr _ (unsigned n). +Definition uint16_from_usize (n : uint_size) : int16 := repr _ (unsigned n). +Definition uint8_from_usize (n : uint_size) : int8 := repr _ (unsigned n). + +Definition uint128_from_uint8 (n : int8) : int128 := repr _ (unsigned n). +Definition uint64_from_uint8 (n : int8) : int64 := repr _ (unsigned n). +Definition uint32_from_uint8 (n : int8) : int32 := repr _ (unsigned n). +Definition uint16_from_uint8 (n : int8) : int16 := repr _ (unsigned n). +Definition usize_from_uint8 (n : int8) : uint_size := repr _ (unsigned n). + +Definition uint128_from_uint16 (n : int16) : int128 := repr _ (unsigned n). +Definition uint64_from_uint16 (n : int16) : int64 := repr _ (unsigned n). +Definition uint32_from_uint16 (n : int16) : int32 := repr _ (unsigned n). +Definition uint8_from_uint16 (n : int16) : int8 := repr _ (unsigned n). +Definition usize_from_uint16 (n : int16) : uint_size := repr _ (unsigned n). + +Definition uint128_from_uint32 (n : int32) : int128 := repr _ (unsigned n). +Definition uint64_from_uint32 (n : int32) : int64 := repr _ (unsigned n). +Definition uint16_from_uint32 (n : int32) : int16 := repr _ (unsigned n). +Definition uint8_from_uint32 (n : int32) : int8 := repr _ (unsigned n). +Definition usize_from_uint32 (n : int32) : uint_size := repr _ (unsigned n). + +Definition uint128_from_uint64 (n : int64) : int128 := repr _ (unsigned n). +Definition uint32_from_uint64 (n : int64) : int32 := repr _ (unsigned n). +Definition uint16_from_uint64 (n : int64) : int16 := repr _ (unsigned n). +Definition uint8_from_uint64 (n : int64) : int8 := repr _ (unsigned n). +Definition usize_from_uint64 (n : int64) : uint_size := repr _ (unsigned n). + +Definition uint64_from_uint128 (n : int128) : int64 := repr _ (unsigned n). +Definition uint32_from_uint128 (n : int128) : int32 := repr _ (unsigned n). +Definition uint16_from_uint128 (n : int128) : int16 := repr _ (unsigned n). +Definition uint8_from_uint128 (n : int128) : int8 := repr _ (unsigned n). +Definition usize_from_uint128 (n : int128) : uint_size := repr _ (unsigned n). + + +Definition uint8_equal : int8 -> int8 -> bool := eqb. + +Theorem nat_mod_eqb_spec : forall {p} (a b : (nat_mod p)), nat_mod_equal a b = true <-> a = b. +Proof. + symmetry ; exact (ssrbool.rwP nat_mod_equal_reflect). +Qed. + +Global Instance nat_mod_eqdec {p} : EqDec ((nat_mod p)) := { + eqb := nat_mod_equal ; + eqb_leibniz := nat_mod_eqb_spec; + }. + +Global Instance nat_mod_comparable `{p : Z} : Comparable ((nat_mod p)) := { + ltb a b := Z.ltb (nat_mod_val p a) (nat_mod_val p b); + leb a b := if Zeq_bool (nat_mod_val p a) (nat_mod_val p b) then true else Z.ltb (nat_mod_val p a) (nat_mod_val p b) ; + gtb a b := Z.ltb (nat_mod_val p b) (nat_mod_val p a); + geb a b := if Zeq_bool (nat_mod_val p b) (nat_mod_val p a) then true else Z.ltb (nat_mod_val p b) (nat_mod_val p a) ; + }. + +Fixpoint nat_mod_rem_aux {n : Z} (a:(nat_mod n)) (b:(nat_mod n)) (f : nat) {struct f} : (nat_mod n) := + match f with + | O => a + | S f' => + if geb a b + then nat_mod_rem_aux (nat_mod_sub a b) b f' + else a + end. + +Definition nat_mod_rem {n : Z} (a:(nat_mod n)) (b:(nat_mod n)) : (nat_mod n) := + if nat_mod_equal b nat_mod_zero + then nat_mod_one + else nat_mod_rem_aux a b (S (Z.to_nat (nat_mod_val n (nat_mod_div a b)))). + +Infix "rem" := nat_mod_rem (at level 33) : hacspec_scope. + +Global Instance bool_eqdec : EqDec bool := { + eqb := Bool.eqb; + eqb_leibniz := Bool.eqb_true_iff; + }. + +Global Instance string_eqdec : EqDec String.string := { + eqb := String.eqb; + eqb_leibniz := String.eqb_eq ; + }. + +Fixpoint list_eqdec {A} `{EqDec A} (l1 l2 : list A) : bool := + match l1, l2 with + | x::xs, y::ys => if eqb x y then list_eqdec xs ys else false + | [], [] => true + | _,_ => false + end. + +Lemma list_eqdec_refl : forall {A} `{EqDec A} (l1 : list A), list_eqdec l1 l1 = true. +Proof. + intros ; induction l1 ; cbn ; try rewrite eqb_refl ; easy. +Qed. + +Lemma list_eqdec_sound : forall {A} `{EqDec A} (l1 l2 : list A), list_eqdec l1 l2 = true <-> l1 = l2. +Proof. + intros A H l1. + induction l1 ; induction l2 ; split ; intros ; simpl in * ; try easy ; try inversion H0. + - (* inductive case *) + apply Field_theory.if_true in H0; destruct H0. + f_equal. + (* show heads are equal *) + + apply (proj1 (eqb_leibniz a a0) H0). + (* show tails are equal using induction hypothesis *) + + apply IHl1. assumption. + - rewrite eqb_refl. + apply list_eqdec_refl. +Qed. + +Global Instance List_eqdec {A} `{EqDec A} : EqDec (list A) := { + eqb := list_eqdec; + eqb_leibniz := list_eqdec_sound; + }. + +Global Program Instance Dec_eq_prod (A B : Type) `{EqDec A} `{EqDec B} : EqDec (A * B) := { + eqb '(a0, b0) '(a1, b1) := andb (eqb a0 a1) (eqb b0 b1) + }. +Next Obligation. + split ; intros ; destruct x ; destruct y. + - rewrite LocationUtility.is_true_split_and in H1. destruct H1. + rewrite (eqb_leibniz) in H1. + rewrite (eqb_leibniz) in H2. + rewrite H1. rewrite H2. reflexivity. + - inversion_clear H1. now do 2 rewrite eqb_refl. +Defined. + +(*** Be Bytes *) + + +Fixpoint nat_be_range_at_position (k : nat) (z : Z) (n : Z) : list bool := + match k with + | O => [] + | S k' => Z.testbit z (n + k') :: nat_be_range_at_position k' z n + end. + +Fixpoint nat_be_range_to_position_ (z : list bool) (val : Z) : Z := + match z with + | [] => val + | x :: xs => nat_be_range_to_position_ xs ((if x then 2 ^ List.length xs else 0) + val) + end. + +Definition nat_be_range_to_position (k : nat) (z : list bool) (n : Z) : Z := + (nat_be_range_to_position_ z 0 * 2^(k * n)). + +Definition nat_be_range' (k : nat) (z : Z) (n : nat) : Z := + nat_be_range_to_position_ (nat_be_range_at_position k z (n * k)) 0. + +Definition nat_be_range (k : nat) (z : Z) (n : nat) := + ((z / 2 ^ (n * k)%Z) mod 2 ^ k)%Z. + +Definition to_be_bytes' {WS} : Z -> list Z := + (fun (k : Z) => + (map + (fun i : nat => nat_be_range 8 k i) + (seq.iota 0 (nat_of_wsize WS / 8)))). + +Definition to_be_bytes'' {WS} : Z -> list Z := + (fun (k : Z) => + (map + (fun i : nat => nat_be_range' 8 k i) + (seq.iota 0 (nat_of_wsize WS / 8)))). + +Definition to_be_bytes {WS} : (@int WS) -> (nseq_ int8 (WS / 8)) := + (fun (k : int _) => + eq_rect + (seq.size (seq.iota 0 (nat_of_wsize WS / 8))) + (fun n : nat => (nseq_ uint8 n)) + (eq_rect _ (fun n : nat => (nseq_ uint8 n)) + (array_from_list + (map + (fun i : nat => repr _ (nat_be_range 8 (toword k) i) : int _) + (seq.iota 0 (nat_of_wsize WS / 8)))) + (length (seq.iota 0 (nat_of_wsize WS / 8))) + (map_length + (fun i : nat => + repr _ (nat_be_range 8 (toword k) i)) + (seq.iota 0 (nat_of_wsize WS / 8)))) + (nat_of_wsize WS / 8)%nat + (seq.size_iota 0 (nat_of_wsize WS / 8))). + +Definition from_be_bytes_fold_fun {WS} (i : int8) (s : ('nat × @int WS)) : ('nat × @int WS) := + let (n,v) := s in + (S n, v .+ (repr WS (int8_to_nat i * (2 ^ (8 * Z.of_nat n)))%Z)). + +Definition from_be_bytes {WS : wsize} : (nseq_ int8 (WS / 8)) -> (@int WS) := + (fun v => snd (List.fold_right from_be_bytes_fold_fun (0%nat, @repr WS 0%Z) (array_to_list v))). + +Definition to_le_bytes' {WS} : Z -> list Z := + (fun (k : Z) => + (map + (fun i : nat => nat_be_range 8 k i) + (rev (seq.iota 0 (nat_of_wsize WS / 8))))). + +Definition to_le_bytes'' {WS} : Z -> list Z := + (fun (k : Z) => + (map + (fun i : nat => nat_be_range' 8 k i) + (rev (seq.iota 0 (nat_of_wsize WS / 8))))). + +Definition to_le_bytes {WS} : (@int WS) -> (nseq_ int8 (WS / 8)) := + fun (k : int _) => + eq_rect (seq.size (seq.iota 0 (nat_of_wsize WS / 8))) (fun n : nat => (nseq_ uint8 n)) + (eq_rect (length (rev (seq.iota 0 (nat_of_wsize WS / 8)))) + (fun n : nat => (nseq_ uint8 n)) (eq_rect + (length + (map + (fun i : nat => + repr _ (nat_be_range 8 (toword k) i)) + (rev (seq.iota 0 (nat_of_wsize WS / 8))))) + (fun n : nat => (nseq_ uint8 n)) (array_from_list + (map + (fun i : nat => + repr _ (nat_be_range 8 (toword k) i)) + (rev (seq.iota 0 (nat_of_wsize WS / 8))))) + (length (rev (seq.iota 0 (nat_of_wsize WS / 8)))) + (map_length + (fun i : nat => + repr _ (nat_be_range 8 (toword k) i)) + (rev (seq.iota 0 (nat_of_wsize WS / 8))))) (length (seq.iota 0 (nat_of_wsize WS / 8))) + (rev_length (seq.iota 0 (nat_of_wsize WS / 8)))) (nat_of_wsize WS / 8)%nat (seq.size_iota 0 (nat_of_wsize WS / 8)). + +Definition from_le_bytes_fold_fun {WS} (i : int8) (s : ('nat × @int WS)) : ('nat × @int WS) := + let (n,v) := s in + (Nat.pred n, v .+ (@repr WS ((int8_to_nat i) * 2 ^ (8 * Z.of_nat n))%Z)). + +Definition from_le_bytes {WS : wsize} : (nseq_ int8 (WS / 8)) -> (@int WS) := + (fun v => snd (List.fold_right from_be_bytes_fold_fun (((WS / 8) - 1)%nat, @repr WS 0%Z) (array_to_list v))). + +(**** Integers to arrays *) +Definition uint32_to_le_bytes : int32 -> (nseq_ int8 4) := @to_le_bytes U32. +Definition uint32_to_be_bytes : int32 -> (nseq_ int8 4) := @to_be_bytes U32. +Definition uint32_from_le_bytes : (nseq_ int8 4) -> int32 := @from_le_bytes U32. +Definition uint32_from_be_bytes : (nseq_ int8 4) -> int32 := @from_be_bytes U32. + +Definition uint64_to_le_bytes : int64 -> (nseq_ int8 8) := @to_le_bytes U64. +Definition uint64_to_be_bytes : int64 -> (nseq_ int8 8) := @to_be_bytes U64. +Definition uint64_from_le_bytes : (nseq_ int8 8) -> int64 := @from_le_bytes U64. +Definition uint64_from_be_bytes : (nseq_ int8 8) -> int64 := @from_be_bytes U64. + +Definition uint128_to_le_bytes : int128 -> (nseq_ int8 16) := @to_le_bytes U128. +Definition uint128_to_be_bytes : int128 -> (nseq_ int8 16) := @to_be_bytes U128. +Definition uint128_from_le_bytes : (nseq_ int8 16) -> int128 := @from_le_bytes U128. +Definition uint128_from_be_bytes : (nseq_ int8 16) -> int128 := @from_be_bytes U128. + +Definition u32_to_be_bytes : int32 -> (nseq_ int8 4) := @to_be_bytes U32. +Definition u32_from_be_bytes : (nseq_ int8 4) -> int32 := @from_be_bytes U32. +Definition u32_to_le_bytes : int32 -> (nseq_ int8 4) := @to_le_bytes U32. +Definition u32_from_le_bytes : (nseq_ int8 4) -> int32 := @from_le_bytes U32. + +Definition u64_to_be_bytes : int64 -> (nseq_ int8 8) := @to_be_bytes U64. +Definition u64_from_be_bytes : (nseq_ int8 8) -> int64 := @from_be_bytes U64. +Definition u64_to_le_bytes : int64 -> (nseq_ int8 8) := @to_le_bytes U64. +Definition u64_from_le_bytes : (nseq_ int8 8) -> int64 := @from_le_bytes U64. + +Definition u128_to_be_bytes : int128 -> (nseq_ int8 16) := @to_be_bytes U128. +Definition u128_from_be_bytes : (nseq_ int8 16) -> int128 := @from_be_bytes U128. +Definition u128_to_le_bytes : int128 -> (nseq_ int8 16) := @to_le_bytes U128. +Definition u128_from_le_bytes : (nseq_ int8 16) -> int128 := @from_le_bytes U128. + +(*** Result *) + +Definition result (b a : choice_type) := chSum a b. +(* #[global] #[refine] Instance result (b a : choice_type) : choice_type := *) +(* {| ct := chSum a b ; := (a + b)%type |}. *) +(* Proof. *) +(* intros. *) +(* cbn. *) +(* do 2 rewrite ChoiceEq. *) +(* reflexivity. *) +(* Defined. *) + +Definition Ok {a b : choice_type} : a -> (result b a) := @inl (a) (b). +Definition Err {a b : choice_type} : b -> (result b a) := @inr (a) (b). + +Arguments Ok {_ _}. +Arguments Err {_ _}. + +Definition result_unwrap_safe {a b} (x : (result b a)) `{match x with inl _ => True | inr _ => False end} : a. + destruct x. + apply s. + contradiction. +Defined. +Axiom falso : False. Ltac admit_falso := destruct falso. +Definition result_unwrap {a b} (x : (result b a)) : a := + result_unwrap_safe x (H := ltac:(admit_falso)). + +Definition option := chOption. +(* Program Definition option_choice_type (a : choice_type) := *) +(* {| ct := chOption a ; := option a ; |}. *) +(* Next Obligation. *) +(* intros. *) +(* rewrite ChoiceEq. *) +(* reflexivity. *) +(* Qed. *) + +(*** Monad / Bind *) + +Module choice_typeMonad. + Class CEMonad : Type := + { + M :> choice_type -> choice_type ; + bind {A B : choice_type} (x : (M A)) (f : A -> (M B)) : (M B) ; + ret {A : choice_type} (x : A) : (M A) ; + monad_law1 : forall {A B : choice_type} a (f : A -> M B), + bind (ret a) f = f a ; + monad_law2 : forall {A : choice_type} c, bind c (@ret A) = c ; + monad_law3 : forall {A B C : choice_type} c (f : A -> M B) (g : B -> M C), + bind (bind c f) g + = bind c (fun a => bind (f a) g) + }. + + (* Class CEMonad2 (M : choice_type -> choice_type) : Type := *) + (* { *) + (* unit {A : choice_type} (x : A) : (M A) ; *) + (* fmap {A B : choice_type} (f : A -> B) (x : (M A)) : (M B) ; *) + (* join {A : choice_type} (x : (M (M A))) : (M A) ; *) + (* }. *) + + (* #[global] Instance CEMonadToCEMonad2 `{CEMonad} : CEMonad2 M := *) + (* {| *) + (* unit A := @ret M _ A ; *) + (* fmap A B f x := bind x (fun y => ret (f y)) ; *) + (* join A x := bind x id *) + (* |}. *) + + (* #[global] Instance CEMonad2ToCEMonad `{CEMonad2} : CEMonad M := *) + (* {| *) + (* ret A := @unit M _ A ; *) + (* bind A B x f := join (fmap f x) *) + (* |}. *) + + (* Class CEMonad_prod (M M0 : choice_type -> choice_type) := *) + (* { prod : forall A, (M0 (M (M0 A))) -> (M (M0 A)) }. *) + + (* #[global] Program Instance ComposeProd2 `{CEMonad2} `{CEMonad2} `{@CEMonad_prod M M0} : CEMonad2 (fun x => M (M0 x)) := *) + (* {| *) + (* unit A x := unit (A := M0 A) (unit x) ; *) + (* fmap A B f x := fmap (A := M0 A) (B := M0 B) (fmap f) x ; *) + (* join A x := join (A := M0 A) (fmap (@prod M M0 _ A) x) *) + (* |}. *) + + (* #[global] Instance ComposeProd `{CEMonad} `{CEMonad} `(@CEMonad_prod M M0) : CEMonad (fun x => M (M0 x)) := (@CEMonad2ToCEMonad _ ComposeProd2). *) + + (* Definition bind_prod `{CEMonad} `{CEMonad} `{@CEMonad_prod M M0} *) + (* {A B} (x : (M (M0 A))) (f : A -> (M (M0 B))) *) + (* : (M (M0 B)) := *) + (* (@bind (fun x => M (M0 x)) (ComposeProd _) A B x f). *) + + + (* Class CEMonad_swap (M M0 : choice_type -> choice_type) := *) + (* { swap : forall A, (M0 (M A)) -> (M (M0 A)) }. *) + + (* #[global] Program Instance ComposeSwap2 `{CEMonad2 } `{CEMonad2} `{@CEMonad_swap M M0} : CEMonad2 (fun x => M (M0 x)) := *) + (* {| *) + (* unit A x := unit (A := M0 A) (unit x) ; *) + (* fmap A B f x := fmap (A := M0 A) (B := M0 B) (fmap f) x ; *) + (* join A x := fmap (join (M := M0)) (join (fmap (@swap M M0 _ (M0 A)) x)) *) + (* |}. *) + + (* #[global] Instance ComposeSwap `{CEMonad} `{CEMonad} `(@CEMonad_swap M M0) : CEMonad (fun x => M (M0 x)) := (@CEMonad2ToCEMonad _ ComposeSwap2). *) + + (* Definition bind_swap `{CEMonad} `{CEMonad} `{@CEMonad_swap M M0} *) + (* A B (x : (M (M0 A))) (f : A -> (M (M0 B))) : (M (M0 B)) := *) + (* (@bind _ (@ComposeSwap M _ M0 _ _) A B x f). *) + + + Section ResultMonad. + Definition result_bind {C A B} (r : (result C A)) (f : A -> (result C B)) : (result C B) := + match r with + | inl a => f a + | inr e => (@Err B C e) + end. + + Definition result_ret {C A : choice_type} (a : A) : (result C A) := Ok a. + + Global Program Instance result_monad {C : choice_type} : CEMonad := + {| + M := result C ; + bind := @result_bind C ; + ret := @result_ret C ; + |}. + Solve All Obligations with now destruct c. + Arguments result_monad {_} &. + + End ResultMonad. + + Definition option_bind {A B} (r : (option A)) (f : A -> (option B)) : (option B) := + match r with + Some (a) => f a + | None => None + end. + + Definition option_ret {A : choice_type} (a : A) : (option A) := Some a. + + Global Program Instance option_monad : CEMonad := + Build_CEMonad option (@option_bind) (@option_ret) _ _ _. + Solve All Obligations with now destruct c. + + Definition option_is_none {A} (x : (option A)) : bool := + match x with + | None => true + | _ => false + end. + +End choice_typeMonad. + +(* #[global] Notation "x 'm(' v ')' ⇠ c1 ;; c2" := *) +(* (choice_typeMonad.bind (M := v) c1 (fun x => c2)) *) +(* (at level 100, c1 at next level, right associativity, *) +(* format "x 'm(' v ')' ⇠ c1 ;; '//' c2") *) +(* : hacspec_scope. *) + +(* #[global] Notation " ' x 'm(' v ')' ⇠ c1 ;; c2" := *) +(* (choice_typeMonad.bind (M := v) c1 (fun x => c2)) *) +(* (at level 100, c1 at next level, x pattern, right associativity, *) +(* format " ' x 'm(' v ')' ⇠ c1 ;; '//' c2") *) +(* : hacspec_scope. *) + +Definition foldi_bind {A : choice_type} `{mnd : choice_typeMonad.CEMonad} (a : uint_size) (b : uint_size) (f : uint_size -> A -> (choice_typeMonad.M A)) (init : (choice_typeMonad.M A)) : (choice_typeMonad.M A) := + @foldi ((choice_typeMonad.M A)) a b (fun x y => choice_typeMonad.bind y (f x)) init. + +(*** Notation *) + +Notation "'ifbnd' b 'then' x 'else' y '>>' f" := (if b then f x else f y) (at level 200) : hacspec_scope. +Notation "'ifbnd' b 'thenbnd' x 'else' y '>>' f" := (if b then (choice_typeMonad.bind x) f else f y) (at level 200) : hacspec_scope. +Notation "'ifbnd' b 'then' x 'elsebnd' y '>>' f" := (if b then f x else (choice_typeMonad.bind y) f) (at level 200) : hacspec_scope. +Notation "'ifbnd' b 'thenbnd' x 'elsebnd' y '>>' f" := (if b then choice_typeMonad.bind x f else choice_typeMonad.bind y f) (at level 200). + +Notation "'foldibnd' s 'to' e 'M(' v ')' 'for' z '>>' f" := + (Hacspec_Lib_Pre.foldi s e (choice_typeMonad.ret z) (fun x y => choice_typeMonad.bind y (f x))) (at level 50) : hacspec_scope. + +Axiom nat_mod_from_byte_seq_be : forall {A n}, (seq A) -> (nat_mod n). + diff --git a/proof-libs/coq/ssprove/src/LocationUtility.v b/proof-libs/coq/ssprove/src/LocationUtility.v new file mode 100644 index 000000000..ef091562e --- /dev/null +++ b/proof-libs/coq/ssprove/src/LocationUtility.v @@ -0,0 +1,622 @@ +From Coq Require Import ZArith List. +From Crypt Require Import choice_type Package. +Import PackageNotation. +From Crypt Require Import pkg_interpreter. +From extructures Require Import ord fset fmap. +Require Import Hacspec_Lib_Comparable. +From Jasmin Require Import xseq. +Require Import Coq.Logic.FunctionalExtensionality. +Import List.ListNotations. + +(*****************************************************) +(* This file defines a utility functions to reason *) +(* about equivalence of Locations and Signatures *) +(*****************************************************) + +(*** Location *) + +Definition loc_eqType := + (@eqtype.tag_eqType choice_type_eqType (fun _ : choice_type => ssrnat.nat_eqType)). + +Definition location_eqb (ℓ ℓ' : Location) := + andb (@eqtype.eq_op ssrnat.nat_eqType (projT2 ℓ) (projT2 ℓ')) + (@eqtype.eq_op _ (projT1 ℓ) (projT1 ℓ')). + +Definition location_eqbP : forall (l1 l2 : Location), + @location_eqb (l1) (l2) + = (@eqtype.eq_op + (@eqtype.tag_eqType choice_type_eqType + (fun _ : choice_type => ssrnat.nat_eqType)) l1 l2). +Proof. + intros. + + unfold location_eqb. + unfold eqtype.eq_op. + + cbn. + rewrite ssrnat.eqnE. + unfold eqtype.tag_eq. + unfold eqtype.tagged_as. + unfold ssrfun.tag. + unfold ssrfun.tagged. + + rewrite Bool.andb_comm. + + unfold eq_rect_r, eq_rect. + + set (eqtype.eq_op _ _) at 2. + replace (choice_type_eq _ _) with b by reflexivity. + + destruct b eqn:b_eq ; subst b. + - f_equal. + case eqtype.eqP ; intros. + + rewrite e in *. + unfold eq_sym. + reflexivity. + + exfalso. + apply (ssrbool.elimT eqtype.eqP) in b_eq. + apply n. + eapply b_eq. + - reflexivity. +Qed. + +Theorem is_true_split_or : forall a b, is_true (a || b)%bool = (is_true a \/ is_true b). +Proof. + intros. + rewrite boolp.propeqE. + symmetry. + apply (ssrbool.rwP ssrbool.orP). +Qed. +Theorem is_true_split_and : forall a b, is_true (a && b)%bool = (is_true a /\ is_true b). +Proof. + intros. + rewrite boolp.propeqE. + symmetry. + apply (ssrbool.rwP ssrbool.andP). +Qed. + +Theorem is_true_split_or_ : forall a b, ((a || b)%bool = true) = (a = true \/ b = true). +Proof. + intros. + rewrite boolp.propeqE. + symmetry. + apply (ssrbool.rwP ssrbool.orP). +Qed. +Theorem is_true_split_and_ : forall a b, ((a && b)%bool = true) = (a = true /\ b = true). +Proof. + intros. + rewrite boolp.propeqE. + symmetry. + apply (ssrbool.rwP ssrbool.andP). +Qed. + +(* Theorem LocsSubset : (forall {A} (L1 L2 : list A) (a : A), *) +(* List.incl L1 L2 -> *) +(* List.In a L1 -> *) +(* List.In a L2). *) +(* intros. *) +(* induction L1 as [ | a0 L ] ; cbn in *. *) +(* - contradiction. *) +(* - destruct (List.incl_cons_inv H). *) +(* destruct H0. *) +(* + subst. *) +(* assumption. *) +(* + apply IHL ; assumption. *) +(* Qed. *) + +Lemma location_eqb_sound : forall ℓ ℓ' : Location, is_true (location_eqb ℓ ℓ') <-> ℓ = ℓ'. +Proof. + intros. + rewrite location_eqbP. + pose (@eqtype.eqP loc_eqType). + unfold eqtype.Equality.axiom in a. + pose (ssrbool.elimT). + pose (@eqtype.tag_eqP ). + + split. + + apply (Couplings.reflection_nonsense (@eqtype.tag_eqType choice_type_eqType (fun _ : choice_type => ssrnat.nat_eqType)) ℓ ℓ'). + intros. subst. + apply eqtype.eq_refl. +Qed. + +Global Program Instance location_eqdec: EqDec (Location) := { + eqb := location_eqb; + eqb_leibniz := location_eqb_sound; + }. + +Definition location_ltb : Location -> Location -> bool := + (tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType)). + +Definition location_ltb_simple : Location -> Location -> bool := + fun x y => ltb (projT2 x) (projT2 y). + +Global Instance location_comparable : Comparable (Location) := + eq_dec_lt_Comparable location_ltb. + +Definition le_is_ord_leq : forall s s0 : nat_ordType, + eqtype.eq_op s s0 = false -> ltb s s0 = (s <= s0)%ord. +Proof. + intros s s0. + unfold ltb , nat_comparable , Nat.ltb. + intros e. + + generalize dependent s. + induction s0 ; intros. + * destruct s ; easy. + * destruct s. reflexivity. + cbn. + cbn in IHs0. + rewrite IHs0. + reflexivity. + assumption. +Qed. + +Definition opsig_eqb (ℓ ℓ' : opsig) : bool := + andb (@eqtype.eq_op ssrnat.nat_eqType (fst ℓ) (fst ℓ')) + (andb (@eqtype.eq_op _ (fst (snd ℓ)) (fst (snd ℓ'))) + (@eqtype.eq_op _ (snd (snd ℓ)) (snd (snd ℓ')))). + +Lemma opsig_eqb_sound : forall ℓ ℓ' : opsig, is_true (opsig_eqb ℓ ℓ') <-> ℓ = ℓ'. +Proof. + intros. + + destruct ℓ as [? []] , ℓ' as [? []]. + setoid_rewrite is_true_split_and. + rewrite is_true_split_and. + unfold fst, snd in *. + + transitivity (i = i0 /\ c = c1 /\ c0 = c2). + { + apply ZifyClasses.and_morph. + symmetry. + apply (ssrbool.rwP (@eqtype.eqP ssrnat.nat_eqType i i0)). + apply ZifyClasses.and_morph. + symmetry. + apply (ssrbool.rwP (@eqtype.eqP _ c c1)). + symmetry. + apply (ssrbool.rwP (@eqtype.eqP _ c0 c2)). + } + + split ; [ intros [? []] | intros H ; inversion H ] ; subst ; easy. +Qed. + +Global Program Instance opsig_eqdec: EqDec (opsig) := { + eqb := opsig_eqb; + eqb_leibniz := opsig_eqb_sound; + }. + +(* Theorem fset_compute : forall {T : ordType}, forall l : T, forall n : list T, List.In l n <-> is_true (ssrbool.in_mem l (@ssrbool.mem _ (seq.seq_predType (Ord.eqType T)) n)). *) +(* intros. *) +(* apply (ssrbool.rwP (xseq.InP _ _)). *) +(* Qed. *) + +Definition opsig_ordType := (prod_ordType nat_ordType (prod_ordType choice_type_ordType choice_type_ordType)). + +Definition loc_ordType := (@tag_ordType choice_type_ordType (fun _ : choice_type => nat_ordType)). + +Fixpoint incl_expand A `{EqDec A} (l1 l2 : list A) : Prop := + match l1 with + | nil => True + | (x :: xs) => In x l2 /\ incl_expand A xs l2 + end. + +(* Theorem in_remove_fset : forall {T : ordType} a (l : list T), List.In a l <-> List.In a (fset l). *) +(* Proof. *) +(* intros. *) +(* do 2 rewrite fset_compute. *) +(* now rewrite <- in_fset. *) +(* Qed. *) + + + +(* Theorem in_split_cat : forall a (l0 l1 : list Location), List.In a (seq.cat l0 l1) <-> List.In a l0 \/ List.In a l1. *) +(* Proof. *) +(* split ; intros. *) +(* - induction l0. *) +(* + right. apply H. *) +(* + destruct H. *) +(* * left. left. assumption. *) +(* * destruct (IHl0 H). *) +(* -- left. right. assumption. *) +(* -- right. assumption. *) +(* - destruct H. *) +(* + induction l0. *) +(* * contradiction. *) +(* * destruct H. *) +(* -- left. assumption. *) +(* -- right. *) +(* apply IHl0. *) +(* assumption. *) +(* + induction l0. *) +(* * assumption. *) +(* * right. *) +(* assumption. *) +(* Qed. *) + +(* Theorem in_split_fset_cat : forall a (l0 l1 : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)}), List.In a (l0 :|: l1) <-> List.In a l0 \/ List.In a l1. *) +(* Proof. *) +(* intros. *) +(* transitivity (In a (seq.cat (eqtype.val l0) (eqtype.val l1))). *) +(* symmetry. *) +(* apply in_remove_fset. *) +(* apply in_split_cat. *) +(* Qed. *) + +(* Theorem loc_list_incl_fsubset : forall (l0 l1 : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)}), is_true (fsubset l0 l1) <-> List.incl l0 l1. *) +(* Proof. *) +(* intros. *) +(* rewrite <- (ssrbool.rwP (@fsubsetP _ l0 l1)). *) + +(* unfold ssrbool.sub_mem. *) +(* unfold incl. *) + +(* assert (forall {A} (P Q : A -> Prop), (forall x, P x <-> Q x) -> (forall x, P x) <-> (forall x, Q x)). *) +(* { split ; intros ; apply H ; apply H0. } *) +(* apply H. clear H. *) +(* intros x. cbn in *. *) + +(* rewrite fset_compute. *) +(* rewrite fset_compute. *) + +(* reflexivity. *) +(* Qed. *) + +(* Theorem opsig_list_incl_fsubset : forall (l0 l1 : _), is_true (fsubset (T:=opsig_ordType) l0 l1) <-> List.incl l0 l1. *) +(* Proof. *) +(* intros. *) +(* rewrite <- (ssrbool.rwP (@fsubsetP _ l0 l1)). *) + +(* unfold ssrbool.sub_mem. *) +(* unfold incl. *) + +(* assert (forall {A} (P Q : A -> Prop), (forall x, P x <-> Q x) -> (forall x, P x) <-> (forall x, Q x)). *) +(* { split ; intros ; apply H ; apply H0. } *) +(* apply H. clear H. *) +(* intros x. cbn in *. *) + +(* rewrite fset_compute. *) +(* rewrite fset_compute. *) + +(* reflexivity. *) +(* Qed. *) + + +(* Lemma valid_injectLocations_b : *) +(* forall (import : Interface) (A : choice.Choice.type) *) +(* (L1 L2 : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)}) *) +(* (v : raw_code A), *) +(* List.incl L1 L2 -> ValidCode L1 import v -> ValidCode L2 import v. *) +(* Proof. *) +(* intros I A L1 L2 v incl. *) +(* apply valid_injectLocations. *) +(* apply loc_list_incl_fsubset. *) +(* apply incl. *) +(* Qed. *) + +(* Lemma valid_injectOpsig_b : *) +(* forall (I1 I2 : Interface) (A : choice.Choice.type) *) +(* (L : {fset tag_ordType (I:=choice_type_ordType) (fun _ : choice_type => nat_ordType)}) *) +(* (v : raw_code A), *) +(* List.incl I1 I2 -> ValidCode L I1 v -> ValidCode L I2 v. *) +(* Proof. *) +(* intros I1 I2 A L v incl. *) +(* apply valid_injectMap. *) +(* apply opsig_list_incl_fsubset. *) +(* apply incl. *) +(* Qed. *) + +(* Theorem loc_list_incl_remove_fset {A} `{EqDec A} : forall (l1 l2 : list Location), List.incl l1 l2 <-> List.incl (fset l1) (fset l2). *) +(* Proof. *) +(* intros. *) + +(* cbn in *. *) + +(* induction l1. *) +(* - rewrite <- fset0E. easy. *) +(* - cbn. *) +(* unfold incl. *) +(* cbn. *) +(* split. *) +(* + intros. *) +(* rewrite <- in_remove_fset. *) +(* rewrite <- in_remove_fset in H1. *) +(* apply H0. *) +(* apply H1. *) +(* + intros. *) +(* pose (@in_remove_fset). *) +(* rewrite -> (in_remove_fset (T:=loc_ordType)). *) +(* apply H0. *) +(* rewrite <- (in_remove_fset (T:=loc_ordType)). *) +(* apply H1. *) +(* Qed. *) + + +(* Theorem opsig_list_incl_remove_fset {A} `{EqDec A} : forall (l1 l2 : list opsig), List.incl l1 l2 <-> List.incl (fset l1) (fset l2). *) +(* Proof. *) +(* intros. *) + +(* cbn in *. *) + +(* induction l1. *) +(* - rewrite <- fset0E. easy. *) +(* - cbn. *) +(* unfold incl. *) +(* cbn. *) +(* split. *) +(* + intros. *) +(* rewrite <- in_remove_fset in H1 |- *. *) +(* apply H0. *) +(* apply H1. *) +(* + intros. *) +(* rewrite -> (in_remove_fset (T:=opsig_ordType)). *) +(* apply H0. *) +(* rewrite <- (in_remove_fset (T:=opsig_ordType)). *) +(* apply H1. *) +(* Qed. *) + +(* Theorem list_incl_cons_iff : (forall A (a : A) l1 l2, List.incl (a :: l1) l2 <-> (List.In a l2 /\ List.incl l1 l2)). *) +(* Proof. *) +(* split. *) +(* - pose List.incl_cons_inv. *) +(* apply List.incl_cons_inv. *) +(* - intros []. *) +(* apply List.incl_cons ; assumption. *) +(* Qed. *) + +(* Theorem loc_list_incl_expand {A} `{EqDec A} : forall (l1 l2 : list Location), *) +(* List.incl l1 l2 <-> incl_expand _ l1 l2. *) +(* Proof. *) +(* induction l1. *) +(* - split ; intros. *) +(* reflexivity. *) +(* apply incl_nil_l. *) +(* - intros. *) +(* rewrite list_incl_cons_iff. *) +(* cbn. *) +(* apply and_iff_compat_l. *) +(* apply IHl1. *) +(* Qed. *) + +(* Theorem opsig_list_incl_expand {A} `{EqDec A} : forall (l1 l2 : list opsig), *) +(* List.incl l1 l2 <-> incl_expand _ l1 l2. *) +(* Proof. *) +(* induction l1. *) +(* - split ; intros. *) +(* reflexivity. *) +(* apply incl_nil_l. *) +(* - intros. *) +(* rewrite list_incl_cons_iff. *) +(* cbn. *) +(* apply and_iff_compat_l. *) +(* apply IHl1. *) +(* Qed. *) + +Definition location_lebP : (tag_leq (I:=choice_type_ordType) (T_:=fun _ : choice_type => nat_ordType)) = leb. +Proof. + intros. + do 2 (apply (@functional_extensionality Location) ; intros []). + cbn. + + unfold tag_leq. + unfold eqtype.tag_eq. + + unfold location_ltb. + unfold tag_leq. + + unfold location_eqb. + + unfold ssrfun.tag , ssrfun.tagged , projT1 , projT2 in *. + + rewrite (Bool.andb_comm _ (eqtype.eq_op _ _)). + + destruct (eqtype.eq_op x _) eqn:x_eq_x0. + 2: reflexivity. + apply Couplings.reflection_nonsense in x_eq_x0. + subst. + rewrite eqtype.eq_refl. + rewrite Bool.andb_true_l. + rewrite Bool.andb_true_l. + rewrite Ord.ltxx. + rewrite Bool.orb_false_l. + + destruct (eqtype.eq_op _ _) eqn:n_eq_n0. + 2: reflexivity. + + unfold eqtype.tagged_as in *. + unfold ssrfun.tagged , projT2 in *. + unfold eq_rect_r , eq_rect in *. + + destruct eqtype.eqP in *. + 2: contradiction. + cbn in n_eq_n0. + destruct eq_sym in *. + rewrite ssrnat.eqnE in n_eq_n0. + apply Couplings.reflection_nonsense in n_eq_n0. + apply Ord.eq_leq. assumption. +Qed. + +Lemma iff_extensionality : forall {A} (P Q : A -> Prop), (forall a, P a <-> Q a) -> ((forall a, P a) <-> (forall a, Q a)). +Proof. + intros. split ; intuition. +Qed. + +Lemma iff_eq_sym : forall {A} (x y : A), (x = y) <-> (y = x). +Proof. + intros. split ; intuition. +Qed. + +Definition loc_seq_has (a : Location) := seq.has (ssrbool.fun_of_rel (@eqtype.eq_op loc_eqType) a). + +Theorem loc_seq_has_remove_sort {A} `{EqDec A} : forall (l : list Location) (a : Location) leb, + is_true (loc_seq_has a l) <-> + is_true (loc_seq_has a (path.sort leb l)). +Proof. + intros. + rewrite <- (Bool.negb_involutive (loc_seq_has a (path.sort leb l))). + + unfold loc_seq_has. + + rewrite <- seq.all_predC. + rewrite path.all_sort. + rewrite seq.all_predC. + + rewrite Bool.negb_involutive. + + reflexivity. +Qed. + +(* Theorem list_in_iff_seq_has {A} `{EqDec A} : forall (l : list Location) (a : Location), *) +(* is_true (loc_seq_has a l) <-> List.In a l. *) +(* Proof. *) +(* induction l ; intros. *) +(* - split ; intros ; easy. *) +(* - cbn. *) +(* rewrite is_true_split_or. *) +(* apply ZifyClasses.or_morph. *) +(* + rewrite <- (ssrbool.rwP (@eqtype.eqP loc_eqType a0 a)). *) +(* apply iff_eq_sym. *) +(* + apply IHl. *) +(* Qed. *) + +(* Theorem list_in_iff_list_in_sort {A} `{EqDec A} : forall (l : list Location) (a : Location) leb, *) +(* List.In a l <-> List.In a (path.sort leb l). *) +(* Proof. *) +(* intros. *) +(* rewrite <- (list_in_iff_seq_has (path.sort leb l)). *) +(* rewrite <- loc_seq_has_remove_sort. *) +(* rewrite list_in_iff_seq_has. *) +(* reflexivity. *) +(* Qed. *) + +(* Theorem list_in_sort_order_ignorant_compute {A} `{EqDec A} : forall (l : list Location) leb1 leb2 a, *) +(* (List.In a (path.sort leb1 l)) <-> List.In a (path.sort leb2 l). *) +(* Proof. *) +(* intros. *) +(* rewrite <- list_in_iff_list_in_sort. *) +(* rewrite <- list_in_iff_list_in_sort. *) +(* reflexivity. *) +(* Qed. *) + +(* Theorem list_incl_sort_order_ignorant_compute {A} `{EqDec A} : forall (l1 l2 : list Location) leb1 leb2, *) +(* List.incl (path.sort leb1 l1) (path.sort leb1 l2) <-> List.incl (path.sort leb2 l1) (path.sort leb2 l2). *) +(* Proof. *) +(* intros. *) +(* apply iff_extensionality. *) +(* intros a. *) + +(* rewrite list_in_sort_order_ignorant_compute with (leb1 := leb1) (leb2 := leb2). *) +(* rewrite list_in_sort_order_ignorant_compute with (leb1 := leb1) (leb2 := leb2). *) +(* reflexivity. *) +(* Qed. *) + +(* Theorem list_incl_sort {A} `{EqDec A} : forall (l1 l2 : list Location) leb, *) +(* List.incl l1 l2 <-> List.incl (path.sort leb l1) (path.sort leb l2). *) +(* Proof. *) +(* intros. *) +(* apply iff_extensionality. *) +(* intros a. *) +(* rewrite <- list_in_iff_list_in_sort. *) +(* rewrite <- list_in_iff_list_in_sort. *) +(* reflexivity. *) +(* Qed. *) + +Theorem choice_type_test_refl : forall x , is_true (choice_type_test x x). +Proof. + intros. + replace (choice_type_test _ _) with (eqtype.eq_op x x) by reflexivity. + apply eqtype.eq_refl. +Qed. + +(* Theorem fset_eqEincl: forall a b : list Location, fset a = fset b <-> List.incl a b /\ List.incl b a. *) +(* Proof. *) +(* intros. *) +(* rewrite (ssrbool.rwP (@eqtype.eqP _ (fset a) (fset b))). *) +(* rewrite (@eqEfsubset _ (fset a) (fset b)). *) +(* rewrite is_true_split_and. *) + +(* apply ZifyClasses.and_morph ; rewrite loc_list_incl_fsubset ; rewrite <- loc_list_incl_remove_fset ; reflexivity. *) +(* Qed. *) + + +Lemma path_sorted_tl : + forall {T : ordType} {A} {e} {fmval : list A}, + is_true (path.sorted e fmval) -> + is_true (path.sorted e (tl fmval)). +Proof. + intros. + destruct fmval. + - easy. + - cbn. + cbn in H. + destruct (fmval). + + reflexivity. + + cbn in H. + now rewrite LocationUtility.is_true_split_and in H. +Qed. + +Fixpoint eqb_fset_helper {T : ordType} `{EqDec T} (x : list T) (i : is_true (path.sorted Ord.lt x)) (y : list T) (j : is_true (path.sorted Ord.lt y)) : bool := + match x, y return + is_true (path.sorted Ord.lt x) -> + is_true (path.sorted Ord.lt y) -> + bool + with + | [], [] => fun _ _ => true + | a :: xs , b :: ys => + fun i j => + andb + (eqb a b) + (eqb_fset_helper xs (path_sorted_tl (T := T) i) ys (path_sorted_tl (T := T) j)) + | _, _ => fun _ _ => false + end i j. +Transparent eqb_fset_helper. + +Definition eqb_fset {T : ordType} `{EqDec T} (x y : {fset T}) : bool := + match x , y with + | @FSet.FSet _ fsval i, @FSet.FSet _ fsval0 i0 => + eqb_fset_helper fsval i fsval0 i0 + end. +Transparent eqb_fset. + +Theorem eqb_leibniz_fset {T : ordType} `{EqDec T} : forall (x y : {fset T}), + is_true (eqb_fset x y) <-> x = y. +Proof. + intros. + split. + - intros. + destruct x , y. + unfold eqb_fset in H0. + + apply pkg_composition.fsval_eq. + simpl. + + generalize dependent fsval0. + induction fsval ; intros. + + destruct fsval0. + * reflexivity. + * discriminate H0. + + destruct fsval0. + * discriminate H0. + * cbn in H0. + + rewrite is_true_split_and in H0 ; destruct H0. + + apply (eqb_leibniz a s) in H0. + subst. + f_equal. + + eapply IHfsval. + apply H1. + - intros. + subst. + destruct y. + simpl. + induction fsval. + + reflexivity. + + simpl. + rewrite IHfsval. + now rewrite eqb_refl. +Qed. + +Instance fset_EqDec {T : ordType} `{EqDec T} : EqDec {fset T} := + {| eqb := eqb_fset ; eqb_leibniz := eqb_leibniz_fset |}.