Require Import ssreflect ssrnat ssrbool seq eqtype.

Parameter ZZ : Type.

(* Group Structure *)
Variable (group_mul : ZZ -> ZZ -> ZZ) (groupinv : ZZ -> ZZ) (Id : ZZ).

Notation "x .* y " := (group_mul x y) (at level 50, left associativity).
Notation "x ^-1" := (groupinv x) (at level 40).

(* Group axioms *)
Axiom GA : forall g1 g2 g3, g1 .* g2 .* g3 = g1 .* (g2 .* g3).
Axiom GId: forall g, g .* Id = g.
Axiom IdG: forall g, Id .* g = g.
Axiom GI : forall g, g .* (g ^-1) = Id.
Axiom IG: forall g, (g ^-1) .* g = Id.

(* Basic lemmata *)

Corollary GI' g A: g .* ((g ^-1) .* A) = A. by rewrite -GA GI IdG. Qed.

Corollary IG' g A: (g^-1) .* (g .* A) = A. by rewrite -GA IG IdG. Qed.

Corollary GI'l g A: A .* g .* (g ^-1) = A. by rewrite GA GI GId. Qed.

Corollary IG'l g A: A .* (g^-1) .* g = A. by rewrite GA IG GId. Qed.

Lemma GCr: forall g3 g1 g2, g1 .* g3 = g2 .* g3 -> g1 = g2.
intros. have: (g1 .* g3 .* g3 ^-1 = g2 .* g3 .* g3 ^-1) by rewrite H.
by rewrite ?GA ?GI ?GId. Qed.

Lemma GCl g3 g1 g2: g3 .* g1 = g3 .* g2 -> g1 = g2.
intros. have: (g3^-1 .* g3 .* g1 = g3 ^-1 .* g3 .* g2) by rewrite ?GA H.
by rewrite ?IG ?IdG. Qed.

Lemma GIM: forall g1 g2, (g1 .* g2) ^-1 = g2 ^-1 .* g1 ^-1.
intros. apply (GCr (g1 .* g2)). by rewrite IG GA -(GA (g1 ^-1)) IG IdG IG. Qed.

Lemma GII: forall g, g ^-1 ^-1 = g.
intros. apply (GCr (g^-1)). by rewrite IG GI. Qed.

Corollary GCl' g3 g1 g2: g1 = g2 -> g3 .* g1 = g3 .* g2.
by move => ->. Qed.

Corollary GCr' g3 g1 g2: g1 = g2 -> g1 .* g3 = g2 .* g3.
by move => ->. Qed.

Lemma IdI: Id ^-1 = Id. apply (GCr Id). by rewrite IG IdG. Qed.

Lemma eqIdP a b: a .* b = Id <-> a = b^-1.
split; intros; [apply (GCr b); by rewrite IG| apply (GCr (b^-1)); by rewrite GA IdG GI GId]. Qed.

