Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^255 - 19
Base: 42.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 42 + 1/2;
    bitwidth := 64;
    s := 2^255;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 6); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^495 - 31
Base: 49.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 49 + 1/2;
    bitwidth := 64;
    s := 2^495;
    c := [(1, 31)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib Compopts.
Require Import AST Integers Floats Values Memory Globalenvs.
Require Import Op RTL ValueDomain.

(** Value analysis for x86_64 operators *)

Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
  | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
  | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
  | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2
  | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2
  | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n)
  | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n)
  | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
  | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2
  | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2)
  | Cmaskzero n, v1 :: nil => maskzero v1 n
  | Cmasknotzero n, v1 :: nil => cnot (maskzero v1 n)
  | _, _ => Bnone
  end.

Definition eval_static_addressing_32 (addr: addressing) (vl: list aval): aval :=
  match addr, vl with
  | Aindexed n, v1::nil => add v1 (I (Int.repr n))
  | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I (Int.repr n))
  | Ascaled sc ofs, v1::nil => add (mul v1 (I (Int.repr sc))) (I (Int.repr ofs))
  | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I (Int.repr sc))) (I (Int.repr ofs)))
  | Aglobal s ofs, nil => Ptr (Gl s ofs)
  | Abased s ofs, v1::nil => add (Ptr (Gl s ofs)) v1
  | Abasedscaled sc s ofs, v1::nil => add (Ptr (Gl s ofs)) (mul v1 (I (Int.repr sc)))
  | Ainstack ofs, nil => Ptr(Stk ofs)
  | _, _ => Vbot
  end.

Definition eval_static_addressing_64 (addr: addressing) (vl: list aval): aval :=
  match addr, vl with
  | Aindexed n, v1::nil => addl v1 (L (Int64.repr n))
  | Aindexed2 n, v1::v2::nil => addl (addl v1 v2) (L (Int64.repr n))
  | Ascaled sc ofs, v1::nil => addl (mull v1 (L (Int64.repr sc))) (L (Int64.repr ofs))
  | Aindexed2scaled sc ofs, v1::v2::nil => addl v1 (addl (mull v2 (L (Int64.repr sc))) (L (Int64.repr ofs)))
  | Aglobal s ofs, nil => Ptr (Gl s ofs)
  | Abased s ofs, v1::nil => addl (Ptr (Gl s ofs)) v1
  | Abasedscaled sc s ofs, v1::nil => addl (Ptr (Gl s ofs)) (mull v1 (L (Int64.repr sc)))
  | Ainstack ofs, nil => Ptr(Stk ofs)
  | _, _ => Vbot
  end.

Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
  if Archi.ptr64
  then eval_static_addressing_64 addr vl
  else eval_static_addressing_32 addr vl.

Definition eval_static_operation (op: operation) (vl: list aval): aval :=
  match op, vl with
  | Omove, v1::nil => v1
  | Ointconst n, nil => I n
  | Olongconst n, nil => L n
  | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop
  | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop
  | Oindirectsymbol id, nil => Ifptr (Gl id Ptrofs.zero)
  | Ocast8signed, v1 :: nil => sign_ext 8 v1
  | Ocast8unsigned, v1 :: nil => zero_ext 8 v1
  | Ocast16signed, v1 :: nil => sign_ext 16 v1
  | Ocast16unsigned, v1 :: nil => zero_ext 16 v1
  | Oneg, v1::nil => neg v1
  | Osub, v1::v2::nil => sub v1 v2
  | Omul, v1::v2::nil => mul v1 v2
  | Omulimm n, v1::nil => mul v1 (I n)
  | Omulhs, v1::v2::nil => mulhs v1 v2
  | Omulhu, v1::v2::nil => mulhu v1 v2
  | Odiv, v1::v2::nil => divs v1 v2
  | Odivu, v1::v2::nil => divu v1 v2
  | Omod, v1::v2::nil => mods v1 v2
  | Omodu, v1::v2::nil => modu v1 v2
  | Oand, v1::v2::nil => and v1 v2
  | Oandimm n, v1::nil => and v1 (I n)
  | Oor, v1::v2::nil => or v1 v2
  | Oorimm n, v1::nil => or v1 (I n)
  | Oxor, v1::v2::nil => xor v1 v2
  | Oxorimm n, v1::nil => xor v1 (I n)
  | Onot, v1::nil => notint v1
  | Oshl, v1::v2::nil => shl v1 v2
  | Oshlimm n, v1::nil => shl v1 (I n)
  | Oshr, v1::v2::nil => shr v1 v2
  | Oshrimm n, v1::nil => shr v1 (I n)
  | Oshrximm n, v1::nil => shrx v1 (I n)
  | Oshru, v1::v2::nil => shru v1 v2
  | Oshruimm n, v1::nil => shru v1 (I n)
  | Ororimm n, v1::nil => ror v1 (I n)
  | Oshldimm n, v1::v2::nil => or (shl v1 (I n)) (shru v2 (I (Int.sub Int.iwordsize n)))
  | Olea addr, _ => eval_static_addressing_32 addr vl
  | Omakelong, v1::v2::nil => longofwords v1 v2
  | Olowlong, v1::nil => loword v1
  | Ohighlong, v1::nil => hiword v1
  | Ocast32signed, v1::nil => longofint v1
  | Ocast32unsigned, v1::nil => longofintu v1
  | Onegl, v1::nil => negl v1
  | Oaddlimm n, v1::nil => addl v1 (L n)
  | Osubl, v1::v2::nil => subl v1 v2
  | Omull, v1::v2::nil => mull v1 v2
  | Omullimm n, v1::nil => mull v1 (L n)
  | Omullhs, v1::v2::nil => mullhs v1 v2
  | Omullhu, v1::v2::nil => mullhu v1 v2
  | Odivl, v1::v2::nil => divls v1 v2
  | Odivlu, v1::v2::nil => divlu v1 v2
  | Omodl, v1::v2::nil => modls v1 v2
  | Omodlu, v1::v2::nil => modlu v1 v2
  | Oandl, v1::v2::nil => andl v1 v2
  | Oandlimm n, v1::nil => andl v1 (L n)
  | Oorl, v1::v2::nil => orl v1 v2
  | Oorlimm n, v1::nil => orl v1 (L n)
  | Oxorl, v1::v2::nil => xorl v1 v2
  | Oxorlimm n, v1::nil => xorl v1 (L n)
  | Onotl, v1::nil => notl v1
  | Oshll, v1::v2::nil => shll v1 v2
  | Oshllimm n, v1::nil => shll v1 (I n)
  | Oshrl, v1::v2::nil => shrl v1 v2
  | Oshrlimm n, v1::nil => shrl v1 (I n)
  | Oshrxlimm n, v1::nil => shrxl v1 (I n)
  | Oshrlu, v1::v2::nil => shrlu v1 v2
  | Oshrluimm n, v1::nil => shrlu v1 (I n)
  | Ororlimm n, v1::nil => rorl v1 (I n)
  | Oleal addr, _ => eval_static_addressing_64 addr vl
  | Onegf, v1::nil => negf v1
  | Oabsf, v1::nil => absf v1
  | Oaddf, v1::v2::nil => addf v1 v2
  | Osubf, v1::v2::nil => subf v1 v2
  | Omulf, v1::v2::nil => mulf v1 v2
  | Odivf, v1::v2::nil => divf v1 v2
  | Omaxf, v1::v2::nil =>  binop_float float_max v1 v2
  | Ominf, v1::v2::nil =>  binop_float float_min v1 v2
  | Onegfs, v1::nil => negfs v1
  | Oabsfs, v1::nil => absfs v1
  | Oaddfs, v1::v2::nil => addfs v1 v2
  | Osubfs, v1::v2::nil => subfs v1 v2
  | Omulfs, v1::v2::nil => mulfs v1 v2
  | Odivfs, v1::v2::nil => divfs v1 v2
  | Osingleoffloat, v1::nil => singleoffloat v1
  | Ofloatofsingle, v1::nil => floatofsingle v1
  | Ointoffloat, v1::nil => intoffloat v1
  | Ofloatofint, v1::nil => floatofint v1
  | Ointofsingle, v1::nil => intofsingle v1
  | Osingleofint, v1::nil => singleofint v1
  | Olongoffloat, v1::nil => longoffloat v1
  | Ofloatoflong, v1::nil => floatoflong v1
  | Olongofsingle, v1::nil => longofsingle v1
  | Osingleoflong, v1::nil => singleoflong v1
  | Ocmp c, _ => of_optbool (eval_static_condition c vl)
  | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2
  | _, _ => Vbot
  end.

Section SOUNDNESS.

Variable bc: block_classification.
Variable ge: genv.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.

Theorem eval_static_condition_sound:
  forall cond vargs m aargs,
  list_forall2 (vmatch bc) vargs aargs ->
  cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
Proof.
  intros until aargs; intros VM. inv VM.
  destruct cond; auto with va.
  inv H0.
  destruct cond; simpl; eauto with va.
  inv H2.
  destruct cond; simpl; eauto with va.
  destruct cond; auto with va.
Qed.

Lemma symbol_address_sound:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)).
Proof.
  intros; apply symbol_address_sound; apply GENV.
Qed.

Lemma symbol_address_sound_2:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)).
Proof.
  intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F.
  constructor. constructor. apply GENV; auto.
  constructor.
Qed.

Hint Resolve symbol_address_sound symbol_address_sound_2: va.

Ltac InvHyps :=
  match goal with
  | [H: None = Some _ |- _ ] => discriminate
  | [H: Some _ = Some _ |- _] => inv H
  | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
     H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
  | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps
  | _ => idtac
  end.

Theorem eval_static_addressing_32_sound:
  forall addr vargs vres aargs,
  eval_addressing32 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing_32 addr aargs).
Proof.
  unfold eval_addressing32, eval_static_addressing_32; intros;
  destruct addr; InvHyps; eauto with va.
  rewrite Ptrofs.add_zero_l; eauto with va.
Qed.

Theorem eval_static_addressing_64_sound:
  forall addr vargs vres aargs,
  eval_addressing64 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing_64 addr aargs).
Proof.
  unfold eval_addressing64, eval_static_addressing_64; intros;
  destruct addr; InvHyps; eauto with va.
  rewrite Ptrofs.add_zero_l; eauto with va.
Qed.

Theorem eval_static_addressing_sound:
  forall addr vargs vres aargs,
  eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing addr aargs).
Proof.
  unfold eval_addressing, eval_static_addressing; intros.
  destruct Archi.ptr64; eauto using eval_static_addressing_32_sound, eval_static_addressing_64_sound.
Qed.

Theorem eval_static_operation_sound:
  forall op vargs m vres aargs,
  eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_operation op aargs).
Proof.
  unfold eval_operation, eval_static_operation; intros;
  destruct op; InvHyps; eauto with va.
  destruct (propagate_float_constants tt); constructor.
  destruct (propagate_float_constants tt); constructor.
  eapply eval_static_addressing_32_sound; eauto.
  eapply eval_static_addressing_64_sound; eauto.
  apply binop_float_sound; auto.
  apply binop_float_sound; auto.
  apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
  apply select_sound; auto. eapply eval_static_condition_sound; eauto.
Qed.

End SOUNDNESS.


From Coq Require Export NArith List Number Decimal.
From Coq Require Import ZArith.

From stdpp Require Import gmap sorting.

Set Implicit Arguments.
Set Contextual Implicit.

Import ListNotations.

#[global] Open Scope N_scope.

Fixpoint decimal_to_digits (d : Decimal.uint) : list N :=
  match d with
  | D0 d => 0 :: decimal_to_digits d
  | D1 d => 1 :: decimal_to_digits d
  | D2 d => 2 :: decimal_to_digits d
  | D3 d => 3 :: decimal_to_digits d
  | D4 d => 4 :: decimal_to_digits d
  | D5 d => 5 :: decimal_to_digits d
  | D6 d => 6 :: decimal_to_digits d
  | D7 d => 7 :: decimal_to_digits d
  | D8 d => 8 :: decimal_to_digits d
  | D9 d => 9 :: decimal_to_digits d
  | Nil => []
  end.

Record DIGITS := { unDIGITS : list N }.

Definition decimal_to_DIGITS (d : Number.uint) :=
  match d with
  | UIntDecimal d => Some {| unDIGITS := decimal_to_digits d |}
  | _ => None
  end.

Definition dummy_from_DIGITS : DIGITS -> option Number.uint := fun _ => None.

Declare Scope DIGITS_scope.
Delimit Scope DIGITS_scope with DIGITS.

Number Notation DIGITS decimal_to_DIGITS dummy_from_DIGITS : DIGITS_scope.

Definition foldi {A B} (f : N -> A -> B -> B) (xs : list A) (b0 : B) : B :=
  let fix _foldi (n : N) (xs : list A) :=
    match xs with
    | x :: xs => f n x (_foldi (N.succ n) xs)
    | nil => b0
    end in _foldi 0 xs.

(* N is awkward because of saturating subtraction, we use Z so going negative
   is a natural way to detect going "out of bounds". *)
Definition point : Type := Z * Z.

Definition map_of_grid (xs : list (list N)) : gmap point N :=
  foldi (fun j =>
    foldi (fun i h => insert (Z.of_N i, Z.of_N j) h))
    xs empty.

Record Input : Type := MkInput
  { input_grid : gmap point N
  ; input_dim : N * N
  }.

Definition input_of_grid (xs : list (list N)) : Input :=
  {| input_grid := map_of_grid xs
  ;  input_dim := match xs with
                  | [] => (0, 0)
                  | row ::_ => (N.of_nat (length row), N.of_nat (length xs))
                  end |}.

Notation "'input' x .. y" := (input_of_grid (map unDIGITS (cons x%DIGITS .. (cons y%DIGITS nil) ..)))
  (at level 200, x at level 0, only parsing).

Definition example : Input := input
1163751742
1381373672
2136511328
3694931569
7463417111
1319128137
1359912421
3125421639
1293138521
2311944581
.

