### Support sequence point, add permissions, and update prelude.

```Both the operational and axiomatic semantics are extended with sequence points
and a permission system based on fractional permissions. In order to achieve
this, the memory model has been completely revised, and is now built on top
of an abstract interface for permissions.

Apart from these changed, the library on lists and sets has been heavily
extended, and minor changed have been made to other parts of the prelude.```
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file collects definitions and theorems on abstract rewriting systems. These are particularly useful as we define the operational semantics as a ... ...
This diff is collapsed.
This diff is collapsed.
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file collects theorems, definitions, tactics, related to propositions with a decidable equality. Such propositions are collected by the [Decision] ... ... @@ -10,6 +10,9 @@ Hint Extern 200 (Decision _) => progress (lazy beta) : typeclass_instances. Lemma dec_stable `{Decision P} : ¬¬P → P. Proof. firstorder. Qed. Lemma Is_true_reflect (b : bool) : reflect b b. Proof. destruct b. by left. right. intros []. Qed. (** We introduce [decide_rel] to avoid inefficienct computation due to eager evaluation of propositions by [vm_compute]. This inefficiency occurs if [(x = y) := (f x = f y)] as [decide (x = y)] evaluates to [decide (f x = f y)] ... ... @@ -21,18 +24,27 @@ Lemma decide_rel_correct {A B} (R : A → B → Prop) `{∀ x y, Decision (R x y (x : A) (y : B) : decide_rel R x y = decide (R x y). Proof. done. Qed. (** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the components is double negated, it will try to remove the double negation. *) Ltac destruct_decide dec := let H := fresh in destruct dec as [H|H]; try match type of H with | ¬¬_ => apply dec_stable in H end. (** The tactic [case_decide] performs case analysis on an arbitrary occurrence of [decide] or [decide_rel] in the conclusion or hypotheses. *) Ltac case_decide := match goal with | H : context [@decide ?P ?dec] |- _ => destruct (@decide P dec) destruct_decide (@decide P dec) | H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ => destruct (@decide_rel _ _ R x y dec) destruct_decide (@decide_rel _ _ R x y dec) | |- context [@decide ?P ?dec] => destruct (@decide P dec) destruct_decide (@decide P dec) | |- context [@decide_rel _ _ ?R ?x ?y ?dec] => destruct (@decide_rel _ _ R x y dec) destruct_decide (@decide_rel _ _ R x y dec) end. (** The tactic [solve_decision] uses Coq's [decide equality] tactic together ... ... @@ -61,6 +73,17 @@ Notation cast_if_not S := (if S then right _ else left _). Definition bool_decide (P : Prop) {dec : Decision P} : bool := if dec then true else false. Lemma bool_decide_reflect P `{dec : Decision P} : reflect P (bool_decide P). Proof. unfold bool_decide. destruct dec. by left. by right. Qed. Ltac case_bool_decide := match goal with | H : context [@bool_decide ?P ?dec] |- _ => destruct_decide (@bool_decide_reflect P dec) | |- context [@bool_decide ?P ?dec] => destruct_decide (@bool_decide_reflect P dec) end. Lemma bool_decide_unpack (P : Prop) {dec : Decision P} : bool_decide P → P. Proof. unfold bool_decide. by destruct dec. Qed. Lemma bool_decide_pack (P : Prop) {dec : Decision P} : P → bool_decide P. ... ... @@ -70,9 +93,14 @@ Proof. unfold bool_decide. by destruct dec. Qed. (** Leibniz equality on Sigma types requires the equipped proofs to be equal as Coq does not support proof irrelevance. For decidable we propositions we define the type [dsig P] whose Leibniz equality is proof irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. *) irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. Due to the absence of universe polymorpic definitions we also define a variant [dsigS] for types in [Set]. *) Definition dsig `(P : A → Prop) `{∀ x : A, Decision (P x)} := { x | bool_decide (P x) }. Definition dsigS {A : Set} (P : A → Prop) `{∀ x : A, Decision (P x)} : Set := { x | bool_decide (P x) }. Definition proj2_dsig `{∀ x : A, Decision (P x)} (x : dsig P) : P (`x) := bool_decide_unpack _ (proj2_sig x). Definition dexist `{∀ x : A, Decision (P x)} (x : A) (p : P x) : dsig P := ... ...
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file collects definitions and theorems on finite collections. Most importantly, it implements a fold and size function and some useful induction ... ...
 (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file provides an axiomatization of the domain function of finite maps. We provide such an axiomatization, instead of implementing the domain function in a generic way, to allow more efficient implementations. *) Require Export collections fin_maps. Class FinMapDom K M D `{!FMap M} `{∀ A, Lookup K A (M A)} `{∀ A, Empty (M A)} `{∀ A, PartialAlter K A (M A)} `{!Merge M} `{∀ A, FinMapToList K A (M A)} `{∀ i j : K, Decision (i = j)} `{∀ A, Dom (M A) D} `{ElemOf K D} `{Empty D} `{Singleton K D} `{Union D} `{Intersection D} `{Difference D} := { finmap_dom_map :>> FinMap K M; finmap_dom_collection :>> Collection K D; elem_of_dom {A} (m : M A) i : i ∈ dom D m ↔ is_Some (m !! i) }. Section theorems. Context `{FinMapDom K M D}. Lemma not_elem_of_dom {A} (m : M A) i : i ∉ dom D m ↔ m !! i = None. Proof. by rewrite elem_of_dom, eq_None_not_Some. Qed. Lemma subseteq_dom {A} (m1 m2 : M A) : m1 ⊆ m2 → dom D m1 ⊆ dom D m2. Proof. unfold subseteq, map_subseteq, collection_subseteq. intros ??. rewrite !elem_of_dom. inversion 1. eauto. Qed. Lemma subset_dom {A} (m1 m2 : M A) : m1 ⊂ m2 → dom D m1 ⊂ dom D m2. Proof. intros [Hss1 Hss2]. split. { by apply subseteq_dom. } intros Hdom. destruct Hss2. intros i x Hi. specialize (Hdom i). rewrite !elem_of_dom in Hdom. feed inversion Hdom. eauto. by erewrite (Hss1 i) in Hi by eauto. Qed. Lemma dom_empty {A} : dom D (@empty (M A) _) ≡ ∅. Proof. split; intro. * rewrite elem_of_dom, lookup_empty. by inversion 1. * solve_elem_of. Qed. Lemma dom_empty_inv {A} (m : M A) : dom D m ≡ ∅ → m = ∅. Proof. intros E. apply map_empty. intros. apply not_elem_of_dom. rewrite E. solve_elem_of. Qed. Lemma dom_insert {A} (m : M A) i x : dom D (<[i:=x]>m) ≡ {[ i ]} ∪ dom D m. Proof. apply elem_of_equiv. intros j. rewrite elem_of_union, !elem_of_dom, !is_Some_alt. setoid_rewrite lookup_insert_Some. destruct (decide (i = j)); esolve_elem_of. Qed. Lemma dom_insert_subseteq {A} (m : M A) i x : dom D m ⊆ dom D (<[i:=x]>m). Proof. rewrite (dom_insert _). solve_elem_of. Qed. Lemma dom_insert_subseteq_compat_l {A} (m : M A) i x X : X ⊆ dom D m → X ⊆ dom D (<[i:=x]>m). Proof. intros. transitivity (dom D m); eauto using dom_insert_subseteq. Qed. Lemma dom_singleton {A} (i : K) (x : A) : dom D {[(i, x)]} ≡ {[ i ]}. Proof. unfold singleton at 1, map_singleton. rewrite dom_insert, dom_empty. solve_elem_of. Qed. Lemma dom_delete {A} (m : M A) i : dom D (delete i m) ≡ dom D m ∖ {[ i ]}. Proof. apply elem_of_equiv. intros j. rewrite elem_of_difference, !elem_of_dom, !is_Some_alt. setoid_rewrite lookup_delete_Some. esolve_elem_of. Qed. Lemma delete_partial_alter_dom {A} (m : M A) i f : i ∉ dom D m → delete i (partial_alter f i m) = m. Proof. rewrite not_elem_of_dom. apply delete_partial_alter. Qed. Lemma delete_insert_dom {A} (m : M A) i x : i ∉ dom D m → delete i (<[i:=x]>m) = m. Proof. rewrite not_elem_of_dom. apply delete_insert. Qed. Lemma map_disjoint_dom {A} (m1 m2 : M A) : m1 ⊥ m2 ↔ dom D m1 ∩ dom D m2 ≡ ∅. Proof. unfold disjoint, map_disjoint, map_intersection_forall. rewrite elem_of_equiv_empty. setoid_rewrite elem_of_intersection. setoid_rewrite elem_of_dom. setoid_rewrite is_Some_alt. naive_solver. Qed. Lemma map_disjoint_dom_1 {A} (m1 m2 : M A) : m1 ⊥ m2 → dom D m1 ∩ dom D m2 ≡ ∅. Proof. apply map_disjoint_dom. Qed. Lemma map_disjoint_dom_2 {A} (m1 m2 : M A) : dom D m1 ∩ dom D m2 ≡ ∅ → m1 ⊥ m2. Proof. apply map_disjoint_dom. Qed. Lemma dom_union {A} (m1 m2 : M A) : dom D (m1 ∪ m2) ≡ dom D m1 ∪ dom D m2. Proof. apply elem_of_equiv. intros i. rewrite elem_of_union, !elem_of_dom, !is_Some_alt. setoid_rewrite lookup_union_Some_raw. destruct (m1 !! i); naive_solver. Qed. Lemma dom_intersection {A} (m1 m2 : M A) : dom D (m1 ∩ m2) ≡ dom D m1 ∩ dom D m2. Proof. apply elem_of_equiv. intros i. rewrite elem_of_intersection, !elem_of_dom, !is_Some_alt. setoid_rewrite lookup_intersection_Some. setoid_rewrite is_Some_alt. naive_solver. Qed. Lemma dom_difference {A} (m1 m2 : M A) : dom D (m1 ∖ m2) ≡ dom D m1 ∖ dom D m2. Proof. apply elem_of_equiv. intros i. rewrite elem_of_difference, !elem_of_dom, !is_Some_alt. setoid_rewrite lookup_difference_Some. destruct (m2 !! i); naive_solver. Qed. End theorems.
This source diff could not be displayed because it is too large. You can view the blob instead.
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** Given a finite set of binary naturals [N], we generate a fresh element by taking the maximum, and adding one to it. We declare this operation as an ... ...
This diff is collapsed.
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file implements finite as unordered lists without duplicates removed. This implementation forms a monad. *) ... ... @@ -51,13 +51,12 @@ Instance listset_filter: Filter A (listset A) := λ P _ l, | Listset l' => Listset (filter P l') end. Global Instance: Collection A (listset A). Instance: Collection A (listset A). Proof. split. * apply _. * intros [?] [?]. apply elem_of_list_intersection. * intros [?] [?]. apply elem_of_list_difference. * intros ? [?] [?]. apply elem_of_list_intersection_with. Qed. Instance listset_elems: Elements A (listset A) := ... ... @@ -67,10 +66,17 @@ Global Instance: FinCollection A (listset A). Proof. split. * apply _. * intros [?] ??. apply elem_of_list_filter. * symmetry. apply elem_of_remove_dups. * intros. apply remove_dups_nodup. Qed. Global Instance: CollectionOps A (listset A). Proof. split. * apply _. * intros ? [?] [?]. apply elem_of_list_intersection_with. * intros [?] ??. apply elem_of_list_filter. Qed. End listset. (** These instances are declared using [Hint Extern] to avoid too ... ...
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file implements finite as unordered lists without duplicates. Although this implementation is slow, it is very useful as decidable equality ... ... @@ -59,18 +59,14 @@ Instance listset_nodup_intersection_with: Instance listset_nodup_filter: Filter A C := λ P _ l, LS _ (filter_nodup P _ (listset_nodup_prf l)). Global Instance: Collection A C. Instance: Collection A C. Proof. split; [split | | |]. split; [split | | ]. * by apply not_elem_of_nil. * by apply elem_of_list_singleton. * intros. apply elem_of_listset_nodup_union_raw. * intros. apply elem_of_list_intersection. * intros. apply elem_of_list_difference. * intros. unfold intersection_with, listset_nodup_intersection_with, elem_of, listset_nodup_elem_of. simpl. rewrite elem_of_remove_dups. by apply elem_of_list_intersection_with. Qed. Global Instance listset_nodup_elems: Elements A C := listset_nodup_car. ... ... @@ -79,10 +75,20 @@ Global Instance: FinCollection A C. Proof. split. * apply _. * intros. apply elem_of_list_filter. * done. * by intros [??]. Qed. Global Instance: CollectionOps A C. Proof. split. * apply _. * intros. unfold intersection_with, listset_nodup_intersection_with, elem_of, listset_nodup_elem_of. simpl. rewrite elem_of_remove_dups. by apply elem_of_list_intersection_with. * intros. apply elem_of_list_filter. Qed. End list_collection. Hint Extern 1 (ElemOf _ (listset_nodup _)) => ... ...
theories/mapset.v 0 → 100644
 (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This files gives an implementation of finite sets using finite maps with elements of the unit type. Since maps enjoy extensional equality, the constructed finite sets do so as well. *) Require Export fin_map_dom. Record mapset (M : Type → Type) := Mapset { mapset_car: M unit }. Arguments Mapset {_} _. Arguments mapset_car {_} _. Section mapset. Context `{FinMap K M}. Instance mapset_elem_of: ElemOf K (mapset M) := λ x X, mapset_car X !! x = Some (). Instance mapset_empty: Empty (mapset M) := Mapset ∅. Instance mapset_singleton: Singleton K (mapset M) := λ x, Mapset {[ (x,()) ]}. Instance mapset_union: Union (mapset M) := λ X1 X2, match X1, X2 with | Mapset m1, Mapset m2 => Mapset (m1 ∪ m2) end. Instance mapset_intersection: Intersection (mapset M) := λ X1 X2, match X1, X2 with | Mapset m1, Mapset m2 => Mapset (m1 ∩ m2) end. Instance mapset_difference: Difference (mapset M) := λ X1 X2, match X1, X2 with | Mapset m1, Mapset m2 => Mapset (m1 ∖ m2) end. Instance mapset_elems: Elements K (mapset M) := λ X, match X with | Mapset m => fst <\$> map_to_list m end. Lemma mapset_eq (X1 X2 : mapset M) : X1 = X2 ↔ ∀ x, x ∈ X1 ↔ x ∈ X2. Proof. split. * intros. by subst. * destruct X1 as [m1], X2 as [m2]. simpl. intros E. f_equal. apply map_eq. intros i. apply option_eq. intros []. by apply E. Qed. Global Instance mapset_eq_dec `{∀ m1 m2 : M unit, Decision (m1 = m2)} : ∀ X1 X2 : mapset M, Decision (X1 = X2) | 1. Proof. solve_decision. Defined. Global Instance mapset_elem_of_dec x (X : mapset M) : Decision (x ∈ X) | 1. Proof. solve_decision. Defined. Instance: Collection K (mapset M). Proof. split; [split | | ]. * unfold empty, elem_of, mapset_empty, mapset_elem_of. simpl. intros. by simpl_map. * unfold singleton, elem_of, mapset_singleton, mapset_elem_of. simpl. by split; intros; simplify_map_equality. * unfold union, elem_of, mapset_union, mapset_elem_of. intros [m1] [m2] ?. simpl. rewrite lookup_union_Some_raw. destruct (m1 !! x) as [[]|]; tauto. * unfold intersection, elem_of, mapset_intersection, mapset_elem_of. intros [m1] [m2] ?. simpl. rewrite lookup_intersection_Some. setoid_replace (is_Some (m2 !! x)) with (m2 !! x = Some ()); [done |]. rewrite is_Some_alt. split; eauto. by intros [[] ?]. * unfold difference, elem_of, mapset_difference, mapset_elem_of. intros [m1] [m2] ?. simpl. rewrite lookup_difference_Some. destruct (m2 !! x) as [[]|]; intuition congruence. Qed. Global Instance: PartialOrder (mapset M). Proof. split; try apply _. intros ????. apply mapset_eq. intuition. Qed. Global Instance: FinCollection K (mapset M). Proof. split. * apply _. * unfold elements, elem_of at 1, mapset_elems, mapset_elem_of. intros [m] x. simpl. rewrite elem_of_list_fmap. split. + intros. exists (x, ()). by rewrite elem_of_map_to_list. + intros ([y []] &?& Hy). subst. by rewrite <-elem_of_map_to_list. * unfold elements, mapset_elems. intros [m]. simpl. apply map_to_list_key_nodup. Qed. Definition mapset_map_with `(f : bool → A → B) (X : mapset M) : M A → M B := match X with | Mapset m => merge (λ x y, match x, y with | Some _, Some a => Some (f true a) | None, Some a => Some (f false a) | _, None => None end) m end. Definition mapset_dom_with `(f : A → bool) (m : M A) : mapset M := Mapset \$ merge (λ x _, match x with | Some a => if f a then Some () else None | None => None end) m (@empty (M A) _). Lemma lookup_mapset_map_with `(f : bool → A → B) X m i : mapset_map_with f X m !! i = f (bool_decide (i ∈ X)) <\$> m !! i. Proof. destruct X as [mX]. unfold mapset_map_with, elem_of, mapset_elem_of. rewrite lookup_merge by done. simpl. by case_bool_decide; destruct (mX !! i) as [[]|], (m !! i). Qed. Lemma elem_of_mapset_dom_with `(f : A → bool) m i : i ∈ mapset_dom_with f m ↔ ∃ x, m !! i = Some x ∧ f x. Proof. unfold mapset_dom_with, elem_of, mapset_elem_of. simpl. rewrite lookup_merge by done. destruct (m !! i) as [a|]. * destruct (Is_true_reflect (f a)); naive_solver. * naive_solver. Qed. Instance mapset_dom {A} : Dom (M A) (mapset M) := mapset_dom_with (λ _, true). Instance mapset_dom_spec: FinMapDom K M (mapset M). Proof. split; try apply _. intros. unfold dom, mapset_dom. rewrite is_Some_alt, elem_of_mapset_dom_with. naive_solver. Qed. End mapset. (** These instances are declared using [Hint Extern] to avoid too eager type class search. *) Hint Extern 1 (ElemOf _ (mapset _)) => eapply @mapset_elem_of : typeclass_instances. Hint Extern 1 (Empty (mapset _)) => eapply @mapset_empty : typeclass_instances. Hint Extern 1 (Singleton _ (mapset _)) => eapply @mapset_singleton : typeclass_instances. Hint Extern 1 (Union (mapset _)) => eapply @mapset_union : typeclass_instances. Hint Extern 1 (Intersection (mapset _)) => eapply @mapset_intersection : typeclass_instances. Hint Extern 1 (Difference (mapset _)) => eapply @mapset_difference : typeclass_instances. Hint Extern 1 (Elements _ (mapset _)) => eapply @mapset_elems : typeclass_instances.
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This files extends the implementation of finite over [positive] to finite maps whose keys range over Coq's data type of binary naturals [N]. *) ... ... @@ -30,9 +30,9 @@ Instance Npartial_alter {A} : PartialAlter N A (Nmap A) := λ f i t, Instance Nto_list {A} : FinMapToList N A (Nmap A) := λ t, match t with | NMap o t => option_case (λ x, [(0,x)]) [] o ++ (fst_map Npos <\$> finmap_to_list t) (fst_map Npos <\$> map_to_list t) end. Instance Nmerge {A} : Merge A (Nmap A) := λ f t1 t2, Instance Nmerge: Merge Nmap := λ A B C f t1 t2, match t1, t2 with | NMap o1 t1, NMap o2 t2 => NMap (f o1 o2) (merge f t1 t2) end. ... ... @@ -46,7 +46,7 @@ Proof. split. * intros ? [??] [??] H. f_equal. + apply (H 0). + apply finmap_eq. intros i. apply (H (Npos i)). + apply map_eq. intros i. apply (H (Npos i)). * by intros ? [|?]. * intros ? f [? t] [|i]; simpl. + done. ... ... @@ -54,27 +54,27 @@ Proof. * intros ? f [? t] [|i] [|j]; simpl; try intuition congruence. intros. apply lookup_partial_alter_ne. congruence. * intros ??? [??] []; simpl. done. apply lookup_fmap. * intros ? [[x|] t]; unfold finmap_to_list; simpl. * intros ? [[x|] t]; unfold map_to_list; simpl. + constructor. - rewrite elem_of_list_fmap. by intros [[??] [??]]. - rewrite (NoDup_fmap _). apply finmap_to_list_nodup. + rewrite (NoDup_fmap _). apply finmap_to_list_nodup. * intros ? t i x. unfold finmap_to_list. split. - rewrite (NoDup_fmap _). apply map_to_list_nodup. + rewrite (NoDup_fmap _). apply map_to_list_nodup. * intros ? t i x. unfold map_to_list. split. + destruct t as [[y|] t]; simpl. - rewrite elem_of_cons, elem_of_list_fmap. intros [? | [[??] [??]]]; simplify_equality; simpl; [done |]. by apply elem_of_finmap_to_list. by apply elem_of_map_to_list. - rewrite elem_of_list_fmap. intros [[??] [??]]; simplify_equality; simpl. by apply elem_of_finmap_to_list. by apply elem_of_map_to_list. + destruct t as [[y|] t]; simpl. - rewrite elem_of_cons, elem_of_list_fmap. destruct i as [|i]; simpl; [intuition congruence |]. intros. right. exists (i, x). by rewrite elem_of_finmap_to_list. intros. right. exists (i, x). by rewrite elem_of_map_to_list. - rewrite elem_of_list_fmap. destruct i as [|i]; simpl; [done |]. intros. exists (i, x). by rewrite elem_of_finmap_to_list. * intros ? f ? [o1 t1] [o2 t2] [|?]; simpl. intros. exists (i, x). by rewrite elem_of_map_to_list. * intros ??? f ? [o1 t1] [o2 t2] [|?]; simpl. + done. + apply (merge_spec f t1 t2). + apply (lookup_merge f t1 t2). Qed.
 (* Copyright (c) 2012, Robbert Krebbers. *) (* Copyright (c) 2012-2013, Robbert Krebbers. *) (* This file is distributed under the terms of the BSD license. *) (** This file collects some trivial facts on the Coq types [nat] and [N] for natural numbers, and the type [Z] for integers. It also declares some useful notations. *) Require Export PArith NArith ZArith. Require Import Qcanon. Require Export base decidable. Open Scope nat_scope. Coercion Z.of_nat : nat >-> Z. (** * Notations and properties of [nat] *) Reserved Notation "x ≤ y ≤ z" (at level 70, y at next level). Reserved Notation "x ≤ y < z" (at level 70, y at next level). Reserved Notation "x < y < z" (at level 70, y at next level). ... ... @@ -42,17 +45,86 @@ Definition sum_list_with {A} (f : A → nat) : list A → nat := end. Notation sum_list := (sum_list_with id). (** * Notations and properties of [positive] *) Open Scope positive_scope. Instance positive_eq_dec: ∀ x y : positive, Decision (x = y) := Pos.eq_dec. Instance positive_inhabited: Inhabited positive := populate 1%positive. Instance positive_inhabited: Inhabited positive := populate 1. Notation "(~0)" := xO (only parsing) : positive_scope. Notation "(~1)" := xI (only parsing) : positive_scope. Instance: Injective (=) (=) xO. Instance: Injective (=) (=) (~0). Proof. by injection 1. Qed. Instance: Injective (=) (=) xI. Instance: Injective (=) (=) (~1). Proof. by injection 1. Qed. (** Since [positive] represents lists of bits, we define list operations on it. These operations are in reverse, as positives are treated as snoc lists instead of cons lists. *) Fixpoint Papp (p1 p2 : positive) : positive := match p2 with | 1 => p1 | p2~0 => (Papp p1 p2)~0 | p2~1 => (Papp p1 p2)~1 end. Infix "++" := Papp : positive_scope. Notation "(++)" := Papp (only parsing) : positive_scope. Notation "( p ++)" := (Papp p) (only parsing) : positive_scope. Notation "(++ q )" := (λ p, Papp p q) (only parsing) : positive_scope. Fixpoint Preverse_go (p1 p2 : positive) : positive := match p2 with | 1 => p1 | p2~0 => Preverse_go (p1~0) p2 | p2~1 => Preverse_go (p1~1) p2 end. Definition Preverse : positive → positive := Preverse_go 1. Global Instance: LeftId (=) 1 (++). Proof. intros p. induction p; simpl; intros; f_equal; auto. Qed. Global Instance: RightId (=) 1 (++). Proof. done. Qed. Global Instance: Associative (=) (++). Proof. intros ?? p. induction p; simpl; intros; f_equal; auto. Qed. Global Instance: ∀ p : positive, Injective (=) (=) (++ p). Proof. intros p ???. induction p; simplify_equality; auto. Qed. Lemma Preverse_go_app_cont p1 p2 p3 : Preverse_go (p2 ++ p1) p3 = p2 ++ Preverse_go p1 p3. Proof. revert p1. induction p3; simpl; intros. * apply (IHp3 (_~1)). * apply (IHp3 (_~0)). * done. Qed. Lemma Preverse_go_app p1 p2 p3 : Preverse_go p1 (p2 ++ p3) = Preverse_go p1 p3 ++ Preverse_go 1 p2. Proof. revert p1. induction p3; intros p1; simpl; auto. by rewrite <-Preverse_go_app_cont. Qed. Lemma Preverse_app p1 p2 : Preverse (p1 ++ p2) = Preverse p2 ++ Preverse p1. Proof. unfold Preverse. by rewrite Preverse_go_app. Qed. Lemma Preverse_xO p : Preverse (p~0) = (1~0) ++ Preverse p. Proof Preverse_app p (1~0). Lemma Preverse_xI p : Preverse (p~1) = (1~1) ++ Preverse p. Proof Preverse_app p (1~1). Fixpoint Plength (p : positive) : nat := match p with | 1 => 0%nat | p~0 | p~1 => S (Plength p)