Lemma eqIdP' a b: a .* (b^-1) = Id -> a = b.
move /(GCr' b). by rewrite GA IG GId IdG. Qed.

Lemma eqIdP'' a b: a = b -> a .* (b^-1) = Id.
move /(GCr' (b^-1)). by rewrite GI. Qed.

Lemma rotate a b: a .* b = Id -> b .* a = Id.
intros. apply eqIdP in H. by rewrite H GI. Qed.

Lemma eqI g h : g^-1 = h^-1 -> g = h. intros.
apply eqIdP'. by rewrite -H GI. Qed.

(* Conjugate elements *)

Definition conj (h g : ZZ) := (g ^-1) .* h .* g.
Notation "h ^ g" := (conj h g).

Lemma conj_def g h: h^-1 .* g .* h = g ^ h. by rewrite /conj. Qed.

Lemma conjI g h: (g^-1)^h = (g^h) ^-1. by rewrite /conj ?GIM GII GA. Qed.

Lemma conj_mul h g1 g2: h ^ (g1 .* g2) = (h ^ g1) ^ g2.
by rewrite /conj ?GIM ?GA. Qed.

Lemma mul_conj g h1 h2: (h1 .* h2) ^ g = h1 ^ g .* h2 ^ g.
by rewrite /conj ?GA -(GA g) GI IdG. Qed.

Lemma conjId g: g ^ Id = g.
by rewrite /conj IdI IdG GId. Qed.

Lemma Idconj g: Id ^ g = Id. by rewrite /conj GId IG. Qed.

Lemma conj_eq g1 g2 h : g1 = g2 -> g1 ^ h = g2 ^ h. by move => ->. Qed.

Lemma eq_inv h g: h = g <-> h ^-1 = g ^-1.
split. by move => ->. move /eqIdP /(GCl' h). by rewrite GId -GA GI IdG. Qed.

(* Commutators *)

Definition Comm (x y : ZZ) : ZZ := (x .* y .* x^-1 .* y^-1).
Notation "[ ~ x1 , x2 , .. , xn ]" :=
  (Comm .. (Comm x1 x2) .. xn) (at level 29, left associativity).

Ltac expand := rewrite /Comm /conj ?GIM ?GII.
Ltac cancel := rewrite ?IdI ?Idconj ?GI' ?GI'l ?IG' ?IG'l ?GI ?IG ?IdG ?GId.
Ltac cancellate := expand; rewrite ?GA; cancel; rewrite -?GA.
Ltac rotate := rewrite ?GA; apply rotate; rewrite -?GA.
Ltac conjugate_r M := rewrite -?GA; move /(GCl' (M ^-1)) /(GCr' M); cancellate.
Ltac conjugate_l M := rewrite -?GA; move /(GCl' M) /(GCr' (M^-1)); cancellate.
Ltac lockconj := (replace conj with (locked conj);  [| by rewrite -lock]).
Ltac cancel_l := rewrite ?GA; apply GCl'; rewrite -?GA.
Ltac cancel_r := rewrite -?GA; apply GCr'; rewrite -?GA.
Ltac bite := repeat (progress (try cancel_l; try cancel_r)).

Lemma Gswap a b: a .* b = b .* a ^ b. by cancellate. Qed.

Lemma Gswap2 a b: a .* b = b ^ (a^-1) .* a. by cancellate. Qed.

Lemma Gswap' a b g: g .* a .* b = g .* b .* a ^ b. by cancellate. Qed.

Lemma Gswap2' a b g: g .* a .* b = g .* b ^ (a^-1) .* a. by cancellate. Qed.

Lemma comm_inv: forall x y, [~ x, y] ^-1 = [~y, x].
intros. by rewrite /Comm ?GIM ?GII -?GA. Qed.

Lemma swap_comm a b: a .* b = [~ a, b] .* b .* a. by expand; cancel. Qed.

Lemma conj_com: forall a b, a ^ b = [~ b ^-1, a] .* a.
intros. rewrite /conj. apply (GCr Id). by rewrite -{1}(IG a) -GA /Comm GII GId. Qed.

Lemma comm3 x y z: [~z, x, y]^ z = [~x, z^-1, y^z]. by cancellate. Qed.

Lemma cmul_l x y z: [~ x .* y, z] = [~y, z] ^ (x^-1) .* [~x, z]. by cancellate. Qed.

Lemma cmul_r x y z: [~ x, y .* z] = [~x, y] .* [~x, z] ^ (y^-1). by cancellate. Qed.

Lemma comm_conj x y z: [~ x, y] ^ z = [~x ^ z, y ^ z]. by cancellate. Qed.

Lemma conj_comm' x y z : [ ~ y, z] ^ x = [ ~ x ^-1 .* y, z] .* [ ~ z, x ^-1]. by cancellate; cancel. Qed.

Lemma comm_d1 x y: [~ x, y] = y ^ (x^-1) .* y^-1. by expand. Qed.

Lemma comm_d2 x y: [~ x, y] = x .* (x^-1) ^ (y^-1). by cancellate. Qed.

Lemma comm_d1' x y g: g .* [ ~ x, y] = g .* y ^ (x ^-1) .* y ^-1. by cancellate. Qed.

Lemma comm_d1'' x y: x ^ y .* x^-1 = [~ y^-1, x]. by rewrite comm_d1; cancellate. Qed.

Lemma comm_d2' x y g: g .* [~ x, y] = g .* x .* (x^-1) ^ (y^-1). by cancellate. Qed.
(* Variations of Hall-Witt identity*)

Lemma HallWitt x y z:
 [~ y^-1, x, z] ^ (y^-1) .* [~ z^-1, y, x] ^ (z^-1) .* [~ x^-1, z, y] ^ (x^-1) = Id.
 by expand; rewrite ?GA; do 4 cancel. Qed.

Corollary HallWitt' x y z: [~ y, x^-1, z^-1]^ y .* [~z, y^-1, x^-1]^ z .* [~x, z^-1, y^-1] ^ x = Id.
move: (HallWitt (x^-1) (y^-1) (z^-1)). by rewrite ?GII. Qed.

Corollary HallWitt'' x y z:
 [~ x^-1, y^-1, (z^-1)^y] .* [~ y^-1, z^-1, (x^-1)^z] .* [~ z^-1, x^-1, (y^-1)^x] = Id.
by rewrite -?comm3 HallWitt'. Qed.


Require Export prosa.model.task.preemption.parameters.
Require Import prosa.model.preemption.limited_preemptive.

(** * Limited-Preemptive Task Model *)

(** In this module, we instantiate the task model in which jobs can be
    preempted only at certain preemption points. *)

(** ** Model Validity *)

(** To begin with, we introduce requirements that the function
    [task_max_nonpr_segment] must satisfy to be coherent with the
    limited-preemptive task model. *)
Section ValidModelWithFixedPreemptionPoints.

  (** Consider any type of tasks with WCET bounds and given preemption points ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskPreemptionPoints Task}.

  (**  ... and any type of jobs associated with these tasks, ... *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  (** ... where each job has an arrival time, an execution cost, and some
      preemption points. *)
  Context `{JobArrival Job}.
  Context `{JobCost Job}.
  Context `{JobPreemptionPoints Job}.

  (** Consider any arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** Consider an arbitrary task set [ts]. *)
  Variable ts : TaskSet Task.

  (** First, we describe structural properties that a sequence of preemption
      points of a task should satisfy. *)

  (** (1) We require the sequence of preemption points to contain the beginning ... *)
  Definition task_beginning_of_execution_in_preemption_points :=
    forall tsk, tsk \in ts -> first0 (task_preemption_points tsk) = 0.

  (** ... and (2) the end of execution. *)
  Definition task_end_of_execution_in_preemption_points :=
    forall tsk, tsk \in ts -> last0 (task_preemption_points tsk) = task_cost tsk.

  (** (3) Furthermore, we require the sequence of preemption points to be a
          non-decreasing sequence. *)
  Definition nondecreasing_task_preemption_points :=
    forall tsk, tsk \in ts -> nondecreasing_sequence (task_preemption_points tsk).

  (** (4) We also require the number of nonpreemptive segments of a job to be
          equal to the number of nonpreemptive segments of its task. Note that
          some of nonpreemptive segments of a job can have zero length;
          nonetheless the number of segments should match. *)
  Definition consistent_job_segment_count :=
    forall j,
      arrives_in arr_seq j ->
      size (job_preemption_points j) = size (task_preemption_points (job_task j)).

  (** (5) We require the lengths of the nonpreemptive segments of a job to be
          bounded by the lengths of the corresponding segments of its task.  *)
  Definition job_respects_segment_lengths :=
    forall j n,
      arrives_in arr_seq j ->
      nth 0 (distances (job_preemption_points j)) n
      <= nth 0 (distances (task_preemption_points (job_task j))) n.

  (** (6) Lastly, we ban empty nonpreemptive segments at the task level. *)
  Definition task_segments_are_nonempty :=
    forall tsk n,
      (tsk \in ts) ->
      n < size (distances (task_preemption_points tsk)) ->
      ε <= nth 0 (distances (task_preemption_points tsk)) n.

  (** We define a valid task-level model with fixed preemption points as the
      conjunction of the hypotheses above. *)
  Definition valid_fixed_preemption_points_task_model :=
    task_beginning_of_execution_in_preemption_points /\
    task_end_of_execution_in_preemption_points /\
    nondecreasing_task_preemption_points /\
    consistent_job_segment_count /\
    job_respects_segment_lengths /\
    task_segments_are_nonempty.

  (** Finally, a model with fixed preemption points is valid if it is both valid
      a the job and task levels. *)
  Definition valid_fixed_preemption_points_model :=
    valid_limited_preemptions_job_model arr_seq /\
    valid_fixed_preemption_points_task_model.

End ValidModelWithFixedPreemptionPoints.

(** ** Run-to-Completion Threshold *)

(** In this section, we instantiate the task-level run-to-completion threshold
    for the task model with fixed preemption points. *)
Section TaskRTCThresholdLimitedPreemptions.

  (** Consider any type of tasks with WCET bounds and fixed preemption points. *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskPreemptionPoints Task}.

  (** Given fixed preemption points, no job can be preempted after a job
      reaches its last non-preemptive segment. Thus, we can set the task-level
      run-to-completion threshold to [task_cost tsk - (task_last_nonpr_seg tsk - ε)],
      which safely bounds [job_cost j - (job_last_nonpr_seg j - ε)]. *)
  Global Program Instance limited_preemptions : TaskRunToCompletionThreshold Task :=
    {
      task_run_to_completion_threshold (tsk : Task) :=
        task_cost tsk - (task_last_nonpr_segment tsk - ε)
    }.

End TaskRTCThresholdLimitedPreemptions.


(* Hernán Gurmendi *)

Section Ejercicio3.
Variable A B C: Set.

Definition apply : (A -> B) -> A -> B
  := fun f x => (f x).

Definition o : (B -> C) -> (A -> B) -> (A -> C)
  := fun f g x => (f (g x)).

Definition twice : (A -> A) -> A -> A
  := fun f x => (f (f x)).

Definition apply' : forall X Y : Set, (X -> Y) -> X -> Y
  := fun (X Y : Set) (f : X -> Y) (x : X) => (f x).

Definition o' : forall X Y Z : Set, (Y -> Z) -> (X -> Y) -> (X -> Z)
  := fun (X Y Z : Set) (f : Y -> Z) (g : X -> Y) (x : X) => (f (g x)).

Definition twice' : forall X : Set, (X -> X) -> X -> X
  := fun (X : Set) (f : X -> X) (x : X) => (f (f x)).

End Ejercicio3.

Section Ejercicio4.
Variable A: Set.

Definition id : A -> A
  := fun (x : A) => x.

Theorem e4 : forall x : A, (o A A A id id) x = id x.
Proof.
  reflexivity.
Qed.

End Ejercicio4.

Section Ejercicio5.

Definition opI : forall A : Set, A -> A
  := id.

Definition opK : forall A B : Set, A -> B -> A
  := fun (A B : Set) (a : A) (b : B) => a.

Definition opS : forall A B C : Set, (A -> B -> C) -> (A -> B) -> A -> C
  := fun (A B C : Set) (f : A -> B -> C) (g : A -> B) (x : A) => ((f x) (g x)).

Lemma e52 : forall A B : Set, opS A (B -> A) A (opK A (B -> A)) (opK A B) = opI A.
Proof.
  reflexivity.
Qed.

End Ejercicio5.

Section Ejercicio10.

Parameter Array : Set -> nat -> Set.
Parameter emptyA : forall X : Set, Array X 0.
Parameter addA : forall (X : Set) (n : nat), X -> Array X n -> Array X (S n).

Parameter Matrix : Set -> nat -> Set.
Parameter emptyM : forall X : Set, Matrix X 0.
Parameter addM : forall (X : Set) (n : nat), Matrix X n -> Array X (n + 1) -> Matrix X (n + 1).

Definition M1 := addM nat 0 (emptyM nat) (addA nat 0 3 (emptyA nat)).
Definition M2 := addM nat 1 M1 (addA nat 1 2 (addA nat 0 3 (emptyA nat))).
Definition M3 := addM nat 2 M2 (addA nat 2 1 (addA nat 1 2 (addA nat 0 3 (emptyA nat)))).

Check M3.

End Ejercicio10.

Section Ejercicio11.

Parameter ABNat : forall n : nat, Set.

Parameter emptyAB : ABNat 0.

Parameter addAB_eq : forall n, ABNat n -> nat -> ABNat n -> ABNat (n + 1).
Parameter addAB_lt : forall n, ABNat n -> nat -> ABNat (n + 1) -> ABNat (n + 1).
Parameter addAB_gt : forall n, ABNat (n + 1) -> nat -> ABNat n -> ABNat (n + 1).

Definition e11_3 : ABNat 2
  := addAB_eq 1 (addAB_eq 0 emptyAB 2 emptyAB) 1 (addAB_eq 0 emptyAB 3 emptyAB).

Parameter ABGen : forall (T : Type) (n : nat), Set.
Parameter emptyABGen : forall (T : Type), ABGen T 0.
Parameter addABGen_eq' : forall T n, ABGen T n -> T -> ABGen T n -> ABGen T (n + 1).
Parameter addABGen_lt' : forall T n, ABGen T n -> T -> ABGen T (n + 1) -> ABGen T (n + 1).
Parameter addABGen_gt' : forall T n, ABGen T (n + 1) -> T -> ABGen T n -> ABGen T (n + 1).

End Ejercicio11.

Section Ejercicio15.

Variable U : Set.
Variable e : U.
Variable A B : U -> Prop.
Variable P : Prop.
Variable R : U -> U -> Prop.

Lemma Ej315_1 : (forall x : U, A x -> B x) -> (forall x : U, A x) -> forall x : U, B x.
Proof.
  intros.
  exact (H x (H0 x)).
Qed.

Lemma Ej315_2 : forall x : U, A x -> ~(forall x : U, ~ A x).
Proof.
  unfold not.
  intros.
  exact (H0 x H).
Qed.

Lemma Ej315_3 : (forall x : U, P -> A x) -> P -> forall x : U, A x.
Proof.
  intros.
  exact (H x H0).
Qed.

Lemma Ej315_4 : (forall x y : U, R x y) -> forall x : U, R x x.
Proof.
  intros.
  exact (H x x).
Qed.

Lemma Ej315_5 : (forall x y: U, R x y -> R y x) -> forall z : U, R e z -> R z e.
Proof.
  intros.
  exact (H e z H0).
Qed.

End Ejercicio15.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Category.

(** The oposite of a category C is a category with the same objects where the arrows are inverted.
As a result, f ∘_Cᵒᵖ g is just g ∘_C f and consequently, assoc is assoc_sym (reversed with arrow
arguments) and vice versa. Similarly, id_unit_left and id_unit_right are also swapped. *)

Definition Opposite (C : Category) : Category :=
{|

  Obj := Obj C;

  Hom := fun a b => (b –≻ a)%morphism;

  compose :=
    fun a b c (f : (b –≻ a)%morphism) (g : (c –≻ b)%morphism) => compose C c b a g f;

  id := fun c => id C c;

  assoc := fun _ _ _ _ f g h => assoc_sym h g f;

  assoc_sym := fun _ _ _ _ f g h => assoc h g f;

  id_unit_left := fun _ _ h => @id_unit_right C _ _ h;

  id_unit_right := fun _ _ h => @id_unit_left C _ _ h

|}.

Notation "C '^op'" := (Opposite C) : category_scope.


Require Export prosa.analysis.definitions.job_properties.
Require Export prosa.analysis.facts.behavior.all.
Require Export prosa.model.task.preemption.parameters.

(** * Run-to-Completion Threshold *)
(** In this section, we provide a few basic properties
    of run-to-completion-threshold-compliant schedules. *)
Section RunToCompletionThreshold.

  (**  Consider any type of jobs. *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** In addition, we assume existence of a function
      mapping jobs to theirs preemption points. *)
  Context `{JobPreemptable Job}.

  (** Consider any kind of processor state model, ... *)
  Context {PState : Type}.
  Context `{ProcessorState Job PState}.

  (** ... any job arrival sequence, ... *)
  Variable arr_seq: arrival_sequence Job.

  (** ... and any given schedule. *)
  Variable sched: schedule PState.

  (** Assume that the preemption model is valid. *)
  Hypothesis H_valid_preemption_model:
    valid_preemption_model arr_seq sched.

  (** Consider an arbitrary job j from the arrival sequence. *)
  Variable j : Job.
  Hypothesis H_j_arrives : arrives_in arr_seq j.

  (** First we prove a few auxiliary lemmas about
      [job_preemption_points]. *)
  Section AuxiliaryLemmas.

    (** We prove that the sequence of preemption points of a zero-cost
        job consists of one element -- 0. *)
    Lemma preemption_points_of_zero_cost_job:
      job_cost j = 0 ->
      job_preemption_points j = [::0].
    Proof.
      intros ZERO.
      destruct (H_valid_preemption_model j) as [A1 [A2 [A3 A4]]]; auto.
      unfold job_preemption_points; rewrite ZERO; simpl.
      simpl; unfold job_cannot_become_nonpreemptive_before_execution in *.
        by rewrite A1.
    Qed.

    (** For a positive-cost job, 0 ... *)
    Lemma zero_in_preemption_points:
      0 < job_cost j ->
      0 \in job_preemption_points j.
    Proof.
      intros POS.
      unfold job_preemption_points, range.
      destruct (H_valid_preemption_model j) as [A1 [A2 [A3 A4]]]; auto.
      unfold job_cannot_become_nonpreemptive_before_execution in *.
      rewrite index_iota_lt_step; last by done.
        by simpl; rewrite A1 in_cons eq_refl.
    Qed.

    (** ... and [job_cost] are in preemption points. *)
    Lemma job_cost_in_preemption_points:
      0 < job_cost j ->
      job_cost j \in job_preemption_points j.
    Proof.
      intros POS.
      unfold job_preemption_points, range, index_iota; rewrite subn0 -addn1.
      rewrite iota_add add0n filter_cat mem_cat.
      apply/orP; right; simpl.
      destruct (H_valid_preemption_model j) as [A1 [A2 [A3 A4]]]; auto.
      unfold job_cannot_be_nonpreemptive_after_completion in *.
        by rewrite A2 in_cons eq_refl.
    Qed.

    (** Therefore, for a positive-cost job size of the sequence of
        preemption points is at least two. *)
    Lemma size_of_preemption_points:
      0 < job_cost j ->
      2 <= size (job_preemption_points j).
    Proof.
      intros POS.
      replace 2 with (size [::0; job_cost j]); last by done.
      apply subseq_leq_size.
      - apply/andP; split. rewrite !in_cons Bool.negb_orb.
        + apply/andP; split. by rewrite neq_ltn POS. by done.
        + apply/andP; split; by done.
      - intros ρ; rewrite !in_cons; move => /orP [/eqP EQ| /orP [/eqP Cost | C]].
        + by subst; apply zero_in_preemption_points.
        + by subst; apply job_cost_in_preemption_points.
        + by done.
    Qed.

    (** Next we show that the sequence of preemption points is a non-decreasing sequence. *)
    Lemma preemption_points_nondecreasing:
      nondecreasing_sequence (job_preemption_points j).
    Proof. by apply increasing_implies_nondecreasing, iota_is_increasing_sequence. Qed.

    (** Next, we prove that the last element of the sequence of
        preemption points is [job_cost]. *)
    Lemma job_cost_is_last_element_of_preemption_points:
      job_cost j = last0 (job_preemption_points j).
    Proof.
      unfold job_preemption_points.
      edestruct H_valid_preemption_model as [A1 [A2 [A3 A4]]]; eauto 2.
      erewrite last0_filter.
      + by apply/eqP; apply eq_refl.
      + unfold range, index_iota; rewrite subn0 -addn1.
          by rewrite iota_add; destruct (iota 0 (job_cost j)).
      + unfold range, index_iota; rewrite subn0 -addn1.
          by rewrite iota_add last0_cat //.
      + by apply A2.
    Qed.

    (** Last non-preemptive segment of a positive-cost job has positive length. *)
    Lemma job_last_nonpreemptive_segment_positive:
      job_cost_positive j ->
      0 < job_last_nonpreemptive_segment j.
    Proof.
      intros COST. unfold job_last_nonpreemptive_segment.
      rewrite last0_nth function_of_distances_is_correct subn_gt0.
      rewrite [size _]pred_Sn -addn1-addn1.
      rewrite -size_of_seq_of_distances ?addn1; last by apply size_of_preemption_points.
      rewrite prednK; last first.
      { rewrite -(leq_add2r 1) !addn1 prednK.
        - apply size_of_preemption_points; eauto.
        - rewrite ltnW //; apply size_of_preemption_points; eauto.
      }
      apply iota_is_increasing_sequence; apply/andP; split.
      - rewrite -(leq_add2r 2) !addn2.
        rewrite prednK; first by done.
        rewrite -(leq_add2r 1) !addn1.
        rewrite prednK.
        + by apply size_of_preemption_points.
        + by rewrite ltnW //; apply size_of_preemption_points.
      - rewrite -(leq_add2r 1) !addn1.
        unfold job_preemption_points, range.
        rewrite prednK ?ltnS; first by done.
          by rewrite ltnW //; apply size_of_preemption_points.
    Qed.

    (** Max nonpreemptive segment of a positive-cost job has positive length. *)
    Lemma job_max_nonpreemptive_segment_positive:
      job_cost_positive j ->
      0 < job_max_nonpreemptive_segment j.
    Proof.
      intros COST.
      eapply leq_trans.
      - by apply job_last_nonpreemptive_segment_positive.
      - by apply last_of_seq_le_max_of_seq.
    Qed.

    (** Next we show that max nonpreemptive segment is at most the
      cost of a job. *)
    Lemma job_max_nonpreemptive_segment_le_job_cost:
      job_max_nonpreemptive_segment j <= job_cost j.
    Proof.
      eapply leq_trans.
      apply max_distance_in_seq_le_last_element_of_seq; apply preemption_points_nondecreasing.
      destruct (H_valid_preemption_model j) as [A1 [A2 [A3 A4]]]; auto.
      case: (posnP (job_cost j)) => [ZERO|POSt].
      { unfold job_preemption_points; rewrite ZERO.
        simpl; unfold job_cannot_become_nonpreemptive_before_execution in *.
          by rewrite A1.
      }
      { eapply leq_trans; first apply last_of_seq_le_max_of_seq.
        rewrite job_cost_is_last_element_of_preemption_points.
        apply last_is_max_in_nondecreasing_seq; first by apply preemption_points_nondecreasing.
        apply max0_in_seq.
        have LL := size_of_preemption_points POSt.
          by destruct (job_preemption_points j).
      }
    Qed.

    (** We also show that last nonpreemptive segment is at most the
        cost of a job. *)
    Lemma job_last_nonpreemptive_segment_le_job_cost:
      job_last_nonpreemptive_segment j <= job_cost j.
    Proof.
      eapply leq_trans.
      - apply last_of_seq_le_max_of_seq.
      - apply job_max_nonpreemptive_segment_le_job_cost.
    Qed.

  End AuxiliaryLemmas.

  (** We prove that the run-to-completion threshold is positive for
        any job with positive cost. I.e., in order to become
        non-preemptive a job must receive at least one unit of
        service. *)
  Lemma job_run_to_completion_threshold_positive:
    job_cost_positive j ->
    0 < job_run_to_completion_threshold j.
  Proof.
    intros COST; unfold job_run_to_completion_threshold, ε.
    have N1 := job_last_nonpreemptive_segment_positive COST.
    have N2 := job_last_nonpreemptive_segment_le_job_cost.
    ssromega.
  Qed.

  (** Next we show that the run-to-completion threshold is at most
        the cost of a job. *)
  Lemma job_run_to_completion_threshold_le_job_cost:
    job_run_to_completion_threshold j <= job_cost j.
  Proof. by apply leq_subr. Qed.

  (** We prove that a job cannot be preempted
        during execution of the last segment. *)
  Lemma job_cannot_be_preempted_within_last_segment:
    forall (ρ : duration),
      job_run_to_completion_threshold j <= ρ < job_cost j ->
      ~~ job_preemptable j ρ.
  Proof.
    move => ρ /andP [GE LT].
    apply/negP; intros C.
    have POS : 0 < job_cost j; first by ssromega.
    rewrite /job_run_to_completion_threshold subnBA in GE; last by apply job_last_nonpreemptive_segment_positive.
    rewrite -subh1 in GE; [rewrite addn1 in GE | by apply job_last_nonpreemptive_segment_le_job_cost].
    rewrite job_cost_is_last_element_of_preemption_points in LT, GE.
    rewrite last_seq_minus_last_distance_seq in GE; last by apply preemption_points_nondecreasing.
    have EQ := antidensity_of_nondecreasing_seq.
    specialize (EQ (job_preemption_points j) ρ (size (job_preemption_points j)).-2 ).
    feed_n 2 EQ; first by apply preemption_points_nondecreasing.
    { apply/andP; split; first by done.
      rewrite prednK; first by rewrite -last0_nth.
      rewrite -(leq_add2r 1) !addn1 prednK.
      - by apply size_of_preemption_points.
      - by eapply leq_trans; last apply size_of_preemption_points.
    }
    move: EQ => /negP EQ; apply: EQ.
    apply conversion_preserves_equivalence; try done.
    eapply leq_trans; first by apply ltnW; exact LT.
      by rewrite job_cost_is_last_element_of_preemption_points.
  Qed.

  (** In order to get a consistent schedule, the scheduler should respect
         the notion of run-to-completion threshold. We assume that, after
         a job reaches its run-to-completion threshold, it cannot be preempted
         until its completion. *)
  Lemma job_nonpreemptive_after_run_to_completion_threshold:
    forall t t',
      t <= t' ->
      job_run_to_completion_threshold j <= service sched j t ->
      ~~ completed_by sched j t' ->
      scheduled_at sched j t'.
  Proof.
    intros ? ? LE TH COM.
    apply H_valid_preemption_model; first by done.
    apply job_cannot_be_preempted_within_last_segment; apply/andP; split.
    - by apply leq_trans with (service sched j t); last apply service_monotonic.
    - by rewrite ltnNge.
  Qed.

End RunToCompletionThreshold.

(** We add the above lemmas into a "Hint Database" basic_facts, so Coq
    will be able to apply them automatically. *)
Hint Resolve job_run_to_completion_threshold_le_job_cost : basic_facts.


Require Export SMlib.
Require Export DataTypes.

Open Scope N_scope.
Open Scope list_scope.

Definition IV := hStoN
"7380166f4914b2b9172442d7da8a0600a96f30bc163138aae38dee4db0fb0e4e".

(* 0 <= j <= 63*)
Definition T (j : nat) : N :=
  if Nat.leb j 15 then hStoN "79cc4519"  else hStoN "7a879d8a".

(* 0 <= j <= 63, X Y Z are words*)
Definition FF (j : nat) (X : N)(Y : N)(Z : N) : N :=
  if Nat.leb j 15 then X $ Y $ Z else
  (X /\ Y) \/ (X /\ Z) \/ (Y /\ Z).
Definition GG (j : nat) (X : N)(Y : N)(Z : N) : N :=
  if Nat.leb j 15 then X $ Y $ Z else
  (X /\ Y) \/ ((~ X) /\ Z).

Definition P0 (X : N) := X $ (X <<< 9) $ (X <<< 17).
Definition P1 (X : N) := X $ (X <<< 15) $ (X <<< 23).

(* 5.2 *)
Definition pad_k (l : N) :=
  Z.to_N (Z.modulo (Z.sub 447%Z (Z.of_N l)) 512).

(*
Definition binaryStr (n : N) :=
  substring 2 (String.length  (BinaryString.of_N n)) (BinaryString.of_N n).  *)

Definition prePad64(s : bL) :=
  List.app(iter (64 - (N.of_nat (List.length s))) (fun s => List.app s [false]) []) s.

Definition Padding (m : bL) (l : N) : bL :=
  List.app ( iter (pad_k l) (fun (s : bL) => List.app s [false]) (List.app m [true])
  ) (prePad64 (NtobL l)).

Definition n_of_B (l : N) := (l + (pad_k l) + 65) / 512.

Definition Block (i : nat)(m : bL)(l : N) : N :=
  bLtoN (subList (Nat.mul i 512%nat) 512 (Padding m l)).

(* j <= 15 *)
Fixpoint W_list_init_rec (j : nat)(Bi : N)(acc : list N) : list N :=
  match j with
  | O => acc
  | S j' =>
      W_list_init_rec j' Bi
      (((shiftr Bi ((N.of_nat (Nat.sub 15 j')) * word_size)) /\ mask_ws) :: acc)
  end.

Definition W_list_init (j : nat)(Bi : N) : list N :=
  List.rev (W_list_init_rec j Bi []).

Definition W_list_aux (l' : list N) : list N :=
  (P1 ((List.nth 15 l' 0) $ (List.nth 8 l' 0) $ (List.nth 2 l' 0) <<< 15)
    $ (List.nth 12 l' 0) <<< 7 $ (List.nth 5 l' 0))
    :: l'.

Fixpoint W_list (j : nat)(l : list N) :=
  match j with
  | O => l
  | S j' => W_list j' (W_list_aux l)
  end.

Definition W (j : nat)(Bi : N) :=
  List.nth (67 - j)%nat (W_list 52 (W_list_init 16 Bi)) 0.
(*
Definition Bitest := HexString.to_N "0x1111222233334444555566667777888899990000aaaabbbbccccddddeeeeffff1111222233334444555566667777888899990000aaaabbbbccccdd1deeeeffff".
Compute HexString.of_N (W 0 Bitest).
Compute HexString.of_N (W 1 Bitest).
Compute HexString.of_N (W 15 Bitest).
Compute HexString.of_N (W 14 Bitest).
Compute List.map HexString.of_N (W_list 52 (W_list_init 16 Bitest)).
*)
(* j <= 63 *)
Definition W' (j : nat) (Bi : N) :=
  (W j Bi) $ (W (j + 4) Bi).

(* reg is 256 bit, i.e. 8 words. A is 1 word *)
Definition Part_A (reg : N) : N := (shiftr reg (7 * word_size)) /\ mask_ws.
Definition Part_B (reg : N) : N := (shiftr reg (6 * word_size)) /\ mask_ws.
Definition Part_C (reg : N) : N := (shiftr reg (5 * word_size)) /\ mask_ws.
Definition Part_D (reg : N) : N := (shiftr reg (4 * word_size)) /\ mask_ws.
Definition Part_E (reg : N) : N := (shiftr reg (3 * word_size)) /\ mask_ws.
Definition Part_F (reg : N) : N := (shiftr reg (2 * word_size)) /\ mask_ws.
Definition Part_G (reg : N) : N := (shiftr reg (1 * word_size)) /\ mask_ws.
Definition Part_H (reg : N) : N := reg /\ mask_ws.

Definition SS1 (reg : N)(j : nat) : N :=
  ( ((Part_A reg) <<< 12) +ws (Part_E reg) +ws
    ((T j) <<< (modulo (N.of_nat j) 32)) ) <<< 7.
(* mod 32 appears on the new version of SM3, which makes no
* difference in my implementation *)
Definition SS2 (reg : N) (j : nat) :=
  (SS1 reg j) $ ((Part_A reg) <<< 12).
Definition TT1 (reg : N)(j : nat)(Bi : N) :=
  (FF j (Part_A reg) (Part_B reg) (Part_C reg)) +ws (Part_D reg) +ws (SS2 reg j) +ws (W' j Bi).
Definition TT2 (reg : N)(j : nat)(Bi : N) :=
  (GG j (Part_E reg) (Part_F reg) (Part_G reg)) +ws (Part_H reg) +ws (SS1 reg j) +ws (W j Bi).

Definition Reg_aux (reg : N)(j : nat)(Bi : N) :=
  (shiftl (TT1 reg j Bi) (7 * word_size)) \/
  (shiftl (Part_A reg) (6 * word_size)) \/
  (shiftl ((Part_B reg) <<< 9) (5 * word_size)) \/
  (shiftl (Part_C reg) (4 * word_size)) \/
  (shiftl (P0 (TT2 reg j Bi)) (3 * word_size)) \/
  (shiftl (Part_E reg) (2 * word_size)) \/
  (shiftl ((Part_F reg) <<< 19) (1 * word_size)) \/
  (Part_G reg).

Fixpoint Reg_tail (k : nat)(j : nat)(Vi : N)(Bi : N)(acc : list N) : list N :=
  match k with
  | O => acc
  | S k' => Reg_tail k' j Vi Bi ((Reg_aux (List.hd 0 acc) (j - k) Bi) :: acc)
  end.

Definition Reg (j : nat)(Vi : N)(Bi : N) : N :=
  List.hd 0 (Reg_tail j j Vi Bi [Vi]).

(* j in [0, 64] Vi is of 256 bit *)
Definition Reg_ntail (j : nat) (Vi : N) (Bi : N) :=
  match j with
  | O => Vi
  | S j' =>
      Reg_aux (Reg j' Vi Bi) j' Bi
  end.

Definition CF (Vi : N) (Bi : N) :=
  (Reg 64 Vi Bi) $ Vi.

Fixpoint V_tail (k : nat)(i : nat)(m : bL)(len: N)(acc : list N) : list N :=
  match k with
  | O => acc
  | S k' => V_tail k' i m len((CF (List.hd 0 acc) (Block (i - k) m len)) :: acc)
  end.

Definition V(i : nat)(m : bL)(len: N) : N := List.hd 0 (V_tail i i m len[IV]).
Fixpoint V_ntail (i : nat)(m : bL)(len : N) : N :=
  match i with
  | O => IV
  | S i' => CF (V_ntail i' m len) (Block i' m len)
  end.

Definition SM3_HashN (m : bL) : N :=
  V (N.to_nat (n_of_B (N.of_nat (List.length m)))) m (N.of_nat (List.length m)).

Definition SM3_Hash (m : bL) : bL :=
  NtobL_len 256 (SM3_HashN m).

(*
Definition hex2bin_with_prefix (m_hex : string) :=
  BinaryString.of_N (HexString.to_N ("0x" ++ m_hex)).

Definition remove_prefix (s : string) (pre_len : nat) : string :=
  substring pre_len (String.length s) s.

Definition hex2bin (m_hex : string) :=
  remove_prefix (hex2bin_with_prefix m_hex) 2.

Definition biNtohex (m_bin : string) :=
  remove_prefix (HexString.of_N (BinaryString.to_N ("0b" ++ m_bin))) 2.
*)
(* duplicate implementation
Fixpoint biNtobL_tail (m_bin : string)(acc : bL) : bL :=
  match m_bin with
  | "" => acc
  | String h m_bin' => biNtobL_tail m_bin' ((Ascii.eqb h "1") :: acc)
  end.

Definition biNtobL (m_bin : string) : bL :=
  List.rev (biNtobL_tail m_bin []).

Fixpoint bLtobin_tail (m : bL)(acc : string) : string :=
  match m with
  | [] => acc
  | true :: tl => bLtobin_tail tl (String.append acc "1")
  | false :: tl => bLtobin_tail tl (String.append acc "0")
  end.

Definition bLtobin (m : bL) : string :=
  (bLtobin_tail m "").

*)
Definition pre_pad_0 (s : string)(mod_size : N) : string :=
  Z.iter (Z.modulo (Z.opp (Z.of_nat (String.length s)))
   (Z.of_N mod_size)) (append "0") s.

Definition SM3_Hash_hex (m_hex : string) :=
  SM3_HashN (bStobL (pre_pad_0 (hStobS m_hex) 4)).

(*
Definition exp_m := "616263".
Definition exp_padded := bStohS (bLtobS (Padding (bStobL(hStobS exp_m)) (6 * 4))).

Definition B0 := (Block 0 (bStobL (hStobS exp_m)) (6 * 4)).

(*
Compute HexString.of_N B0.
Compute HexString.of_N (W 67 B0).  (* Correct. *)
Compute HexString.of_N (W 0  B0).  (* Correct. *)
Compute HexString.of_N (W 15  B0).  (* Correct. *)
Compute HexString.of_N (W 14  B0).  (* Correct. *)
Compute HexString.of_N (W' 63 B0). (* Correct. *)
Compute HexString.of_N (W' 1 B0). (* Correct. *)
Compute hStobS exp_m.
Compute n_of_B 24.
Compute HexString.of_N (V 1 (bStobL "011000010110001001100011") 24).

Compute HexString.of_N IV.
Compute HexString.of_N (Reg 0 IV B0).
Compute HexString.of_N (Reg 1 IV B0). (*Correct*)
Compute HexString.of_N (Reg 64 IV B0). (*Correct*)
Compute HexString.of_N ((Reg 64 IV B0) $ IV). (*Correct*)

(* "0x66c7f0f462eeedd9d1f2d46bdc10e4e24167c4875cf2f7a2297da02b8f4ba8e0" *)

Compute HexString.of_N (SM3_HashN (bStobL "011000010110001001100011")). (* Correct *)
Compute HexString.of_N (SM3_Hash_hex exp_m). (* Correct *)

Definition exp_m2 := "61626364616263646162636461626364616263646162636461626364616263646162636461626364616263646162636461626364616263646162636461626364".
(*debe9ff9 2275b8a1 38604889 c18e5a4d 6fdb70e5 387e5765 293dcba3 9c0c5732*)
Compute HexString.of_N (SM3_Hash_hex exp_m2). (* Correct *)
*)
*)


(* =================================================================================== *)
(** * Σ-equations and their models

- Definition of an equation [equation]
- The satisfyability predicate for 1-model [satisfies_equation]
- Definition of 2-model [model_equations]
- Precategory of 2-model [category_model_equations]
- Forgetful functor from 2-models to 1-models [ModEq_Mod_functor]
- A 1-signature morphism : S1 -> S2 induce a map between equations on S1 and equations
   on S2

*)
(* =================================================================================== *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import Modules.Signatures.Signature.
Require Import Modules.Signatures.ModelCat.
Require Import Modules.SoftEquations.SignatureOver.

(** Notation for 1-model morphisms *)
Local Notation  "R →→ S" := (rep_fiber_mor R S) (at level 6).

Section Equation.
  (** We fix a 1-signature [Sig] in a category [C] *)
  Context  {C : category} {Sig : signature C}.
  Local Notation REP := (model Sig).

  (** A half-equation between [S1] and [S2] is just a Sig-module morphism between them *)
  Definition half_equation (S1 S2 : signature_over Sig) := signature_over_Mor Sig S1 S2.
  Identity Coercion half_equation_to_sig_mor : half_equation >-> signature_over_Mor.

  (** An equation is given by a pair of Sig-modules and a pair of half-equations between them *)
  Definition equation :=
    ∑ (S1 S2 : signature_over Sig), half_equation S1 S2 × half_equation S1 S2 .

  (** The Sig-module source of an equation *)
  Definition source_equation (e : equation) : signature_over Sig :=
    pr1 e.
  Local Notation σ := source_equation.

  (** The Sig-module target of an equation *)
  Definition target_equation (e : equation) : signature_over Sig :=
    pr1 (pr2 e).
  Local Notation τ := target_equation.

  (** The first half-equation of an equation *)
  Definition halfeq1 (e : equation) : half_equation (source_equation e) (target_equation e) :=
    pr1 (pr2 (pr2 e)).

  (** The second half-equation of an equation *)
  Definition halfeq2 (e : equation) : half_equation (source_equation e) (target_equation e) :=
    pr2 (pr2 (pr2 e)).

  (** The proposition stating that a 1-model [R] satisfies the equation: the R-component of
      both half-equations must be equal *)
  Definition satisfies_equation (e : equation) (R : REP)  : UU := halfeq1 e R = halfeq2 e R.

  (** This statment is hProp *)
  Definition satisfies_equation_isaprop (e : equation) (R : REP)  :
     isaprop (satisfies_equation e R) :=
    homset_property (category_LModule  _ _ ) _ _ _ _.

  Definition satisfies_equation_hp (e : equation) (R : REP) : hProp  :=
    make_hProp _ (satisfies_equation_isaprop e R).

  (** The proposition that a 1-model satisfies a family of equations: it must satisfy
      each of them *)
  Definition satisfies_all_equations_hp {O} (e : O -> equation) R :=
    forall_hProp (fun o => satisfies_equation_hp (e o) R).

  (** Definition of a 2-model: an 1-model [R] satisfying the family of equations [e] *)
  Definition model_equations {O : UU} (e : O -> equation) : UU :=
    ∑ (R : REP), ∏ x, satisfies_equation (e x)  R.

  (** The underlying 1-model of a 2-model *)
  Coercion model_equations_to_model {O e } (R : model_equations (O := O) e ) : REP := pr1 R.

  (** a 2-model satisfies the associated family of equations *)
  Definition model_equations_eq {O} {e : O -> equation} (R : model_equations e) :
    satisfies_all_equations_hp e  R := pr2 R.

  (** The category of 2-model as the full subcategory of 1-models satisfying the required family of equations *)
  Definition category_model_equations {O} (e : O -> equation) : precategory :=
    subcategory _ (full_sub_precategory (C := rep_fiber_category Sig)
                         (satisfies_all_equations_hp e)).

  (** Forgetful functor from 2-models (of a fixed 2-signature) to 1-models *)
  Definition ModEq_Mod_functor {O} (e : O -> equation) :
    functor (category_model_equations e) (rep_fiber_category Sig) :=
    sub_precategory_inclusion _ _.

  Definition ModEq_Mod_fully_faithful {O} (e : O -> equation) :
    fully_faithful (ModEq_Mod_functor e) :=
    fully_faithful_sub_precategory_inclusion _ _.

End Equation.

Arguments equation [_] _.

Definition po_equation
           {C : category} {S1 S2 : signature C} (f : signature_Mor S1 S2)
           (e : equation S1)
  : equation S2 :=
  po_signature_over f (source_equation e)  ,,
                    po_signature_over f (target_equation e)  ,,
                    po_signature_over_mor f (halfeq1 e)  ,,
                    po_signature_over_mor f (halfeq2 e).

Definition po_satisfies_equation
           {C : category} {S1 S2 : signature C} (f : signature_Mor S1 S2)
           (e : equation S1)
           (R : model _)
           (hR : satisfies_equation (po_equation f e) R) :
  satisfies_equation e (pb_rep f R) := hR.


Require Import init.

Require Import well_order.
Require Import card_base.
Require Import set.
Require Import function.
Require Export ord_basic.
Require Import nat.

Unset Keyed Unification.

(* begin hide *)
Open Scope card_scope.

Section CardOrder.

Local Open Scope card_scope.

Let card_le A B := ∃ f : A → B, Injective f.
Local Infix "≦" := card_le.

Lemma card_le_wd_one : ∀ A B C D, A ~ B → C ~ D → A ≦ C → B ≦ D.
Proof.
    intros A B C D [f f_bij] [g g_bij] [h h_inj].
    pose (f' := bij_inv f).
    exists (λ x, g (h (f' x))).
    split.
    intros a b eq.
    apply g_bij in eq.
    apply h_inj in eq.
    apply (bij_inv_bij f) in eq.
    exact eq.
Qed.

Lemma card_le_wd : ∀ A B C D, A ~ B → C ~ D → (A ≦ C) = (B ≦ D).
Proof.
    intros A B C D AB CD.
    apply propositional_ext.
    split.
    -   apply card_le_wd_one; assumption.
    -   pose proof (eq_symmetric card_equiv) as sym.
        apply card_le_wd_one; apply sym; assumption.
Qed.

End CardOrder.

Global Instance card_order : Order card := {
    le := binary_op card_le_wd;
}.
(* end hide *)
Theorem card_to_initial_ord_lte :
    ∀ κ μ, card_to_initial_ord κ < card_to_initial_ord μ → κ ≤ μ.
Proof.
    intros κ μ lt.
    remember (card_to_initial_ord κ) as α.
    apply (f_equal ord_to_card) in Heqα.
    rewrite card_to_initial_ord_to_card_eq in Heqα.
    remember (card_to_initial_ord μ) as β.
    apply (f_equal ord_to_card) in Heqβ.
    rewrite card_to_initial_ord_to_card_eq in Heqβ.
    unfold ord_to_card in *.
    equiv_get_value α β.
    equiv_simpl in Heqα.
    equiv_simpl in Heqβ.
    rewrite ord_lt_initial in lt.
    destruct lt as [x [f [f_bij f_iso]]].
    equiv_get_value κ μ.
    unfold le; equiv_simpl.
    exists (λ a, [f a|]).
    split.
    intros a b eq.
    apply f_bij.
    apply set_type_eq.
    exact eq.
Qed.

(* begin hide *)
Lemma card_le_connex : ∀ κ μ, {κ ≤ μ} + {μ ≤ κ}.
Proof.
    intros A B.
    classic_case (A = B) as [eq|neq].
    {
        subst.
        left.
        equiv_get_value B.
        unfold le; equiv_simpl.
        exists identity.
        apply identity_bijective.
    }
    apply or_to_strong.
    pose (α := card_to_initial_ord A).
    pose (β := card_to_initial_ord B).
    pose proof (trichotomy α β) as [[leq|eq]|leq].
    -   left.
        apply card_to_initial_ord_lte.
        exact leq.
    -   apply card_to_initial_ord_eq in eq.
        contradiction.
    -   right.
        apply card_to_initial_ord_lte.
        exact leq.
Qed.
Global Instance card_le_connex_class : Connex le := {
    connex := card_le_connex
}.

Lemma card_le_transitive : ∀ κ μ ν, κ ≤ μ → μ ≤ ν → κ ≤ ν.
Proof.
    intros A B C AB BC.
    equiv_get_value A B C.
    unfold le in *.
    equiv_simpl.
    equiv_simpl in AB.
    equiv_simpl in BC.
    destruct AB as [f f_bij].
    destruct BC as [g g_bij].
    exists (λ x, g (f x)).
    apply inj_comp; assumption.
Qed.
Global Instance card_le_trans_class : Transitive le := {
    trans := card_le_transitive
}.

Lemma card_le_antisymmetric : ∀ κ μ, κ ≤ μ → μ ≤ κ → κ = μ.
Proof.
    intros A B AB BC.
    equiv_get_value A B.
    unfold le in AB, BC.
    equiv_simpl in AB.
    equiv_simpl in BC.
    equiv_simpl.
    destruct AB as [f f_inj], BC as [g g_inj].
    pose (lonely b := ∀ a, f a ≠ b).
    pose (descendent_of b1 b0 := ∃ n, b1 = iterate_func (λ x, f (g x)) n b0).
    assert (∀ a, (∃ b, lonely b ∧ descendent_of (f a) b) → ∃ b, g b = a) as h_ex.
    {
        intros a [b [b_lonely [n descendent]]].
        destruct n; simpl in descendent.
        -   specialize (b_lonely a).
            contradiction.
        -   apply f_inj in descendent.
            exists (iterate_func (λ x, f (g x)) n b).
            symmetry; exact descendent.
    }
    pose (h a :=
        match (sem (∃ b, lonely b ∧ descendent_of (f a) b)) with
        |   strong_or_left H => ex_val (h_ex a H)
        |   strong_or_right _ => f a
        end
    ).
    exists h.
    split; split.
    -   assert (∀ (a1 a2 : A) (P : (∃ b, lonely b ∧ descendent_of (f a1) b)),
                                  ¬(∃ b, lonely b ∧ descendent_of (f a2) b) →
                                    ex_val (h_ex a1 P) = f a2 → a1 = a2) as wlog.
        {
            clear - f_inj g_inj.
            intros a1 a2 a1_eq a2_eq.
            destruct a1_eq as [lb1 [lb1_lonely lb1_descendent]].
            rewrite_ex_val b1 b1_eq.
            intro a_eq.
            subst.
            rewrite not_ex in a2_eq.
            specialize (a2_eq lb1).
            rewrite not_and in a2_eq.
            destruct a2_eq as [a2_eq|a2_eq]; try contradiction.
            destruct lb1_descendent as [n eq].
            destruct n.
            -   simpl in eq.
                specialize (lb1_lonely (g (f a2))).
                contradiction.
            -   unfold descendent_of in a2_eq.
                rewrite not_ex in a2_eq.
                specialize (a2_eq n).
                simpl in eq.
                apply f_inj in eq.
                apply g_inj in eq.
                contradiction.
        }
        intros a1 a2 a_eq.
        unfold h in a_eq.
        classic_case (∃ b, lonely b ∧ descendent_of (f a1) b) as [a1_eq|a1_eq];
        classic_case (∃ b, lonely b ∧ descendent_of (f a2) b) as [a2_eq|a2_eq].
        +   destruct a1_eq as [lb1 [lb1_lonely lb1_descendent]].
            destruct a2_eq as [lb2 [lb2_lonely lb2_descendent]].
            revert a_eq.
            rewrite_ex_val b1 b1_eq.
            rewrite_ex_val b2 b2_eq.
            intro a_eq.
            subst.
            reflexivity.
        +   exact (wlog a1 a2 a1_eq a2_eq a_eq).
        +   symmetry; symmetry in a_eq; exact (wlog a2 a1 a2_eq a1_eq a_eq).
        +   apply f_inj.
            exact a_eq.
    -   intros b.
        unfold h.
        classic_case (∃ bl, lonely bl ∧ descendent_of b bl) as [b_eq|b_eq].
        +   destruct b_eq as [bl [bl_lonely [n bl_descendent]]].
            exists (g b).
            classic_case (∃ b', lonely b' ∧ descendent_of (f (g b)) b') as [b_eq|b_eq].
            *   rewrite_ex_val b' b'_eq.
                apply g_inj.
                exact b'_eq.
            *   rewrite not_ex in b_eq.
                specialize (b_eq bl).
                rewrite not_and_impl in b_eq.
                specialize (b_eq bl_lonely).
                unfold descendent_of in b_eq.
                rewrite bl_descendent in b_eq.
                rewrite not_ex in b_eq.
                specialize (b_eq (nat_suc n)).
                simpl in b_eq.
                contradiction.
        +   pose proof b_eq as b_eq2.
            rewrite not_ex in b_eq2.
            specialize (b_eq2 b).
            rewrite not_and in b_eq2.
            destruct b_eq2 as [b_eq2|b_eq2].
            *   unfold lonely in b_eq2.
                rewrite not_all in b_eq2.
                destruct b_eq2 as [a b_eq2].
                rewrite not_not in b_eq2.
                exists a.
                rewrite <- b_eq2 in b_eq.
                classic_case (∃ bl, lonely bl ∧ descendent_of (f a) bl); auto.
                contradiction.
            *   unfold descendent_of in b_eq2.
                rewrite not_ex in b_eq2.
                specialize (b_eq2 zero).
                contradiction b_eq2; reflexivity.
Qed.
Global Instance card_le_antisym_class : Antisymmetric le := {
    antisym := card_le_antisymmetric
}.
(* end hide *)
Theorem ord_to_card_lt : ∀ α β, ord_to_card α < ord_to_card β → α < β.
Proof.
    intros α β leq.
    classic_contradiction contr.
    rewrite nlt_le in contr.
    rewrite ord_le_lt in contr.
    destruct contr as [contr|contr].
    -   subst.
        destruct leq; contradiction.
    -   destruct leq as [leq neq].
        assert (ord_to_card β ≤ ord_to_card α) as leq2.
        {
            clear leq neq.
            rename α into A.
            rename β into B.
            equiv_get_value A B.
            rewrite ord_lt_initial in contr.
            unfold le, ord_to_card; equiv_simpl.
            destruct contr as [x [f [f_bij f_iso]]]; clear f_iso.
            exists (λ x, [f x|]).
            split.
            intros a b eq.
            apply f_bij.
            apply set_type_eq.
            exact eq.
        }
        pose proof (antisym leq leq2).
        contradiction.
Qed.

(* begin hide *)
Lemma card_le_wo : ∀ S : card → Prop, (∃ κ, S κ) → ∃ κ, is_least le S κ.
Proof.
    intros S S_ex.
    pose (f (κ : set_type S) := card_to_initial_ord [κ|]).
    pose (S' α := ∃ κ, f κ = α).
    assert (∃ x, S' x) as S'_ex.
    {
        destruct S_ex as [κ Sκ].
        exists (card_to_initial_ord κ).
        unfold S'.
        exists [κ|Sκ].
        unfold f; cbn.
        reflexivity.
    }
    pose proof (well_ordered S' S'_ex) as [α [[[κ Sκ] κ_eq] α_min]].
    unfold f in κ_eq; cbn in κ_eq.
    exists κ.
    split; try exact Sκ.
    intros μ Sμ.
    classic_contradiction leq.
    rewrite nle_lt in leq.
    rewrite <- card_to_initial_ord_to_card_eq in leq.
    rewrite <- (card_to_initial_ord_to_card_eq μ) in leq.
    apply ord_to_card_lt in leq.
    rewrite κ_eq in leq.
    assert (S' (card_to_initial_ord μ)) as S'μ by (exists [μ|Sμ]; reflexivity).
    specialize (α_min _ S'μ).
    destruct (le_lt_trans α_min leq); contradiction.
Qed.
Global Instance card_le_wo_class : WellOrdered le := {
    well_ordered := card_le_wo
}.
(* end hide *)
Theorem card_le_sub : ∀ κ A, κ ≤ |A| → ∃ S : A → Prop, |set_type S| = κ.
Proof.
    intros B A leq.
    equiv_get_value B.
    unfold le in leq; equiv_simpl in leq.
    destruct leq as [f f_inj].
    exists (λ y, ∃ x, f x = y).
    equiv_simpl.
    exists (λ (y : set_type (λ y, ∃ x, f x = y)), ex_val [|y]).
    split; split.
    -   intros [a a_ex] [b b_ex] eq; cbn in *.
        apply set_type_eq; cbn.
        rewrite <- (ex_proof a_ex).
        rewrite <- (ex_proof b_ex).
        unfold ex_val in eq.
        rewrite eq.
        reflexivity.
    -   intros y.
        assert (∃ x, f x = f y) by (exists y; reflexivity).
        exists [f y|H].
        cbn.
        apply f_inj.
        rewrite <- (ex_proof H).
        reflexivity.
Qed.

Theorem card_sub_le : ∀ (A : Type) (S : A → Prop), |set_type S| ≤ |A|.
Proof.
    intros A S.
    unfold le; equiv_simpl.
    exists (λ x, [x|]).
    split.
    intros a b eq.
    apply set_type_eq.
    exact eq.
Qed.

(* begin hide *)
Open Scope set_scope.
(* end hide *)
Theorem card_minus_le {U} : ∀ (A B : U → Prop),
    |set_type (A - B)| ≤ |set_type A|.
Proof.
    intros A B.
    unfold le; equiv_simpl.
    exists (λ x, [[x|]|land [|x]]).
    split.
    intros a b eq.
    inversion eq as [eq2].
    apply set_type_eq.
    exact eq2.
Qed.

Theorem image_under_le {U V} : ∀ (A : U → Prop) (f : U → V),
    |set_type (image_under f A)| ≤ |set_type A|.
Proof.
    intros A f.
    unfold le; equiv_simpl.
    exists (λ x, [ex_val [|x] | land (ex_proof [|x])]).
    split.
    intros a b eq.
    inversion eq as [eq2]; clear eq.
    rewrite_ex_val x xH.
    rewrite_ex_val y yH.
    destruct xH as [Ax a_eq], yH as [Ay b_eq].
    subst.
    apply set_type_eq.
    rewrite a_eq, b_eq.
    reflexivity.
Qed.

Theorem card_lt_ex : ∀ U V, |U| < |V| → ∀ f : U → V, ∃ y, ∀ x, f x ≠ y.
Proof.
    intros U V ltq f.
    classic_contradiction f_sur.
    rewrite <- nle_lt in ltq.
    apply ltq.
    unfold le; equiv_simpl.
    apply (partition_principle f).
    split.
    intros y.
    rewrite not_ex in f_sur.
    specialize (f_sur y).
    rewrite not_all in f_sur.
    destruct f_sur as [x eq].
    rewrite not_not in eq.
    exists x.
    exact eq.
Qed.
(* begin hide *)
Close Scope set_scope.
Close Scope card_scope.
(* end hide *)


Require Import VCF.Sem.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import VCF.BinRelDomain.
Require Import VCF.Coqlib.
Require Import VCF.KnasterTarski.
Require Import ZArith.
Require Import List.

Local Open Scope Z.

Definition var: Type := nat.

Inductive unop: Type :=
  | BNot.

Inductive binop: Type :=
  | APlus
  | AMinus
  | AMult
  | BEq
  | BLe
  | BAnd.

Inductive com : Type :=
  | CSkip
  | CAssConst (X: var) (n : Z)
  | CAssVar (X: var) (Y : var)
  | CAssUnop (X: var) (op: unop) (Y : var)
  | CAssBinop (X: var) (op: binop) (Y : var) (Z : var)
  | CSeq (c1 c2 : com)
  | CIf (X : var) (c1 c2 : com)
  | CWhile (X : var) (c : com).

Definition unop_sem (op: unop): Z -> Z :=
  match op with
  | BNot => fun x => if Z.eqb x 0 then 1 else 0
  end.

Definition binop_sem (op: binop): Z -> Z -> Z :=
  match op with
  | APlus => Z.add
  | AMinus => Z.sub
  | AMult => Z.mul
  | BEq => fun x y => if Z.eqb x y then 1 else 0
  | BLe => fun x y => if Z.leb x y then 1 else 0
  | BAnd => fun x y => if andb (Z.eqb x 1) (Z.eqb y 1) then 1 else 0
  end.

Definition state := var -> Z.

Definition var_true_sets (X: var) : state -> Prop :=
  fun st => st X <> 0.

Definition if_sem
  (cond: state -> Prop)
  (then_branch else_branch: state -> state -> Prop)
  : state -> state -> Prop
:=
  Sets.union
    (Rel.concat (Rel.test cond) then_branch)
    (Rel.concat (Rel.test (Sets.complement cond)) else_branch).

Definition loop_sem_CL:
  @CompleteLattice_Setoid
    (state -> state -> Prop)
    Sets.included
    Sets.equiv
    Sets.omega_union
:= SETS_included_CL.

Local Existing Instance loop_sem_CL.

Definition loop_sem (cond: state -> Prop) (loop_body: state -> state -> Prop):
  state -> state -> Prop :=
  KT_fix_l
    (fun sem =>
       Sets.union
         (Rel.concat
           (Rel.test cond)
           (Rel.concat loop_body sem))
         (Rel.test (Sets.complement cond))).

Fixpoint ceval (c: com): state -> state -> Prop :=
  match c with
  | CSkip => Rel.id
  | CAssConst X n =>
      fun st1 st2 =>
        st2 X = n /\
        forall V, X <> V -> st1 V = st2 V
  | CAssVar X Y =>
      fun st1 st2 =>
        st2 X = st1 Y /\
        forall V, X <> V -> st1 V = st2 V
  | CAssUnop X op Y =>
      fun st1 st2 =>
        st2 X = unop_sem op (st1 Y) /\
        forall V, X <> V -> st1 V = st2 V
  | CAssBinop X op Y Z =>
      fun st1 st2 =>
        st2 X = binop_sem op (st1 Y) (st1 Z) /\
        forall V, X <> V -> st1 V = st2 V
  | CSeq c1 c2 => Rel.concat (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem (var_true_sets b) (ceval c1) (ceval c2)
  | CWhile b c => loop_sem (var_true_sets b) (ceval c)
  end.

Lemma ceval_fold_right_CSeq: forall cs c,
  ceval (fold_right CSeq c cs) = fold_right Rel.concat (ceval c) (map ceval cs).
Proof.
  intros.
  apply fold_right_map.
  intros.
  simpl.
  auto.
Qed.

Lemma ceval_fold_left_CSeq: forall cs c,
  ceval (fold_left CSeq cs c) = fold_left Rel.concat (map ceval cs) (ceval c).
Proof.
  intros.
  apply fold_left_map.
  intros.
  simpl.
  auto.
Qed.


Require Export projective_plane_axioms.

(** Fano's plane **)
(** also known as PG(2,2). **)

(** To show that our axiom system is consistent we build a finite model. **)

Module FanoPlane : ProjectivePlane.

(** We define point and line by an inductive type representing the seven possibilities. **)
(** We can not use directly the inductive type for
  a technical reason related to Coq's implementation. **)

Inductive ind_Point : Set := A | B | C | D | E | F | G.
Inductive ind_line    : Set := ABF | BCD | CAE | ADG | BEG | CFG | DEF.

Definition Point : Set := ind_Point.
Definition Line    : Set := ind_line.

Definition Incid_bool : Point -> Line -> bool := fun P L =>
 match (P,L) with
 (A,ABF) | (A,CAE) | (A,ADG) | (B, BCD) | (B, BEG) | (B, ABF)
|(C,BCD) | (C,CAE) | (C,CFG) | (D,BCD) | (D,ADG) | (D,DEF)
|(E,CAE) | (E,BEG) | (E,DEF) | (F,ABF) | (F,DEF) | (F,CFG)
|(G,ADG) | (G,CFG) | (G,BEG)  => true
| _ => false
end.

Definition Incid : Point -> Line -> Prop := fun P L =>
 (Incid_bool P L =true).

Hint Unfold Incid Incid_bool.

Lemma incid_dec : forall (A:Point)(l:Line), {Incid A l} + {~Incid A l}.
Proof.
intros.
unfold Incid.
elim l;elim A0;unfold Incid_bool;simpl;auto;right;discriminate.
Qed.

(** A1 : any two points lie on a unique line **)

Ltac solve_ex L := solve [exists L;auto].

Lemma a1_exist : forall ( A B :Point) ,{l:Line | Incid A l /\ Incid B l}.
Proof with auto.
intros.
elim A0;elim B0;
(** A tactic which tries all possible lines **)
first [solve_ex ABF
     |  solve_ex BCD
     |  solve_ex CAE
     |  solve_ex ADG
     |  solve_ex BEG
     |  solve_ex CFG
     |  solve_ex DEF
 ].
Qed.

Lemma degen_point: forall A:Point, forall P: Prop, A<>A -> P.
Proof.
intuition.
Qed.

Lemma degen_line: forall A:Line, forall P: Prop, A<>A -> P.
Proof.
intuition.
Qed.

Ltac remove_degen := match goal with
| H: ?A <> ?A |- ?G => apply (degen_point A G H) || apply (degen_line A G H)
end.

Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
  ~A=B -> Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> l1=l2.
Proof.
intros X Y l1 l2 HXY H1 H2 H3 H4.
induction X;induction Y; try remove_degen;
induction l1;try discriminate; induction l2; discriminate || reflexivity.
Qed.

(** A2 : any two lines meet in a unique point **)
Lemma a2_exist : forall (l1 l2:Line), {A:Point | Incid A l1 /\ Incid A l2}.
Proof.
intros.
induction l1;induction l2;
(** A tactic which tries all possible points **)
first [solve_ex A
     |  solve_ex B
     |  solve_ex C
     |  solve_ex D
     |  solve_ex E
     |  solve_ex F
     |  solve_ex G
 ].
Qed.

Lemma a2_unique : forall(l1 l2 :Line)(A B :Point),
  ~l1=l2 -> Incid A l1 -> Incid A l2 -> Incid B l1 -> Incid B l2 -> A=B.
Proof.
intros l1 l2 X Y H H1 H2 H3 H4.
 induction X;induction Y;try reflexivity;
 induction l1;try discriminate;
 induction l2;try discriminate;try remove_degen.
Qed.

Lemma uniqueness : forall A B :Point, forall l m : Line,
 Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A=B\/l=m.
intros P Q l m H1 H2 H3 H4.
 induction P; induction Q; try ((left;reflexivity) || (right;reflexivity));
 induction l; try discriminate;
 induction m; try discriminate; try (left; reflexivity) ; try (right; reflexivity); try remove_degen.
Qed.

(** A3 : there exist four points with no three collinear **)
Lemma a3: {A:Point & {B :Point & {C:Point & {D :Point |
  (forall l :Line, dist4 A B C D/\
    (Incid A l /\ Incid B l -> ~Incid C l /\ ~Incid D l)
    /\ (Incid A l /\ Incid C l -> ~Incid B l /\ ~Incid D l)
    /\  (Incid A l /\ Incid D l -> ~Incid C l /\ ~Incid B l)
    /\  (Incid C l /\ Incid B l -> ~Incid A l /\ ~Incid D l)
    /\ (Incid D l /\ Incid B l -> ~Incid C l /\ ~Incid A l)
    /\  (Incid C l /\ Incid D l -> ~Incid B l /\ ~Incid A l))}}}}.
Proof.
exists A.
exists B.
exists C.
exists G.
intros.
split.
unfold dist4;intuition;discriminate.
elim l;unfold Incid, Incid_bool;intuition;discriminate.
Qed.

End FanoPlane.


Require Import Arith ZArith ZArith ZifyClasses ZifyInst Lia.
From Coq.ssr Require Import ssreflect.
From stdpp Require Import base gmap fin_sets.

(* For the [lia] tactic to support [Nat.div]. *)
Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations.
Program Instance Op_Nat_div : BinOp Nat.div :=
  {| TBOp := Z.div ; TBOpInj := Nat2Z_inj_div |}.
Add Zify BinOp Op_Nat_div.

Record Quorum `{Countable A} (X : gset A) := quorum {
  quorum_car :> gset A → Prop;
  quorum_subseteq Q : quorum_car Q → Q ⊆ X;
  quorum_intersection_nonempty Q1 Q2 :
    quorum_car Q1 → quorum_car Q2 → Q1 ∩ Q2 ≠ ∅;
}.
Arguments quorum {_ _ _}.
Arguments quorum_car : simpl never.
Arguments quorum_subseteq {_ _ _ _}.
Arguments quorum_intersection_nonempty {_ _ _ _}.

Lemma quorum_choose `{Countable A, QuorumX : Quorum X} (Q1 Q2 : gset A) :
  QuorumX Q1 → QuorumX Q2 → ∃ a, a ∈ Q1 ∩ Q2.
Proof.
  intros ??. by eapply set_choose_L, quorum_intersection_nonempty.
Qed.

Program Definition Quorum_majority `{Countable A} (X : gset A) : Quorum X :=
  quorum _ (λ Q, size X / 2 < size Q ∧ Q ⊆ X) _ _.
Next Obligation. by destruct 1. Qed.
Next Obligation.
  intros ?????? [? ?] [? ?] ?.
  assert (size Q1 + size Q2 ≤ size X).
  { rewrite -size_union; [set_solver|].
    by apply subseteq_size, union_subseteq. }
  lia.
Qed.


From mathcomp Require Import ssreflect.
From stdpp Require Import fin_collections listset_nodup.

Lemma from_option_inv_ne {A B : Type} (f : A -> B) b a opt :
  from_option f b opt = a -> a ≠ b -> is_Some opt.
Proof.
  case opt.
  eauto. intros <-. contradiction.
Qed.

Lemma collection_fold_union_singleton `{FinCollection A C} {B} f (b : B) (x : A) (X : C)
      `{!Equivalence R} `{!Proper ((=) ==> R ==> R) f} :
  (∀ a1 a2 b, R (f a1 (f a2 b)) (f a2 (f a1 b))) ->
  x ∉ X ->
  R (collection_fold f b ({[x]} ∪ X)) (f x (collection_fold f b X)).
Proof.
  assert (HProper: Proper (eq ==> R ==> R) f) ; first assumption.
  intros Hf ?.
  rewrite /collection_fold /=.
  assert (Proper ((≡ₚ) ==> R) (foldr f b)).
  { intro. apply foldr_permutation. typeclasses eauto. intro. by apply HProper. assumption. }
  rewrite elements_union_singleton /=; last assumption. reflexivity.
Qed.

Lemma collection_fold_domains `{FinCollection A C} {B} (b : B) X f g `{!Equivalence R}
      `{!Proper ((=) ==> R ==> R) f} `{!Proper ((=) ==> R ==> R) g}:
  (∀ a1 a2 b, R (f a1 (f a2 b)) (f a2 (f a1 b))) ->
  (∀ a1 a2 b, R (g a1 (g a2 b)) (g a2 (g a1 b))) ->
  (forall a b1 b2, R b1 b2 -> a ∈ X -> R (f a b1) (g a b2)) ->
  R (collection_fold f b X) (collection_fold g b X).
Proof.
  intros.
  apply (collection_ind
           (fun X => (forall a b1 b2, R b1 b2 -> a ∈ X -> R (f a b1) (g a b2)) ->
                     R (collection_fold f b X) (collection_fold g b X))) ; last assumption.
  {
    intros ?? Heq. rewrite (collection_fold_proper _ _ _ _ _ _ Heq).
    rewrite (collection_fold_proper _ _ _ _ _ _ Heq).
      split ; intros Hyp ? ; apply Hyp ; intros ???? ; [rewrite Heq |rewrite -Heq] ; eauto.
      all : assumption.
  }
  - intros. by rewrite /collection_fold /= elements_empty.
  - intros ??? IH Hfg.
    rewrite collection_fold_union_singleton ; [|assumption..].
    rewrite collection_fold_union_singleton ; [|assumption..].
    apply Hfg. apply IH. intros. apply Hfg. assumption. all: set_solver.
Qed.

Definition collection_sum_with `{Elements A C} (f : A -> nat) : C -> nat :=
  collection_fold (fun a n => n + f a) 0.

Instance collection_sum_with_proper `{FinCollection A C} (f : A -> nat) : Proper ((≡) ==> (=)) (collection_sum_with f : C -> nat).
Proof.
  unfold collection_sum_with.
  apply (collection_fold_proper).
  apply eq_equivalence.
  solve_proper.
  intros. lia.
 Qed.

Lemma collection_sum_with_empty `{FinCollection A C} f :
  collection_sum_with f ∅ = 0.
Proof.
  unfold collection_sum_with, collection_fold. simpl.
  rewrite elements_empty. done.
Qed.

Lemma collection_sum_with_singleton_union `{FinCollection A C} x D f :
  x ∉ D ->
  collection_sum_with f ({[x]} ∪ D) = f x + collection_sum_with f D.
Proof.
  rewrite /collection_sum_with plus_comm.
  apply (collection_fold_union_singleton (fun a n => n + f a)) ; [typeclasses eauto..|intros;lia].
Qed.

Lemma collection_sum_with_subseteq_le `{FinCollection A C} `{forall x D, Decision (x ∈ D)} (D1 D2 : C) f :
  D1 ⊆ D2 ->
  collection_sum_with f D1 ≤ collection_sum_with f D2.
Proof.
  apply (collection_ind
           (fun D1 => forall D2,
                D1 ⊆ D2 ->
                collection_sum_with f D1 ≤ collection_sum_with f D2)).
  { intros ? ? Heq. apply forall_proper. intros.
    rewrite subseteq_proper ; [|done..].
      by rewrite (collection_sum_with_proper f _ _ Heq ).
  }
  - clear D1 D2.
    intros D2 _. rewrite collection_sum_with_empty. lia.
  - clear D1 D2.
    intros x D1 Hx IH D2 Hsubset.
    rewrite (union_difference {[x]} D2) ; [|set_solver].
    rewrite collection_sum_with_singleton_union.
    rewrite collection_sum_with_singleton_union.
    assert (D1 ⊆ D2 ∖ {[x]}) as Hsubset'. set_solver.
    specialize (IH (D2 ∖ {[x]}) Hsubset').
    lia. set_solver. assumption.
Qed.

Lemma collection_sum_with_union `{FinCollection A C} `{forall x D, Decision (x ∈ D)} D1 D2 f :
  collection_sum_with f (D1 ∪ D2) =
  (collection_sum_with f D1 + collection_sum_with f D2) - collection_sum_with f (D1 ∩ D2).
Proof.
  apply (collection_ind (fun D => collection_sum_with f (D ∪ D2) =
                                  (collection_sum_with f D + collection_sum_with f D2) - collection_sum_with f (D ∩ D2))).
  {
    intros X Y ?. rewrite union_proper ; [|done..].
    rewrite intersection_proper ; [|done..].
      by rewrite (collection_sum_with_proper _ X Y).
  }
  - rewrite intersection_empty_l union_empty_l collection_sum_with_empty .
    lia.
  - intros x D HnIn IH.
    rewrite collection_sum_with_singleton_union ; [|assumption].

    destruct (decide (x ∈ D2)) as [HD2|HD2].
    + rewrite {1}[{[x]} ∪ D]union_comm -union_assoc (subseteq_union_1 {[x]} D2).
      rewrite intersection_union_r. rewrite (subseteq_intersection_1 {[x]} D2).
      rewrite collection_sum_with_singleton_union.
      rewrite IH. lia.
      rewrite not_elem_of_intersection. by left.
      apply elem_of_subseteq_singleton. assumption.
      apply elem_of_subseteq_singleton. assumption.
    + rewrite -union_assoc.
      rewrite collection_sum_with_singleton_union.
      rewrite intersection_union_r. rewrite (_:{[x]} ∩ D2 ≡ ∅).
      rewrite union_empty_l. rewrite IH.
      pose proof (collection_sum_with_subseteq_le (D ∩ D2) D f (intersection_subseteq_l _ _)).
      lia. set_solver. set_solver.
Qed.

Lemma collection_sum_with_domains `{FinCollection A C} D f g :
  (forall x, x ∈ D -> f x = g x) ->
  collection_sum_with f D = collection_sum_with g D.
Proof.
  intro. unfold collection_sum_with.
  apply collection_fold_domains ; [typeclasses eauto..| | |] ; [(intros ; lia)..|auto].
Qed.

Instance listset_nodup_dec_elem_of `{EqDecision A} x (C : listset_nodup A) : Decision (x ∈ C) :=
  elem_of_list_dec x (elements C).

Lemma f_neq {A B} (f : A -> B) x y :
 f x ≠ f y -> x ≠ y.
Proof. intros Hf ?. apply Hf. f_equal. assumption. Qed.

Lemma filter_app {A} (P : A -> Prop) `{∀ x, Decision (P x)} (l1 l2 : list A):
  filter P (l1 ++ l2) = filter P l1 ++ filter P l2.
Proof.
  induction l1. reflexivity.
  simpl. unfold filter, list_filter.
  case_decide. list_simplifier. by f_equal.
  done.
Qed.

Lemma sum_list_with_lookup `(f: A -> nat) l i x :
  (l !! i) = Some x ->
  f x ≤ sum_list_with f l.
Proof.
  revert i.
  induction l as [|x' l IH] ; [done|].
  intros [|i].
  - simpl.
    intro.
    simplify_eq.
    lia.
  - simpl.
    intro Hlookup.
    pose proof (IH _ Hlookup).
    lia.
Qed.

Lemma list_fmap_insert `(f: A -> B) (l : list A) i x :
  f <$> (<[i := x]> l) = <[i := f x]> (f <$> l).
Proof.
  revert i.
  induction l as [| y l' IH] ; [done|].
  intros [|i] ; [done|].
  csimpl.
  by rewrite IH.
Qed.

Ltac rename_last H' := match goal with [H : _ |- _] => rename H into H' end ; move H' at top.


From Coq Require Import ZArith.ZArith Strings.String.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype tuple.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.
Import Ascii.

Definition BITS n := n.-tuple bool.
Notation eta_expand x := (fst x, snd x).
Definition splitlsb {n} (p: BITS n.+1): BITS n*bool := (behead_tuple p, thead p).
Definition joinlsb {n} (pair: BITS n*bool) : BITS n.+1 := cons_tuple pair.2 pair.1.
Notation "'nilB'" := (nil_tuple _).
Coercion singleBit b : BITS 1 := joinlsb (nilB, b).

(* Extend by one bit at the most significant bit. Again, signExtend 1 n does not work
   because BITS (n+1) is not definitionally equal to BITS n.+1  *)
Fixpoint joinmsb {n} : bool * BITS n -> BITS n.+1 :=
  if n is _.+1
  then fun p => let (hibit, p) := p in
                let (p,b) := splitlsb p in joinlsb (joinmsb (hibit, p), b)
  else fun p => joinlsb (nilB, p.1).
Definition joinmsb0 {n} (p: BITS n) : BITS n.+1 := joinmsb (false,p).

(* Special case: split at the most significant bit.
   split 1 n doesn't work because it requires BITS (n+1) not BITS n.+1 *)
Fixpoint splitmsb {n} : BITS n.+1 -> bool * BITS n :=
  if n is _.+1
  then fun p => let (p,b) := splitlsb p in let (c,r) := splitmsb p in (c,joinlsb(r,b))
  else fun p => let (p,b) := splitlsb p in (b,p).
Arguments splitmsb : simpl never.

Definition dropmsb {n} (p: BITS n.+1) := (splitmsb p).2.

Definition fullAdder carry b1 b2 : bool * bool :=
    match carry, b1, b2 with
    | false, false, false => (false, false)
    | true, false, false | false, true, false | false, false, true => (false, true)
    | true, true, false | false, true, true | true, false, true => (true, false)
    | true, true, true => (true, true)
    end.

(* Add with carry, producing a word one bit larger than the inputs *)
Fixpoint adcBmain n carry : BITS n -> BITS n -> BITS n.+1 :=
  if n is _.+1 then
    fun p1 p2 => let (p1,b1) := eta_expand (splitlsb p1) in
                 let (p2,b2) := eta_expand (splitlsb p2) in
                 let (carry',b) := fullAdder carry b1 b2 in
                   joinlsb (adcBmain carry' p1 p2, b)
  else fun _ _ => singleBit carry.
Arguments adcBmain n carry a b : simpl never.

Definition adcB {n} carry (p1 p2: BITS n) := splitmsb (adcBmain carry p1 p2).

Fixpoint fromNat {n} m : BITS n :=
  if n is _.+1
  then joinlsb (fromNat m./2, odd m)
  else nilB.
Notation "# m" := (fromNat m) (at level 0).
Arguments fromNat n m : simpl never.

Definition toNat {n} (p: BITS n) := foldr (fun (b:bool) n => b + n.*2) 0 p.

Definition charToBit c : bool := ascii_dec c "1".

Fixpoint fromBin s : BITS (length s) :=
  if s is String c s
  then joinmsb (charToBit c, fromBin s) else #0.

Notation "#b y" := (fromBin y) (at level 0).

Check #0.
Check #b"0111".

Check adcBmain false.
Definition a1 := #b"111".
Definition a2 := #b"001".
Compute (toNat a1).
Compute (toNat a2).
Definition res := (adcBmain false a1 a2).
Compute (toNat res).
Compute (fst (splitmsb res)).
Compute (splitmsb res).
Example e1 : (adcBmain false #b"01" #b"01") = (fromNat 2).
Proof.
  simpl. unfold adcBmain. unfold fullAdder. simpl.
  unfold joinlsb. simpl. unfold cons_tuple. reflexivity.
Qed.

Inductive Reg : Set := r1 | r2 | r3 | r6 | r8.
Definition reg_dec : forall r r' : Reg, {r = r'} + {r <> r'}.
Proof. intros. decide equality. Defined.

Definition total_map (A : Type) := Reg -> A.
Definition t_empty {A : Type} (v : A) : total_map A := (fun _ => v).
Definition beq_reg x y :=
  if reg_dec x y then true else false.
Definition t_update {A : Type} (m : total_map A) (x : Reg) (v : A) :=
  fun x' => if (beq_reg x x') then v else m x'.
Theorem reg_dec_refl : forall x, true  = reg_dec x x.
Proof.
  intros x. induction x; reflexivity.
Qed.
Lemma t_update_eq : forall A (m : total_map A) x v,
  (t_update m x v) x = v.
Proof. intros. unfold t_update.
       unfold beq_reg.
       rewrite <- reg_dec_refl. reflexivity.
Qed.
Theorem beq_reg_true_iff : forall x y,
  beq_reg x y = true <-> x = y.
Proof.
  intros [] []; split; try reflexivity; try intro H; inversion H.
Qed.
Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - unfold not in H. exfalso. apply H. reflexivity. reflexivity.
Qed.
Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros b. split.
  - apply not_true_is_false.
  - intros H. rewrite H. intros H'. inversion H'.
Qed.
Theorem beq_reg_false_iff : forall x y,
    beq_reg x y = false <-> x <> y.
    intros x y. rewrite <- beq_reg_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.
Theorem t_update_neq : forall (X : Type) v x1 x2 (m : total_map X),
  x1 <> x2 -> (t_update m x1 v) x2 = m x2.
Proof.
  intros. unfold t_update.  apply beq_reg_false_iff in H.
  rewrite H. reflexivity.
Qed.

Definition reg_state := total_map (BITS 32).

Inductive ins : Type :=
| seq : ins -> ins -> ins
| add : Reg -> Reg -> Reg -> ins
| mov : Reg -> (BITS 32) -> ins.

Notation "i1 ;; i2" :=
  (seq i1 i2) (at level 80, right associativity).

Inductive armR : ins -> reg_state -> reg_state -> Prop :=
| ESeq : forall i1 i2 st st' st'',
    armR i1 st st' ->
    armR i2 st' st'' ->
    armR (i1 ;; i2) st st''
| EAdd : forall rd rn rop2 st,
    armR (add rd rn rop2) st (t_update st rd
                               (snd (splitmsb (adcBmain false (st rn) (st rop2)))))
| EMov : forall st reg cnst,
    armR (mov reg cnst) st (t_update st reg cnst).

(* ====================================================================== *)

Definition AddLoopArm : ins :=
  (mov r1 (fromNat 5)) ;;
  (mov r3 (fromNat 0)) ;;
  (mov r2 (fromNat 1)) ;;
  (add r6 r1 r2).

Lemma finalstate8: forall st st' : reg_state,
         (armR AddLoopArm st st') ->
         (toNat (st' r6)) = 6.
Proof.
  unfold AddLoopArm. intros. inversion H.
  inversion H5. inversion H11. inversion H14.
  inversion H2. inversion H8. subst.
  inversion H17. rewrite t_update_eq.
  rewrite t_update_neq. rewrite t_update_eq.
  rewrite t_update_neq. rewrite t_update_eq.

  reflexivity.

  inversion H. subst.
  inversion H5. subst. inversion H7. subst. inversion H9.
  subst. inversion H4. subst.


Require Export Setoid Coq.Classes.Morphisms.
Require Export Sets SetInterface SetConstructs SetProperties.
Require Import Util LengthEq EqDec Get AllInRel.
Require Import CSetNotation CSetTac CSetBasic CSetComputable ElemEq.

Set Implicit Arguments.

Notation "'list_union' L" := (fold_left union L ∅) (at level 40).

Lemma list_union_start {X} `{OrderedType X} (s: set X) L t
: s ⊆ t
  -> s ⊆ fold_left union L t.
Proof.
  intros. general induction L; simpl; eauto.
  eapply IHL; eauto. cset_tac; intuition.
Qed.

Lemma list_union_incl {X} `{OrderedType X} (L:list (set X)) (s s':set X)
  : (forall n t, get L n t -> t ⊆ s')
   -> s ⊆ s'
   -> fold_left union L s ⊆ s'.
Proof.
  intros. general induction L; simpl. eauto.
  assert (a ⊆ s'). eapply H0; eauto using get.
  eapply IHL; eauto. intros. rewrite H0; eauto using get.
  cset_tac; intuition.
Qed.

Lemma incl_list_union {X} `{OrderedType X} (s: set X) L n t u
: get L n t
  -> s ⊆ t
  -> s ⊆ fold_left union L u.
Proof.
  intros. general induction L.
  + simpl. inv H0; eauto.
    - eapply list_union_start; cset_tac; intuition.
Qed.

Lemma list_union_get {X} `{OrderedType X} L (x:X) u
: x ∈ fold_left union L u
  -> { n : nat & { t : set X | get L n t /\ x ∈ t} } + { x ∈ u }.
Proof.
  intros. general induction L; simpl in *; eauto.
  - decide (x ∈ a).
    + left; do 2 eexists; split; eauto using get.
    + edestruct IHL as [[? []]|]; eauto; dcr.
      * left. eauto using get.
      * right. cset_tac; intuition.
Qed.

Lemma get_list_union_map X Y `{OrderedType Y} (f:X -> set Y) L n x
: get L n x
  -> f x [<=] list_union (List.map f L).
Proof.
  intros. eapply incl_list_union.
  + eapply map_get_1; eauto.
  + reflexivity.
Qed.

Lemma get_in_incl X `{OrderedType X} (L:list X) s
: (forall n x, get L n x -> x ∈ s)
  -> of_list L ⊆ s.
Proof.
  intros. general induction L; simpl.
  - cset_tac; intuition.
  - exploit H0; eauto using get.
    exploit IHL; intros; eauto using get.
    cset_tac; intuition.
Qed.

Lemma get_in_of_list X `{OrderedType X} L n x
    : get L n x
      -> x ∈ of_list L.
Proof.
  intros. general induction H0; simpl; cset_tac; intuition.
Qed.

Lemma list_union_start_swap X `{OrderedType X} (L : list (set X)) s
: fold_left union L s [=] s ∪ list_union L.
Proof.
  general induction L; simpl; eauto.
  - cset_tac; intuition.
  - rewrite IHL. symmetry. rewrite IHL.
    hnf; intros. cset_tac; intuition.
Qed.

Lemma list_union_app X `{OrderedType X} (L L' : list (set X)) s
: fold_left union (L ++ L') s [=] fold_left union L s ∪ list_union L'.
Proof.
  general induction L; simpl; eauto using list_union_start_swap.
Qed.

Lemma list_union_cons X `{OrderedType X} s sl
: list_union (s :: sl) [=] s ∪ list_union sl.
Proof.
  simpl. setoid_rewrite list_union_start_swap.
  hnf; intros. cset_tac; intuition.
Qed.

Lemma incl_list_union_cons X `{OrderedType X} s sl
: list_union sl ⊆ list_union (s :: sl).
Proof.
  simpl. setoid_rewrite list_union_start_swap at 2.
  cset_tac; intuition.
Qed.

Hint Resolve incl_list_union_cons : cset.

Ltac norm_lunion :=
 repeat match goal with
      | [ |- context [ fold_left union ?A ?B ]] =>
        match B with
          | empty => fail 1
          | _ => rewrite (list_union_start_swap A B)
        end
    end.

Instance fold_left_union_morphism X `{OrderedType X}:
  Proper (PIR2 Equal ==> Equal ==> Equal) (fold_left union).
Proof.
  unfold Proper, respectful; intros.
  general induction H0; simpl; eauto.
  - rewrite IHPIR2; eauto. reflexivity.
    rewrite H1, pf. reflexivity.
Qed.

Instance fold_left_subset_morphism X `{OrderedType X}:
  Proper (PIR2 Subset ==> Subset ==> Subset) (fold_left union).
Proof.
  unfold Proper, respectful; intros.
  general induction H0; simpl; eauto with cset.
  eapply IHPIR2. rewrite H1, pf; eauto.
Qed.

Lemma list_union_eq {X} `{OrderedType X} (L L':list (set X)) (s s':set X)
: length L = length L'
  -> (forall n s t, get L n s -> get L' n t -> s [=] t)
  -> s [=] s'
  -> fold_left union L s [=] fold_left union L' s'.
Proof.
  intros. length_equify.
  general induction H0; simpl; eauto.
  exploit H1; eauto using get.
  rewrite H2, H3; eauto using get.
Qed.

Lemma list_union_f_incl X `{OrderedType X} Y (f g:Y->set X) s
: (forall n y, get s n y -> f y ⊆ g y)
  -> list_union (List.map f s) ⊆ list_union (List.map g s).
Proof.
  intros. general induction s; simpl; eauto.
  norm_lunion.
  rewrite IHs, H0; eauto using get; reflexivity.
Qed.

Lemma list_union_f_eq X `{OrderedType X} Y (f g:Y->set X) s
: (forall n y, get s n y -> f y [=] g y)
  -> list_union (List.map f s) [=] list_union (List.map g s).
Proof.
  intros. general induction s; simpl; eauto.
  norm_lunion.
  rewrite IHs, H0; eauto using get; eauto.
Qed.

Lemma list_union_f_union X `{OrderedType X} Y (f g:Y->set X) s
: list_union (List.map f s) ∪ list_union (List.map g s) [=]
             list_union (List.map (fun x => f x ∪ g x) s).
Proof.
  intros. general induction s; simpl; eauto.
  - cset_tac; intuition.
  - norm_lunion.
    rewrite <- IHs; eauto using get. cset_tac.
Qed.

Lemma list_union_minus_dist X `{OrderedType X} D'' s s' L
  :
    s \ D'' [=] s'
 ->  fold_left union L s \ D''
[=] fold_left union (List.map (fun s => s \ D'') L) s'.
Proof.
  general induction L; simpl; eauto.
  - eapply IHL. rewrite <- H0.
    clear_all; cset_tac; intuition.
Qed.

Require Import CSetDisjoint.

Lemma list_union_disjunct {X} `{OrderedType X} Y D
:  (forall (n : nat) (D' : set X), get Y n D' -> disj D' D)
   <-> disj (list_union Y) D.
Proof.
  split; intros.
  - eapply disj_intersection.
    eapply set_incl;[ cset_tac|].
    hnf; intros.
    general induction Y; simpl in * |- *.
    + cset_tac.
    + exploit H0; eauto using get.
      exploit IHY; intros; eauto using get.
      rewrite list_union_start_swap.
      rewrite list_union_start_swap in H1.
      cset_tac.
  - eapply disj_1_incl; eauto.
    eapply incl_list_union; eauto.
Qed.

Lemma list_union_indexwise_ext X `{OrderedType X} Y (f:Y->set X) Z (g:Z -> set X) L L'
: length L = length L'
  -> (forall n y z, get L n y -> get L' n z -> f y [=] g z)
  -> list_union (List.map f L) [=] list_union (List.map g L').
Proof.
  intros. length_equify.
  general induction H0; simpl; eauto.
  rewrite list_union_start_swap.
  setoid_rewrite list_union_start_swap at 2.
  rewrite IHlength_eq, H1; eauto using get; reflexivity.
Qed.

Lemma list_union_rev X `{OrderedType X} (L:list (set X)) s
: fold_left union L s [=] fold_left union (rev L) s.
Proof.
  general induction L; simpl; eauto.
  rewrite list_union_app.
  simpl.
  rewrite IHL.
  rewrite list_union_start_swap.
  setoid_rewrite list_union_start_swap at 2.
  hnf; intros. clear_all; cset_tac; intuition.
Qed.

Require Import Drop.

Lemma list_union_drop_incl X `{OrderedType X} (L:list (set X)) n
: list_union (drop n L) ⊆ list_union L.
Proof.
  intros; hnf; intros.
  edestruct list_union_get; eauto; dcr.
  eapply incl_list_union; eauto using get_drop. reflexivity.
  cset_tac; intuition.
Qed.

Lemma get_InA_OT X `{OrderedType X} (L:list X) n x
  :  get L n x
     -> InA _eq x L.
Proof.
  intros Get. general induction Get; eauto using InA.
Qed.

Lemma get_InA X (L:list X) n x
  :  get L n x
     -> InA eq x L.
Proof.
  intros Get. general induction Get; eauto using InA.
Qed.

Lemma get_elements_in X `{OrderedType X} s n x
  :  get (elements s) n x
     -> x ∈ s.
Proof.
  intros Get. eapply get_InA_OT in Get.
  rewrite (@InA_in X H) in Get.
  rewrite of_list_elements in Get. eauto.
Qed.

Lemma of_list_get_first X `{OrderedType X} (Z:list X) z
: z ∈ of_list Z
  -> exists n z', get Z n z' /\ z' === z /\ (forall n' z', n' < n -> get Z n' z' -> z' =/= z).
Proof.
  intros. general induction Z; simpl in *.
  decide (z === a).
  - eexists 0, a; repeat split; eauto using get.
    + intros. exfalso. omega.
  - eapply add_iff in H0 as [|].
    + exfalso. cset_tac.
    + edestruct IHZ; eauto. dcr.
      eexists (S x), x0; repeat split; eauto using get.
      * intros. inv H4; intro; eauto. eapply H5; eauto. omega.
Qed.

Lemma get_InA_R X (R:X -> X -> Prop) `{Reflexive X R} (L:list X) n x
  :  Get.get L n x
     -> InA R x L.
Proof.
  revert_until X. clear.
  intros. general induction H0; eauto using InA.
Qed.

Lemma NoDupA_get_neq' X (R:X -> X -> Prop) `{Reflexive X R}
      `{Transitive X R}
      (L:list X) n x m y
  : NoDupA R L
    -> n < m
    -> Get.get L n x
    -> Get.get L m y
    -> ~ R x y.
Proof.
  revert_until X. clear.
  intros.
  general induction H3; invt NoDupA.
  inv H4; try omega.
  eapply get_InA_R in H10; eauto.
  - revert H0 H6 H10 ; clear.
    intros. general induction H10.
    + intro. eapply H6. econstructor; eauto.
    + intro. eapply IHInA; eauto.
  - inv H4; try omega.
    eapply IHget; try eapply H11; eauto; omega.
Qed.

Lemma NoDupA_get_neq X (R:X -> X -> Prop) `{Reflexive X R}
      `{Symmetric X R}
      `{Transitive X R}
      (L:list X) n x m y
  : NoDupA R L
    -> n <> m
    -> Get.get L n x
    -> Get.get L m y
    -> ~ R x y.
Proof.
  intros.
  decide (n < m).
  - eapply NoDupA_get_neq'; eauto.
  - assert (m < n) by omega.
    intro. symmetry in H7.
    eapply NoDupA_get_neq'; eauto.
Qed.

Lemma of_list_list_union
      (X : Type)
      `{OrderedType X}
      (s : ⦃X⦄)
      (L : list ⦃X⦄)
  :
    s ∈ of_list L -> s ⊆ list_union L
.
Proof.
  intro s_in.
  apply of_list_1 in s_in.
  induction s_in;
    simpl in *; eauto.
  - rewrite H0.
    apply list_union_start.
    cset_tac.
  - rewrite list_union_start_swap, IHs_in.
    cset_tac.
Qed.

Lemma list_union_elem_eq_ext
      (X : Type)
      `{OrderedType X}
      (L L' : list ⦃X⦄)
  :
    elem_eq L L'
    -> list_union L [=] list_union L'
.
Proof.
  intros. unfold elem_eq in H0.
  enough (forall (l l' : list ⦃X⦄),
                    of_list l ⊆ of_list l'
                    -> list_union l ⊆ list_union l') as enouf.
  {
    unfold elem_eq.
    apply eq_incl in H0 as [incl1 incl2].
    apply incl_eq; eauto.
  }
  clear L L' H0.
  intros.
  general induction l;
    simpl in *; eauto.
  - cset_tac.
  - norm_lunion.
    rewrite add_union_singleton in H0.
    assert (a ⊆ list_union l') as a_sub.
    {
      apply of_list_list_union; eauto.
      clear IHl; cset_tac.
    }
    rewrite a_sub.
    rewrite IHl with (l':=l'); eauto.
    clear; cset_tac.
    cset_tac.
Qed.


Require Export P01.

(** Prove the following claim, marking cases (and subcases) with
    bullets when you use [destruct]. *)

Print xorb.

Theorem xorb_to_andb : forall b c : bool,
  xorb b c = true -> andb b c = false.
Proof.
  exact FILL_IN_HERE.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

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

(* Why3 assumption *)
Definition permut {a:Type} {a_WT:WhyType a} (l1:(list a))
  (l2:(list a)): Prop := forall (x:a), ((list.NumOcc.num_occ x
  l1) = (list.NumOcc.num_occ x l2)).

(* Why3 goal *)
Lemma Permut_refl : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  (permut l l).
Proof.
now intros a a_WT l.
Qed.

(* Why3 goal *)
Lemma Permut_sym : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), (permut l1 l2) -> (permut l2 l1).
Proof.
now intros a a_WT l1 l2 h1.
Qed.

(* Why3 goal *)
Lemma Permut_trans : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), (permut l1 l2) -> ((permut l2 l3) -> (permut
  l1 l3)).
Proof.
intros a a_WT l1 l2 l3 h1 h2 x.
now rewrite h1.
Qed.

(* Why3 goal *)
Lemma Permut_cons : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), (permut l1 l2) -> (permut
  (Init.Datatypes.cons x l1) (Init.Datatypes.cons x l2)).
Proof.
intros a a_WT x l1 l2 h1 y.
simpl.
now rewrite h1.
Qed.

(* Why3 goal *)
Lemma Permut_swap : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a)
  (l:(list a)), (permut (Init.Datatypes.cons x (Init.Datatypes.cons y l))
  (Init.Datatypes.cons y (Init.Datatypes.cons x l))).
Proof.
intros a a_WT x y l z.
simpl.
ring.
Qed.

(* Why3 goal *)
Lemma Permut_cons_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), (permut
  (Init.Datatypes.app (Init.Datatypes.cons x l1) l2)
  (Init.Datatypes.app l1 (Init.Datatypes.cons x l2))).
Proof.
intros a a_WT x l1 l2 y.
induction l1 as [|l1h l1t IHl1].
easy.
simpl in IHl1 |- *.
rewrite <- IHl1.
ring.
Qed.

(* Why3 goal *)
Lemma Permut_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), (permut
  (Init.Datatypes.app (Init.Datatypes.app l1 l2) l3)
  (Init.Datatypes.app l1 (Init.Datatypes.app l2 l3))).
Proof.
intros a a_WT l1 l2 l3 y.
now rewrite List.app_assoc.
Qed.

(* Why3 goal *)
Lemma Permut_append : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (k1:(list a)) (k2:(list a)), (permut l1 k1) -> ((permut l2
  k2) -> (permut (Init.Datatypes.app l1 l2) (Init.Datatypes.app k1 k2))).
Proof.
intros a a_WT l1 l2 k1 k2 h1 h2 y.
rewrite 2!NumOcc.Append_Num_Occ.
now apply f_equal2.
Qed.

(* Why3 goal *)
Lemma Permut_append_swap : forall {a:Type} {a_WT:WhyType a},
  forall (l1:(list a)) (l2:(list a)), (permut (Init.Datatypes.app l1 l2)
  (Init.Datatypes.app l2 l1)).
Proof.
intros a a_WT l1 l2 y.
rewrite 2!NumOcc.Append_Num_Occ.
apply Zplus_comm.
Qed.

(* Why3 goal *)
Lemma Permut_mem : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), (permut l1 l2) -> ((list.Mem.mem x l1) ->
  (list.Mem.mem x l2)).
Proof.
intros a a_WT x l1 l2 h1 h2.
apply NumOcc.Mem_Num_Occ.
rewrite <- h1.
now apply NumOcc.Mem_Num_Occ.
Qed.

(* Why3 goal *)
Lemma Permut_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), (permut l1 l2) ->
  ((list.Length.length l1) = (list.Length.length l2)).
Proof.
intros a a_WT l1 l2 h1.
revert l2 h1.
induction l1 as [|l1h l1t IHl1].
- destruct l2 as [|l2h l2t].
  easy.
  intros H.
  specialize (H l2h).
  contradict H.
  simpl.
  case why_decidable_eq ; intros H.
  generalize (NumOcc.Num_Occ_NonNeg l2h l2t).
  omega.
  now elim H.
- intros l2 H.
  assert (H': Mem.mem l1h l2).
    apply NumOcc.Mem_Num_Occ.
    specialize (H l1h).
    simpl in H.
    destruct (why_decidable_eq l1h l1h) as [_|H'].
    2: now elim H'.
    generalize (NumOcc.Num_Occ_NonNeg l1h l1t).
    omega.
  destruct (Append.mem_decomp _ _ H') as [l2a [l2b Hl2]].
  rewrite Hl2.
  rewrite Append.Append_length.
  change (1 + Length.length l1t = Length.length l2a + (1 + Length.length l2b))%Z.
  rewrite (IHl1 (l2a ++ l2b)%list).
  rewrite Append.Append_length.
  ring.
  rewrite Hl2 in H.
  assert (H1 := Permut_cons_append l1h l2a l2b).
  apply Permut_sym in H1.
  generalize (Permut_trans _ _ _ H H1).
  change ((l1h :: l2a) ++ l2b)%list with (l1h :: (l2a ++ l2b))%list.
  generalize (l2a ++ l2b)%list.
  clear.
  intros l H y.
  specialize (H y).
  simpl in H.
  omega.
Qed.


(*
Chapter 3
*)

Require Import TLC.LibLN.
Require Import Coq.Lists.ListSet.
From Coq Require Export Lists.List.
Export ListNotations.
Require Import Coq.Init.Nat.

Inductive trm : Set :=
  | tru : trm
  | fals : trm
  | cond : trm -> trm -> trm -> trm
  | zro  : trm
  | succ : trm -> trm
  | pred : trm -> trm
  | iszero : trm -> trm.

Lemma eq_dec : forall x y:trm, {x = y} + {x <> y}.
Proof.
 decide equality; auto.
Defined.

Notation "l1 `union` l2" := (set_union eq_dec l1 l2) (at level 80).
Notation "l1 `inter` l2" := (set_inter eq_dec l1 l2) (at level 80).

Fixpoint constants (u: trm) : list trm :=
  match u with
  | tru => [tru]
  | fals => [fals]
  | cond t1 t2 t3 => constants t1 `union` constants t2 `union` constants t3
  | zro => [zro]
  | succ t => constants t
  | pred t => constants t
  | iszero t => constants t
  end.

Fixpoint size (u: trm) : nat :=
  match u with
  | tru => 1
  | fals => 1
  | cond t1 t2 t3 => 1 + size t1 + size t2 + size t3
  | zro => 1
  | succ t => 1 + size t
  | pred t => 1 + size t
  | iszero t => 1 + size t
  end.

Fixpoint depth (u: trm) : nat :=
  match u with
  | tru => 1
  | fals => 1
  | cond t1 t2 t3 => max (max (depth t1) (depth t2)) (depth t3) + 1
  | zro => 1
  | succ t => 1 + depth t
  | pred t => 1 + depth t
  | iszero t => 1 + depth t
  end.