(* Priority queue with a heap à la Lampropoulos (Ode on a random urn) *)
Module Q.

Inductive t (K : Type) (leK : K -> K -> Prop) (V : Type) : Type :=
| Node : K -> V -> t leK V -> t leK V -> t leK V
  (* invariant: the right tree is bigger than the left tree *)
| Leaf : t leK V
.

Section Q.

Context {K : Type} {leK : K -> K -> Prop} {V : Type} `{!RelDecision leK}.

Definition empty : t leK V := Leaf.

Fixpoint push (k : K) (v : V) (q : t leK V) : t leK V :=
  match q with
  | Leaf => Node k v Leaf Leaf
  | Node k' v' l r =>
    if decide_rel leK k k' then Node k v r (push k' v' l) else Node k' v' r (push k v l)
  end.

Fixpoint unsnoc (q : t leK V) : option (K * V * t leK V) :=
  match q with
  | Leaf => None
  | Node k v l r =>
    match unsnoc r with
    | None => Some (k, v, Leaf)
    | Some (k', v', r') => Some (k', v', Node k v r' l)
    end
  end.

(* Remove the root of [q] and push [(k, v)]. This looks awkward but seems necessary
   to make the function structurally recursive. *)
Fixpoint sift (k : K) (v : V) (q : t leK V) : t leK V :=
  match q with
  | Leaf => Node k v Leaf Leaf
  | Node _ _ l r =>
    match l, r with
    | Leaf, Node k' v' _ _ =>
      if decide_rel leK k k' then Node k v l r else Node k' v' Leaf (Node k v Leaf Leaf)
    | _, Leaf => Node k v l r (* If r = Leaf then l = Leaf *)
    | Node kl vl _ _, Node kr vr _ _ =>
      if decide_rel leK kl kr then
        if decide_rel leK k kl then
          Node k v l r
        else
          Node kl vl (sift k v l) r
      else
        if decide_rel leK k kr then
          Node k v l r
        else
          Node kr vr l (sift k v r)
    end
  end.

Definition pop (q : t leK V) : option (K * V * t leK V) :=
  match q with
  | Leaf => None
  | Node k v l r =>
    let q :=
      match unsnoc r with
      | None => Leaf
      | Some (k', v', r') => sift k' v' (Node k v r' l)
      end in
    Some (k, v, q)
  end.

Fixpoint pops (n : nat) (q : t leK V) : list (K * V) :=
  match n with
  | O => []
  | S n =>
    match pop q with
    | None => []
    | Some (k, v, q) => (k, v) :: pops n q
    end
  end.

End Q.
End Q.

(* Compute Q.pops 5 (Q.push (leK := N.le) 3 tt (Q.push 2 tt (Q.push 7 tt (Q.push 4 tt Q.empty)))). *)

Definition isSome {A} (x : option A) :=
  match x with
  | Some _ => true
  | None => false
  end.

(* [gset] insertion (as [fun x s => union (singleton x) s]) is slow,
   so we redefine our own sets from maps which have fast [insert]. *)
Notation set X := (gmap X unit).
Notation insert_set x s := (insert x tt s).
Notation elem_set x s := (isSome (lookup x s)).

Section Dijkstra. (* This is really A* now *)

Context (V : Type) `{Countable V}.

Record graph : Type :=
  { max_edges : N  (* upper bound on the number of edges, as fuel *)
  ; neighbors : V -> list (N * V)
  ; heuristic : V -> N  (* Upper bound on the remaining distance *)
  }.

Definition no_fuel : N. Proof. exact 0. Qed.

Definition _dijkstra (g : graph) (goal : V) (__dijkstra : _)
    (q : Q.t N.le (N * V)) (visited : set V) : N :=
  match Q.pop q with None => 0 | Some (_, (d, v), q) =>
  if decide (v = goal) then d (* REACHED GOAL *) else
  if elem_set v visited then __dijkstra q visited (* SKIP *) else
  let visited := insert_set v visited in
  let push q '(dd, v) := Q.push (d + dd + heuristic g v) (d + dd, v) q in
  let q := fold_left push (neighbors g v) q in
  __dijkstra q visited
  end.

Definition dijkstra (g : graph) (goal start : V) : N :=
  N.iter (N.succ (max_edges g)) (_dijkstra g goal) (fun _ _ => 0)
    (Q.push 0 (* don't need the heuristic for the first point *) (0, start) Q.empty)
    empty.

End Dijkstra.

Definition grid_neighbors '((i,j) : point) : list point :=
  [(i+1,j); (i-1,j); (i,j+1); (i,j-1)]%Z.

Fixpoint map_filter {A B} (f : A -> option B) (xs : list A) : list B :=
  match xs with
  | [] => []
  | x :: xs =>
    match f x with
    | None => map_filter f xs
    | Some y => y :: map_filter f xs
    end
  end%list.

Definition neigh (m : gmap point N) (ij : point) : list (N * point) :=
  map_filter (fun ij =>
    match lookup ij m with
    | None => None
    | Some d => Some (d, ij)
    end) (grid_neighbors ij).

Definition heuristic_to '((igoal, jgoal) : point) '((i, j) : point) : N :=
  (Z.abs_N (igoal - i) + Z.abs_N (jgoal - j)).

Definition graph_of_input (i : Input) (goal : point) : graph point :=
  let '(x, y) := input_dim i in
  {| max_edges := 4 * x * y
  ;  neighbors := neigh (input_grid i)
  ;  heuristic := heuristic_to goal
  |}.

Definition solve (i : Input) : N :=
  let '(x, y) := input_dim i in
  let goal := (Z.of_N (x - 1), Z.of_N (y - 1)) in
  let g := graph_of_input i goal in
  let start := (0, 0)%Z in
  dijkstra g goal start.

(* Compute solve example. *)

Module Part2.
Section Part2.

Context (ii : Input).

Definition REPEAT := 5.

Definition goal :=
  let '(x, y) := input_dim ii in
  (Z.of_N (REPEAT * x - 1), Z.of_N (REPEAT * y - 1)).

Definition decompose_point '((i, j) : point) : N * point :=
  let '(x, y) := input_dim ii in
  ( ((Z.to_N i `div` x) + (Z.to_N j `div` y))%N
  , (i `mod` Z.of_N x, j `mod` Z.of_N y)%Z).

Definition out_of_bounds '((i, j) : point) : bool :=
  let '(x, y) := input_dim ii in
  (i <? 0)%Z || (j <? 0)%Z || (Z.of_N (REPEAT * x) <=? i)%Z || (Z.of_N (REPEAT * y) <=? j)%Z.

Definition neigh (m : gmap point N) (ij : point) : list (N * point) :=
  map_filter (fun ij =>
    if out_of_bounds ij then None else
    let '(s, ij') := decompose_point ij in
    let wrap x := ((x - 1) `mod` 9) + 1 in
    match lookup ij' m with
    | None => None
    | Some d => Some (wrap (d + s), ij)
    end) (grid_neighbors ij).

Definition graph_of_input : graph point :=
  {| max_edges := let '(x, y) := input_dim ii in 100 * x * y  (* 4 * REPEAT * REPEAT *)
  ;  neighbors := neigh (input_grid ii)
  ;  heuristic := heuristic_to goal
  |}.

Definition solve : N :=
  let g := graph_of_input in
  let start := (0, 0)%Z in
  dijkstra g goal start.

End Part2.
End Part2.

Definition solve2 := Part2.solve.

(*
Section Test.

Let g := Part2.graph_of_input example.

Compute neighbors g (11,0)%Z.

End Test.
*)

(* Time Compute solve2 example. *)

Definition solve12 i := (solve i, solve2 i).


(*
A Tutorial on [Co-]Inductive Types in Coq
Eduardo Giménez ∗ , Pierre Castéran †
May 1998 — August 17, 2007
*)


(** * Inflationarity *)

(** The dual notion of an inflationarity or a progressive map
    is a deflationarity or a regressive map,
    which is why we do not define it separately. *)

From DEZ Require Export
  Init.

(** ** Inflationary Unary Operation *)
(** ** Progressive Map *)

Class IsInflUnOp (A : Type) (X : A -> A -> Prop)
  (f : A -> A) : Prop :=
  infl_un_op (x : A) : X x (f x).

(** ** Inflationary Left Action *)

Class IsInflActL (A B : Type) (X : B -> B -> Prop)
  (al : A -> B -> B) : Prop :=
  infl_act_l (x : A) (a : B) : X a (al x a).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (al : A -> B -> B).

(** Inflationarity of a left action is a special case
    of the inflationarity of its partial application. *)

#[export] Instance infl_act_l_is_infl_un_op
  `{!IsInflActL X al} (x : A) : IsInflUnOp X (al x).
Proof. intros a. apply infl_act_l. Qed.

#[local] Instance infl_un_op_is_infl_act_l
  `{!forall x : A, IsInflUnOp X (al x)} : IsInflActL X al.
Proof. intros x a. apply infl_un_op. Qed.

End Context.

(** ** Inflationary Right Action *)

Class IsInflActR (A B : Type) (X : B -> B -> Prop)
  (ar : B -> A -> B) : Prop :=
  infl_act_r (a : B) (x : A) : X a (ar a x).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (ar : B -> A -> B).

(** Inflationarity of a left action is a special case
    of the inflationarity of its flipped partial application. *)

#[export] Instance infl_act_r_is_infl_un_op_flip
  `{!IsInflActR X ar} (x : A) : IsInflUnOp X (flip ar x).
Proof. intros a. unfold flip. apply infl_act_r. Qed.

#[local] Instance infl_un_op_flip_is_infl_act_r
  `{!forall x : A, IsInflUnOp X (flip ar x)} : IsInflActR X ar.
Proof.
  intros x a.
  change (ar x a) with (flip ar a x).
  apply infl_un_op.
Qed.

End Context.

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (al : A -> B -> B).

(** Inflationarity of a left action is a special case
    of the inflationarity of its flipped version. *)

#[local] Instance infl_act_l_is_infl_act_r_flip
  `{!IsInflActL X al} : IsInflActR X (flip al).
Proof. intros a x. unfold flip in *. eauto. Qed.

#[local] Instance infl_act_r_flip_is_infl_act_l
  `{!IsInflActR X (flip al)} : IsInflActL X al.
Proof. intros x. unfold flip in *. eauto. Qed.

End Context.

(** ** Left-Inflationary Binary Operation *)

Class IsInflL (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) : Prop :=
  infl_l (x y : A) : X y (k x y).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A).

(** Left-inflationarity of a binary operation is a special case
    of the inflationarity of its partial application. *)

#[export] Instance infl_l_is_infl_un_op
  `{!IsInflL X k} (x : A) : IsInflUnOp X (k x).
Proof. intros y. apply infl_l. Qed.

#[local] Instance infl_un_op_is_infl_l
  `{!forall x : A, IsInflUnOp X (k x)} : IsInflL X k.
Proof. intros x y. apply infl_un_op. Qed.

End Context.

(** ** Right-Inflationary Binary Operation *)

Class IsInflR (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) : Prop :=
  infl_r (x y : A) : X x (k x y).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A).

(** Right-inflationarity of a binary operation is a special case
    of the inflationarity of its flipped partial application. *)

#[export] Instance infl_r_is_infl_un_op_flip
  `{!IsInflR X k} (y : A) : IsInflUnOp X (flip k y).
Proof. intros x. unfold flip. apply infl_r. Qed.

#[local] Instance infl_un_op_flip_is_infl_r
  `{!forall y : A, IsInflUnOp X (flip k y)} : IsInflR X k.
Proof.
  intros x y.
  change (k x y) with (flip k y x).
  apply infl_un_op.
Qed.

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A).

(** Left-inflationarity of a binary operation is a special case
    of the right-inflationarity of its flipped version. *)

#[local] Instance infl_l_is_infl_r_flip
  `{!IsInflL X k} : IsInflR X (flip k).
Proof. intros y x. unfold flip in *. eauto. Qed.

#[local] Instance infl_r_flip_is_infl_l
  `{!IsInflActR X (flip k)} : IsInflActL X k.
Proof. intros x y. unfold flip in *. eauto. Qed.

End Context.

(** ** Inflationary Binary Operation *)

Class IsInfl (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) : Prop := {
  infl_is_infl_l :> IsInflL X k;
  infl_is_infl_r :> IsInflR X k;
}.


(* Tauto bug initially due to wrong test for binary connective *)

Parameter A B : Type.

Axiom P : A -> B ->  Prop.

Inductive IP (a  : A) (b: B) : Prop :=
| IP_def : P a b ->   IP a b.

Goal forall (a : A) (b : B), IP a b ->  ~ IP a b -> False.
Proof.
  intros.
  tauto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import IZF_logic.

(** Sets as pointed graphs
    ~~~~~~~~~~~~~~~~~~~~~~
    In the following, we will interpret sets as pointed graphs, that
    is, as triples of the form (X, A, a) where :

    - X : Typ1     is the carrier (i.e. the small type of vertices);
    - A : (Rel X)  is the edge (or local membership) relation;
    - a : X        is the root.

    Naming conventions
    ~~~~~~~~~~~~~~~~~~
    Since the PTS Fw.2 does not provide any pairing mechanism, we will
    introduce the three components of each pointed graph separately.
    Of course, this separation is error-prone, and to avoid confusions
    we will name components according to the following scheme:

    Pointed graph   Vertices
    -------------   --------
    (X, A, a)       x, x', x0, x1, etc.
    (Y, B, b)       y, y', y0, y1, etc.
    (Z, C, c)       z, z', z0, z1, etc.
    etc.

    Moreover, a letter affected with a prime (such as x') will usually
    indicate that the vertex (or carrier, or relation) it denotes is in
    some sense an element of the corresponding unaffected letter. *)

(********************************)
(** * Equality as bisimilarity  *)
(********************************)

(** Two pointed graphs (X, A, a) and (Y, B, b) are bisimilar if there
    exists a relation R:X->Y->Prop satisfying the following conditions:

    (BIS1) (x,x':X; y:Y) (A x' x)/\(R x y) -> (Ex y':Y | (B y' y)/\(R x' y'))

    (BIS2) (x,x':X; y:Y) (A x' x)/\(R x y) -> (Ex y':Y | (B y' y)/\(R x' y'))

    (BIS3) (R a b)

    Instead of defining this relation by the mean of standard logical
    connectives, we give an equivalent impredicative encoding for it
    in order to make the forthcoming proofs a little bit shorter. *)

