(** * Undecidability of the halting problem of Rowing Machines *)

Require Import Undecidability.Synthetic.Undecidability.

Require Import RM CM2_undec.
Require Import Reductions.CM2_Halt_to_RM_Halt.

Lemma RM_HALT_undec : undecidable RM_HALT.
Proof.
  apply (undecidability_from_reducibility CM2_HALT_undec).
  exact CM2_Halt_to_RM_Halt.reduction.
Qed.


From mathcomp.ssreflect Require Import ssreflect ssrnat ssrbool seq tuple eqtype .

(* This solves an error where the implementation of ssrbool.ml
   doesn't match the interface *)
Require Extraction.
Extraction Inline ssrbool.SimplPred.

Extraction Language OCaml.
(* Extraction Blacklist string list nat. *)
Set Extraction Optimize.
Unset Extraction AccessOpaque.
Set Extraction AutoInline.
Unset Extraction SafeImplicits.

Set Extraction File Comment  "Generated Automagically using Coq-extract - see corresponding .v file for proofs*)
open Core
(*".

(* Constants to inline:
 Set Extraction Inline <constant-name>
 *)

(* Implicit parameters
Fixpoint len (A: Type) (xs: list A) : nat := match xs with | nil => 0 | cons h t => 1 + len _ t end.
Extraction Implicit lezn [ A ].
Extraction len.

let rec len = function
| Nil -> O
| Cons (_, t) -> add (S O) (len t)
*)

(* Realizing axioms
Extracting Constant <name> => <item>
 *)

Extract Inlined Constant Nat.zero => "0".
Extract Inlined Constant Nat.one => "1".
Extract Inlined Constant Nat.two => "2".

Extract Inlined Constant Nat.succ => "Int.succ".
Extract Inlined Constant Nat.pred => "Int.pred".
Extract Inlined Constant Nat.add => "(+)".
Extract Inlined Constant Nat.sub => "(-)".

Extract Inlined Constant Nat.mul => "(*)".
Extract Inlined Constant Nat.eqb => "Int.(=)".

Extract Inlined Constant Nat.leb => "(<=)".
Extract Inlined Constant Nat.ltb => "(<)".

Extract Inlined Constant Nat.modulo => "(%)".
Extract Inlined Constant Nat.double => "(fun x -> x * 2)".

Extract Inductive comparison => int [ "0" "-1" "+1" ] "(fun feq flt fgt n -> match n with | 0 -> feq () | -1 -> flt () | 1 -> fgt ())".
Extract Inlined Constant Nat.compare => "compare".
Extract Inlined Constant Nat.max => "max".
Extract Inlined Constant Nat.min => "min".
Extract Inlined Constant Nat.even => "(fun x -> x % 2 = 0)".
Extract Inlined Constant Nat.odd => "(fun x -> not ( x % 2 = 0))".
Extract Inlined Constant Nat.pow => "Int.( ** )".

     (* Definition of_uint_acc : Decimal.uint -> nat -> nat. *)
     (* Definition of_uint : Decimal.uint -> nat. *)
     (* Definition to_little_uint : nat -> Decimal.uint -> Decimal.uint. *)
     (* Definition to_uint : nat -> Decimal.uint. *)
     (* Definition of_int : Decimal.int -> option nat. *)
     (* Definition to_int : nat -> Decimal.int. *)
     (* Definition divmod : nat -> nat -> nat -> nat -> nat * nat. *)
Extract Inlined Constant Nat.div => "Int.(/)".

Extract Inlined Constant Nat.modulo => "Int.(%)".
     (* Definition gcd : nat -> nat -> nat. *)
     (* Definition square : nat -> nat. *)
     (* Definition sqrt_iter : nat -> nat -> nat -> nat -> nat. *)
     (* Definition sqrt : nat -> nat. *)
     (* Definition log2_iter : nat -> nat -> nat -> nat -> nat. *)
     (* Definition log2 : nat -> nat. *)
     (* Definition iter : nat -> forall A : Type, (A -> A) -> A -> A. *)
Extract Inlined Constant Nat.div2 => "(fun x y -> x / y)".
     (* Definition testbit : nat -> nat -> bool. *)
     (* Definition shiftl : (fun _ : nat => nat) 0 -> forall n : nat, (fun _ : nat => nat) n. *)
     (* Definition shiftr : (fun _ : nat => nat) 0 -> forall n : nat, (fun _ : nat => nat) n. *)
     (* Definition bitwise : (bool -> bool -> bool) -> nat -> nat -> nat -> nat. *)
     (* Definition land : nat -> nat -> nat. *)
     (* Definition lor : nat -> nat -> nat. *)
     (* Definition ldiff : nat -> nat -> nat. *)
     (* Definition lxor : nat -> nat -> nat. *)
Extract Inlined Constant addn => "(+)".
Extract Inlined Constant eqn => "Int.(=)".

Extract Inlined Constant addn_rec => "(+)".
Extract Inlined Constant addn => "(+)".
Extract Inlined Constant subn_rec => "(-)".
Extract Inlined Constant subn => "(-)".

Extract Inlined Constant leq => "(<=)".
Extract Inlined Constant geq => "(>=)".
Extract Inlined Constant ltn => "(<)".
Extract Inlined Constant gtn => "(>)".
Extract Inlined Constant maxn => "max".
Extract Inlined Constant minn => "min".
Extract Inlined Constant iter => "Fn.apply_n_times".
Extract Inlined Constant iteri => "(fun n f a0 -> fst (Fn.apply_n_times ~n (fun (x,n) ->  (f (n-1) x, n - 1)) (a0, n)))".
Extract Inlined Constant muln_rec => "Int.( * )".
Extract Inlined Constant muln => "Int.( * )".

Extract Inlined Constant expn_rec => "Int.( ** )".
Extract Inlined Constant expn => "Int.( ** )".
Extract Inlined Constant nat_of_bool => "Bool.to_int".

Extract Inlined Constant odd => "(fun x -> not ( x % 2 = 0))".

Extract Inlined Constant double_rec => "(fun x -> x * 2)".
Extract Inlined Constant double => "(fun x -> x * 2)".
Extract Inlined Constant half => "(fun x -> x / 2)".
Extract Inlined Constant uphalf => "(fun x -> (x + 1) / 2)".

Extract Inlined Constant unit_eqMixin => "unit".
Extract Inlined Constant unit_eqType => "unit".
Extract Inlined Constant eqb => "Bool.(=)".
Extract Inlined Constant pred1  => "(fun x y -> Poly.(x = y))".

Extract Inlined Constant pair_eq => "Poly.(=)".
Extract Constant prod_eqMixin "'a" "'b" => "('a * 'b)".
Extract Constant prod_eqType "'a" "'b" => "('a * 'b)".
Extract Inductive option  => "option" [ "Some" "None"].
Extract Inlined Constant opt_eq => "Poly.(=)".
Extract Constant option_eqMixin "'a" => "'a option".
Extract Constant option_eqType "'a" => "'a option".

Extract Inductive sum => "Either.t" ["First" "Second"].
Extract Inlined Constant sum_eq => "Poly.(=)".
Extract Constant sum_eqMixin "'a" "'b" => "('a, 'b) Core._either".
Extract Constant sum_eqType "'a" "'b" => "('a, 'b) Core._either".

Extract Inductive nat => int [ "0" "succ" ] "(fun f0 fs n -> if n = 0 then f0 () else fs (n - 1))".
Extract Inductive unit => "unit" [ "()" ].
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive sumbool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive reflect => "bool" [ "true" "false" ].

Extraction Inline Equality.axiom.
Extraction Inline Equality.op.
Extraction Inline Equality.sort.
Extraction Inline Equality.class.

Extraction Implicit Equality.axiom [T e].
Extraction Implicit Equality.mixin_of [T].
Extraction Implicit Equality.Mixin [T  ].
Extraction Implicit Equality.Pack [ sort].
Extraction Implicit Equality.op [T].
Extraction Implicit Equality.clone [T].
Extraction Implicit Equality.class [].
Extraction Implicit Equality.sort [t].

Extract Constant Equality.axiom "'a" => "unit" .

Extract Inlined Constant eqnP => "()".
Extract Inlined Constant Bool.eqb_spec => "()".
Extract Inlined Constant fintype.subset_eqP => "()".
Extract Inlined Constant fintype.subset_eqP => "()".
Extract Inlined Constant Equality.class => "".

Extract Inlined Constant size => "List.length".
Extract Inlined Constant nilp => "(fun x -> List.length x > 0)".
Extract Inlined Constant ohead => "List.hd".

Extract Inlined Constant eqseqP => "()".
Extraction Implicit eqseqP [T].

     (* Definition head : forall T : Type, T -> seq T -> T. *)
     (* Definition behead : forall T : Type, seq T -> seq T. *)
     (* Definition ncons : forall T : Type, nat -> T -> seq T -> seq T. *)
     (* Definition nseq : forall T : Type, nat -> T -> seq T. *)
     (* Definition seqn_type : Type -> nat -> Type. *)
     (* Definition seqn_rec : forall T : Type, (seq T -> seqn_type T 0) -> forall n : nat, seqn_type T n. *)
     (* Definition seqn : forall (T : Type) (n : nat), seqn_type T n. *)
     (* Definition cat : forall T : Type, seq T -> seq T -> seq T. *)
     (* Definition rcons : forall T : Type, seq T -> T -> seq T. *)
     (* Definition last : forall T : Type, T -> seq T -> T. *)
     (* Definition belast : forall T : Type, T -> seq T -> seq T. *)
     (* Definition nth : forall T : Type, T -> seq T -> nat -> T. *)
     (* Definition set_nth : forall T : Type, T -> seq T -> nat -> T -> seq T. *)
     (* Definition find : forall T : Type, pred T -> seq T -> nat. *)
     (* Definition filter : forall T : Type, pred T -> seq T -> seq T. *)
     (* Definition count : forall T : Type, pred T -> seq T -> nat. *)
     (* Definition has : forall T : Type, pred T -> seq T -> bool. *)
     (* Definition all : forall T : Type, pred T -> seq T -> bool. *)
     (* Definition drop : forall T : Type, nat -> seq T -> seq T. *)
     (* Definition take : forall T : Type, nat -> seq T -> seq T. *)
     (* Definition rot : forall T : Type, nat -> seq T -> seq T. *)
     (* Definition rotr : forall T : Type, nat -> seq T -> seq T. *)
     (* Definition catrev : forall T : Type, seq T -> seq T -> seq T. *)
     (* Definition rev : forall T : Type, seq T -> seq T. *)
     (* Definition eqseq : forall T : eqType, seq T -> seq T -> bool. *)
     (* Definition seq_eqMixin : forall T : eqType, Equality.mixin_of (seq T). *)
     (* Definition seq_eqType : eqType -> eqType. *)
     (* Definition mem_seq : forall T : eqType, seq T -> T -> bool. *)
     (* Definition seq_eqclass : eqType -> Type. *)
     (* Definition seq_of_eqclass : forall T : eqType, seq_eqclass T -> seq T. *)
     (* Definition pred_of_seq : forall T : eqType, seq_eqclass T -> predPredType T. *)
     (* Definition seq_predType : forall T : eqType, predType T. *)
     (* Definition mem_seq_predType : forall T : eqType, predType T. *)
     (* Definition constant : forall T : eqType, seq T -> bool. *)
     (* Definition uniq : forall T : eqType, seq T -> bool. *)
     (* Definition undup : forall T : eqType, seq T -> seq T. *)
     (* Definition index : forall T : eqType, T -> seq T -> nat. *)
     (* Definition inE : *)
     (* Definition bitseq : Set. *)
     (* Definition bitseq_eqType : eqType. *)
     (* Definition bitseq_predType : predType bool_eqType. *)
     (* Definition incr_nth : seq nat -> nat -> seq nat. *)
     (* Definition perm_eq : forall T : eqType, seq T -> seq T -> bool. *)
     (* Definition mask : forall T : Type, bitseq -> seq T -> seq T. *)
     (* Definition subseq : forall T : eqType, seq T -> seq T -> bool. *)
     (* Definition rem : forall T : eqType, T -> seq T -> seq T. *)
Extract Inlined Constant seq.map => "(fun f xs -> List.map xs f)".
     (* Definition pmap : forall aT rT : Type, (aT -> option rT) -> seq aT -> seq rT. *)
     (* Definition iota : nat -> nat -> seq nat. *)
     (* Definition mkseq : forall T : Type, (nat -> T) -> nat -> seq T. *)
     (* Definition foldr : forall T R : Type, (T -> R -> R) -> R -> seq T -> R. *)
     (* Definition sumn : seq nat -> nat. *)
     (* Definition foldl : forall T R : Type, (R -> T -> R) -> R -> seq T -> R. *)
     (* Definition pairmap : forall T1 T2 : Type, (T1 -> T1 -> T2) -> T1 -> seq T1 -> seq T2. *)
     (* Definition scanl : forall T1 T2 : Type, (T1 -> T2 -> T1) -> T1 -> seq T2 -> seq T1. *)
     (* Definition zip : forall S T : Type, seq S -> seq T -> seq (S * T). *)
     (* Definition unzip1 : forall S T : Type, seq (S * T) -> seq S. *)
     (* Definition unzip2 : forall S T : Type, seq (S * T) -> seq T. *)
     (* Definition all2 : forall S T : Type, (S -> T -> bool) -> seq S -> seq T -> bool. *)
     (* Definition flatten : forall T : Type, seq (seq T) -> seq T. *)
     (* Definition shape : forall T : Type, seq (seq T) -> seq nat. *)
     (* Definition reshape : forall T : Type, seq nat -> seq T -> seq (seq T). *)
     (* Definition flatten_index : seq nat -> nat -> nat -> nat. *)
     (* Definition reshape_index : seq nat -> nat -> nat. *)
     (* Definition reshape_offset : seq nat -> nat -> nat. *)
     (* Definition allpairs_dep : *)
     (* Definition allpairs : forall S T R : Type, (S -> T -> R) -> seq S -> seq T -> seq R. *)
     (* Definition incr_tally : forall T : eqType, seq (T * nat) -> T -> seq (T * nat). *)
     (* Definition tally : forall T : eqType, seq T -> seq (T * nat). *)
     (* Definition wf_tally : forall T : eqType, qualifier 1 (seq (T * nat)). *)
     (* Definition tally_seq : forall T : eqType, seq (T * nat) -> seq T. *)
     (* Definition cons_perms_ : *)
     (*   forall T : eqType, *)
     (*   (seq T -> seq (T * nat) -> seq (seq T) -> seq (seq T)) -> *)
     (*   seq T -> seq (T * nat) -> seq (T * nat) -> seq (seq T) -> seq (seq T). *)
     (* Definition perms_rec : *)
     (*   forall T : eqType, nat -> seq T -> seq (T * nat) -> seq (seq T) -> seq (seq T). *)
     (* Definition permutations : forall T : eqType, seq T -> seq (seq T). *)
     (* Definition all_iff_and_rect : *)
     (*   forall (P Q : Prop) (P0 : Type), (P -> Q -> P0) -> all_iff_and P Q -> P0. *)
     (* Definition all_iff_and_ind : forall P Q P0 : Prop, (P -> Q -> P0) -> all_iff_and P Q -> P0. *)
     (* Definition all_iff_and_rec : *)
     (*   forall (P Q : Prop) (P0 : Set), (P -> Q -> P0) -> all_iff_and P Q -> P0. *)
     (* Definition all_iff : Prop -> seq Prop -> Prop. *)

(* Example coq:

(* Getting rid of reflect and other proof related equalities *)

Module Type NetbufTypes.
Parameter A:Set.
(* These need to be types that can be coerced into ordType *)
Axiom A_eqMixin : Equality.mixin_of A.

End NetbufTypes.

Module Netbuf (Params: NetbufTypes).
  Section Netbuf.

  Canonical A_eqType := Eval hnf in EqType Params.A Params.A_eqMixin.

  Record t :=  mkNetBuffer {
                     x: nat; y: nat; z: seq Params.A;
                   }.
  Definition updateNetBuffer (buf: t) : t := mkNetBuffer (x buf + 1) (y buf) [::].
  Definition eqNetBuffer (buf: t) (buf': t) : bool := (x buf) == (x buf').

  Definition eq_netBuf  (v v': Params.A) (buf buf': t)  := if  v == v' then buf else buf'.

  Definition len_netBuf (buf: t) := size (z buf).

  Extraction Inline x y z.
  End Netbuf.
End Netbuf.
*)


(** ** Decidability *)

(** This file contains definition and facts regarding synthetic decidability
    from the Coq Library of Undecidability Proofs. *)

Require Import Util.

Definition dec (P : Prop) := {P} + {~P}.
Definition ldec (P : Prop) := P \/ ~P.
Definition decidable {X} (p : X -> Prop) := exists f : X -> bool, forall x, p x <-> f x = true.
Definition ldecidable {X} (p : X -> Prop) := forall x, p x \/ ~ p x.
Definition eq_dec X := forall x y : X, dec (x = y).

Definition reduction {X Y} (f : X -> Y) (P : X -> Prop) (Q : Y -> Prop) := forall x, P x <-> Q (f x).
Definition reduces {X Y} (P : X -> Prop) (Q : Y -> Prop) := exists f : X -> Y, reduction f P Q.
Notation "P ⪯ Q" := (reduces P Q) (at level 70).

Existing Class eq_dec.

Definition tsat (f : nat -> bool) := exists n, f n = true.
Definition stable P := ~~P -> P.
Definition MP := forall f, stable (tsat f).

Existing Class dec.
Coercion dec2bool {P} (d: dec P) := if d then true else false.
Definition Dec (X: Prop) {d: dec X} : dec X := d.

Lemma Dec_reflect (X: Prop) (d: dec X) :
  is_true (Dec X) <-> X.
Proof.
  destruct d as [A|A]; cbv in *; intuition congruence.
Qed.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> is_true (Dec X).
Proof.
  destruct d as [A|A]; cbn; intuition congruence.
Qed.

Global Hint Extern 4 =>
  match goal with
    | [ |- dec ((fun _ => _) _) ] => cbn
  end : typeclass_instances.

Instance dec_eq_dec X `{eq_dec X} (x y : X) : dec (x = y) := H _ _.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

Lemma Dec_true P {H : dec P} : dec2bool (Dec P) = true -> P.
Proof.
  destruct (Dec P); cbv in *; firstorder.
  congruence.
Qed.

Lemma Dec_false P {H : dec P} : dec2bool (Dec P) = false -> ~P.
Proof.
  destruct (Dec P); cbv in *; firstorder.
  congruence.
Qed.

Global Hint Extern 4 =>
  match goal with
    [ H : dec2bool (Dec ?P) = true |- _ ] => apply Dec_true in H
  | [ H : dec2bool (Dec ?P) = true |- _ ] => apply Dec_false in H
  end : core.

Structure eqType := EqType {
  eqType_X :> Type;
  eqType_dec : eq_dec eqType_X }.

Arguments EqType X {_} : rename.

Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.

Existing Instance eqType_dec.

Instance True_dec :
  dec True.
Proof.
  unfold dec; tauto.
Qed.

Instance False_dec :
  dec False.
Proof.
  unfold dec; tauto.
Qed.

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec; tauto.
Qed.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Qed.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Qed.

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. unfold dec. tauto.
Qed.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. unfold dec. tauto.
Qed.

Lemma decidable_if X (p : X -> Prop) :
  (forall x, dec (p x)) -> decidable p.
Proof.
  intros H. exists (fun x => if H x then true else false).
  split; now destruct (H x).
Qed.

Lemma decidable_ext X (p1 p2 : X -> Prop) :
  (forall x, p1 x <-> p2 x) -> decidable p1 -> decidable p2.
Proof.
  intros H [f Hf]. exists f. firstorder.
Qed.

Instance unit_eq_dec :
  eq_dec unit.
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance sum_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance option_eq_dec X :
  eq_dec X -> eq_dec (option X).
Proof.
  unfold eq_dec, dec. decide equality.
Defined.

Instance Empty_set_eq_dec:
  eq_dec Empty_set.
Proof.
  unfold eq_dec, dec. decide equality.
Qed.

Instance True_eq_dec:
  eq_dec True.
Proof.
  intros x y. destruct x,y. now left.
Qed.

Instance False_eq_dec:
  eq_dec False.
Proof.
  intros [].
Qed.

Lemma decidable_transport_red {X Y} (P : X -> Prop) (Q : Y -> Prop) :
  P ⪯ Q -> decidable Q -> decidable P.
Proof.
  intros [g Hg] [f Hf]. exists (fun y => f (g y)). intros x. split.
  - intros H. apply Hf, Hg, H.
  - intros H. apply Hg, Hf, H.
Qed.


Require Import String.
Require Import Lia.
Require Import List.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import Coq.Vectors.VectorEq.
Require Import Coq.Arith.Bool_nat.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export RelationClasses.
Require Export Morphisms.
Require Import Program.
From ST Require Import EVarsScratchwork.
From ST Require Import Vector.
From ST Require Export Logic.V Logic.Term.
From ST Require Export SoftType.Radix SoftType.Attribute SoftType.Adjective SoftType.SoftType SoftType.JudgementType.
From ST Require Export SoftType.LocalContext SoftType.GlobalContext.
Import ListNotations.
Import VectorNotations.
Open Scope string_scope.

(** * Inference Rules for Soft Types

We can now code up the inference rules for Wiedijk's soft type system inductively.
*)
Definition Judgement : Type := GlobalContext * LocalContext * JudgementType.

Definition Judgement_body (j : Judgement) :=
match j with
| (_,_, body) => body
end.

Global Instance EnumerateEVarsJudgement : EnumerateEVars Judgement := {
list_evars j := match j with
| (gc,lc,judge) => insert_merge (list_evars gc) (insert_merge (list_evars lc) (list_evars judge))
end
}.

Theorem list_evars_judgement_sorted : forall (j : Judgement),
  sorted (list_evars j).
Proof. intros. destruct j.
  unfold list_evars; unfold EnumerateEVarsJudgement.
  assert (sorted (list_evars j)). { apply list_evars_judgement_type_sorted. }
  destruct p.
  assert (sorted (insert_merge (list_evars l) (list_evars j))). {
    apply insert_merge_sorted2; assumption.
  }
  apply insert_merge_sorted2; assumption.
Qed.

Definition push {A : Type} (a : A) (l : list A) : list A :=
  List.app l (List.cons a List.nil).
Close Scope string_scope.
Import ListNotations.

Notation "gc ;; lc |- j" := (gc, lc, j) (at level 80).
Import ListNotations.
Open Scope list_scope.
Inductive well_typed : Judgement -> Prop :=
| wt_empty_context : well_typed ([] ;; [] |- CorrectContext)
| wt_var : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (J : JudgementType),
  well_typed (Γ ;; Δ |- Inhabited T) ->
  well_typed (Γ ;; (push T Δ) |- CorrectContext)
(* TODO: substitution rule for a vector of declarations *)
| wt_subst : forall (Γ : GlobalContext) (Δ : LocalContext) (t : Term) (T : SoftType) (J : JudgementType),
  well_typed (Γ ;; (List.cons T Δ) |- J) ->
  well_typed (Γ ;; Δ |- Esti t T) ->
  well_typed (Γ ;; (capture_free_subst 0 t Δ) |- (subst (BVar (length Δ)) t J))
(* XXX Wiedijk combines this [wt_assume] rule with [wt_subst] in a single step, I decompose them into two. *)
| wt_assume : forall (Γ : GlobalContext) (Δ : LocalContext) (J : JudgementType),
  gc_contains Γ (Δ, J) ->
  well_typed (Γ ;; Δ |- J)
(* TODO: inhabited types produce new local variables *)
| wt_subtype_star_star : forall (Γ : GlobalContext) (Δ : LocalContext),
  well_typed (Γ ;; Δ |- CorrectContext) ->
  well_typed (Γ ;; Δ |- Subtype Star Star)
| wt_inhabited_star : forall (Γ : GlobalContext) (Δ : LocalContext),
  well_typed (Γ ;; Δ |- CorrectContext) ->
  well_typed (Γ ;; Δ |- Inhabited Star)
| wt_subtype_refl : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 : SoftType),
  well_typed (Γ ;; Δ |- Subtype T1 T2) ->
  well_typed (Γ ;; Δ |- Subtype T1 T1)
| wt_subtype_trans : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 T3 : SoftType),
  well_typed (Γ ;; Δ |- Subtype T1 T2) ->
  well_typed (Γ ;; Δ |- Subtype T2 T3) ->
  well_typed (Γ ;; Δ |- Subtype T1 T3)
| wt_subsumption : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 : SoftType) (t : Term),
  well_typed (Γ ;; Δ |- Esti t T1) ->
  well_typed (Γ ;; Δ |- Subtype T1 T2) ->
  well_typed (Γ ;; Δ |- Esti t T2)
| wt_parent_inhabited : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 : SoftType),
  well_typed (Γ ;; Δ |- Subtype T1 T2) ->
  well_typed (Γ ;; Δ |- Inhabited T1) ->
  well_typed (Γ ;; Δ |- Inhabited T2)
| wt_cons_pos : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (A : Attribute),
  well_typed (Γ ;; Δ |- HasAttribute A T) ->
  well_typed (Γ ;; Δ |- Subtype (prefix (Pos A) T) T)
| wt_cons_neg : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (A : Attribute),
  well_typed (Γ ;; Δ |- HasAttribute A T) ->
  well_typed (Γ ;; Δ |- Subtype (prefix (Neg A) T) T)
| wt_adj_subtype : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 : SoftType) (a : Adjective),
  well_typed (Γ ;; Δ |- Subtype T1 T2) ->
  well_typed (Γ ;; Δ |- Subtype (prefix a T2) T2) ->
  well_typed (Γ ;; Δ |- Subtype (prefix a T1) T1)
| wt_adj_subtype_adj : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 : SoftType) (a : Adjective),
  well_typed (Γ ;; Δ |- Subtype T1 T2) ->
  well_typed (Γ ;; Δ |- Subtype (prefix a T2) T2) ->
  well_typed (Γ ;; Δ |- Subtype (prefix a T1) (prefix a T2))
| wt_adj_diamond : forall (Γ : GlobalContext) (Δ : LocalContext) (T1 T2 : SoftType) (a1 a2 : Adjective),
  well_typed (Γ ;; Δ |- Subtype T1 (prefix a1 T2)) ->
  well_typed (Γ ;; Δ |- Subtype T1 (prefix a2 T2)) ->
  well_typed (Γ ;; Δ |- Subtype T1 (prefix a1 (prefix a2 T2)))
  (* Rules governing Definitions *)
| wt_functor_def : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (f : name),
  not (gc_defines_term Γ f) ->
  well_typed (Γ ;; Δ |- Inhabited T) ->
  well_typed (Γ ++ [(Δ, (Esti (Fun f (local_vars Δ)) T))] ;; [] |- CorrectContext)
| wt_mode_def : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (M : name),
  not (gc_defines_type Γ M) ->
  well_typed (Γ ;; Δ |- Inhabited T) ->
  well_typed (Γ ++
              [(Δ, (Subtype (mk_mode M (local_vars Δ)) T)) ;
                (Δ, (Inhabited (mk_mode M (local_vars Δ))))] ;; [] |- CorrectContext)
| wt_attr_def : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (alpha : name),
  not (gc_defines_attr Γ alpha) ->
  well_typed (Γ ;; Δ |- Inhabited T) ->
  well_typed (Γ ++ [(Δ, HasAttribute (Attr (List.length Δ) alpha (local_vars Δ)) T)] ;; List.nil |- CorrectContext)
  (* Rules governing clusters *)
| wt_cluster_exist : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (a : Adjective),
  well_typed (Γ ;; Δ |- Subtype (prefix a T) T) ->
  well_typed (Γ ;; Δ |- Inhabited T) ->
  well_typed (Γ ++ [(Δ, (Inhabited (prefix a T)))] ;; [] |- CorrectContext)
| wt_cluster_cond : forall (Γ : GlobalContext) (Δ : LocalContext) (T : SoftType) (a1 a2 : list Adjective),
  well_typed (Γ ;; Δ |- Subtype (prefix_all a1 T) T) ->
  well_typed (Γ ;; Δ |- Subtype (prefix_all a2 T) T) ->
  well_typed (List.app Γ (List.cons (Δ, (Subtype (prefix_all a1 T) (prefix_all a2 T))) List.nil) ;; List.nil |- CorrectContext)
| wt_cluster_fun : forall (Γ : GlobalContext) (Δ : LocalContext) (t : Term) (T : SoftType) (a : Adjective),
  well_typed (Γ ;; Δ |- Esti t T) ->
  well_typed (Γ ;; Δ |- Subtype (prefix a T) T) ->
  well_typed (Γ ++ [(Δ, (Esti t (prefix a T)))] ;; [] |- CorrectContext)
  (* Rules governing redefinitions *)
| wt_redef_fun : forall (Γ : GlobalContext) (Δ₁ Δ₂ : LocalContext) (t : Term) (T1 T2 T3 : SoftType),
  term_is_fun t ->
  well_typed (Γ ;; Δ₂ |- Inhabited T2) ->
  well_typed (Γ ;; Δ₂ |- Subtype T2 T3) ->
  well_typed (Γ ;; (Δ₁ ++ Δ₂) |- Esti (fun_with_locals t Δ₂) T3) ->
  well_typed (Γ ++ [((Δ₁ ++ Δ₂), (Esti (fun_with_locals t Δ₂) T3))] ;; List.nil |- CorrectContext)
| wt_redef_mode : forall (Γ : GlobalContext) (Δ₁ Δ₂ : LocalContext) (M : Radix) (T1 T2 T3 : SoftType),
  radix_is_mode M ->
  well_typed (Γ ;; Δ₂ |- Inhabited T2) ->
  well_typed (Γ ;; Δ₂ |- Subtype T2 T3) ->
  well_typed (Γ ;; (Δ₁ ++ Δ₂) |- Subtype ([], (mode_with_locals M Δ₂)) T3) ->
  well_typed (Γ ++ [((Δ₁ ++ Δ₂), (Subtype ([], (mode_with_locals M Δ₂)) T3))] ;; [] |- CorrectContext).


Require Export
  HoTT.Basics
  HoTT.Types
  HoTT.Truncations.Core.

Declare Scope mc_scope.
Delimit Scope mc_scope with mc.
Global Open Scope mc_scope.

Generalizable Variables A B f g x y.

Monomorphic Universe Ularge Uhuge.
Monomorphic Constraint Ularge < Uhuge.

Lemma merely_destruct {A} {P : Type} {sP : IsHProp P}
  (x : merely A) : (A -> P) -> P.
Proof.
intros E;revert x.
apply Trunc_ind.
- apply _.
- exact E.
Qed.

Notation " g ∘ f " := (Compose g f)%mc.
Notation "(∘)" := Compose (only parsing) : mc_scope.

Definition id {A : Type} (a : A) := a.

Notation "(=)" := paths (only parsing) : mc_scope.
Notation "( x =)" := (paths x) (only parsing) : mc_scope.
Notation "(= x )" := (fun y => paths y x) (only parsing) : mc_scope.

Notation "(<>)" := (fun x y => ~x = y) (only parsing) : mc_scope.
Notation "( x <>)" := (fun y => x <> y) (only parsing) : mc_scope.
Notation "(<> x )" := (fun y => y <> x) (only parsing) : mc_scope.

Class Apart A := apart : Relation A.
Infix "≶" := apart : mc_scope.
Notation "(≶)" := apart (only parsing) : mc_scope.
Notation "( x ≶)" := (apart x) (only parsing) : mc_scope.
Notation "(≶ x )" := (fun y => apart y x) (only parsing) : mc_scope.

(* Even for setoids with decidable equality x <> y does not imply x ≶ y.
Therefore we introduce the following class. *)
Class TrivialApart A {Aap : Apart A} :=
  { trivial_apart_prop : is_mere_relation A apart
  ; trivial_apart : forall x y, x ≶ y <-> x <> y }.
#[export] Existing Instance trivial_apart_prop.

Definition sig_apart `{Apart A} (P: A -> Type) : Apart (sig P) := fun x y => x.1 ≶ y.1.
#[export]
Hint Extern 10 (Apart (sig _)) => apply @sig_apart : typeclass_instances.

Class Cast A B := cast: A -> B.
Arguments cast _ _ {Cast} _.
Notation "' x" := (cast _ _ x) : mc_scope.
#[global] Typeclasses Transparent Cast.

(* Other canonically named relations/operations/constants: *)
Class SgOp A := sg_op: A -> A -> A.
Class MonUnit A := mon_unit: A.
Class Plus A := plus: A -> A -> A.
Class Mult A := mult: A -> A -> A.
Class One A := one: A.
Class Zero A := zero: A.
Class Negate A := negate: A -> A.
Class DecRecip A := dec_recip: A -> A.
Definition ApartZero R `{Zero R} `{Apart R} := sig (≶ zero).
Class Recip A `{Apart A} `{Zero A} := recip: ApartZero A -> A.
#[global] Typeclasses Transparent SgOp MonUnit Plus Mult Zero One Negate.

Class Meet A := meet: A -> A -> A.
Class Join A := join: A -> A -> A.
Class Top A := top: A.
Class Bottom A := bottom: A.
#[global] Typeclasses Transparent Meet Join Top Bottom.

Class Le A := le: Relation A.
Class Lt A := lt: Relation A.
#[global] Typeclasses Transparent Le Lt.

Definition NonNeg R `{Zero R} `{Le R} := sig (le zero).
Definition Pos R `{Zero R} `{Lt R} := sig (lt zero).
Definition NonPos R `{Zero R} `{Le R} := sig (fun y => le y zero).

Global Instance plus_is_sg_op `{f : Plus A} : SgOp A := f.
Global Instance mult_is_sg_op `{f : Mult A} : SgOp A := f.
Global Instance one_is_mon_unit `{c : One A} : MonUnit A := c.
Global Instance zero_is_mon_unit `{c : Zero A} : MonUnit A := c.
Global Instance meet_is_sg_op `{f : Meet A} : SgOp A := f.
Global Instance join_is_sg_op `{f : Join A} : SgOp A := f.
Global Instance top_is_mon_unit `{s : Top A} : MonUnit A := s.
Global Instance bottom_is_mon_unit `{s : Bottom A} : MonUnit A := s.

#[export]
Hint Extern 4 (Apart (ApartZero _)) => apply @sig_apart : typeclass_instances.
#[export]
Hint Extern 4 (Apart (NonNeg _)) => apply @sig_apart : typeclass_instances.
#[export]
Hint Extern 4 (Apart (Pos _)) => apply @sig_apart : typeclass_instances.

(* Notations: *)
Declare Scope mc_add_scope.
Infix "+" := sg_op : mc_add_scope.
Notation "(+)" := sg_op (only parsing) : mc_add_scope.
Notation "( x +)" := (sg_op x) (only parsing) : mc_add_scope.
Notation "(+ x )" := (fun y => sg_op y x) (only parsing) : mc_add_scope.

Declare Scope mc_mult_scope.
Infix "*" := sg_op : mc_mult_scope.
Notation "( x *.)" := (sg_op x) (only parsing) : mc_mult_scope.
Notation "(.*.)" := sg_op (only parsing) : mc_mult_scope.
Notation "(.* x )" := (fun y => sg_op y x) (only parsing) : mc_mult_scope.

Infix "+" := plus : mc_scope.
Notation "(+)" := plus (only parsing) : mc_scope.
Notation "( x +)" := (plus x) (only parsing) : mc_scope.
Notation "(+ x )" := (fun y => y + x) (only parsing) : mc_scope.

Infix "*" := mult : mc_scope.
(* We don't add "( * )", "( * x )" and "( x * )" notations
   because they conflict with comments. *)
Notation "( x *.)" := (mult x) (only parsing) : mc_scope.
Notation "(.*.)" := mult (only parsing) : mc_scope.
Notation "(.* x )" := (fun y => y * x) (only parsing) : mc_scope.

Notation "- x" := (negate x) : mc_scope.
Notation "(-)" := negate (only parsing) : mc_scope.
Notation "x - y" := (x + -y) : mc_scope.

Notation "0" := zero : mc_scope.
Notation "1" := one : mc_scope.
Notation "2" := (1 + 1) : mc_scope.
Notation "3" := (1 + (1 + 1)) : mc_scope.
Notation "4" := (1 + (1 + (1 + 1))) : mc_scope.
Notation "5" := (1 + (1 + (1 + (1 + 1)))) : mc_scope.
Notation "6" := (1 + (1 + (1 + (1 + (1 + 1))))) : mc_scope.
Notation "- 1" := (-(1)) : mc_scope.
Notation "- 2" := (-(2)) : mc_scope.
Notation "- 3" := (-(3)) : mc_scope.
Notation "- 4" := (-(4)) : mc_scope.

Notation "/ x" := (dec_recip x) : mc_scope.
Notation "(/)" := dec_recip (only parsing) : mc_scope.
Notation "x / y" := (x * /y) : mc_scope.

Notation "// x" := (recip x) : mc_scope.
Notation "(//)" := recip (only parsing) : mc_scope.
Notation "x // y" := (x * //y) : mc_scope.

Notation "⊤" := top : mc_scope.
Notation "⊥" := bottom : mc_scope.

Infix "⊓" := meet : mc_scope.
Notation "(⊓)" := meet (only parsing) : mc_scope.
Notation "( X ⊓)" := (meet X) (only parsing) : mc_scope.
Notation "(⊓ X )" := (fun Y => Y ⊓ X) (only parsing) : mc_scope.

Infix "⊔" := join : mc_scope.
Notation "(⊔)" := join (only parsing) : mc_scope.
Notation "( X ⊔)" := (join X) (only parsing) : mc_scope.
Notation "(⊔ X )" := (fun Y => Y ⊔ X) (only parsing) : mc_scope.

Infix "≤" := le : mc_scope.
Notation "(≤)" := le (only parsing) : mc_scope.
Notation "( x ≤)" := (le x) (only parsing) : mc_scope.
Notation "(≤ x )" := (fun y => y ≤ x) (only parsing) : mc_scope.

Infix "<=" := le (only parsing) : mc_scope.
Notation "(<=)" := le (only parsing) : mc_scope.
Notation "( x <=)" := (le x) (only parsing) : mc_scope.
Notation "(<= x )" := (fun y => y ≤ x) (only parsing) : mc_scope.

Infix "<" := lt : mc_scope.
Notation "(<)" := lt (only parsing) : mc_scope.
Notation "( x <)" := (lt x) (only parsing) : mc_scope.
Notation "(< x )" := (fun y => y < x) (only parsing) : mc_scope.

Notation "x ≤ y ≤ z" := (x ≤ y /\ y ≤ z) : mc_scope.
Notation "x ≤ y < z" := (x ≤ y /\ y < z) : mc_scope.
Notation "x < y < z" := (x < y /\ y < z) : mc_scope.
Notation "x < y ≤ z" := (x < y /\ y ≤ z) : mc_scope.

(** It is likely that ≤ and < are transitive (and ≤ reflexive) so inform [auto] of this. *)
Ltac auto_trans := match goal with
                    [ H: ?R ?x ?y, I: ?R ?y ?z |- ?R ?x ?z] => apply (transitivity H I)
                  end.

#[export]
Hint Extern 2 (?x ≤ ?y) => reflexivity : core.
#[export]
Hint Extern 4 (?x ≤ ?z) => auto_trans : core.
#[export]
Hint Extern 4 (?x < ?z) => auto_trans : core.

Class Abs A `{Le A} `{Zero A} `{Negate A}
  := abs_sig: forall (x : A), { y : A | (0 ≤ x -> y = x) /\ (x ≤ 0 -> y = -x)}.
Definition abs `{Abs A} := fun x : A => (abs_sig x).1.

(* Common properties: *)
(* Class Inverse `(A -> B) : Type := inverse: B -> A.
Arguments inverse {A B} _ {Inverse} _.
Typeclasses Transparent Inverse.
Notation "f ⁻¹" := (inverse f) : mc_scope. *)

Class Idempotent `(f: A -> A -> A) (x : A) : Type := idempotency: f x x = x.
Arguments idempotency {A} _ _ {Idempotent}.

Class UnaryIdempotent {A} (f: A -> A) : Type :=
  unary_idempotent : Idempotent Compose f.
#[export] Existing Instances unary_idempotent.

Lemma unary_idempotency `{UnaryIdempotent A f} x : f (f x) = f x.
Proof.
change (f (f x)) with (Compose f f x).
apply (ap (fun g => g x)).
change (Compose f f = f).
apply idempotency. apply _.
Qed.

Class BinaryIdempotent `(op: A -> A -> A) : Type
  := binary_idempotent : forall x, Idempotent op x.
#[export] Existing Instances binary_idempotent.

Class LeftIdentity {A B} (op : A -> B -> B) (x : A): Type
  := left_identity: forall y, op x y = y.
Class RightIdentity {A B} (op : A -> B -> A) (y : B): Type
  := right_identity: forall x, op x y = x.

Class Absorption {A B C} (op1: A -> C -> A) (op2: A -> B -> C) : Type
  := absorption: forall x y, op1 x (op2 x y) = x.

Class LeftAbsorb {A B} (op : A -> B -> A) (x : A): Type
  := left_absorb: forall y, op x y = x.
Class RightAbsorb {A B} (op : A -> B -> B) (y : B): Type
  := right_absorb: forall x, op x y = y.

Class LeftInverse {A} {B} {C} (op : A -> B -> C) (inv : B -> A) (unit : C)
  := left_inverse: forall x, op (inv x) x = unit.
Class RightInverse {A} {B} {C} (op : A -> B -> C) (inv : A -> B) (unit : C)
  := right_inverse: forall x, op x (inv x) = unit.

Class Commutative {B A} (f : A -> A -> B) : Type
  := commutativity: forall x y, f x y = f y x.

#[global] Typeclasses Transparent Commutative.

Class HeteroAssociative {A B C AB BC ABC}
  (fA_BC: A -> BC -> ABC) (fBC: B -> C -> BC)
  (fAB_C: AB -> C -> ABC) (fAB : A -> B -> AB): Type
  := associativity : forall x y z, fA_BC x (fBC y z) = fAB_C (fAB x y) z.
Class Associative {A} (f : A -> A -> A)
  := simple_associativity : HeteroAssociative f f f f.
#[export] Existing Instances simple_associativity.

Class Involutive {A} (f : A -> A) := involutive: forall x, f (f x) = x.

Class TotalRelation `(R : Relation A) : Type := total : forall x y : A, R x y |_| R y x.
Arguments total {A} _ {TotalRelation} _ _.

Class Trichotomy `(R : Relation A)
  := trichotomy : forall x y : A, R x y |_| x = y |_| R y x.
Arguments trichotomy {A} R {Trichotomy} _ _.

Arguments irreflexivity {A} _ {Irreflexive} _ _.

Class CoTransitive `(R : Relation A) : Type := cotransitive
  : forall x y, R x y -> forall z, hor (R x z) (R z y).
Arguments cotransitive {A R CoTransitive x y} _ _.

Class AntiSymmetric `(R : Relation A) : Type
  := antisymmetry: forall x y, R x y -> R y x -> x = y.
Arguments antisymmetry {A} _ {AntiSymmetric} _ _ _ _.

Class EquivRel `(R : Relation A) : Type := Build_EquivRel
  { EquivRel_Reflexive : Reflexive R ;
    EquivRel_Symmetric : Symmetric R ;
    EquivRel_Transitive : Transitive R }.
#[export] Existing Instances EquivRel_Reflexive EquivRel_Symmetric EquivRel_Transitive.

Definition SigEquivRel {A:Type} (R : Relation A) : Type :=
  {_ : Reflexive R | { _ : Symmetric R | Transitive R}}.

Global Instance trunc_sig_equiv_rel `{Funext} {A : Type}
  (R : Relation A) {n} `{!forall (x y : A), IsTrunc n (R x y)}
  :  IsTrunc n (SigEquivRel R).
Proof.
  apply @istrunc_sigma.
  - apply istrunc_forall.
  - intros. apply @istrunc_sigma; intros; apply istrunc_forall.
Defined.

Lemma issig_equiv_rel {A:Type} (R : Relation A)
  : SigEquivRel R <~> EquivRel R.
Proof.
  issig.
Defined.

Global Instance istrunc_equiv_rel `{Funext} {A : Type}
  (R : Relation A) {n} `{!forall (x y : A), IsTrunc n (R x y)}
  : IsTrunc n (EquivRel R).
Proof.
  exact (istrunc_equiv_istrunc (SigEquivRel R) (issig_equiv_rel R)).
Qed.

Class Conjugate A := conj : A -> A.

Class DistrOpp {A} `(SgOp A) `(Conjugate A)
  := distropp : forall x y : A, conj (sg_op x y) = sg_op (conj y) (conj x).

Class SwapOp {A} `(Negate A) `(Conjugate A)
  := swapop : forall x, conj (-x) = - (conj x).

Class FactorNegLeft {A} `(Negate A) `(SgOp A)
  := factorneg_l : forall x y, sg_op (-x) y = - (sg_op x y).

Class FactorNegRight {A} `(Negate A) `(SgOp A)
  := factorneg_r : forall x y, sg_op x (-y) = - (sg_op x y).

Class LeftHeteroDistribute {A B C}
  (f : A -> B -> C) (g_r : B -> B -> B) (g : C -> C -> C) : Type
  := distribute_l : forall a b c, f a (g_r b c) = g (f a b) (f a c).
Class RightHeteroDistribute {A B C}
  (f : A -> B -> C) (g_l : A -> A -> A) (g : C -> C -> C) : Type
  := distribute_r: forall a b c, f (g_l a b) c = g (f a c) (f b c).
Class LeftDistribute {A} (f g: A -> A -> A)
  := simple_distribute_l : LeftHeteroDistribute f g g.
#[export] Existing Instances simple_distribute_l.
Class RightDistribute {A} (f g: A -> A -> A)
  := simple_distribute_r : RightHeteroDistribute f g g.
#[export] Existing Instances simple_distribute_r.

Class HeteroSymmetric {A} {T : A -> A -> Type}
  (R : forall {x y}, T x y -> T y x -> Type) : Type
  := hetero_symmetric `(a : T x y) (b : T y x) : R a b -> R b a.

(* Although cancellation is the same as being injective, we want a proper
  name to refer to this commonly used property. *)
Section cancellation.
  Context `(op : A -> A -> A) (z : A).

  Class LeftCancellation := left_cancellation : forall x y, op z x = op z y -> x = y.
  Class RightCancellation := right_cancellation : forall x y, op x z = op y z -> x = y.

  Context {Aap : Apart A}.

  Class StrongLeftCancellation := strong_left_cancellation
    : forall x y, x ≶ y -> op z x ≶ op z y.
  Class StrongRightCancellation := strong_right_cancellation
    : forall x y, x ≶ y -> op x z ≶ op y z.
End cancellation.

(* Common names for properties that hold in N, Z, Q, ... *)
Class ZeroProduct A `{!Mult A} `{!Zero A} : Type
  := zero_product : forall x y, x * y = 0 -> x = 0 |_| y = 0.

Class ZeroDivisor {R} `{Zero R} `{Mult R} (x : R) : Type
  := zero_divisor : x <> 0 /\ exists y, y <> 0 /\ x * y = 0.

Class NoZeroDivisors R `{Zero R} `{Mult R} : Type
  := no_zero_divisors x : ~ZeroDivisor x.

Global Instance zero_product_no_zero_divisors `{ZeroProduct A}
  : NoZeroDivisors A.
Proof.
intros x [? [? [? E]]].
destruct (zero_product _ _ E); auto.
Qed.

(* A common induction principle for both the naturals and integers *)
Class Biinduction R `{Zero R} `{One R} `{Plus R} : Type
  := biinduction (P : R -> Type)
  : P 0 -> (forall n, P n <-> P (1 + n)) -> forall n, P n.

(** Additional operations **)
Class CutMinus A := cut_minus : A -> A -> A.
Infix "∸" := cut_minus : mc_scope.
Notation "(∸)" := cut_minus (only parsing) : mc_scope.
Notation "( x ∸)" := (cut_minus x) (only parsing) : mc_scope.
Notation "(∸ y )" := (fun x => x ∸ y) (only parsing) : mc_scope.

Inductive comparison : Set := LT | EQ | GT.

Class Compare A := compare : A -> A -> comparison.
Infix "?=" := compare : mc_scope.
Notation "(?=)" := compare (only parsing) : mc_scope.
Notation "( x ?=)" := (compare x) (only parsing) : mc_scope.
Notation "(?= y )" := (fun x => x ?= y) (only parsing) : mc_scope.

Class Eqb A := eqb : A -> A -> Bool.
Infix "=?" := eqb : mc_scope.
Notation "(=?)" := eqb (only parsing) : mc_scope.
Notation "( x =?)" := (eqb x) (only parsing) : mc_scope.
Notation "(=? y )" := (fun x => x =? y) (only parsing) : mc_scope.

Class Ltb A := ltb : A -> A -> Bool.
Infix "<?" := ltb : mc_scope.
Notation "(<?)" := ltb (only parsing) : mc_scope.
Notation "( x <?)" := (ltb x) (only parsing) : mc_scope.
Notation "(<? y )" := (fun x => x <? y) (only parsing) : mc_scope.

Class Leb A := leb : A -> A -> Bool.
Infix "<=?" := leb : mc_scope.
Notation "(<=?)" := leb (only parsing) : mc_scope.
Notation "( x <=?)" := (leb x) (only parsing) : mc_scope.
Notation "(<=? y )" := (fun x => x <=? y) (only parsing) : mc_scope.

Class Return (M : Type -> Type) := ret : forall {A}, A -> M A.

Class Bind (M : Type -> Type) := bind : forall {A B}, M A -> (A -> M B) -> M B.

Class Enumerable@{i} (A : Type@{i}) :=
  { enumerator : nat -> A
  ; enumerator_issurj : IsSurjection enumerator }.
#[export] Existing Instance enumerator_issurj.
Arguments enumerator A {_} _.
Arguments enumerator_issurj A {_} _.

(*
  The following class is nice to parametrize instances by additional properties, for example:
  [forall z, PropHolds (z <> 0) -> LeftCancellation op z]
  This tool is very powerful as we can combine it with instances as:
  [forall x y, PropHolds (x <> 0) -> PropHolds (y <> 0) -> PropHolds (x * y <> 0)]
  Of course, one should be very careful not to make too many instances as that could
  easily lead to a blow-up of the search space (or worse, cycles).
*)
Class PropHolds (P : Type) := prop_holds: P.

#[export]
Hint Extern 0 (PropHolds _) => assumption : typeclass_instances.

Ltac solve_propholds :=
  match goal with
  | [ |- PropHolds (?P) ] => apply _
  | [ |- ?P ] => change (PropHolds P); apply _
  end.


(** * Homotopy PreCategory of Types *)
Require Import Category.Core Category.Morphisms.
Require Import HoTT.Basics HoTT.Truncations HSet.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope path_scope.

Local Open Scope category_scope.

(** Quoting the HoTT Book:

    Example. There is a precategory whose type of objects is [U] and
    with [hom(X,Y) : ∥X → Y∥₀], and composition defined by induction
    on truncation from ordinary composition [(Y → Z) → (X → Y) → (X →
    Z)]. We call this the homotopy precategory of types. *)

(** We don't want access to all of the internals of this category at top level. *)
Module HomotopyPreCategoryInternals.
  Section homotopy_precategory.
    Local Notation object := Type (only parsing).
    Local Notation morphism s d := (Trunc 0 (s -> d)) (only parsing).

    Definition compose s d d' (m : morphism d d') (m' : morphism s d)
    : morphism s d'.
    Proof.
      revert m'; apply Trunc_rec; intro m'.
      revert m; apply Trunc_rec; intro m.
      apply tr.
      exact (m o m')%core.
    Defined.

    Definition identity x : morphism x x
      := tr idmap.

    Global Arguments compose [s d d'] m m' / .
    Global Arguments identity x / .
  End homotopy_precategory.
End HomotopyPreCategoryInternals.

(** ** The Homotopy PreCategory of Types *)
Definition homotopy_precategory : PreCategory.
Proof.
  refine (@Build_PreCategory
            Type
            _
            (@HomotopyPreCategoryInternals.identity)
            (@HomotopyPreCategoryInternals.compose)
            _
            _
            _
            _);
  simpl; intros;
  repeat match goal with
           | [ m : Trunc _ _ |- _ ]
             => revert m;
               apply Trunc_ind;
               [ intro;
                 match goal with
                   | [ |- IsHSet (?a = ?b :> ?T) ]
                     => generalize a b; intros;
                        let H := fresh in
                        assert (H : forall x y : T, IsHProp (x = y))
                 end;
                 typeclasses eauto
               | intro ]
         end;
  simpl;
  apply ap;
  exact idpath.
Defined.


From Coq Require Import ssreflect ssrfun ssrbool.
From Coq Require Import FunctionalExtensionality.
From Mon Require Export Base.
From Coq Require Import Relation_Definitions Morphisms RelationPairs.
From Mon Require Import SPropBase SPropMonadicStructures.
From Relational Require Import OrderEnrichedCategory Rel.

Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

(** This files is an order-enriched alternative to RelativeMonadExamples.v *)

Section TypeCat.

  Import SPropNotations.
  Record strictSet :=
    mkStrictSet
      { sSet_carrier :> Type
      ; is_strict : forall (x y : sSet_carrier), x = y -> x = y
      }.

  (* The category of types *)
  Program Definition TypeCat : ord_category :=
    mkOrdCategory Type (* strictSet *)
               (fun A B => A -> B)
               (fun _ _ f g => forall x, f x = g x) _
               (fun A a => a)
               (fun _ _ _ f g x => f (g x))
               _ _ _ _.
  Next Obligation. constructor ; cbv ; intuition ; etransitivity ; eauto. Qed.
  Next Obligation. cbv ; intuition. induction (H0 x1). apply H. Qed.

  Import SPropNotations.
  (* TypeCat × TypeCat *)
  Definition TypeCatSq := prod_cat TypeCat TypeCat.

  (* Functor × : TypeCat × TypeCat → TypeCat *)
  Program Definition typeCat_prod : ord_functor TypeCatSq TypeCat :=
    mkOrdFunctor (fun A => nfst A × nsnd A)
              (fun _ _ f p => ⟨nfst f (nfst p), nsnd f (nsnd p)⟩)
              _ _ _.
  Next Obligation. cbv ; intuition; f_equiv; auto.
  Qed.

  (* Program Definition TypeCat_cc : cartesian_category := *)
  (*   mkCartesianCategory *)
  (*     TypeCat *)
  (*     unit *)
  (*     (mkNatTrans _ _ (fun _ _ => tt) _) *)
  (*     typeCat_prod *)
  (*     (mkNatTrans _ _ (fun=>nfst) _) *)
  (*     (mkNatTrans _ _ (fun=>nsnd) _) *)
  (*     (fun X A B f g x => ⟨f x, g x⟩) *)
  (*     _ _ _ _ _. *)
  (* Next Obligation. cbv ; intuition. rewrite H H0=> //. Qed. *)
  (* Next Obligation. destruct (f x)=> //. Qed. *)
End TypeCat.

Section OrdCat.
  Import SPropNotations.
  (* Category of preordered types *)
  Definition ordType := {A : Type ⫳ { R : relation A | PreOrder R } }.
  Definition extract_ord {A : ordType} := proj1_sig (dsnd A).
  Definition extract_ord_preord A : PreOrder (@extract_ord A) := proj2_sig (dsnd A).
  Global Existing Instance extract_ord_preord.
  Notation " x ≤ y " := (extract_ord x y) (at level 70).

  Program Definition OrdCat : ord_category :=
    mkOrdCategory
      ordType
      (fun A B => {f : dfst A -> dfst B | Proper (extract_ord ==> extract_ord) f})
      (fun _ _ f g => forall x, f∙1 x ≤ g∙1 x) _
      (fun A => ⦑id⦒)
      (fun _ _ _ f g => ⦑f∙1 \o g∙1⦒)
      _ _ _ _.
  Next Obligation. constructor.
    intuition.
    unfold Transitive. intros f g h. intros H G x.
    pose Hx := (H x). pose GX := (G x). etransitivity.
    apply Hx. apply GX.
  Qed.
  Next Obligation. cbv ; intuition. Qed.
  Next Obligation. cbv ; intuition. apply H3; apply H2 => //. Qed.
  Next Obligation.
    cbv ; intuition; etransitivity; first (apply: x∙2; apply: H0).
    apply: H.
  Qed.
  Next Obligation. apply sig_eq ; compute.
    rewrite -FunctionalExtensionality.eta_expansion. reflexivity.
  Qed.
  Next Obligation. apply sig_eq ; compute.
    rewrite -FunctionalExtensionality.eta_expansion. reflexivity.
  Qed.
  Next Obligation.
    apply sig_eq ; compute. reflexivity.
  Qed.

  Program Definition discr : ord_functor TypeCat OrdCat :=
    mkOrdFunctor (fun A => dpair _ A ⦑eq⦒)
                 (fun _ _ f => ⦑ f ⦒)
              _ _ _.
  Next Obligation. intuition. Qed.
  Next Obligation. intuition. Qed.
  Next Obligation. cbv ; intuition. Qed.
  Next Obligation. apply sig_eq. reflexivity. Qed.
  Next Obligation. apply sig_eq. compute. reflexivity. Qed.

  Program Definition discr_ff : ff_struct discr :=
    {| ff_invmap _ _ f := proj1_sig f |}.
  Next Obligation. cbv ; intuition. Qed.

  Notation " X ---> Y " := (X -> dfst Y) (at level 99).

  Program Definition to_discr {X Y} (f : X ---> Y) : OrdCat⦅discr X; Y⦆ := ⦑f⦒.
  Next Obligation. apply sig_eq. compute. reflexivity. Qed.

  Program Definition OrdCat_cst {A B} (b:dfst B) : OrdCat⦅A; B⦆ := ⦑fun=> b⦒.
  Next Obligation. cbv; intuition. Qed.

  Lemma ordCat_helper {A B} (f g : OrdCat⦅A;B⦆) :
    f ⪷ g -> forall (x y:dfst A), x ≤ y -> f∙1 x ≤ g∙1 y.
  Proof.
    move=> Hfg x y Hxy; etransitivity;[apply: (f∙2); exact: Hxy| apply: Hfg].
  Qed.
  Next Obligation. compute. intros x y. intros Exy ; rewrite Exy.
    destruct Y as [A eA]. destruct eA as [R poR].
    destruct poR. apply PreOrder_Reflexive.
  Qed.
End OrdCat.

(* Re-exporting the notation *)
Module OrderEnrichedRelativeMonadExamplesNotation.

  Notation " x ≤ y " :=
    (extract_ord x y) (at level 70) : SPropMonadicStructures_scope.
  Notation " X ---> Y " :=
    (X -> dfst Y) (at level 99) : SPropMonadicStructures_scope.

End OrderEnrichedRelativeMonadExamplesNotation.

Import OrderEnrichedRelativeMonadExamplesNotation.

Section OrdProduct.
  Context {A B} (relA : relation A) (relB : relation B)
          `{!PreOrder relA, !PreOrder relB}.

  Definition prod_rel : relation (A × B) :=
    relation_conjunction (@RelCompFun (A × B) A relA nfst)
                          (RelCompFun relB nsnd).

  Global Instance : PreOrder prod_rel.
  Proof. constructor ; cbv ; intuition ; etransitivity ; eassumption. Qed.
End OrdProduct.

(** Embedding of the monads from the unary setting into relative monads *)

Definition rMonad := ord_relativeMonad (ord_functor_id TypeCat).
Definition unarySpecMonad := ord_relativeMonad discr.
Definition unaryEffectObs M W := relativeMonadMorphism discr (natIso_sym (ord_functor_unit_left _)) M W.

Section UnarySpecMonadOps.
  Import SPropNotations.
  Definition retW {W : unarySpecMonad} {A} : A ---> W A := (ord_relmon_unit W A)∙1.
  Definition bindWStr {W : unarySpecMonad} {Γ A B}
              (wm: Γ ---> W A) (wf : Γ × A ---> W B) : Γ ---> W B :=
    fun γ => (ord_relmon_bind W (to_discr (fun a => wf⟨γ, a⟩)))∙1 (wm γ).
End UnarySpecMonadOps.

Section MonadAsRMonad.
  Context (M:Monad).
  Import FunctionalExtensionality.

  (* Transforming a standard monad to a relative monad on the identity functor *)
  Program Definition monad_to_relmon : rMonad :=
    mkOrdRelativeMonad M (fun A => @ret M A) (fun A B f => bind^~ f) _ _ _ _.
  Next Obligation. cbv ; intuition. induction (@functional_extensionality_dep _ _ _ _ H)=> //. Qed.
  Next Obligation. extensionality c ; rewrite /bind monad_law2 //. Qed.
  Next Obligation. extensionality c ; rewrite /bind monad_law1 //. Qed.
  Next Obligation. extensionality c ; rewrite /bind monad_law3 //. Qed.
End MonadAsRMonad.

Section OrderedMonadAsRMonad.
  Context (M:OrderedMonad).

  Import SPropNotations.
  Import FunctionalExtensionality.
  (* Any unary specification monad in the sense of [Dijkstra monads for All] give raise to a relative monad *)
  Program Definition ordmonad_to_relmon : unarySpecMonad :=
    mkOrdRelativeMonad (fun A => dpair _ (M A) ⦑@omon_rel M A⦒)
                       (fun A => ⦑@ret M A⦒)
                       (fun A B f => ⦑bind^~ (proj1_sig f)⦒) _ _ _ _.
  Next Obligation. typeclasses eauto. Qed.
  Next Obligation. cbv ; intuition ; induction H ; reflexivity. Qed.
  Next Obligation.
    cbv ; intuition. apply omon_bind=> //= ?. apply H; reflexivity.
  Qed.
  Next Obligation. cbv ; intuition. apply omon_bind=> //. reflexivity. Qed.
  Next Obligation. apply sig_eq; extensionality x ; rewrite /= /bind monad_law2 //. Qed.
  Next Obligation. apply sig_eq; extensionality x ; rewrite /= /bind monad_law1 //. Qed.
  Next Obligation. apply sig_eq; extensionality x ; rewrite /= /bind monad_law3 //. Qed.

End OrderedMonadAsRMonad.

Section MonadMorphismAsRMonMorphism.
  Context {M0:Monad} {W0:OrderedMonad} (θ0:MonadMorphism M0 W0).
  Let M := monad_to_relmon M0.
  Let W := ordmonad_to_relmon W0.
  Let θ := from_discrete_monad_monotonic θ0.

  Import SPropNotations.
  Import FunctionalExtensionality.
  (* morphisms of monads also transfer to relativeMonad morphisms *)

  Program Definition mmorph_to_rmmorph : unaryEffectObs M W :=
    mkRelMonMorph discr _ M W (fun (A:TypeCat) => ⦑θ A⦒) _ _.
  Next Obligation. cbv ; intros ; induction H ; reflexivity. Qed.
  Next Obligation.
    apply sig_eq=> /=; extensionality a=> /=; rewrite mon_morph_ret //.
  Qed.
  Next Obligation.
    apply sig_eq ; extensionality a ; rewrite /= mon_morph_bind //.
  Qed.

End MonadMorphismAsRMonMorphism.

(** Specialization of relative monads for the simple setting *)

Section SimpleRelationalSpecMonad.

  Definition Jprod := ord_functor_comp typeCat_prod discr.

  (* Simple relational specification  monad *)
  Definition RelationalSpecMonad0 : Type := ord_relativeMonad Jprod.

  Import SPropNotations.

  Let idxid := (prod_functor (ord_functor_id TypeCat) (ord_functor_id TypeCat)).
  Program Definition idxid_iso_id : natIso idxid (ord_functor_id TypeCatSq) :=
    mkNatIso _ _ (fun=> Id _) (fun=> Id _) _ _ _.

  Definition compPairRMonad (M1 M2 : rMonad): ord_relativeMonad (ord_functor_id TypeCatSq) :=
    rmon_transp_natIso (product_rmon M1 M2) idxid_iso_id.

  Context (M01 M02 : Monad).
  Let M1 := monad_to_relmon M01.
  Let M2 := monad_to_relmon M02.

  Definition compPair := compPairRMonad M1 M2.

  Definition to_prod {A1 A2 B1 B2} (f1 : A1 -> M01 B1) (f2 : A2 -> M02 B2)
             : TypeCatSq⦅ ⟨A1,A2⟩ ; compPair ⟨B1, B2⟩⦆ := ⟨f1 , f2⟩.

  Definition RelationalEffectObservation0 (W:RelationalSpecMonad0) : Type :=
    relativeMonadMorphism Jprod (natIso_sym (ord_functor_unit_left _)) compPair W.

  Definition RelationalLaxEffectObservation0 (W:RelationalSpecMonad0) : Type :=
    relativeLaxMonadMorphism Jprod (natIso_sym (ord_functor_unit_left _)) compPair W.

  Definition mkREO0 (W:RelationalSpecMonad0) θ pf1 pf2
    : RelationalEffectObservation0 W
    := @mkRelMonMorph _ _ _ _ _ _ _ _ _ θ pf1 pf2.

  Definition mkRLEO0 (W:RelationalSpecMonad0) θ pf1 pf2
    : RelationalLaxEffectObservation0 W
    := @mkRelLaxMonMorph _ _ _ _ _ _ _ _ _ θ pf1 pf2.

End SimpleRelationalSpecMonad.

(* Any unary specification monad yield a simple relational spec monad
   when precomposing with the product functor *)
Section RelationalSpecMonadZeroFromOrderedMonad.
  Context (M:OrderedMonad).

  Definition ordmonad_to_relspecmon0 := relativeMonad_precomposition typeCat_prod (ordmonad_to_relmon M).

End RelationalSpecMonadZeroFromOrderedMonad.

Notation "wm |= wf" := (proj1_sig (ord_relmon_bind _ wf) wm) (at level 50).

(** Specialization of relative monads for the full setting *)
(* A direct definition using the lifting condition is difficult to use with
intensional equality, so we encode exactly the components we need *)

Section NaiveDefinition.
  Definition discr2 := prod_functor discr discr.
  Definition unarySpecPair (W1 W2 : unarySpecMonad)
    : ord_relativeMonad discr2 :=
      product_rmon W1 W2.

  (* Changing this Let to Definition breaks RSM_from_RSM0 below... *)
  Definition OrdCatSq := prod_cat OrdCat OrdCat.
  Definition OrdCatTr := prod_cat OrdCatSq OrdCat.

  Program Definition J : ord_functor TypeCatSq OrdCatTr :=
    mkOrdFunctor (fun A => ⟨⟨discr (nfst A), discr (nsnd A)⟩, Jprod A⟩)
                 (fun _ _ f => ⟨⟨ofmap discr (nfst f),
                              ofmap discr (nsnd f)⟩,
                             ofmap Jprod f⟩) _ _ _.
  Next Obligation. cbv ; intuition ; f_equiv ; auto.
  Qed.
  Next Obligation.
    apply nprod_eq ; simpl. apply nprod_eq ; simpl.
    all : compute ; f_equal ; apply ax_proof_irrel.
  Qed.
  Next Obligation.
    apply nprod_eq ; simpl. apply nprod_eq ; simpl.
    all: compute ; f_equal ; apply ax_proof_irrel.
  Qed.

  Definition ordcatTr2Sq : ord_functor OrdCatTr OrdCatSq :=
    left_proj_functor _ _.

  Program Definition discr2_iso_J_proj
    : natIso discr2 (ord_functor_comp J ordcatTr2Sq) :=
    mkNatIso _ _ (fun A => Id (discr2 A)) (fun A => Id (discr2 A)) _ _ _.
  Next Obligation.
    apply nprod_eq ; simpl. f_equal. apply ax_proof_irrel.
    apply f_equal. apply ax_proof_irrel.
  Qed.
  Next Obligation.
    apply nprod_eq ; simpl ; f_equal. all: apply ax_proof_irrel.
  Qed.
  Next Obligation.
    apply nprod_eq ; simpl ; f_equal. all: apply ax_proof_irrel.
  Qed.

  Definition preRelationalSpecMonad : Type := ord_relativeMonad J.

  (* Relational specification monads are pre-relational specification monads
   satisfying a lifting condition ensuring that the first and second components
   define unary spec monads *)

  (* Record RelationalSpecMonad  := *)
  (*   mkRSM { *)
  (*       rsm_left : unarySpecMonad ; *)
  (*       rsm_right : unarySpecMonad ; *)
  (*       rsm_rel : lifting_of *)
  (*                   J ordcatTr2Sq discr2_iso_J_proj *)
  (*                   (unarySpecPair rsm_left rsm_right) *)
  (*     }. *)

  (* Context (M01 M02 : Monad). *)
  (* Notation compPair := (compPair M01 M02). *)

  (* Definition preRelationalEffectObservation (W:preRelationalSpecMonad) : Type := *)
  (*   relativeMonadMorphism J (natIso_sym (ord_functor_unit_left _)) compPair W. *)

  (* Definition preRelationalLaxEffectObservation (W:preRelationalSpecMonad) : Type := *)
  (*   relativeLaxMonadMorphism J (natIso_sym (ord_functor_unit_left _)) compPair W. *)

  (* Definition mkpreREO (W:preRelationalSpecMonad) θ pf1 pf2 *)
  (*   : preRelationalEffectObservation W *)
  (*   := @mkRelMonMorph _ _ _ _ _ _ _ _ _ θ pf1 pf2. *)

  (* Definition mkpreRLEO (W:preRelationalSpecMonad) θ pf1 pf2 *)
  (*   : preRelationalLaxEffectObservation W *)
  (*   := @mkRelLaxMonMorph _ _ _ _ _ _ _ _ _ θ pf1 pf2. *)

  (* Program Definition πord1 {A B} : OrdCat⦅Jprod ⟨A, B⟩ ; discr A⦆ := ⦑ nfst ⦒. *)
  (* Next Obligation. intuition. Qed. *)

  (* Program Definition πord2 {A B} : OrdCat⦅Jprod ⟨A, B⟩ ; discr B⦆ := ⦑ nsnd ⦒. *)
  (* Next Obligation. intuition. Qed. *)

  (* Lemma sig_rew {A P} {x y : A} {Hx Hy} *)
  (*   : x = y -> exist P x Hx = exist P y Hy. *)
  (* Proof. move=> ? ; apply sig_eq=> //. Qed. *)

  (* Import FunctionalExtensionality. *)
  (* (* Any simple relational specification monad yield a full relational specification monad *) *)
  (* Program Definition RSM_from_RSM0 (W : RelationalSpecMonad0) : preRelationalSpecMonad := *)
  (*   mkOrdRelativeMonad *)
  (*     (fun A => ⟨⟨W ⟨nfst A, unit⟩, W ⟨unit, nsnd A⟩⟩, W A⟩) *)
  (*                   (fun A => ⟨⟨⦑fun a => proj1_sig (ord_relmon_unit W ⟨nfst A, unit⟩) ⟨a,tt⟩⦒, *)
  (*                            ⦑fun a => proj1_sig (ord_relmon_unit W ⟨unit, nsnd A⟩) ⟨tt, a⟩⦒⟩, *)
  (*                           ord_relmon_unit W A⟩) *)
  (*                   (fun A B f => *)
  (*                      ⟨⟨ ord_relmon_bind W (nfst (nfst f) ∙ πord1), *)
  (*                        ord_relmon_bind W (nsnd (nfst f) ∙ πord2)⟩, *)
  (*                       ord_relmon_bind W (nsnd f)⟩) *)
  (*                   _ _ _ _. *)
  (* Next Obligation. cbv ; intuition. induction H. sreflexivity. Qed. *)
  (* Next Obligation. cbv ; intuition. induction H. sreflexivity. Qed. *)
  (* Next Obligation. *)
  (*   cbv ; intuition; *)
  (*     apply (ord_relmon_bind_proper W ⟨_,_⟩ _ _ _)=> ?; *)
  (*     [apply p0| apply q0| apply q]. *)
  (* Qed. *)
  (* Next Obligation. *)
  (*   intuition. *)
  (*   f_equal;[f_equal|]; apply: sig_eq=> /=. *)
  (*   1,2: set f := ⦑_⦒; have -> : f = ord_relmon_unit W ⟨_,_⟩. *)
  (*   all: try by rewrite ord_relmon_law1. *)
  (*   apply sig_eq; extensionality x; move: x=> [? []] //. *)
  (*   apply sig_eq; extensionality x; move: x=> [[] ?] //. *)
  (* Qed. *)
  (* Next Obligation. *)
  (*   intuition. *)
  (*   f_equal;[f_equal|]; apply: sig_eq=> /=. *)
  (*   - extensionality x; set f := ⦑_⦒. *)
  (*     move: (ord_relmon_law2 W ⟨_,unit⟩ _ f)=> /(f_equal proj1_sig) /(equal_f ^~ ⟨_, _⟩)//=. *)
  (*   - extensionality x; set f := ⦑_⦒. *)
  (*     move: (ord_relmon_law2 W ⟨unit,_⟩ _ f)=> /(f_equal proj1_sig) /(equal_f ^~ ⟨_, _⟩)//=. *)
  (*   - move: (ord_relmon_law2 W _ _ nsnd) => /(f_equal proj1_sig) //. *)
  (* Qed. *)
  (* Next Obligation. *)
  (*   intuition ; cbv. *)
  (*   f_equal;[f_equal|]; apply: sig_eq=> /=. (* ; extensionality x. *) *)
  (*   - epose (ord_relmon_law3 W ⟨ _, unit⟩ ⟨_, unit⟩ _ *)
  (*                      ⦑fun x1 => proj1_sig nfst1 (Base.nfst x1) ⦒ *)
  (*                      ⦑fun x0 => proj1_sig nfst (Base.nfst x0)⦒) as s. *)
  (*     extensionality x; move: s => /(f_equal proj1_sig) /(equal_f ^~ x) s; apply s. *)
  (*   - epose (ord_relmon_law3 W ⟨unit, _⟩ ⟨unit, _⟩ _ *)
  (*                      ⦑fun x1 => proj1_sig nsnd1 (Base.nsnd x1) ⦒ *)
  (*                      ⦑fun x0 => proj1_sig nsnd2 (Base.nsnd x0)⦒) as s. *)
  (*     extensionality x; move: s => /(f_equal proj1_sig) /(equal_f ^~ x) s; apply s. *)
  (*   - rewrite ord_relmon_law3=> //. *)
  (* Qed. *)

End NaiveDefinition.

Section RelationalSpecMonad.

  Record rsm_components (W1 W2 : unarySpecMonad) :=
    mkRSMComponents
      { rsmc_carrier :> TypeCatSq -> OrdCat
      ; rsmc_return : forall A, OrdCat⦅Jprod A; rsmc_carrier A⦆
      ; rsmc_act: forall {A1 A2 B1 B2},
            OrdCat⦅discr A1;W1 B1⦆ -> OrdCat⦅discr A2;W2 B2⦆ ->
            OrdCat⦅Jprod ⟨A1,A2⟩; rsmc_carrier ⟨B1,B2⟩⦆ -> OrdCat⦅rsmc_carrier ⟨A1,A2⟩; rsmc_carrier ⟨B1,B2⟩⦆
      ; rsmc_act_proper :
          forall {A1 A2 B1 B2},
            Proper (ord_cat_le _ ==> ord_cat_le _ ==> ord_cat_le _ ==> ord_cat_le _) (@rsmc_act A1 A2 B1 B2)
      ; rsmc_law1 : forall A1 A2,
          rsmc_act (ord_relmon_unit W1 A1) (ord_relmon_unit W2 A2)
                   (rsmc_return ⟨A1,A2⟩) = Id _
      ; rsmc_law2 :
          forall A1 A2 B1 B2 f1 f2 (f: OrdCat⦅Jprod ⟨A1,A2⟩; rsmc_carrier ⟨B1,B2⟩⦆),
              rsmc_act f1 f2 f ∙ rsmc_return _ = f
      ; rsmc_law3 :
          forall A1 A2 B1 B2 C1 C2 f1 f2 f g1 g2 g,
            @rsmc_act A1 A2 C1 C2
                  (ord_relmon_bind W1 g1 ∙ f1)
                  (ord_relmon_bind W2 g2 ∙ f2)
                  (@rsmc_act B1 B2 C1 C2 g1 g2 g ∙ f)
            = (@rsmc_act B1 B2 C1 C2 g1 g2 g)
                 ∙ (@rsmc_act A1 A2 B1 B2 f1 f2 f)
      }.

  Record RelationalSpecMonad  :=
    mkRSM {
        rsm_left : unarySpecMonad ;
        rsm_right : unarySpecMonad ;
        rsm_rel : rsm_components rsm_left rsm_right
      }.

End RelationalSpecMonad.

Arguments rsmc_carrier {_ _} _ _.
Arguments rsmc_return {_ _} _ _.
Arguments rsmc_act {_ _} _ {_ _ _ _} _ _ _.

Arguments to_prod {_ _ _ _ _ _} _ _.

Section RelationalEffectObservation.

  Context (M1 M2 : rMonad) (M12 := compPairRMonad M1 M2).

  Section RelationalEffectObservationComponents.
    Context {W1 W2 : unarySpecMonad}.
    Context (Wrel : rsm_components W1 W2).
    Context (θ1 : unaryEffectObs M1 W1) (θ2 : unaryEffectObs M2 W2).
    Notation W := (rsmc_carrier Wrel).
    Notation η := (rsmc_return Wrel).
    Notation actW := (rsmc_act Wrel).

    Record reo_components
      :=
      mkREOComponents
        { reoc_carrier : forall {A}, OrdCat⦅Jprod (M12 A);W A⦆
        ; reoc_law1 : forall {A}, reoc_carrier ∙ ofmap Jprod (ord_relmon_unit M12 A) = η A
        ; reoc_law2 : forall {A B} (f:TypeCatSq⦅A;M12 B⦆),
            reoc_carrier ∙ ofmap Jprod (ord_relmon_bind M12 f)
            = actW (θ1 _ ∙ ofmap discr (nfst f))
                  (θ2 _ ∙ ofmap discr (nsnd f))
                  (reoc_carrier ∙ ofmap Jprod f) ∙ reoc_carrier
        }.
  End RelationalEffectObservationComponents.

  Context (W : RelationalSpecMonad).
  Record relationalEffectObservation :=
    mkREO
      { reo_left : unaryEffectObs M1 (rsm_left W)
      ; reo_right : unaryEffectObs M2 (rsm_right W)
      ; reo_rel : reo_components (rsm_rel W) reo_left reo_right
      }.

End RelationalEffectObservation.

Arguments reo_left {_ _ _} _.
Arguments reo_right {_ _ _} _.
Arguments reo_rel {_ _ _} _.

(** The definition that we use provides an instance of the naive def *)
Section ToNaiveDefinitions.
  Context (W : RelationalSpecMonad).

  Notation W1 := (rsm_left W).
  Notation W2 := (rsm_right W).

  Context {M1 M2 : rMonad}
          (θ : relationalEffectObservation M1 M2 W).

  Notation M12 := (compPair M1 M2).
  Notation θ1 := (reo_left θ).
  Notation θ2 := (reo_right θ).

  Notation Wrel := (rsm_rel W).
  Notation W0 := (rsmc_carrier Wrel).
  Notation η := (rsmc_return Wrel).
  Notation actW := (rsmc_act Wrel).

  Import SPropNotations.

  (* We show that we can define the sur-approximation of this coq-development from that data *)
  Local Ltac feq_npair := repeat (congr npair).

  Program Definition W' : preRelationalSpecMonad :=
    mkOrdRelativeMonad (fun A => ⟨⟨W1 (nfst A), W2 (nsnd A)⟩, W0 A⟩)
                    (fun A => ⟨⟨ord_relmon_unit W1 (nfst A), ord_relmon_unit W2 (nsnd A)⟩,
                           η A⟩)
                    (fun A B f =>
                       ⟨⟨ord_relmon_bind W1 (nfst (nfst f)),
                         ord_relmon_bind W2 (nsnd (nfst f))⟩,
                       actW(nfst (nfst f)) (nsnd (nfst f)) (nsnd f)⟩)
                    _ _ _ _.
  Next Obligation.
    cbv ; intuition ; last first.
    apply: rsmc_act_proper=> ?; [apply H| apply H2| apply H1].
      apply (ord_relmon_bind_proper W2). compute. assumption.
      apply: (ord_relmon_bind_proper W1). compute. assumption.
  Qed.

  Next Obligation.
    feq_npair ;[apply: (ord_relmon_law1 W1)| apply: (ord_relmon_law1 W2)|];
    rewrite /actW ?rsmc_law1 //.
  Qed.
  Next Obligation.
    move: f => [[f1 f2] frel].
    unshelve feq_npair.
    apply: (ord_relmon_law2 W1).
    apply: (ord_relmon_law2 W2).
    apply sig_eq, f_equal, rsmc_law2.
  Qed.
  Next Obligation.
    unshelve feq_npair.
    apply: (ord_relmon_law3 W1).
    apply: (ord_relmon_law3 W2).
    apply sig_eq, f_equal, rsmc_law3.
  Qed.

  (* Context (θrc : reo_components θ1 θ2 Wrel). *)
  (* Notation θW := (@reoc_carrier _ _ _ _ _ _ _ θrc ⟨_,_⟩). *)

  (* Program Definition θ : preRelationalEffectObservation M1 M2 W := *)
  (*   mkpreREO M1 M2 W (fun A => ⟨⟨θ1 (nfst A), θ2 (nsnd A)⟩, θW⟩) _ _. *)
  (* Next Obligation. *)
  (*   f_equal ; [f_equal|]; apply sig_eq ; apply: (f_equal proj1_sig). *)
  (*   apply (rmm_law1 _ _ _ _ θ1). *)
  (*   apply (rmm_law1 _ _ _ _ θ2). *)
  (*   apply: reoc_law1. *)
  (* Qed. *)
  (* Next Obligation. *)
  (*   f_equal ; [f_equal|]; apply sig_eq ; apply: (f_equal proj1_sig). *)
  (*   apply (rmm_law2 _ _ _ _ θ1). *)
  (*   apply (rmm_law2 _ _ _ _ θ2). *)
  (*   apply (reoc_law2 θ1 θ2). *)
  (* Qed. *)

End ToNaiveDefinitions.


(** * Prog_Intervals.v: Rules for distributions and intervals *)

Add Rec LoadPath "." as ALEA.

Require Export Prog.
Require Export Intervals.

(* Module Rules (Univ:Universe). *)
(* Module PP := (Proba Univ). *)
(* Import Univ. *)
(* Import PP MP UP. *)

(* begin hide *)
Set Implicit Arguments.
Open Local Scope U_scope.
Open Local Scope O_scope.
(* end hide *)

(** Distributions operates on intervals *)

Definition Imu : forall A:Type, distr A ->  (A -> IU) -> IU.
intros A m F; exists (mu m (fun x => low (F x))) (mu m (fun x => up (F x))).
apply mu_monotonic; auto.
Defined.

Lemma low_Imu : forall (A:Type) (e:distr A) (F: A -> IU),
             low (Imu e F) = mu e (fun x => low (F x)).
trivial.
Save.

Lemma up_Imu : forall (A:Type) (e:distr A) (F: A -> IU),
             up (Imu e F) = mu e (fun x => up (F x)).
trivial.
Save.

Lemma Imu_monotonic : forall (A:Type) (e:distr A) (F G : A -> IU),
            (forall x, Iincl (F x) (G x)) -> Iincl (Imu e F) (Imu e G).
unfold Iincl,Imu; simpl; intuition.
apply (mu_monotonic e); intro x; case (H x); auto.
apply (mu_monotonic e); intro x; case (H x); auto.
Save.

Lemma Imu_stable_eq : forall (A:Type) (e:distr A) (F G : A -> IU),
            (forall x, Ieq (F x) (G x)) -> Ieq (Imu e F) (Imu e G).
unfold Ieq,Imu; simpl; intuition.
apply (mu_stable_eq e); intro x; case (H x); auto.
apply (mu_stable_eq e); intro x; case (H x); auto.
Save.
Hint Resolve Imu_monotonic Imu_stable_eq.

Lemma Imu_singl : forall (A:Type) (e:distr A) (f:A -> U),
           Ieq (Imu e (fun x => singl (f x))) (singl (mu e f)).
unfold Ieq,Imu,singl; simpl; intuition.
Save.

Lemma Imu_inf : forall (A:Type) (e:distr A) (f:A -> U),
           Ieq (Imu e (fun x => inf (f x))) (inf (mu e f)).
unfold Ieq,Imu,inf; simpl; intuition.
Save.

Lemma Imu_sup : forall (A:Type) (e:distr A) (f:A -> U),
           Iincl (Imu e (fun x => sup (f x))) (sup (mu e f)).
unfold Iincl,Imu,inf; simpl; intuition.
Save.

Lemma Iin_mu_Imu :
   forall (A:Type) (e:distr A) (F:A -> IU) (f:A -> U),
           (forall x, Iin (f x) (F x)) -> Iin (mu e f) (Imu e F).
unfold Iin,Imu; simpl; split.
apply (mu_monotonic e); intro x; case (H x); auto.
apply (mu_monotonic e); intro x; case (H x); auto.
Save.
Hint Resolve Iin_mu_Imu.

Definition Iok (A:Type) (I:IU) (e:distr A) (F:A -> IU) := Iincl (Imu e F) I.
Definition Iokfun (A B:Type)(I:A -> IU) (e:A -> distr B) (F:A -> B -> IU)
               := forall x, Iok (I x) (e x) (F x).

Lemma Iin_mu_Iok :
   forall (A:Type) (I:IU) (e:distr A) (F:A -> IU) (f:A -> U),
           (forall x, Iin (f x) (F x)) -> Iok I e F -> Iin (mu e f) I.
intros; apply Iincl_in with (Imu e F); auto.
Save.

(** *** Stability *)
Lemma Iok_le_compat : forall (A:Type) (I J:IU) (e:distr A) (F G:A -> IU),
   Iincl I J -> (forall x, Iincl (G x) (F x)) -> Iok I e F -> Iok J e G.
unfold Iok; intros; apply Iincl_trans with I; auto.
apply Iincl_trans with (Imu e F); auto.
Save.

Lemma Iokfun_le_compat : forall (A B:Type) (I J:A -> IU) (e:A -> distr B) (F G:A -> B -> IU),
   (forall x, Iincl (I x) (J x)) -> (forall x y, Iincl (G x y) (F x y)) -> Iokfun I e F -> Iokfun J e G.
unfold Iokfun; intros; apply Iok_le_compat with (I x) (F x); auto.
Save.

(** *** Rule for values *)

Lemma Iunit_eq : forall (A: Type) (a:A) (F:A -> IU), Ieq (Imu (Munit a) F) (F a).
intros; unfold Ieq,Imu,Munit; auto.
Save.

(** *** Rule for application *)

Lemma Ilet_eq : forall (A B : Type) (a:distr A) (f:A -> distr B)(I:IU)(G:B -> IU),
   Ieq (Imu (Mlet a f) G) (Imu a (fun x => Imu (f x) G)).
unfold Ieq,Imu,Mlet,Iincl; simpl; intuition.
Save.
Hint Resolve Ilet_eq.

Lemma Iapply_rule : forall (A B : Type) (a:distr A) (f:A -> distr B)(I:IU)(F:A -> IU)(G:B -> IU),
    Iok I a F -> Iokfun F f (fun x => G) -> Iok I (Mlet a f) G.
unfold Iokfun,Iok;intros.
apply Ieq_incl_trans with (Imu a (fun x => Imu (f x) G)); auto.
apply Iincl_trans with (Imu a F); auto.
Save.

(** *** Rule for abstraction *)
Lemma Ilambda_rule : forall (A B:Type)(f:A -> distr B)(F:A -> IU)(G:A -> B -> IU),
   (forall x:A, Iok (F x) (f x) (G x)) -> Iokfun F f G.
trivial.
Save.

(** *** Rule for conditional *)

Lemma Imu_Mif_eq : forall (A:Type)(b:distr bool)(f1 f2:distr A)(F:A -> IU),
 Ieq (Imu (Mif b f1 f2) F) (Iplus (Imultk (mu b B2U) (Imu f1 F)) (Imultk (mu b NB2U) (Imu f2 F))).
red; intros.
rewrite low_Imu; rewrite up_Imu.
repeat rewrite Mif_eq.
repeat rewrite low_Iplus; repeat rewrite low_Imultk.
repeat rewrite up_Iplus; repeat rewrite up_Imultk.
repeat rewrite low_Imu; repeat rewrite up_Imu; auto.
Save.

Lemma Iifrule :
  forall (A:Type)(b:(distr bool))(f1 f2:distr A)(I1 I2:IU)(F:A -> IU),
       Iok I1 f1 F -> Iok I2 f2 F
       -> Iok (Iplus (Imultk (mu b B2U) I1) (Imultk (mu b NB2U) I2)) (Mif b f1 f2) F.
unfold Iok; intros.
apply Ieq_incl_trans with (1:=Imu_Mif_eq b f1 f2 F).
split.
repeat rewrite low_Iplus; repeat rewrite low_Imultk.
apply Uplus_le_compat; auto.
repeat rewrite up_Iplus; repeat rewrite up_Imultk.
apply Uplus_le_compat; auto.
Save.

(** *** Rule for fixpoints
with [ phi x = F phi x ], [p] a decreasing sequence of intervals functions
([ p (i+1) x ] is a bubset of [ (p i x) ] such that [ (p 0 x) ] contains [0] for all [x].

[ forall f i, (forall x, iok (p i x) f (q x)) => forall x, iok (p (i+1) x) (F f x) (q x) ]  implies [ forall x, iok (lub p x) (phi x) (q x) ]
*)
Section IFixrule.
Variables A B : Type.

Variable F : (A -> distr B) -m> (A -> distr B).

Section IRuleseq.
Variable Q : A -> B -> IU.

Variable I : A -> nat -m> IU.

Lemma Ifixrule :
   (forall x:A, Iin 0 (I x O)) ->
   (forall (i:nat) (f:A -> distr B),
      (Iokfun (fun x => I x i) f Q) -> Iokfun (fun x => I x (S i))  (fun x => F f x) Q)
   -> Iokfun (fun x => Ilim (I x)) (Mfix F) Q.
red; intros p0 Hrec.
assert (forall n:nat,
        (Iokfun (fun x => (I x n)) (fun x => Miter F n x) Q)).
induction n; simpl; auto.
split.
rewrite low_lim; rewrite low_Imu.
apply lub_le; auto.
intro n; transitivity (low (Imu (Miter F n x) (Q x))).
case (H n x); auto.
rewrite low_Imu; apply Mfix_le_iter; auto.
rewrite up_lim; rewrite up_Imu.
unfold Mfix,mu_lub; simpl.
apply lub_glb_le; intros.
case (H n x); auto.
Save.
End IRuleseq.

Section ITransformFix.

Section IFix_muF.
Variable Q : A -> B -> IU.
Variable ImuF : (A -> IU) -m> (A -> IU).

Lemma ImuF_stable : forall I J, I==J -> ImuF I == ImuF J.
intros; apply fstable with (f:=ImuF); auto.
Save.

Section IF_muF_results.
Hypothesis Iincl_F_ImuF :
    forall f x, f <= Mfix F ->
                      Iincl (Imu (F f x) (Q x)) (ImuF (fun y => Imu (f y) (Q y)) x).

Lemma Iincl_fix_ifix : forall x, Iincl (Imu (Mfix F x) (Q x)) (fixp (D:=A -> IU) ImuF x).
assert (forall n x, Iincl (Imu (Miter F n x) (Q x)) (Ccpo.iter (D:=A -> IU) ImuF n x)).
induction n; simpl; intros; auto.
apply Iincl_trans with (ImuF (fun y => Imu (Miter F n y) (Q y)) x).
apply Iincl_F_ImuF.
intro y; unfold Mfix, fixp.
intro f; simpl.
apply (le_mlub (fun y0 : nat => mu (iter_ F y0 y) f) n).
apply (fmonotonic ImuF); auto.
intros; unfold Iincl, Imu,Mfix,fixp; simpl; split.
apply lub_le_compat; intro n; case (H n x); intros.
transitivity (low (Imu (Miter F n x) (Q x))); auto.
apply lub_glb_le; intros; auto.
case (H n x); intros.
transitivity (up (Imu (Miter F n x) (Q x))); auto.
Save.
Hint Resolve Iincl_fix_ifix.

(*
Hypothesis Iincl_ImuF_F :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y)) ->
                      Iincl (ImuF (fun y => Imu (f y) (Q y)) x) (Imu (F f x) (Q x)).

Lemma Iincl_ifix_fix : forall x, Iincl (Ifix ImuF ImuF_mon x) (Imu (Mfix F F_mon x) (Q x)) .
assert (forall n x, Iincl (Iiter ImuF n x) (Imu (iter F n x) (Q x))).
induction n; simpl; intros; auto.
apply Iincl_trans with (ImuF (fun y => Imu (iter F n y) (Q y)) x).
apply IF_muF_incl.
repeat red; intros; unfold Mfix, mu_lub,mu_lub_;simpl.
apply le_lub with (f:=fun n => mu (iter F n y) f); auto.
apply ImuF_mon; auto.
intros; unfold Iincl, Ifix,Imu,Mfix,mu_lub; simpl.
unfold mu_lub_; split.
apply lub_le_compat; intros.
case (H n x); intros.
transitivity (low (Imu (iter F n x) (Q x))); auto.
apply lub_glb_le; intros; auto.
apply (@muf_mon_succ A B F F_mon n x).
case (Iiter_decr ImuF ImuF_mon x n); auto.
case (H n x); intros.
transitivity (up (Imu (iter F n x) (Q x))); auto.
Save.
Hint Resolve Iincl_fix_mu.

Lemma Iincl_ImuF : forall f, (forall x, Iincl (f x) (ImuF f x)) -> forall x, Iincl (Imu (Mfix F F_mon x) (Q x)) (f x).
intros; apply Iincl_trans with (Ifix ImuF ImuF_mon x); auto.
apply Iincl_inv; auto.
Save.

Hypothesis muF_F_le :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y)) ->
                        muF (fun y => mu (f y) (q y)) x <= mu (F f x) (q x).

Lemma mufix_mu_le : forall x, mufix muF x <= mu (Mfix F F_mon x) (q x).
intros; unfold mufix,Mfix,mu_lub; simpl.
unfold mu_lub_.
apply lub_le_compat; intros.
generalize x; induction n; simpl; intros; auto.
transitivity (muF (fun y => mu (iter F n y) (q y)) x0).
apply muF_mon; auto.
apply muF_F_le.
repeat red; intros; unfold Mfix, mu_lub,mu_lub_;simpl.
apply le_lub with (f:=fun n => mu (iter F n y) f); auto.
Save.

End F_muF_results.
Hint Resolve mu_mufix_le mufix_mu_le.

Lemma mufix_mu :
   (forall f x, (forall y, le_distr (f y) (Mfix F F_mon y))
          -> mu (F f x) (q x) == muF (fun y => mu (f y) (q y)) x)
   -> forall x, mufix muF x == mu (Mfix F F_mon x) (q x).
intros; apply Ole_antisym; auto.
apply mufix_mu_le; intros; auto.
rewrite (H f x0); auto.
Save.
Hint Resolve mufix_mu.
End Fix_muF.

Section Fix_Term.

Definition pterm (x:A) := mu (Mfix F F_mon x) (f_one B).
Variable muF : (A -> U) -> A -> U.

Hypothesis muF_mon : Fmonotonic muF.

Hypothesis F_muF_eq_one :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y))
    -> mu (F f x) (f_one B) == muF (fun y => mu (f y) (f_one B)) x.

Hypothesis muF_cont :  Fcontlub muF.

Lemma muF_pterm :  feq pterm (muF pterm).
red; intros; unfold pterm.
rewrite <- (mufix_mu (fun (x:A) => f_one B) muF_mon F_muF_eq_one x).
rewrite mufix_eq; auto.
apply muF_stable; auto.
red; intros; auto.
apply (mufix_mu (fun (x:A) => f_one B) muF_mon F_muF_eq_one x0).
Save.
Hint Resolve muF_pterm.
End Fix_Term.

Section Fix_muF_Term.

Variable muF : (A -> B -> U) -> (A -> U) -> A -> U.

Hypothesis muF_mon : forall q, Fmonotonic (muF q).

Variable q : A -> B -> U.
Definition qinv x y := [1-]q x y.

Hypothesis F_muF_le_inv :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y))
    -> mu (F f x) (qinv x) <= muF qinv (fun y => mu (f y) (qinv y)) x.

Lemma muF_le_term : forall f,  (muF qinv (finv f) <= finv f) ->
    forall x, f x & pterm x <= mu (Mfix F F_mon x) (q x).
intros; transitivity (mu (Mfix F F_mon x) (fesp (q x) (f_one B))).
transitivity ([1-] mu (Mfix F F_mon x) (qinv x) & pterm x).
apply Uesp_le_compat; auto.
apply Uinv_le_perm_right.
apply muF_le with (muF:=muF qinv) (q:=qinv) (f:=finv f) (x:=x); auto.
unfold pterm; replace (qinv x) with (finv (q x)); auto.
apply mu_monotonic; intro; unfold fesp,f_one; repeat Usimpl; auto.
Save.

Hypothesis F_muF_le :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y))
    -> mu (F f x) (q x) <= muF q (fun y => mu (f y) (q y)) x.

Lemma muF_eq : forall f, fle (muF q f) f -> fle (muF qinv (finv f)) (finv f)->
    forall x, pterm x == 1 -> mu (Mfix F F_mon x) (q x) == f x.
intros; apply Ole_antisym.
apply muF_le with (muF:=muF q); auto.
transitivity (f x & pterm x).
rewrite H1; auto.
apply muF_le_term; auto.
Save.

End Fix_muF_Term.

*)
End IF_muF_results.

End IFix_muF.
End ITransformFix.
End IFixrule.

Lemma IFlip_eq : forall Q : bool -> IU, Ieq (Imu Flip Q) (Iplus (Imultk [1/2] (Q true)) (Imultk [1/2] (Q false))).
red; unfold Flip, flip; intro x; auto.
Save.
Hint Resolve IFlip_eq.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*             Burak Ekici, Damien Pous.                                  *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations.
Set Implicit Arguments.

Module Make(Import M: Memory.T).
  Module Export AxiomsExp := Decorations.Make(M).

 Reserved Notation "x == y" (at level 80).
 Reserved Notation "x ~ y" (at level 80).

 Definition idem X Y (x y: term X Y) := x = y.

 Inductive strong: forall X Y, relation (term X Y) :=
 | refl X Y: Reflexive (@strong X Y)
 | sym: forall X Y, Symmetric (@strong X Y)
 | trans: forall X Y, Transitive (@strong X Y)
 | replsubs: forall X Y Z, Proper (@strong X Y ==> @strong Y Z ==> @strong X Z) comp
 | ids: forall X Y (f: term X Y), f o id == f
 | idt: forall X Y (f: term X Y), id o f == f
 | assoc: forall X Y Z T (f: term X Y) (g: term Y Z) (h: term Z T), f o (g o h) == (f o g) o h
 | wtos: forall X Y (f g: term X Y), RO f -> RO g -> f ~ g -> f == g
 | s_lpair_eq: forall X Y' Y (f1: term Y X) (f2: term Y' X), RO f1 -> pi2 o pair f1 f2 == f2
 | effect: forall X Y (f g: term Y X), forget o f == forget o g -> f ~ g -> f == g
 | local_global: forall X (f g: term unit X), (forall i: Loc, lookup i o f ~ lookup i o g) -> f == g
 | tcomp: forall X Y Z (f: Z -> Y) (g: Y -> X), tpure (compose g f) == tpure g o tpure f
 with weak: forall X Y, relation (term X Y) :=
 | wsym: forall X Y, Symmetric (@weak X Y)
 | wtrans: forall X Y, Transitive (@weak X Y)
 | pwrepl: forall A B C (g: term C B), (PURE g) ->  Proper (@weak B A ==> @weak C A) (comp g)
 | wsubs: forall A B C, Proper (@weak C B ==> @idem B A ==> @weak C A) comp
 | stow: forall  X Y (f g: term X Y), f == g -> f ~ g
 | w_lpair_eq: forall X Y' Y (f1: term Y X) (f2: term Y' X), RO f1 -> pi1 o pair f1 f2 ~ f1
 | w_unit: forall X (f g: term unit X), f ~ g
 | ax1: forall i, lookup i o update i ~ id
 | ax2: forall i j, i<>j -> lookup j o update i ~ lookup j o forget
 | lpair_ueq: forall  X Y Y'(f g: term (Y*Y') X), pi1 o f ~ pi1 o g -> pi2 o f ~ pi2 o g -> f ~ g
   where "x == y" := (strong x y)
   and "x ~ y" := (weak x y).

 Instance wisrefl X Y: Reflexive (@weak X Y).
 Proof. intro f. apply stow, refl. Qed.

 Instance strong_is_equivalence X Y: Equivalence (@strong X Y).
 Proof. constructor; intro. apply refl. apply sym. apply trans. Qed.

 Instance weak_is_equivalence X Y: Equivalence (@weak X Y).
 Proof. constructor; intro. apply stow. apply refl. intros. apply wsym. assumption. apply wtrans. Qed.

 Instance strong_is_weak_equivalence: forall X Y, subrelation (@strong X Y) (@weak X Y).
 Proof. constructor. apply stow,sym. assumption. Qed.

 Lemma s_unit: forall X (f: term unit X), (RO f) ->  f == forget.
 Proof. intros X f H. apply wtos; [exact H| decorate| apply w_unit]. Qed.

 (*
 Parameters X Y Z: Type.
 Check (respectful (@strong Y Z) (@strong X Z)).
 Check (respectful (@strong Y Z) (@weak X Z)).
 Check respectful (@strong X Y) (respectful (@strong Y Z) (@strong X Z)).
 Check ((@strong X Y) ==> (@strong Y Z) ==> (@strong X Z)).
 Check  Proper (@strong X Y ==> @strong Y Z ==> @strong X Z) comp. *)

 Existing Instance wsubs.
 Existing Instance pwrepl.
 Existing Instance replsubs.

 Goal forall X Y Z (f f': term Y Z) (g: term X Y), PURE g -> f ~ f' ->  g o f ~ g o f'.
 Proof. intros X Y Z f f' g H0 H1. setoid_rewrite <- H1. reflexivity. Qed.

 Goal forall X Y Z (f f': term X Y) (g: term Y Z), f ~ f' -> f o g ~ f' o g.
 Proof. intros X Y Z f f' g H0. setoid_rewrite <- H0. reflexivity. Qed.

End Make.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall H O Hprime Kprime Oprime SH SHprime : Universe, ((wd_ H O /\ (wd_ O SH /\ (wd_ H SH /\ (wd_ Hprime Oprime /\ (wd_ Oprime SHprime /\ (wd_ Hprime SHprime /\ (col_ H O SH /\ (col_ Hprime Oprime SHprime /\ col_ SHprime Oprime Kprime)))))))) -> col_ Hprime Oprime Kprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Grothendieck Construction of a functor to Set *)
Require Import Category.Core Functor.Core.
Require Import SetCategory.Core.
Require Import Basics.Trunc HSet Types.Sigma TruncType.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Section Grothendieck.
  Context `{Funext}.

  (**
     Quoting Wikipedia:

     The Grothendieck construction is an auxiliary construction used
     in the mathematical field of category theory.

     Let

<<
     F : C → Set
>>

     be a functor from any small category to the category of sets.
     The Grothendieck construct for [F] is the category [Γ F] whose
     objects are pairs [(c, x)], where [c : C] is an object and [x : F
     c] is an element, and for which the set [Hom (Γ F) (c1, x1) (c2,
     x2)] is the set of morphisms [f : c1 → c2] in [C] such that
     [F₁ f x1 = x2].  *)

  Variable C : PreCategory.
  Variable F : Functor C set_cat.

  Record Pair :=
    {
      c : C;
      x : F c
    }.

  Definition issig_pair : { c : C | F c } <~> Pair.
  Proof.
    issig.
  Defined.

  Local Notation morphism s d :=
    { f : morphism C s.(c) d.(c)
    | F _1 f s.(x) = d.(x) }.

  Definition compose_H s d d'
             (m1 : morphism d d')
             (m2 : morphism s d)
  : (F _1 (m1 .1 o m2 .1)) s.(x) = d'.(x).
  Proof.
    etransitivity; [ | exact (m1.2) ].
    etransitivity; [ | apply ap; exact (m2.2) ].
    match goal with
      | [ |- ?f ?x = ?g (?h ?x) ] => change (f x = (g o h) x)
    end.
    match goal with
      | [ |- ?f ?x = ?g ?x ] => apply (@apD10 _ _ f g)
    end.
    apply (composition_of F).
  Defined.

  Definition compose s d d'
             (m1 : morphism d d')
             (m2 : morphism s d)
  : morphism s d'.
  Proof.
    exists (m1.1 o m2.1).
    apply compose_H.
  Defined.

  Definition identity_H s
    := apD10 (identity_of F s.(c)) s.(x).

  Definition identity s : morphism s s.
  Proof.
    exists 1.
    apply identity_H.
  Defined.

  Global Arguments compose_H : simpl never.
  Global Arguments identity_H : simpl never.
  Global Arguments identity _ / .
  Global Arguments compose _ _ _ _ _ / .

  (** ** Category of elements *)
  Definition category : PreCategory.
  Proof.
    refine (@Build_PreCategory
              Pair
              (fun s d => morphism s d)
              identity
              compose
              _
              _
              _
              _);
    abstract (
        repeat intro;
        apply path_sigma_uncurried; simpl;
        ((exists (associativity _ _ _ _ _ _ _ _))
           || (exists (left_identity _ _ _ _))
           || (exists (right_identity _ _ _ _)));
        exact (center _)
      ).
  Defined.

  (** ** First projection functor *)
  Definition pr1 : Functor category C
    := Build_Functor
         category C
         c
         (fun s d => @pr1 _ _)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).
End Grothendieck.


Require Import Logic.LogicGenerator.demo931.impl1.
Import T.

(*
1. coqprop P1 && coqprop P2 && ... coqprop Px && P
  |-- coqprop Q1 && coqprop Q2 && ... coqprop Qx && Q
2. coqprop P1 && coqprop P2 && ... coqprop Px && P |-- Q
3. P |-- coqprop Q1 && coqprop Q2 && ... coqprop Qx && Q
*)

(*
(coq_prop P) && Q |-- (coq_prop P') && Q'
<== P -> (Q |-- (coq_prop P') && Q')
<== (P -> P') /\ (P -> (Q |-- Q'))
*)

Lemma cp_lem1 : forall (P :Prop) (Q Q' : expr),
  (P -> (derivable1 Q Q'))
  -> (derivable1 (andp (coq_prop P) Q) Q').
Proof.
  intros. hnf. intros.
  unfold impp, andp, coq_prop.
  unfold derivable1, provable, impp in H.
  intros. apply H; try tauto.
Qed.

Lemma cp_lem2 : forall (P P' : Prop) (Q Q' : expr),
  (P -> P') -> (P -> (derivable1 Q Q')) ->
  (P -> (derivable1 Q (andp (coq_prop P') Q'))).
Proof.
  intros.
  unfold derivable1, andp, coq_prop, provable, impp in *.
  intros. split; try tauto.
  apply H0; try tauto.
Qed.

Ltac pop_coq_prop :=
  repeat match goal with
  | |- derivable1 (andp (coq_prop ?P) _) _ => apply cp_lem1
  | |- (_ -> (derivable1 _ (andp (coq_prop ?P') _))) => apply cp_lem2
  | _ => idtac
  end.

Context {P : Prop} {P' : Prop} {Q : expr} {Q' : expr}.

Goal derivable1 (andp (coq_prop P) Q) Q'.
Proof. pop_coq_prop. Abort.

Goal (P -> (derivable1 Q (andp (coq_prop P') Q'))).
Proof. pop_coq_prop. Abort.

Goal (derivable1 (andp (coq_prop P) Q) (andp (coq_prop P') Q')).
Proof. pop_coq_prop. Abort.

(* Ltac entailer :=
  match goal with
  | |- _ |-- _ => idtac
  | _ => fail "The proof goal's conclusion is not an assertion derivation."
  end;
  assert_simpl;
  apply FOL_complete;
  let st := fresh "st" in
  intros st;
  cbv [Assertion_denote term_denote];
  repeat
    match goal with
    | |- context [aexp_denote st (Concrete_Pretty_Printing.AId ?X)] =>
           let X' := fresh X "'" in
           set (X' := aexp_denote st (Concrete_Pretty_Printing.AId X));
           clearbody X';
           revert X'
    end;
  first [ clear st | fail 1 "This is not a concrete derivation." ]. *)

(* Lemma lem1 : (P -> (derivable1 Q (andp (coq_prop P') Q')))
  -> (derivable1 (andp (coq_prop P) Q) (andp (coq_prop P') Q')).
Admitted.

Lemma lem2 : ((P -> P') /\ (P -> (derivable1 Q Q')))
  -> (P -> (derivable1 Q (andp (coq_prop P') Q'))).
Admitted.

Theorem thm : ((P -> P') /\ (P -> (derivable1 Q Q')))
  -> (derivable1 (andp (coq_prop P) Q) (andp (coq_prop P') Q')). *)


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.Word.
Require Import
        Bedrock.Word
        Coq.omega.Omega
        Coq.Strings.Ascii
        Coq.Numbers.BinNums
        Coq.NArith.BinNat.

Section Ascii.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnit monoid bool}.

  Definition format_ascii (c : ascii) (ce : CacheFormat) : B * CacheFormat :=
    format_word (NToWord 8 (N_of_ascii c)) ce.

  Definition decode_ascii (b : B) (cd : CacheDecode) : ascii * B * CacheDecode :=
    let (bundle, cd) := decode_word (sz:=8) b cd in
    let (n, b) := bundle in
        (ascii_of_N (wordToN n), b, cd).

  Open Local Scope nat.
  Theorem Ascii_decode_correct :
    format_decode_correct monoid (fun n => True) format_ascii decode_ascii.
  Proof.
    unfold format_decode_correct, format_ascii, decode_ascii.
    intros env env' xenv xenv' c c' bin' ext ext' Eeq Ppred Penc Pdec.
    destruct (decode_word (mappend bin' ext) env') as [[? ?] ?] eqn: ?.
    inversion Pdec; subst; clear Pdec.
    pose proof (Word_decode_correct env env' xenv xenv' (NToWord 8 (N_of_ascii c)) w
                  bin' ext ext' Eeq I Penc Heqp).
    intuition eauto.
    rewrite <- H. clear.
    rewrite wordToN_nat. rewrite NToWord_nat.
    destruct (wordToNat_natToWord' 8 (BinNat.N.to_nat (N_of_ascii c))).
    assert (x = 0).
    { destruct x; eauto; exfalso.
      remember (wordToNat (natToWord 8 (BinNat.N.to_nat (N_of_ascii c)))) as xx; clear Heqxx.
      replace (xx + S x * pow2 8) with (256 + (xx + x * 256)) in H.
      assert (BinNat.N.to_nat (N_of_ascii c) < 256).
      assert (N.lt (N_of_ascii c) 256).
      clear H. induction c; repeat (match goal with
                                    | B : bool |- _ => destruct B
                                    end); simpl; unfold Nlt; eauto.
      change (256%nat) with (N.to_nat 256).
      apply Nomega.Nlt_out. eauto.
      omega. change (pow2 8) with 256. omega.
    }
    subst. rewrite <- plus_n_O in H. rewrite H. clear H.
    rewrite Nnat.N2Nat.id. rewrite ascii_N_embedding. eauto.
  Qed.
End Ascii.