Definition EQV (X : Typ1) (A : Rel X) (a : X) (Y : Typ1)
  (B : Rel Y) (b : Y) : Prop :=
  forall E : Prop,
  (forall R : X -> Y -> Prop,
   (forall (x x' : X) (y : Y),
    A x' x -> R x y -> ex2 Y (fun y' => B y' y) (fun y' => R x' y')) ->
   (forall (y y' : Y) (x : X),
    B y' y -> R x y -> ex2 X (fun x' => A x' x) (fun x' => R x' y')) ->
   R a b -> E) -> E.

(** Here is the corresponding introduction rule: *)

Lemma EQV_intro :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y)
   (b : Y) (R : X -> Y -> Prop),
 (forall (x x' : X) (y : Y),
  A x' x -> R x y -> ex2 Y (fun y' => B y' y) (fun y' => R x' y')) ->
 (forall (y y' : Y) (x : X),
  B y' y -> R x y -> ex2 X (fun x' => A x' x) (fun x' => R x' y')) ->
 R a b -> EQV X A a Y B b.

Proof fun X A a Y B b R H1 H2 H3 E e => e R H1 H2 H3.

(** It would be useless to define the corresponding elimination rule
    whose behaviour is obtained by using [Apply H] instead of [Elim H]
    in the following proof scripts.

    We first check that bisimilarity is an equivalence relation: *)

Lemma EQV_refl : forall (X : Typ1) (A : Rel X) (a : X), EQV X A a X A a.

Proof.
intros X A a; apply EQV_intro with (fun x y => eq X x y).
(* BIS 1 *)
intros x x' y H1 H2; apply ex2_intro with x'.
apply H2; assumption. apply eq_refl.
(* BIS 2 *)
intros y y' x H1 H2; apply ex2_intro with y'.
apply (eq_sym _ _ _ H2); assumption. apply eq_refl.
(* BIS 3 *)
apply eq_refl.
Qed.

Lemma EQV_sym :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 EQV X A a Y B b -> EQV Y B b X A a.

Proof.
intros X A a Y B b H; apply H; clear H; intros R H1 H2 H3.
apply EQV_intro with (fun y x => R x y); assumption.
Qed.

Lemma EQV_trans :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y)
   (b : Y) (Z : Typ1) (C : Rel Z) (c : Z),
 EQV X A a Y B b -> EQV Y B b Z C c -> EQV X A a Z C c.

Proof.
intros X A a Y B b Z C c H1 H4.
apply H1; clear H1; intros R H1 H2 H3.
apply H4; clear H4; intros S H4 H5 H6.
apply EQV_intro with (fun x z => ex2 Y (fun y => R x y) (fun y => S y z)).
(* BIS1 *)
intros x x' z H7 H; apply H; clear H; intros y H8 H9.
apply (H1 x x' y H7 H8); intros y' H10 H11.
apply (H4 y y' z H10 H9); intros z' H12 H13.
apply ex2_intro with z'. assumption.
apply ex2_intro with y'; assumption.
(* BIS2 *)
intros z z' x H7 H; apply H; clear H; intros y H8 H9.
apply (H5 z z' y H7 H9); intros y' H10 H11.
apply (H2 y y' x H10 H8); intros x' H12 H13.
apply ex2_intro with x'. assumption.
apply ex2_intro with y'; assumption.
(* BIS3 *)
apply ex2_intro with b; assumption.
Qed.

(** The following lemma states that the bisimilarity relation can be
    shifted one vertex down by following the edges of both local
    membership relations. *)

Lemma EQV_shift :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 EQV X A a Y B b ->
 forall a' : X,
 A a' a -> ex2 Y (fun b' => B b' b) (fun b' => EQV X A a' Y B b').

Proof.
intros X A a Y B b H; eapply H; clear H; intros R H1 H2 H3.
intros a' H4; apply (H1 a a' b H4 H3); intros b' H5 H6.
apply ex2_intro with b'. assumption.
apply EQV_intro with R; assumption.
Qed.

(******************************************)
(** * Membership as shifted bisimilarity  *)
(******************************************)

(** A pointed graph (X, A, a) represents an element of a pointed graph
    (Y, B, b) if there is a vertex b':Y one edge below the root b such
    that the pointed graphs (X, A, a) and (Y, B, b') are bisimilar.

    This relation is impredicatively encoded as follows: *)

Definition ELT (X : Typ1) (A : Rel X) (a : X) (Y : Typ1)
  (B : Rel Y) (b : Y) : Prop :=
  forall E : Prop, (forall b' : Y, B b' b -> EQV X A a Y B b' -> E) -> E.

Lemma ELT_intro :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b b' : Y),
 B b' b -> EQV X A a Y B b' -> ELT X A a Y B b.

Proof fun X A a Y B b b' H1 H2 E e => e b' H1 H2.

(** Direct elements of a pointed graph (X, A, a) are simply the pointed
    graphs of the form (X, A, a') such that (A a' a), that is, the
    pointed graphs we obtain by shifting the root one edge downwards: *)

Lemma ELT_direct :
 forall (X : Typ1) (A : Rel X) (a a' : X), A a' a -> ELT X A a' X A a.

Proof.
intros X A a a' H; apply ELT_intro with a'.
assumption.  apply EQV_refl.
Qed.

(** We now state the (left and right) compatibility of the membership
    relation w.r.t. the bisimilarity relation.  Both compatibilities
    rely on the transitivity of the bisimilarity relation, and the
    right compatibility uses the EQV_shift lemma we proved above. *)

Lemma ELT_compat_l :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y)
   (b : Y) (Z : Typ1) (C : Rel Z) (c : Z),
 EQV X A a Y B b -> ELT Y B b Z C c -> ELT X A a Z C c.

Proof.
intros X A a Y B b Z C c H1 H.
apply H; clear H; intros c' H2 H3.
apply ELT_intro with c'.  assumption.
apply EQV_trans with Y B b; assumption.
Qed.

Lemma ELT_compat_r :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y)
   (b : Y) (Z : Typ1) (C : Rel Z) (c : Z),
 ELT X A a Y B b -> EQV Y B b Z C c -> ELT X A a Z C c.

Proof.
intros X A a Y B b Z C c H.
eapply H; clear H; intros b' H1 H2 H3.
apply (EQV_shift _ _ _ _ _ _ H3 b' H1); intros c' H4 H5.
apply ELT_intro with c'.  assumption.
apply EQV_trans with Y B b'; assumption.
Qed.

(************************************)
(** * Inclusion and extensionality  *)
(************************************)

(** The inclusion relation is defined as expected: *)

Definition SUB (X : Typ1) (A : Rel X) (a : X) (Y : Typ1)
  (B : Rel Y) (b : Y) : Prop :=
  forall (Z : Typ1) (C : Rel Z) (c : Z), ELT Z C c X A a -> ELT Z C c Y B b.

(** Inclusion is clearly reflexive and transitive: *)

Lemma SUB_refl : forall (X : Typ1) (A : Rel X) (a : X), SUB X A a X A a.

Proof.
unfold SUB in |- *; auto.
Qed.

Lemma SUB_trans :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y)
   (b : Y) (Z : Typ1) (C : Rel Z) (c : Z),
 SUB X A a Y B b -> SUB Y B b Z C c -> SUB X A a Z C c.

Proof.
unfold SUB in |- *; auto.
Qed.

(** We now state the extensionality property, which expresses that the
    inclusion relation is antisymmetric (thus being a partial ordering
    relation between sets).  Equivalently, this property says that two
    pointed graphs are bisimilar when they have the same elements. *)

Theorem extensionality :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 SUB X A a Y B b -> SUB Y B b X A a -> EQV X A a Y B b.

Proof.
intros X A a Y B b H1 H2.
(* Give the bisimulation: *)
apply
 EQV_intro with (fun x y => or (and (eq X x a) (eq Y y b)) (EQV X A x Y B y)).
(* BIS1 *)
intros x x' y H3 H4; apply H4; clear H4; intro H4.
(* BIS1, first case: x = a and y = b *)
apply H4; clear H4; intros H4 H5.
generalize (ELT_direct X A x x' H3); eapply (eq_sym _ _ _ H4).
intro H6; apply (H1 _ _ _ H6); intros y' H7 H8.
apply ex2_intro with y'.
apply (eq_sym _ _ _ H5); assumption.
apply or_inr; assumption.
(* BIS1, second case: (EQV X A x Y B y) *)
apply (EQV_shift _ _ _ _ _ _ H4 x' H3).
intros y' H5 H6; apply ex2_intro with y'.
assumption.  apply or_inr; assumption.
(* BIS2 *)
intros y y' x H3 H4; apply H4; clear H4; intro H4.
(* BIS2, first case: x = a and y = b *)
apply H4; clear H4; intros H4 H5.
generalize (ELT_direct Y B y y' H3); eapply (eq_sym _ _ _ H5).
intro H6; apply (H2 _ _ _ H6); intros x' H7 H8.
apply ex2_intro with x'.
apply (eq_sym _ _ _ H4); assumption.
apply or_inr; apply EQV_sym; assumption.
(* BIS2, second case: (EQV X A x Y B y) *)
apply (EQV_shift _ _ _ _ _ _ (EQV_sym _ _ _ _ _ _ H4) y' H3).
intros x' H5 H6; apply ex2_intro with x'.
assumption.  apply or_inr; apply EQV_sym; assumption.
(* BIS3 *)
apply or_inl; apply and_intro; apply eq_refl.
Qed.

(*******************)
(** * Delocations  *)
(*******************)

(** Let (X, A) and (Y, B) be two graphs.  A delocation from (X, A) to
    (Y, B) is a function f : X->Y such that:

    1. (x,x':X)    (A x' x) -> (B (f x') (f x))

    2. (x:X; y':Y) (B y' (f x)) -> (Ex x':X | (A x' x) /\ y'=(f x'))

    Intuitively, a delocation is a morphism of graphs in which any edge
    of the target graph (Y, B) which points to an element of the image
    of f can be tracked back as an edge in the source graph via f.
    This notion is formalized as follows: *)

Definition deloc (X : Typ1) (A : Rel X) (Y : Typ1)
  (B : Rel Y) (f : X -> Y) : Prop :=
  and (forall x x' : X, A x' x -> B (f x') (f x))
    (forall (x : X) (y' : Y),
     B y' (f x) -> ex2 X (fun x' => A x' x) (fun x' => eq Y y' (f x'))).

(** The notion of delocation f:(X,A)->(Y,B) is interesting since it
    automatically induces a bisimulation from the pointed graph (X, A, x)
    to the pointed graph (Y, B, (f x)) for any vertex x:X in the source
    graph (X,A).  This property is stated by the following lemma: *)

Lemma EQV_deloc :
 forall (X : Typ1) (A : Rel X) (Y : Typ1) (B : Rel Y) (f : X -> Y),
 deloc X A Y B f -> forall x : X, EQV X A x Y B (f x).

Proof.
intros X A Y B f H.  eapply H; clear H; intros H1 H2 x0.
apply EQV_intro with (fun x y => eq Y y (f x)).
(* BIS1 *)
intros x x' y H3 H4; apply ex2_intro with (f x').
apply (eq_sym _ _ _ H4); apply H1; assumption.
apply eq_refl.
(* BIS2 *)
intros y y' x H3 H4.
exact (H2 x y' (H4 (B y') H3)).
(* BIS3 *)
apply eq_refl.
Qed.


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 O E Eprime A B C D U Bu Xu : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ Bu Xu /\ (wd_ B Bu /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Bu /\ (col_ O E Xu /\ (col_ U O Eprime /\ col_ Eprime O Eprime)))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O E Eprime A B C1 C2 B1 B2 : Universe, ((wd_ O E /\ (wd_ A O /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ O B2 /\ (wd_ O B /\ (wd_ O B1 /\ (wd_ B1 B2 /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C1 /\ (col_ O E C2 /\ col_ O B1 B2)))))))))))) -> col_ C1 O C2)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export csubst2.

Lemma isprogram_isint {o} :
  forall a b c,
    isprogram a
    -> isprogram b
    -> @isprogram o c
    -> isprogram (mk_isint a b c).
Proof.
  repeat constructor.
  unfold closed; simpl.
  allrw <- null_iff_nil.
  repeat (rw null_app).
  repeat (rw null_iff_nil).
  allunfold @isprogram; allunfold @closed.
  repeat (rewrite remove_nvars_nil_l); sp.
  simpl; sp; allunfold @isprogram; sp; subst; constructor; auto.
Qed.

Lemma isprogram_isint_iff {p} :
  forall a b c, (isprogram a # isprogram b # @isprogram p c) <=> isprogram (mk_isint a b c).
Proof.
  intros; split; intro i.
  apply isprogram_isint; sp.
  inversion i as [cl w].
  allunfold @closed; allsimpl.
  allrw remove_nvars_nil_l.
  allrw app_nil_r.
  allrw app_eq_nil_iff; repnd; allrw.
  inversion w as [| | o lnt k meq ]; allsimpl; subst.
  generalize (k (nobnd a)) (k (nobnd b)) (k (nobnd c)); intros i1 i2 i3.
  dest_imp i1 hyp; dest_imp i2 hyp; dest_imp i3 hyp.
  unfold isprogram; allrw.
  inversion i1; inversion i2; inversion i3; subst; sp.
Qed.

Lemma isprog_isint {p} :
  forall a b c,
    isprog a
    -> isprog b
    -> @isprog p c
    -> isprog (mk_isint a b c).
Proof.
  sp; allrw @isprog_eq.
  apply isprogram_isint; auto.
Qed.

Definition mkc_isint {p} (t1 t2 t3 : @CTerm p) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
  let (c,z) := t3 in
  exist isprog (mk_isint a b c) (isprog_isint a b c x y z).

Lemma mkc_isint_eq {p} :
  forall a b c d e f,
    mkc_isint a b c = @mkc_isint p d e f
    -> a = d # b = e # c = f.
Proof.
  introv eq.
  destruct_cterms.
  allunfold @mkc_isint.
  inversion eq; subst; dands; tcsp; eauto with pi.
Qed.

Lemma fold_isint {p} :
  forall a b c,
    oterm (NCan (NCanTest CanIsint)) [ nobnd a, nobnd b, @nobnd p c ]
    = mk_isint a b c.
Proof.
  sp.
Qed.

Lemma lsubstc_mk_isint {p} :
  forall t1 t2 t3 sub,
  forall w1 : wf_term t1,
  forall w2 : wf_term t2,
  forall w3 : @wf_term p t3,
  forall w  : wf_term (mk_isint t1 t2 t3),
  forall c1 : cover_vars t1 sub,
  forall c2 : cover_vars t2 sub,
  forall c3 : cover_vars t3 sub,
  forall c  : cover_vars (mk_isint t1 t2 t3) sub,
    lsubstc (mk_isint t1 t2 t3) w sub c
    = mkc_isint (lsubstc t1 w1 sub c1)
                  (lsubstc t2 w2 sub c2)
                  (lsubstc t3 w3 sub c3).
Proof.
  introv.

  apply cterm_eq; simpl.
  unfold csubst; simpl;
  change_to_lsubst_aux4; simpl;
  rw @sub_filter_nil_r;
  allrw @fold_nobnd;
  rw @fold_isint; sp.
Qed.

Lemma lsubstc_mk_isint_ex {p} :
  forall t1 t2 t3 sub,
  forall w  : wf_term (@mk_isint p t1 t2 t3),
  forall c  : cover_vars (mk_isint t1 t2 t3) sub,
  {w1 : wf_term t1
   & {w2 : wf_term t2
   & {w3 : wf_term t3
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
   & {c3 : cover_vars t3 sub
      & lsubstc (mk_isint t1 t2 t3) w sub c
           = mkc_isint (lsubstc t1 w1 sub c1)
                         (lsubstc t2 w2 sub c2)
                         (lsubstc t3 w3 sub c3)}}}}}}.
Proof.
  sp.

  assert (wf_term t1) as w1.
  { allrw @wf_can_test_iff; sp. }

  assert (wf_term t2) as w2.
  { allrw @wf_can_test_iff; sp. }

  assert (wf_term t3) as w3.
  { allrw @wf_can_test_iff; sp. }

  assert (cover_vars t1 sub) as c1.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  assert (cover_vars t2 sub) as c2.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  assert (cover_vars t3 sub) as c3.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  exists w1 w2 w3 c1 c2 c3.
  apply lsubstc_mk_isint.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
(* ZBasics.v, by Vince Barany *)

Require Export Coq.ZArith.ZArith.
Require Export CoRN.logic.CLogic.
From Coq Require Import Lia.

(**
* Basic facts on Z
** Arithmetic over nat
*)

Section narith.

Lemma le_trans : forall l k n : nat, k <= l -> l <= n -> k <= n.
Proof.
 intros l k n Hkl Hln.
 induction  n as [| n Hrecn].
  inversion Hln.
  rewrite <- H.
  exact Hkl.
 inversion Hln.
  rewrite <- H.
  exact Hkl.
 apply le_S.
 apply Hrecn.
 assumption.
Qed.

Lemma minus_n_Sk : forall n k : nat, k < n -> n - k = S (n - S k).
Proof.
 intros n k Hlt.
 induction  n as [| n Hrecn].
  inversion Hlt.
 rewrite <- minus_Sn_m.
  simpl in |- *.
  reflexivity.
 unfold lt in Hlt.
 inversion Hlt.
  auto.
 apply (le_trans (S k)).
  auto.
 assumption.
Qed.

Lemma le_minus : forall n k : nat, n - k <= n.
Proof.
 intros n.
 induction  n as [| n Hrecn].
  simpl in |- *.
  auto.
 intro k.
 case k.
  simpl in |- *.
  auto.
 intro k'.
 simpl in |- *.
 apply (le_trans n).
  apply Hrecn.
 auto.
Qed.

Lemma minus_n_minus_n_k : forall k n : nat, k <= n -> k = n - (n - k).
Proof.
 intros k n Hle.
 induction  k as [| k Hreck].
  rewrite <- minus_n_O.
  apply minus_n_n.
 set (K := k) in |- * at 2.
 rewrite Hreck.
  unfold K in |- *; clear K.
  rewrite (minus_n_Sk n k).
   rewrite (minus_n_Sk n (n - S k)).
    reflexivity.
   unfold lt in |- *.
   rewrite <- (minus_n_Sk n k).
    apply le_minus.
   unfold lt in |- *.
   exact Hle.
  unfold lt in |- *.
  exact Hle.
 apply (le_trans (S k)).
  auto.
 exact Hle.
Qed.

End narith.

#[global]
Hint Resolve le_trans: zarith.
#[global]
Hint Resolve minus_n_Sk: zarith.
#[global]
Hint Resolve le_minus: zarith.
#[global]
Hint Resolve minus_n_minus_n_k: zarith.

(**
** Arithmetic over Z
*)

Section zarith.

Definition Zdec : forall a : Z, {a = 0%Z} + {a <> 0%Z}.
Proof.
 intro a.
 case a.
   left; reflexivity.
  intro; right; discriminate.
 intro; right; discriminate.
Defined.

(* True in any ring *)
Lemma unique_unit : forall u : Z, (forall a : Z, (a * u)%Z = a) -> u = 1%Z.
Proof.
 intros.
 rewrite <- (Zmult_1_l u).
 rewrite (H 1%Z).
 reflexivity.
Qed.

Lemma Zmult_zero_div : forall a b : Z, (a * b)%Z = 0%Z -> a = 0%Z \/ b = 0%Z.
Proof.
 intros a b.
 case a; case b; intros; auto; try discriminate.
Qed.

Lemma Zmult_no_zero_div :
 forall a b : Z, a <> 0%Z -> b <> 0%Z -> (a * b)%Z <> 0%Z.
Proof.
 intros a b Ha Hb.
 intro Hfalse.
 generalize (Zmult_zero_div a b Hfalse).
 tauto.
Qed.

Lemma Zmult_unit_oneforall :
 forall u a : Z, a <> 0%Z -> (a * u)%Z = a -> forall b : Z, (b * u)%Z = b.
Proof.
 intros u a H0 Hu b.
 apply (Zmult_absorb a).
  assumption.
 rewrite Zmult_assoc.
 rewrite (Zmult_comm a b).
 rewrite <- Zmult_assoc.
 rewrite Hu.
 reflexivity.
Qed.

Lemma Zunit_eq_one : forall u a : Z, a <> 0%Z -> (a * u)%Z = a -> u = 1%Z.
Proof.
 intros u a H1 H2.
 apply unique_unit.
 intro.
 apply (Zmult_unit_oneforall u a H1 H2).
Qed.

Lemma Zmult_intro_lft :
 forall a b c : Z, a <> 0%Z -> (a * b)%Z = (a * c)%Z -> b = c.
Proof.
 intros a b c Ha Habc.
 cut ((b - c)%Z = 0%Z); auto with zarith.
 elim (Zmult_zero_div a (b - c)).
   intro; elim Ha; assumption.
  tauto.
 rewrite Zmult_comm; rewrite BinInt.Zmult_minus_distr_r;
   rewrite (Zmult_comm b a); rewrite (Zmult_comm c a).
 auto with zarith.
Qed.

Lemma Zmult_intro_rht :
 forall a b c : Z, a <> 0%Z -> (b * a)%Z = (c * a)%Z -> b = c.
Proof.
 intros a b c.
 rewrite (Zmult_comm b a); rewrite (Zmult_comm c a); apply Zmult_intro_lft.
Qed.

Lemma succ_nat: forall (m:nat),Zpos (P_of_succ_nat m) = (Z_of_nat m + 1)%Z.
Proof.
 intro m.
 induction m.
  reflexivity.
 simpl.
 case (P_of_succ_nat m).
   simpl.
   reflexivity.
  simpl.
  reflexivity.
 simpl.
 reflexivity.
Qed.

End zarith.

#[global]
Hint Resolve Zdec: zarith.
#[global]
Hint Resolve unique_unit: zarith.
#[global]
Hint Resolve Zmult_zero_div: zarith.
#[global]
Hint Resolve Zmult_no_zero_div: zarith.
#[global]
Hint Resolve Zmult_unit_oneforall: zarith.
#[global]
Hint Resolve Zunit_eq_one: zarith.
#[global]
Hint Resolve Zmult_intro_lft: zarith.
#[global]
Hint Resolve Zmult_intro_rht: zarith.

(**
** Facts on inequalities over Z
*)

Section zineq.

Lemma Zgt_Zge: forall (n m:Z), (n>m)%Z -> (n>=m)%Z.
Proof.
 intros n m.
 intuition.
Qed.

Lemma Zle_antisymm : forall a b : Z, (a >= b)%Z -> (b >= a)%Z -> a = b.
Proof.
 auto with zarith.
Qed.

Definition Zlt_irref : forall a : Z, ~ (a < a)%Z := Z.lt_irrefl.

Lemma Zgt_irref : forall a : Z, ~ (a > a)%Z.
Proof.
 intro a.
 intro Hlt.
 generalize (Z.gt_lt a a Hlt).
 apply Zlt_irref.
Qed.

Lemma Zlt_NEG_0 : forall p : positive, (Zneg p < 0)%Z.
Proof.
 intro p; unfold Z.lt in |- *; simpl in |- *; reflexivity.
Qed.

Lemma Zgt_0_NEG : forall p : positive, (0 > Zneg p)%Z.
Proof.
 intro p; unfold Z.gt in |- *; simpl in |- *; reflexivity.
Qed.

Lemma Zle_NEG_0 : forall p : positive, (Zneg p <= 0)%Z.
Proof.
 intro p; intro H0; inversion H0.
Qed.

Lemma Zge_0_NEG : forall p : positive, (0 >= Zneg p)%Z.
Proof.
 intro p; intro H0; inversion H0.
Qed.

Lemma Zle_NEG_1 : forall p : positive, (Zneg p <= -1)%Z.
Proof.
 intro p.
 case p; intros; intro H0; inversion H0.
Qed.

Lemma Zge_1_NEG : forall p : positive, (-1 >= Zneg p)%Z.
Proof.
 intro p.
 case p; intros; intro H0; inversion H0.
Qed.

Lemma Zlt_0_POS : forall p : positive, (0 < Zpos p)%Z.
Proof.
 intro p; unfold Z.lt in |- *; simpl in |- *; reflexivity.
Qed.

Lemma Zgt_POS_0 : forall p : positive, (Zpos p > 0)%Z.
Proof.
 intro p; unfold Z.gt in |- *; simpl in |- *; reflexivity.
Qed.

Lemma Zle_0_POS : forall p : positive, (0 <= Zpos p)%Z.
Proof.
 intro p; intro H0; inversion H0.
Qed.

Lemma Zge_POS_0 : forall p : positive, (Zpos p >= 0)%Z.
Proof.
 intro p; intro H0; inversion H0.
Qed.

Lemma Zle_1_POS : forall p : positive, (1 <= Zpos p)%Z.
Proof.
 intro p.
 case p; intros; intro H0; inversion H0.
Qed.

Lemma Zge_POS_1 : forall p : positive, (Zpos p >= 1)%Z.
Proof.
 intro p.
 case p; intros; intro H0; inversion H0.
Qed.

Lemma Zle_neg_pos : forall p q : positive, (Zneg p <= Zpos q)%Z.
Proof.
 intros; unfold Z.le in |- *; simpl in |- *; discriminate.
Qed.

Lemma ZPOS_neq_ZERO : forall p : positive, Zpos p <> 0%Z.
Proof.
 intros; intro; discriminate.
Qed.

Lemma ZNEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z.
Proof.
 intros; intro; discriminate.
Qed.

Lemma Zge_gt_succ : forall a b : Z, (a >= b + 1)%Z -> (a > b)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zge_gt_pred : forall a b : Z, (a - 1 >= b)%Z -> (a > b)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zgt_ge_succ : forall a b : Z, (a + 1 > b)%Z -> (a >= b)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zgt_ge_pred : forall a b : Z, (a > b - 1)%Z -> (a >= b)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zlt_asymmetric : forall a b : Z, {(a < b)%Z} + {a = b} + {(a > b)%Z}.
Proof.
 intros a b.
 set (d := (a - b)%Z).
 replace a with (b + d)%Z; [ idtac | unfold d in |- *; lia ].
 case d; simpl in |- *.
   left; right; auto with zarith.
  intro p.
  right.
  rewrite <- (Zplus_0_r b).
  replace (b + 0 + Zpos p)%Z with (b + Zpos p)%Z; auto with zarith.
 intro p.
 left; left.
 rewrite <- (Zplus_0_r b).
 replace (b + 0 + Zneg p)%Z with (b + Zneg p)%Z by auto with zarith.
 cut (Zneg p < 0)%Z. auto with zarith.
 apply Zlt_NEG_0.
Qed.

Lemma Zle_neq_lt : forall a b : Z, (a <= b)%Z -> a <> b -> (a < b)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zmult_pos_mon_le_lft :
 forall a b c : Z, (a >= b)%Z -> (c >= 0)%Z -> (c * a >= c * b)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zmult_pos_mon_le_rht :
 forall a b c : Z, (a >= b)%Z -> (c >= 0)%Z -> (a * c >= b * c)%Z.
Proof.
 auto with zarith.
Qed.

Lemma Zmult_pos_mon_lt_lft :
 forall a b c : Z, (a > b)%Z -> (c > 0)%Z -> (c * a > c * b)%Z.
Proof.
 intros a b c.
 induction  c as [| p| p]. auto with zarith.
  intros Hab H0.
  induction  p as [p Hrecp| p Hrecp| ]. 3: auto with zarith.
   replace (Zpos (xI p)) with (2 * Zpos p + 1)%Z by auto with zarith.
   repeat rewrite Zmult_plus_distr_l.
   cut (2 * Zpos p * a > 2 * Zpos p * b)%Z. auto with zarith.
   repeat rewrite <- Zmult_assoc.
   cut (Zpos p * a > Zpos p * b)%Z; auto with zarith.
  replace (Zpos (xO p)) with (2 * Zpos p)%Z by auto with zarith.
  repeat rewrite <- Zmult_assoc.
  cut (Zpos p * a > Zpos p * b)%Z; auto with zarith.
 intros Hab H0.
 inversion H0.
Qed.

Lemma Zmult_pos_mon_lt_rht :
 forall a b c : Z, (a > b)%Z -> (c > 0)%Z -> (a * c > b * c)%Z.
 intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c); apply Zmult_pos_mon_lt_lft.
Qed.

Lemma Zmult_pos_mon : forall a b : Z, (a * b > 0)%Z -> (a * b >= a)%Z.
Proof.
 intros a b.
 case a.
   auto with zarith.
  case b.
    auto with zarith.
   intros.
   set (pp := Zpos p0) in |- * at 2.
   rewrite <- (Zmult_1_l pp).
   unfold pp in |- *; clear pp.
   rewrite Zmult_comm.
   apply Zmult_pos_mon_le_rht.
    apply Zge_POS_1.
   apply Zge_POS_0.
  intros p q; simpl in |- *; intro H0; inversion H0.
 intros p H0.
 apply (Zge_trans (Zneg p * b) 0 (Zneg p)).
  auto with zarith.
 apply Zge_0_NEG.
Qed.

Lemma Zdiv_pos_pos : forall a b : Z, (a * b > 0)%Z -> (a > 0)%Z -> (b > 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *;
     simpl in |- *; intros; try discriminate; auto.
Qed.

Lemma Zdiv_pos_nonneg :
 forall a b : Z, (a * b > 0)%Z -> (a >= 0)%Z -> (b > 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *;
     simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto).
Qed.

Lemma Zdiv_pos_neg : forall a b : Z, (a * b > 0)%Z -> (a < 0)%Z -> (b < 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *;
     simpl in |- *; intros; try discriminate; auto.
Qed.

Lemma Zdiv_pos_nonpos :
 forall a b : Z, (a * b > 0)%Z -> (a <= 0)%Z -> (b < 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *;
     simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto).
Qed.

Lemma Zdiv_neg_pos : forall a b : Z, (a * b < 0)%Z -> (a > 0)%Z -> (b < 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *;
     simpl in |- *; intros; try discriminate; auto.
Qed.

Lemma Zdiv_neg_nonneg :
 forall a b : Z, (a * b < 0)%Z -> (a >= 0)%Z -> (b < 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *;
     simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto).
Qed.

Lemma Zdiv_neg_neg : forall a b : Z, (a * b < 0)%Z -> (a < 0)%Z -> (b > 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *;
     simpl in |- *; intros; try discriminate; auto.
Qed.

Lemma Zdiv_neg_nonpos :
 forall a b : Z, (a * b < 0)%Z -> (a <= 0)%Z -> (b > 0)%Z.
Proof.
 intros a b; induction  a as [| p| p]; [ induction  b as [| p| p] | induction  b as [| p0| p0]
   | induction  b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *;
     simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto).
Qed.

Lemma Zcompat_lt_plus: forall (n m p:Z),(n < m)%Z-> (p+n < p+m)%Z.
Proof.
 intros n m p.
 intuition.
Qed.

Transparent Zplus.

Lemma lt_succ_Z_of_nat: forall (m:nat)( k n:Z),
  (Z_of_nat (S m)<(k+n))%Z -> (Z_of_nat m <(k+n))%Z.
Proof.
 intros m k n.
 simpl.
 set (H:=(succ_nat m)).
 rewrite H.
 intuition.
Qed.

Opaque Zplus.

End zineq.

#[global]
Hint Resolve Z.lt_gt: zarith.
#[global]
Hint Resolve Z.gt_lt: zarith.
#[global]
Hint Resolve Z.le_ge: zarith.
#[global]
Hint Resolve Z.ge_le: zarith.
#[global]
Hint Resolve Z.lt_irrefl: zarith.

#[global]
Hint Resolve Zle_antisymm: zarith.
#[global]
Hint Resolve Zlt_irref: zarith.
#[global]
Hint Resolve Zgt_irref: zarith.
#[global]
Hint Resolve Zlt_NEG_0: zarith.
#[global]
Hint Resolve Zgt_0_NEG: zarith.
#[global]
Hint Resolve Zle_NEG_0: zarith.
#[global]
Hint Resolve Zge_0_NEG: zarith.
#[global]
Hint Resolve Zle_NEG_1: zarith.
#[global]
Hint Resolve Zge_1_NEG: zarith.
#[global]
Hint Resolve Zlt_0_POS: zarith.
#[global]
Hint Resolve Zgt_POS_0: zarith.
#[global]
Hint Resolve Zle_0_POS: zarith.
#[global]
Hint Resolve Zge_POS_0: zarith.
#[global]
Hint Resolve Zle_1_POS: zarith.
#[global]
Hint Resolve Zge_POS_1: zarith.
#[global]
Hint Resolve ZBasics.Zle_neg_pos: zarith.
#[global]
Hint Resolve ZPOS_neq_ZERO: zarith.
#[global]
Hint Resolve ZNEG_neq_ZERO: zarith.
#[global]
Hint Resolve Zgt_ge_succ: zarith.
#[global]
Hint Resolve Zgt_ge_pred: zarith.
#[global]
Hint Resolve Zge_gt_succ: zarith.
#[global]
Hint Resolve Zge_gt_pred: zarith.
#[global]
Hint Resolve Zlt_asymmetric: zarith.
#[global]
Hint Resolve Zle_neq_lt: zarith.
#[global]
Hint Resolve Zmult_pos_mon_le_lft: zarith.
#[global]
Hint Resolve Zmult_pos_mon_le_rht: zarith.
#[global]
Hint Resolve Zmult_pos_mon_lt_lft: zarith.
#[global]
Hint Resolve Zmult_pos_mon_lt_rht: zarith.
#[global]
Hint Resolve Zmult_pos_mon: zarith.
#[global]
Hint Resolve Zdiv_pos_pos: zarith.
#[global]
Hint Resolve Zdiv_pos_neg: zarith.
#[global]
Hint Resolve Zdiv_pos_nonpos: zarith.
#[global]
Hint Resolve Zdiv_pos_nonneg: zarith.
#[global]
Hint Resolve Zdiv_neg_pos: zarith.
#[global]
Hint Resolve Zdiv_neg_neg: zarith.
#[global]
Hint Resolve Zdiv_neg_nonpos: zarith.
#[global]
Hint Resolve Zdiv_neg_nonneg: zarith.

(**
** Facts on the absolute value-function over Z
*)

Section zabs.

Lemma Zabs_idemp : forall a : Z, Z.abs (Z.abs a) = Z.abs a.
Proof.
 intro a; case a; auto.
Qed.

Lemma Zabs_nonneg : forall (a : Z) (p : positive), Z.abs a <> Zneg p.
Proof.
 intros; case a; intros; discriminate.
Qed.

Lemma Zabs_geq_zero : forall a : Z, (0 <= Z.abs a)%Z.
Proof.
 intro a.
 case a; unfold Z.abs in |- *; auto with zarith.
Qed.

Lemma Zabs_elim_nonneg : forall a : Z, (0 <= a)%Z -> Z.abs a = a.
Proof.
 intro a.
 case a; auto.
 intros p Hp; elim Hp.
 apply Zgt_0_NEG.
Qed.

Lemma Zabs_zero : forall a : Z, Z.abs a = 0%Z -> a = 0%Z.
Proof.
 intro a.
 case a.
   tauto.
  intros; discriminate.
 intros; discriminate.
Qed.

Lemma Zabs_Zopp : forall a : Z, Z.abs (- a) = Z.abs a.
Proof.
 intro a.
 case a; auto with zarith.
Qed.

Lemma Zabs_geq : forall a : Z, (a <= Z.abs a)%Z.
Proof.
 intro a.
 unfold Z.abs in |- *.
 case a; auto with zarith.
 Qed.
 Lemma Zabs_Zopp_geq : forall a : Z, (- a <= Z.abs a)%Z.
 intro a.
 rewrite <- Zabs_Zopp.
 apply Zabs_geq.
 Qed.
 Lemma Zabs_Zminus_symm : forall a b : Z, Z.abs (a - b) = Z.abs (b - a).
 intros a b.
 replace (a - b)%Z with (- (b - a))%Z by auto with zarith.
 apply Zabs_Zopp.
Qed.

Lemma Zabs_lt_pos : forall a b : Z, (Z.abs a < b)%Z -> (0 < b)%Z.
Proof.
 intros a b Hab.
 unfold Z.lt in |- *.
 elim (Zcompare_Gt_Lt_antisym b 0).
 intros H1 H2.
 apply H1.
 fold (b > 0)%Z in |- *.
 apply (Zgt_le_trans b (Z.abs a) 0); auto with zarith.
Qed.

Lemma Zabs_le_pos : forall a b : Z, (Z.abs a <= b)%Z -> (0 <= b)%Z.
Proof.
 intros a b Hab.
 apply (Z.le_trans 0 (Z.abs a) b).
  auto with zarith.
 assumption.
Qed.

Lemma Zabs_lt_elim :
 forall a b : Z, (a < b)%Z -> (- a < b)%Z -> (Z.abs a < b)%Z.
Proof.
 intros a b.
 case a; auto with zarith.
Qed.

Lemma Zabs_le_elim :
 forall a b : Z, (a <= b)%Z -> (- a <= b)%Z -> (Z.abs a <= b)%Z.
Proof.
 intros a b.
 case a; auto with zarith.
Qed.

Lemma Zabs_mult_compat : forall a b : Z, (Z.abs a * Z.abs b)%Z = Z.abs (a * b).
Proof.
 intros a b.
 case a; case b; intros; auto with zarith.
Qed.

(* triangle inequality (with Zplus) *)

Let case_POS :
  forall p q r : positive,
  (Zpos q + Zneg p)%Z = Zpos r ->
  (Z.abs (Zpos q + Zneg p) <= Z.abs (Zpos q) + Z.abs (Zneg p))%Z.
Proof.
 intros p q r Hr.
 rewrite Hr.
 simpl in |- *.
 rewrite <- Hr.
 fold (Zpos q + Zpos p)%Z in |- *.
 unfold Z.le in |- *.
 rewrite (Zcompare_plus_compat (Zneg p) (Zpos p) (Zpos q)).
 apply (ZBasics.Zle_neg_pos p).
 Defined.
 Let case_NEG : forall p q r : positive, (Zpos q + Zneg p)%Z = Zneg r ->
   (Z.abs (Zpos q + Zneg p) <= Z.abs (Zpos q) + Z.abs (Zneg p))%Z.
 intros p q r Hr.
 rewrite <- (Z.opp_involutive (Zpos q + Zneg p)) in Hr.
 rewrite <- (Z.opp_involutive (Zneg r)) in Hr.
 generalize (Z.opp_inj (- (Zpos q + Zneg p)) (- Zneg r) Hr).
 intro Hr'. rewrite Zopp_plus_distr in Hr'. unfold Z.opp in Hr'.
 rewrite <- (Zabs_Zopp (Zpos q + Zneg p)). rewrite Zopp_plus_distr. unfold Z.opp in |- *.
 rewrite <- (Zabs_Zopp (Zpos q)). unfold Z.opp in |- *.
 rewrite <- (Zabs_Zopp (Zneg p)). unfold Z.opp in |- *.
 rewrite (Zplus_comm (Zneg q) (Zpos p)).
 rewrite (Zplus_comm (Z.abs (Zneg q)) (Z.abs (Zpos p))).
 rewrite Zplus_comm in Hr'.
 apply (case_POS _ _ _ Hr').
 Defined.
 Lemma Zabs_triangle : forall a b : Z, (Z.abs (a + b) <= Z.abs a + Z.abs b)%Z.
 intros a b.
 case a; case b. 1-5, 7, 9: auto with zarith.
  intros p q.
  generalize (case_POS p q) (case_NEG p q).
  case (Zpos q + Zneg p)%Z.
    auto with zarith.
   intros p0 case_POS0 case_NEG0. apply (case_POS0 p0). reflexivity.
   intros p0 case_POS0 case_NEG0. apply (case_NEG0 p0). reflexivity.
   intros p q.
   rewrite (Zplus_comm (Zneg q) (Zpos p)).
   rewrite (Zplus_comm (Z.abs (Zneg q)) (Z.abs (Zpos p))).
   generalize (case_POS q p) (case_NEG q p).
   case (Zpos p + Zneg q)%Z.
     auto with zarith.
     intros p0 case_POS0 case_NEG0. apply (case_POS0 p0). reflexivity.
     intros p0 case_POS0 case_NEG0. apply (case_NEG0 p0). reflexivity.
     Qed.
     (* triangle inequality with Zminus *)
     Lemma Zabs_Zminus_triangle : forall a b : Z, (Z.abs (Z.abs a - Z.abs b) <= Z.abs (a - b))%Z.
 assert (case : forall a b : Z, (Z.abs a - Z.abs b <= Z.abs (a - b))%Z).
  intros a b.
  unfold Z.le in |- *.
  unfold Zminus in |- *.
  rewrite <- (Zcompare_plus_compat (Z.abs a + - Z.abs b) (Z.abs (a + - b)) (Z.abs b)) .
  rewrite (Zplus_comm (Z.abs a) (- Z.abs b)).
  rewrite Zplus_assoc.
  rewrite (Zplus_comm (Z.abs b) (- Z.abs b)).
  rewrite Zplus_opp_l.
  rewrite Zplus_0_l.
  assert (l : forall a b : Z, a = (b + (a - b))%Z).
   auto with zarith.
  set (a' := a) in |- * at 2.
  rewrite (l a b).
  unfold a' in |- *.
  fold (a - b)%Z in |- *.
  apply (Zabs_triangle b (a - b)).
 intros a b.
 apply Zabs_le_elim.
  apply case.
 replace (- (Z.abs a - Z.abs b))%Z with (Z.abs b - Z.abs a)%Z by auto with zarith.
 rewrite Zabs_Zminus_symm.
 apply case.
Qed.

End zabs.

#[global]
Hint Resolve Zabs_idemp: zarith.
#[global]
Hint Resolve Zabs_nonneg: zarith.
#[global]
Hint Resolve Zabs_geq_zero: zarith.
#[global]
Hint Resolve Zabs_elim_nonneg: zarith.
#[global]
Hint Resolve Zabs_zero: zarith.
#[global]
Hint Resolve Zabs_Zopp: zarith.
#[global]
Hint Resolve Zabs_geq: zarith.
#[global]
Hint Resolve Zabs_Zopp_geq: zarith.
#[global]
Hint Resolve Zabs_Zminus_symm: zarith.
#[global]
Hint Resolve Zabs_lt_pos: zarith.
#[global]
Hint Resolve Zabs_le_pos: zarith.
#[global]
Hint Resolve Zabs_lt_elim: zarith.
#[global]
Hint Resolve Zabs_le_elim: zarith.
#[global]
Hint Resolve Zabs_mult_compat: zarith.
#[global]
Hint Resolve Zabs_triangle: zarith.
#[global]
Hint Resolve Zabs_Zminus_triangle: zarith.

(**
** Facts on the sign-function over Z
*)

Section zsign.

Lemma Zsgn_mult_compat : forall a b : Z, (Z.sgn a * Z.sgn b)%Z = Z.sgn (a * b).
Proof.
 intros a b.
 case a; case b; intros; auto with zarith.
Qed.

Lemma Zmult_sgn_abs : forall a : Z, (Z.sgn a * Z.abs a)%Z = a.
Proof.
 intro a.
 case a; intros; auto with zarith.
Qed.

Lemma Zmult_sgn_eq_abs : forall a : Z, Z.abs a = (Z.sgn a * a)%Z.
Proof.
 intro a.
 case a; intros; auto with zarith.
Qed.

Lemma Zsgn_plus_l : forall a b : Z, Z.sgn a = Z.sgn b -> Z.sgn (a + b) = Z.sgn a.
Proof.
 intros a b.
 case a; case b; simpl in |- *; auto; intros; try discriminate.
Qed.

Lemma Zsgn_plus_r : forall a b : Z, Z.sgn a = Z.sgn b -> Z.sgn (a + b) = Z.sgn b.
Proof.
 intros.
 rewrite Zplus_comm.
 apply Zsgn_plus_l.
 auto.
Qed.

Lemma Zsgn_opp : forall z : Z, Z.sgn (- z) = (- Z.sgn z)%Z.
Proof.
 intro z.
 case z; simpl in |- *; auto.
Qed.

Lemma Zsgn_ZERO : forall z : Z, Z.sgn z = 0%Z -> z = 0%Z.
Proof.
 intros z.
 case z; simpl in |- *; intros; auto; try discriminate.
Qed.

Lemma Zsgn_pos : forall z : Z, Z.sgn z = 1%Z -> (z > 0)%Z.
Proof.
 intros z.
 case z; simpl in |- *; intros; auto with zarith; try discriminate.
Qed.

Lemma Zsgn_neg : forall z : Z, Z.sgn z = (-1)%Z -> (z < 0)%Z.
Proof.
 intros z.
 case z; simpl in |- *; intros; auto with zarith; try discriminate.
Qed.

End zsign.

#[global]
Hint Resolve Zsgn_mult_compat: zarith.
#[global]
Hint Resolve Zmult_sgn_abs: zarith.
#[global]
Hint Resolve Zmult_sgn_eq_abs: zarith.
#[global]
Hint Resolve Zsgn_plus_l: zarith.
#[global]
Hint Resolve Zsgn_plus_r: zarith.
#[global]
Hint Resolve Zsgn_opp: zarith.
#[global]
Hint Resolve Zsgn_ZERO: zarith.
#[global]
Hint Resolve Zsgn_pos: zarith.
#[global]
Hint Resolve Zsgn_neg: zarith.


(* -------------------------------------------------------------------- *)
(* ------- *) Require Import ClassicalFacts Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals realseq realsum distr.
(* ------- *) Require Import inhabited passn pwhile.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.
Local Open Scope syn_scope.
Local Open Scope mem_scope.

Notation ROHS := (X in X <= _)%pattern.
Notation LOHS := (X in _ <= X)%pattern.

(* -------------------------------------------------------------------- *)
Axiom funext : forall {T U : Type} (f g : T -> U),
  (forall x, f x = g x) -> f = g.

Lemma funext2 : forall {T U V : Type} (f g : T -> U -> V),
  (forall x y, f x y = g x y) -> f = g.
Proof. by move=> T U V f g eq; apply/funext=> x; apply/funext. Qed.

(* -------------------------------------------------------------------- *)
Lemma distr_eqP {T : choiceType} (f1 f2 : Distr T):
  f1 =1 f2 <-> f1 = f2.
Proof.
split=> [|->] //; case: f1 f2 => [mu1 ge0_1 s1 le1_1] [mu2 ge0_2 s2 le1_2].
move/funext => /= eq_mu; have PI (A : Prop): A \/ ~ A by case: (asboolP A); auto.
by subst; f_equal; apply proof_irrelevance_cci.
Qed.

(* -------------------------------------------------------------------- *)
Section DistrRecast.
Variables (T U V : choiceType) (f g : T -> Distr U) (mu nu : Distr T).

Lemma dlet_null : \dlet_(i <- dnull) f i = dnull.
Proof. by apply/distr_eqP/dlet_null. Qed.

Lemma dlet_unit x : \dlet_(i <- dunit x) f i = f x.
Proof. by apply/distr_eqP/dlet_unit. Qed.

Lemma dlet_if b :
    \dlet_(t <- if b then mu else nu) f t
  =  if b then \dlet_(t <- mu) f t else \dlet_(t <- nu) f t.
Proof. by case:ifP. Qed.

Lemma dlet_dlet (f1 : T -> Distr U) (f2 : U -> Distr V) :
    \dlet_(x <- \dlet_(y <- mu) f1 y) f2 x
  = \dlet_(y <- mu) \dlet_(x <- f1 y) f2 x.
Proof. by apply/distr_eqP/dlet_dlet. Qed.

Lemma eq_in_dlet :
  {in dinsupp mu, f =1 g} -> mu = nu ->
  \dlet_(i <- mu) f i = \dlet_(i <- nu) g i.
Proof.
by move=> eqf <-; apply/distr_eqP/eq_in_dlet=>// x /eqf ->.
Qed.

Lemma eq_dlim (fn gn : nat -> Distr T):
  fn =1 gn -> \dlim_(n) fn n = \dlim_(n) gn n.
Proof. by move=> eq_fg; apply/distr_eqP/eq_dlim=> ??; rewrite eq_fg. Qed.

Lemma dlet_dmargin (f1 : T -> U) (g1 : U -> Distr V):
       \dlet_(u <- dmargin f1 mu) g1 u = \dlet_(t <- mu) g1 (f1 t).
Proof. apply /distr_eqP/dlet_dmargin. Qed.

Lemma dmargin_dlet (f1 : U -> V) (g1 : T -> Distr U):
       dmargin f1 (\dlet_(t <- mu) g1 t) = \dlet_(t <- mu) dmargin f1 (g1 t).
Proof. apply /distr_eqP/dmargin_dlet. Qed.

Lemma dmargin_dunit (t : T) (f1 : T -> U):
   @dmargin R _ _ f1 (dunit t) = dunit (f1 t).
Proof. apply /distr_eqP/dmargin_dunit. Qed.

Lemma dlet_dunit_id : \dlet_(t <- mu) (dunit t) = mu :> Distr T.
Proof. by apply/distr_eqP/dlet_dunit_id. Qed.

Lemma dlim_let (h : nat -> T -> Distr U) (d : Distr T) :
  (forall x n m, (n <= m)%N -> h n x <=1 h m x) ->
    \dlim_(n) \dlet_(x <- d) (h n x) =
      \dlet_(x <- d) \dlim_(n) (h n x).
Proof. by move=> ?; apply/distr_eqP/dlim_let. Qed.

Lemma dlimC: \dlim_(_) mu = mu.
Proof. by apply/distr_eqP/dlimC. Qed.
End DistrRecast.

(* -------------------------------------------------------------------- *)
Section DLimRecast.
Variables (T U : choiceType).
Variables (f : nat -> {distr T / R}) (h : T -> {distr U / R}).

Lemma dlet_lim : (forall n m, (n <= m)%N -> f n <=1 f m) ->
  \dlet_(x <- \dlim_(n) f n) h x = \dlim_(n) \dlet_(x <- f n) h x.
Proof. by move=> ?; apply/distr_eqP/dlet_lim. Qed.
End DLimRecast.

(* -------------------------------------------------------------------- *)
Section DProj.
Context {T : choiceType} (mu : Distr (T * T)).

Lemma dprojE s x :
  dmargin (fst, snd)#s mu x =
    psum (fun y => mu ((x, y)#s, (y, x)#s)).
Proof. by case: s => /=; rewrite ?(dfstE, dsndE). Qed.

Lemma summable_proj s x1 :
  summable (fun x2 => mu ((x1, x2)#s, (x2, x1)#s)).
Proof. by case: s => /=; [apply/summable_fst | apply/summable_snd]. Qed.
End DProj.

(* -------------------------------------------------------------------- *)
Fixpoint ubn {A : choiceType} (f : A -> Distr A) (t : pred A) n := fun a =>
  if n is n.+1 return Distr A then
    if t a then \dlet_(x <- f a) ubn f t n x else dunit a
  else dnull.

(* -------------------------------------------------------------------- *)
Reserved Notation "m .[ x <- v ]"
  (at level 2, x, v at level 200, format "m .[ x  <-  v ]").

(* -------------------------------------------------------------------- *)
Notation "m .[ x ]"      := (@mget _ _ (x%V).(vtype) m (x%V).(vname)) : mem_scope.
Notation "m .[ x <- v ]" := (@mset _ _ (x%V).(vtype) m (x%V).(vname) v) : mem_scope.

(* -------------------------------------------------------------------- *)
Section Semantics.
Context {X : eqType} {cmem: memType X}.

Notation vars    := (@vars_ X).
Notation expr    := (@expr_ X cmem).
Notation cmd     := (@cmd_  X cmem).
Notation bexpr   := (expr bool).
Notation dexpr T := (expr (Distr T)).

Notation mdistr := (Distr cmem.(mheap)).
Notation mnull  := (@dnull R cmem.(mheap)).

(* -------------------------------------------------------------------- *)
Fixpoint esem {T : Type} (e : expr T) (m : cmem) : T :=
  match e in expr_ _ _ T return T with
  | var_ T x => m.[x]
  | cst_ T c => c
  | prp_ P   => P m
  | app_ T U e1 e2 => (esem e1 m) (esem e2 m)
  end.

(* -------------------------------------------------------------------- *)
Fixpoint ssem_aux (s : cmd) (m : cmem) : mdistr :=
  match s with
  | abort => mnull
  | skip  => dunit m

  | x <<- e =>
      dunit (m.[x <- esem e m])

  | x <$- e =>
      \dlet_(v <- esem e m) (dunit m.[x <- v])

  | If e then c1 else c2 =>
      match esem e m with
      | true  => ssem_aux c1 m
      | false => ssem_aux c2 m
      end

  | While e Do c =>
      dlim (fun n => ubn (ssem_aux c) (esem e) n m)

  | seqc c1 c2 =>
     \dlet_(m' <- ssem_aux c1 m) (ssem_aux c2 m')
  end.

Definition ssem_r s m := ssem_aux s m.

(* -------------------------------------------------------------------- *)
Fact ssem_key : unit. Proof. by []. Qed.
Definition ssem_ := locked_with ssem_key ssem_r.
Canonical ssem_unlockable := [unlockable fun ssem_].

(* -------------------------------------------------------------------- *)
Implicit Types (m : cmem) (c : cmd).

Notation ssem := ssem_.
Notation prp  := prp_.

Lemma sem_eqP c1 c2 :
  (forall m, ssem c1 m = ssem c2 m) <-> ssem c1 = ssem c2.
Proof. by split=> [|->//] eq; apply/funext=> m. Qed.

Fixpoint whilen e c n :=
  if n is n.+1 then
    (If e then (c;; whilen e c n) else skip)
  else abort.

Lemma ssem_abortE m : ssem abort m = mnull.
Proof. by rewrite unlock. Qed.

Lemma ssem_skipE m : ssem skip m = dunit m.
Proof. by rewrite unlock. Qed.

Lemma ssem_assnE {T} (x : vars T) (e : expr T) m :
  ssem (x <<- e) m = dunit (m.[x <- esem e m]).
Proof. by rewrite unlock. Qed.

Lemma ssem_rndE {T} (x : vars T) (e : dexpr T) m :
  ssem (x <$- e) m = \dlet_(v <- esem e m) (dunit m.[x <- v]).
Proof. by rewrite unlock. Qed.

Lemma ssem_ifE e c1 c2 m :
  ssem (If e then c1 else c2) m =
    if esem e m then ssem c1 m else ssem c2 m.
Proof. by rewrite unlock. Qed.

Lemma ssem_seqE c1 c2 m :
  ssem (c1 ;; c2) m = \dlet_(m' <- ssem c1 m) (ssem c2 m').
Proof. by rewrite unlock. Qed.

Lemma esem_varE {T : ihbType} (x : vars T) m :
   esem (@var_ _ _ T x) m = m.[x].
Proof. by []. Qed.

Lemma esem_cstE {T : Type} (c : T) m : esem (cst_ c) m = c.
Proof. by []. Qed.

Lemma esem_prpE (P : pred cmem) m : esem (prp_ P) m = P m.
Proof. by []. Qed.

Lemma esem_appE {T U : Type} (e1 : expr (T -> U)) (e2 : expr T) m :
  esem (app_ e1 e2) m = (esem e1 m) (esem e2 m).
Proof. by []. Qed.

Lemma ssem_whileE e c m :
  ssem (While e Do c) m = dlim (fun n => ssem (whilen e c n) m).
Proof.
rewrite {1}unlock /=; apply/eq_dlim=> n /=.
elim: n m => /= [|n ih] m; first by rewrite ssem_abortE.
rewrite ssem_ifE; case: (esem e m); last by rewrite ssem_skipE.
rewrite ssem_seqE /=;apply/eq_in_dlet => //.
by rewrite unlock.
Qed.

Lemma ssem_while_ubn e c m :
  ssem (While e Do c) m = dlim (fun n => ubn (ssem c) (esem e) n m).
Proof. by rewrite unlock. Qed.

Definition semE :=
  (ssem_abortE, ssem_skipE, @ssem_assnE, @ssem_rndE,
   ssem_ifE   , ssem_seqE , ssem_whileE).

Definition bsemE := locked (
  funext ssem_abortE,
  funext ssem_skipE,
  fun T (x : vars T) (e : expr _) => funext (ssem_assnE x e),
  fun T (x : vars T) (e : expr _) => funext (ssem_rndE x e),
  fun e c1 c2 => funext (ssem_ifE e c1 c2),
  fun c1 c2 => funext (ssem_seqE c1 c2),
  fun e c => funext (ssem_whileE e c)).

Lemma sem_seqA c1 c2 c3 :
  ssem ((c1 ;; c2) ;; c3) = ssem (c1 ;; (c2 ;; c3)).
Proof. by apply/sem_eqP=> m; rewrite !bsemE dlet_dlet. Qed.

Lemma sem_ifseq e ct cf c :
    ssem ((If e then ct else cf) ;; c)
  = ssem (If e then (ct ;; c) else (cf ;; c)).
Proof. by apply/sem_eqP=> m; rewrite !bsemE; case: ifP. Qed.

Lemma sem_seql c1 c1' c2 :
  ssem c1 =1 ssem c1' -> ssem (c1 ;; c2) = ssem (c1' ;; c2).
Proof. by move/sem_eqP=> eq; rewrite !bsemE eq. Qed.

Lemma sem_seqr c1 c2 c2' :
  ssem c2 =1 ssem c2' -> ssem (c1 ;; c2) = ssem (c1 ;; c2').
Proof. by move/sem_eqP=> eq; rewrite !bsemE eq. Qed.

Lemma sem_ift e ct ct' cf : ssem ct =1 ssem ct' ->
  ssem (If e then ct else cf) = ssem (If e then ct' else cf).
Proof. by move=> /sem_eqP eq; rewrite !bsemE eq. Qed.

Lemma sem_iff e ct cf cf' : ssem cf =1 ssem cf' ->
  ssem (If e then ct else cf) = ssem (If e then ct else cf').
Proof. by move=> /sem_eqP eq; rewrite !bsemE eq. Qed.

Lemma sem_whileb e c c' :
  ssem c =1 ssem c' -> ssem (While e Do c) = ssem (While e Do c').
Proof.
 move=> /sem_eqP eq;apply/sem_eqP=> m;rewrite !semE.
 apply/eq_dlim=> /= n; elim: n m => //= n /sem_eqP ih m.
 by rewrite !bsemE ih eq .
Qed.

(* -------------------------------------------------------------------- *)
Lemma dlim_seql (C : nat -> cmd) (c : cmd) m :
     (forall m n p, (n <= p)%N -> ssem (C n) m <=1 ssem (C p) m)
  -> \dlim_(n) (ssem (C n ;; c) m)
   = \dlet_(m' <- \dlim_(n) ssem (C n) m) ssem c m'.
Proof.
move=> leC; rewrite dlet_lim; last by apply/leC.
by apply/eq_dlim=> n; rewrite semE.
Qed.

Lemma dlim_seqr (C : nat -> cmd) (c : cmd) m :
     (forall m n p, (n <= p)%N -> ssem (C n) m <=1 ssem (C p) m)
  -> \dlim_(n) (ssem (c ;; C n) m)
   = \dlet_(m' <- ssem c m) \dlim_(n) (ssem (C n) m').
Proof.
move=> leC; rewrite -dlim_let //.
by apply/eq_dlim => n; rewrite semE.
Qed.

Lemma dlim_ift (e : expr bool) (C : nat -> cmd) (c : cmd) m :
    \dlim_(n) (ssem (If e then C n else c) m)
  = if esem e m then \dlim_(n) ssem (C n) m else ssem c m.
Proof.
pose F n := if esem e m then ssem (C n) m else ssem c m.
rewrite -(@eq_dlim _ F) {}/F => [|k]; last by rewrite !semE.
by case: ifPn => _; rewrite ?dlimC.
Qed.

Lemma dlim_iff (e : expr bool) (C : nat -> cmd) (c : cmd) m :
    \dlim_(n) (ssem (If e then c else C n) m)
  = if esem e m then ssem c m else \dlim_(n) ssem (C n) m.
Proof.
pose F n := if esem e m then ssem c m else ssem (C n) m.
rewrite -(@eq_dlim _ F) {}/F => [|k]; last by rewrite !semE.
by case: ifPn => _; rewrite ?dlimC.
Qed.

(* -------------------------------------------------------------------- *)
Definition iterc n (c : cmd) :=
  nosimpl (iterop n seqc c skip).

Lemma iterc0 c : iterc 0 c = skip.
Proof. by []. Qed.

Lemma itercS n c : iterc n.+1 c = iter n (seqc c) c.
Proof. by rewrite /iterc iteropS. Qed.

(* -------------------------------------------------------------------- *)
Lemma homo_ssem (mu1 mu2 : Distr cmem) c :
  mu1 <=1 mu2 -> \dlet_(m <- mu1) ssem c m <=1 \dlet_(m <- mu2) ssem c m.
Proof. by move=> le_mu m; apply/le_dlet. Qed.

Lemma sem_seq_le c1 c2 c1' c2' :
     ssem c1 <=2 ssem c1'
  -> ssem c2 <=2 ssem c2'
  -> ssem (c1 ;; c2) <=2 ssem (c1' ;; c2').
Proof. by move=> le1 le2 m1 m2; rewrite !semE; apply/le_dlet. Qed.

Lemma le_whilen (n : nat) (e : expr bool) (c : cmd) m m' :
  ssem (whilen e c n) m m' <= ssem (whilen e c n.+1) m m'.
Proof.
elim: n m m' => /= [|n ih] m m'.
  by rewrite ssem_abortE dnullE ge0_mu.
rewrite !ssem_ifE; case: (esem e m) => //.
rewrite !ssem_seqE; apply/le_in_dlet.
by move=> {m m'} m _ m'; apply/ih.
Qed.

Lemma homo_whilen e c m n p : (n <= p)%N ->
  ssem (whilen e c n) m <=1 ssem (whilen e c p) m.
Proof.
elim: p n => [|p ih] n; first by rewrite leqn0 => /eqP->.
rewrite leq_eqVlt => /orP[/eqP->//|]; rewrite ltnS => le_np m'.
by apply/(ler_trans (ih _ le_np m'))/le_whilen.
Qed.

Lemma dcvg_whilen e c m : dcvg (fun n => ssem (whilen e c n) m).
Proof.
move=> m'; set u := fun n : nat => _; case: (@ncvg_mono_bnd _ u).
+ by move=> n p le_np; apply/homo_whilen.
+ apply/asboolP/nboundedP; exists 2%:R => // n.
  apply/(@ler_lt_trans _ 1%:R); rewrite ?ltr1n //.
  by rewrite ger0_norm (ge0_mu, le1_mu1).
by move=> l ul; exists l%:E.
Qed.

Lemma unroll_while_w (e e' : expr bool) c m :
     (forall m, esem e' m -> esem e m)
  -> ssem (While e Do c) m =
     ssem (IfT e' then c ;; While e Do c) m.
Proof.
move=> impe; apply/distr_eqP=> m'; rewrite !semE.
case: ifPn => h; last by rewrite dlet_unit -semE.
rewrite -dlim_bump /= -ssem_seqE dlim_ift.
rewrite dlim_seqr; last by apply/homo_whilen.
rewrite impe // semE; apply/distr_eqP: m'.
by apply/eq_in_dlet=> // m' _; rewrite semE.
Qed.

Lemma unroll_while (e : expr bool) c m :
  ssem (While e Do c) m =
  ssem (IfT e then c ;; While e Do c) m.
Proof. by apply/unroll_while_w. Qed.

Lemma unroll_while_in (e : expr bool) c m :
  ssem (While e Do c) m =
  ssem (IfT e then (c ;; While e Do c)) m.
Proof.
rewrite unroll_while !semE; case: ifP => // h.
rewrite dlet_unit semE; apply/distr_eqP=> m'.
by rewrite -dlim_bump /= dlim_ift h semE.
Qed.

Lemma ssem_while0 (e : expr bool) c m : ~~ esem e m ->
  ssem (While e Do c) m = dunit m.
Proof. by rewrite unroll_while_in !semE => /negbTE ->. Qed.

Lemma ssem_whileS (e : expr bool) c m : esem e m ->
  ssem (While e Do c) m = ssem (c ;; While e Do c) m.
Proof. by rewrite unroll_while_in !semE => ->. Qed.

Lemma unrolls_while_w (e e' : expr bool) c m :
     (forall m, esem e' m -> esem e m)
  -> ssem (While e Do c) m =
     ssem (While e' Do c;; While e Do c) m.
Proof.
move=> impe; apply/distr_eqP=> m'; apply/eqP.
rewrite eqr_le andbC; apply/andP; split.
  rewrite ssem_seqE (ssem_whileE e') dlet_lim; last first.
    apply/homo_whilen.
  apply/leub_dlim => n {m'} m'; rewrite -ssem_seqE.
  elim: n m m' => [|n ihn] m m' /=.
    by rewrite !semE dlet_null; apply/lef_dnull.
  rewrite sem_ifseq ssem_ifE; case: ifPn => [/impe em|].
    by rewrite ssem_whileS // sem_seqA; apply/sem_seq_le.
  by rewrite 2!semE dlet_unit.
rewrite ssem_whileE; apply/leub_dlim; move: {m'} m => [:a] m n m'.
case/asboolP: (esem e' m) => [|/negP]; last first.
  abstract: a n m m' => h; rewrite ssem_seqE (@ssem_while0 e') //.
  rewrite dlet_unit semE; apply/dlim_ub=> {m'} k p le_kp m'.
  by apply/homo_whilen.
elim: n m m' => [|n ihn] m m' h.
  by rewrite ssem_abortE; apply/lef_dnull.
rewrite ssem_ifE impe // !ssem_seqE ssem_whileS //.
rewrite ssem_seqE dlet_dlet; apply/le_in_dlet=> {h m m'} m _ m'.
rewrite -ssem_seqE; case/asboolP: (esem e' m) => [|/negP h].
  by move/ihn. by apply/a.
Qed.

Lemma split_while (e1 e2:expr bool) c:
     ssem (While e1 Do c)
   = ssem (While (e1 && e2) Do c ;; While e1 Do c).
Proof. by apply/funext=> m; apply/unrolls_while_w => {m} m /= /andP[]. Qed.

Lemma prpP (P : pred cmem) m : reflect (P m) (esem (prp_ P) m).
Proof. by apply/idP. Qed.
End Semantics.

(* -------------------------------------------------------------------- *)
Section EqCmd.
Context {I : eqType} {M : memType I}.

Local Notation cmd := (cmd_ I M).

Definition eqcmd (c1 c2 : cmd) :=
  forall m, ssem_ c1 m = ssem_ c2 m.

Global Instance eqcmd_R : Equivalence eqcmd.
Proof.
constructor=> //.
+ by move=> f1 f2 eq s; rewrite eq.
+ by move=> f1 f2 f3 eq1 eq2 s; rewrite eq1.
Qed.

Notation "c1 '=C' c2" := (eqcmd c1 c2) (at level 70, no associativity).

Notation CLHS := (X in X =C _)%pattern.
Notation CRHS := (X in _ =C X)%pattern.

Lemma seq_skip_l (c : cmd) : (skip ;; c) =C c.
Proof. by move=> m;rewrite !semE dlet_unit. Qed.

Lemma seq_skip_r (c : cmd) : (c ;; skip) =C c.
Proof.
move=> m; rewrite semE -[X in _ = X]dlet_dunit_id;
by apply eq_in_dlet => // ??; rewrite semE.
Qed.

Lemma seqA (c1 c2 c3 : cmd) : (c1 ;; (c2 ;; c3)) =C (c1 ;; c2 ;; c3).
Proof.
move=> m;rewrite !semE dlet_dlet.
by apply eq_in_dlet=> // m' _;rewrite semE.
Qed.

Lemma iter_seq_out n c c1 c2 :
  iter n (seqc c) (c1 ;; c2) =C (iter n (seqc c) c1 ;; c2).
Proof.
by elim: n => //= n ih m; rewrite -seqA !ssem_seqE; apply/eq_in_dlet.
Qed.

Lemma iter_seq_swap n c : iter n (seqc^~ c) c =C iter n (seqc c) c.
Proof.
elim: n => // n ih m; rewrite [in RHS]iterSr.
by rewrite iter_seq_out !ssem_seqE; apply/eq_in_dlet.
Qed.

Lemma itercSl n c: iterc n.+1 c =C (c ;; iterc n c).
Proof. by move=> m; case: n => [|n] //=; rewrite seq_skip_r. Qed.

Lemma itercSr n c: iterc n.+1 c =C (iterc n c ;; c).
Proof.
move=> m; case: n => [|n]; first by rewrite iterc0 seq_skip_l.
rewrite !itercS /= -iterS -iter_seq_swap /=.
by rewrite !ssem_seqE; apply/eq_in_dlet=> //; apply/iter_seq_swap.
Qed.

Global Instance seq_m : Proper (eqcmd ==> eqcmd ==> eqcmd) seqc.
Proof. by move=> ?? H1 ?? H2 m;rewrite !semE; apply eq_in_dlet. Qed.

Global Instance while_m : Proper (eq ==> eqcmd ==> eqcmd) while.
Proof.
move=> ?? H1 ?? H2 m; rewrite !ssem_while_ubn H1; apply/eq_dlim=> n.
by elim: n m => //= n ih m; case: ifP => // _; apply eq_in_dlet.
Qed.

Global Instance cond_m : Proper (eq ==> eqcmd ==> eqcmd ==> eqcmd) cond.
Proof. by move=> ?? H1 ?? H2 ?? H3 m; rewrite !semE H1; case: ifP. Qed.

Fixpoint mk_seqr (c1 c2 : cmd) :=
  match c2 with
  | skip        => c1
  | seqc c2 c2' => mk_seqr (mk_seqr c1 c2) c2'
  | _           => seqc c1 c2
  end.

Definition mk_seq (c1 c2 : cmd) :=
  if c1 is skip then c2 else  mk_seqr c1 c2.

Fixpoint normc (c : cmd) :=
  match c with
  | abort | skip | assign _ _ _ | random _ _ _ => c
  | cond e c1 c2 => cond e (normc c1) (normc c2)
  | while e c    => while e (normc c)
  | seqc c1 c2   => mk_seq (normc c1) (normc c2)
  end.

Lemma mk_seqrP (c1 c2 : cmd) : mk_seqr c1 c2 =C seqc c1 c2.
Proof.
elim:c2 c1=> //= [|c2 H1 c3 H2] c1;first by rewrite seq_skip_r.
by rewrite seqA H2 H1.
Qed.

Lemma mk_seqP (c1 c2 : cmd) : mk_seq c1 c2 =C seqc c1 c2.
Proof. by case:c1 => //= *;rewrite ?mk_seqrP // seq_skip_l. Qed.

Lemma normcP (c : cmd) : c =C normc c.
Proof.
by elim: c=> //= [?? H1 ? H2|?? H1|? H1 ? H2];
rewrite ?mk_seqP [in CLHS]H1 ?[in CLHS]H2.
Qed.

(* -------------------------------------------------------------------- *)
Lemma ssem_iterop_iter n c :
  iterc n c =C iter n (seqc c) skip.
Proof.
case: n => // n; rewrite itercS /=; elim: n => [|n ih] /=.
  by rewrite seq_skip_r. by rewrite ih.
Qed.

Lemma ssem_iterop_iterrev n c :
  iterc n c =C iter n (seqc^~ c) skip.
Proof.
rewrite ssem_iterop_iter; elim: n=> // n ih.
rewrite iterSr iterS -{}ih; elim: n => /= [|n ih].
- by rewrite seq_skip_l seq_skip_r.
- by rewrite ih seqA.
Qed.

Lemma whilen_iterc n b c :
  whilen b c n.+1 =C (iterc n (IfT b then c) ;; (IfT b then abort)).
Proof.
rewrite ssem_iterop_iter; elim: n => [|n ihn] /=.
  rewrite seq_skip_l => m; rewrite !semE; case: ifP=> // _.
  by rewrite bsemE; apply/distr_eqP=> m'; rewrite dletC dnullE mulr0.
rewrite -seqA -ihn /= => m; rewrite !semE; case: ifP => // bm.
by rewrite dlet_unit !semE bm.
Qed.
End EqCmd.

Notation "c1 '=C' c2" := (eqcmd c1 c2) (at level 70, no associativity).

(* -------------------------------------------------------------------- *)
Lemma unrolln_while n (e : expr bool) c :
  (While e Do c) =C (iterc n (IfT e then c) ;; While e Do c).
Proof.
rewrite ssem_iterop_iter; elim: n => [|n ih] /=.
  by rewrite seq_skip_l.
by rewrite -seqA -ih => m; rewrite unroll_while.
Qed.

(* -------------------------------------------------------------------- *)
Notation ssem   := (@ssem_ _ cmem).
Notation mdistr := (Distr cmem).
Notation mnull  := (@dnull R cmem.(mheap)).

Arguments ssem_ X cmem s%S m%M.
Arguments esem X cmem T e%X m%M.

Notation "e `_ m" := (@esem _ _ _ e%X m%M) : sem_scope.

(* -------------------------------------------------------------------- *)
Definition dssem c mu := (\dlet_(m <- mu) ssem c m).

Instance dsem_m : Proper (@eqcmd _ _ ==> eq ==> eq) dssem.
Proof. by move=> c1 c2 eqc /= mu _ <-; apply/eq_in_dlet. Qed.

(* -------------------------------------------------------------------- *)
Lemma dssem_abortE mu : dssem abort mu = mnull.
Proof.
by apply/distr_eqP=> m; rewrite /dssem bsemE dletC dnullE mulr0.
Qed.

Lemma dssem_skipE mu : dssem skip mu = mu.
Proof.
by apply/distr_eqP=> m; rewrite /dssem bsemE dlet_dunit_id.
Qed.

Lemma dssem_seqE c1 c2 mu :
  dssem (c1 ;; c2) mu = dssem c2 (dssem c1 mu).
Proof.
by apply/distr_eqP=> m; rewrite /dssem bsemE dlet_dlet.
Qed.

(* -------------------------------------------------------------------- *)
Definition lossless (P : assn) c :=
  forall m, m \in P -> dweight (ssem c m) = 1.

Definition dlossless (P : dassn) c :=
  forall mu, mu \in P -> dweight (dssem c mu) = 1.

(* -------------------------------------------------------------------- *)
Reserved Notation "m .[ x @ s <- v ]"
  (at level 2, x, s, v at level 200, format "m .[ x @ s  <-  v ]").

Reserved Notation "m .[~1 x <- v ]"
  (at level 2, x, v at level 200, format "m .[~1  x  <-  v ]").

Reserved Notation "m .[~2 x <- v ]"
  (at level 2, x, v at level 200, format "m .[~2  x  <-  v ]").

Notation rsem    := (@ssem_ _ rmem).
Notation rmdistr := (Distr rmem.(mheap)).
Notation rmnull  := (@dnull R rmem.(mheap)).

Notation "m .[ x @ s <- v ]" := m.[x # s <- v].
Notation "m .[~1 x <- v ]"   := m.[x @ '1 <- v].
Notation "m .[~2 x <- v ]"   := m.[x @ '2 <- v].

Lemma mselect_mset T s s' (m : rmem) (x : vars T) (v : T) :
  m.[x @ s <- v] # s' = if s == s' then (m#s).[x <- v] else m#s'.
Proof. by case: s s' x => [] [] []. Qed.

Lemma esem_iE T s (e : expr T) (m : rmem) : esem (e#s) m = esem e m#s.
Proof. by elim: e => {T} /= [ ?[?]| | | ??? -> ? ->]. Qed.

Lemma esem_1E T (e : expr T) (m : rmem): esem (e#'1) m = esem e m.1.
Proof. by rewrite esem_iE. Qed.

Lemma esem_2E T (e : expr T) (m : rmem): esem (e#'2) m = esem e m.2.
Proof.  by rewrite esem_iE. Qed.

Definition esemE := (@esem_appE, @esem_cstE, esem_1E, esem_2E).

Definition ssemE := (esemE, @semE).

Lemma mget_iE {T : ihbType} (m : rmem) (x : vars T) s :
  m.[irvar s x] = (m#s).[x].
Proof. by case:s x=> -[]. Qed.

Lemma mset_iE {T : ihbType} (m : rmem) (x : vars T) (v : T) s :
  m.[x#s <- v] =
  (((m#'1).[x <- v], m.1)#s, (m.2, (m#'2).[x <- v])#s)%M.
Proof. by case:x m s => xid [m1 m2] []. Qed.

Lemma ssem_iE s c (m : rmem): rsem (ircmd s c) m =
  \dlet_(m' <- ssem c m#s) dunit ((m', m.1)#s, (m.2, m')#s)%M.
Proof.
elim: c m => [||T v e|T v e|e c1 Hc1 c2 Hc2|e c Hc|c1 Hc1 c2 Hc2] [m1 m2].
+ by rewrite !ssemE dlet_null.
+ by rewrite !ssemE dlet_unit; case:s.
+ by rewrite !ssemE esem_iE dlet_unit mset_iE;case:s.
+ rewrite !ssemE esem_iE dlet_dlet; apply eq_in_dlet => // t _.
  by rewrite dlet_unit mset_iE;case: s.
+ by rewrite !ssemE esem_iE;case:ifP.
+ rewrite !ssemE dlet_lim; last by apply/homo_whilen.
  apply eq_dlim=> n; elim: n (m1,m2)=> [ | n Hn] m /=.
  + by rewrite !ssemE dlet_null.
  rewrite !ssemE esem_iE;case:ifP => _.
  + rewrite Hc !dlet_dlet;apply eq_in_dlet=>// m' _.
    by rewrite dlet_unit Hn;case s.
  by rewrite dlet_unit;case: m s {Hc Hn}=> ?? [].
rewrite !ssemE Hc1 !dlet_dlet;apply eq_in_dlet=>// m _.
by rewrite !dlet_unit Hc2;apply eq_in_dlet =>[? _|];case s.
Qed.

Lemma ssem_1E (m : rmem) c :
  rsem (c#'1) m = \dlet_(m1 <- ssem c m.1) (dunit (m1, m.2)).
Proof. by apply ssem_iE. Qed.

Lemma ssem_2E (m : rmem) c :
  rsem (c#'2) m = \dlet_(m2 <- ssem c m.2) (dunit (m.1, m2)).
Proof. by apply ssem_iE. Qed.

(* -------------------------------------------------------------------- *)
Notation "`[{ e }]" := (@esem _ _ _ e%X) (at level 2, format "`[{ e }]").

(* -------------------------------------------------------------------- *)
Ltac diff_v := try (right; (assumption || rewrite eq_sym; assumption)).

Notation SET := ((_.[_ <- _].[_])%pattern) (only parsing).

Ltac mem_t := rewrite ?mget_iE ![SET](mget_eq, mget_neq); diff_v.


(* -------------------------------------------------------------------- *)
(* Copyright (c) - 2015--2016 - IMDEA Software Institute                *)
(* Copyright (c) - 2015--2018 - Inria                                   *)
(* Copyright (c) - 2016--2018 - Polytechnique                           *)

(* We follow the 4CT dedekind construction of reals, but adapted to the *)
(* SSReflect hierarchy (see reals.v)                                    *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
(* ------- *) Require Import Setoid.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import GRing.Theory Num.Theory.

Local Ltac done := solve [intuition] || ssreflect.done.

(* -------------------------------------------------------------------- *)
Module Classical.
Parameter lpo : forall {T : countType} (P : T -> Prop),
  forall (x : T), {P x} + {~(P x)}.

Parameter pex : forall {T : countType} (P Q : T -> Prop),
  (forall (x : T), P x <-> Q x) -> P = Q.

Lemma dec (P : Prop): {P} + {~P}.
Proof. by case: (lpo (fun (_ : unit) => P) tt). Qed.

Lemma decT {T : Type} (P : Prop) (x y : T):
  P -> (if dec P then x else y) = x.
Proof. by case: (dec _). Qed.

Lemma decF {T : Type} (P : Prop) (x y : T):
  ~P -> (if dec P then x else y) = y.
Proof. by case: (dec _). Qed.
End Classical.

Import Classical.

(* -------------------------------------------------------------------- *)
CoInductive ratx : predArgType := RatX of (rat -> Prop).

Definition ratx_val x := let: RatX x := x in x.

Canonical ratx_subType := Eval hnf in [newType for ratx_val].

(* -------------------------------------------------------------------- *)
Fact ratx_key : unit. Proof. by []. Qed.
Definition ratx_of_pred    k := locked_with k RatX.
Canonical  ratx_unlockable k := [unlockable fun ratx_of_pred k].

Definition pred_of_ratx X q := ratx_val X q.

Coercion pred_of_ratx : ratx >-> Funclass.

(* -------------------------------------------------------------------- *)
Definition eqrx (X1 X2 : ratx) :=
  if dec (forall q, X1 q <-> X2 q) then true else false.

Lemma eqrxP X1 X2 : reflect (X1 = X2) (eqrx X1 X2).
Proof.
apply: (iffP idP)=> [|<-]; last by rewrite /eqrx decT.
rewrite /eqrx; case: (dec _)=> //= eqv h.
by case: X1 X2 eqv => [X1] [X2] /= eqv; rewrite (@pex _ X1 X2).
Qed.

Definition ratx_eqMixin := EqMixin eqrxP.
Canonical  ratx_eqType  := Eval hnf in EqType ratx ratx_eqMixin.

(* -------------------------------------------------------------------- *)
CoInductive is_cut (X : rat -> Prop) : Prop :=
  IsCut (ub : exists a, X a)
        (lb : exists a, ~ X a)
        (filter : forall a b, X a -> (a < b)%R -> X b)
        (open : forall a, X a -> exists2 b, X b & (b < a)%R).

Definition is_cutb (X : rat -> Prop) :=
  if dec (is_cut X) then true else false.

CoInductive cut := Cut (ltc : ratx) of is_cutb ltc.

Coercion ltc x := let: Cut ltc_x _ := x in ltc_x.

Canonical cut_subType := Eval hnf in [subType for ltc].

(* -------------------------------------------------------------------- *)
Definition cut_eqMixin := Eval hnf in [eqMixin of cut by <:].
Canonical  cut_eqType  := Eval hnf in EqType cut cut_eqMixin.