(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax Orders.
Require Import Alphabet.

(** The terminal non-terminal alphabets of the grammar. **)
Module Type Alphs.
  Parameters terminal nonterminal : Type.
  Declare Instance TerminalAlph: Alphabet terminal.
  Declare Instance NonTerminalAlph: Alphabet nonterminal.
End Alphs.

(** Definition of the alphabet of symbols, given the alphabet of terminals
    and the alphabet of non terminals **)
Module Symbol(Import A:Alphs).

  Inductive symbol :=
    | T: terminal -> symbol
    | NT: nonterminal -> symbol.

  Program Instance SymbolAlph : Alphabet symbol :=
    { AlphabetComparable := {| compare := fun x y =>
        match x, y return comparison with
          | T _, NT _ => Gt
          | NT _, T _ => Lt
          | T x, T y => compare x y
          | NT x, NT y => compare x y
        end |};
      AlphabetFinite := {| all_list :=
        map T all_list++map NT all_list |} }.
  Next Obligation.
    destruct x; destruct y; intuition; apply compare_antisym.
  Qed.
  Next Obligation.
    destruct x; destruct y; destruct z; intuition; try discriminate.
    apply (compare_trans _ t0); intuition.
    apply (compare_trans _ n0); intuition.
  Qed.
  Next Obligation.
    intros x y.
    destruct x; destruct y; try discriminate; intros.
    rewrite (compare_eq t t0); now intuition.
    rewrite (compare_eq n n0); now intuition.
  Defined.
  Next Obligation.
    rewrite in_app_iff.
    destruct x; [left | right]; apply in_map; apply all_list_forall.
  Qed.

End Symbol.

(** A curryfied function with multiple parameters **)
Definition arrows_right: Type -> list Type -> Type :=
  fold_right (fun A B => A -> B).

Module Type T.
  Include Alphs <+ Symbol.

  (** [symbol_semantic_type] maps a symbols to the type of its semantic
     values. **)
  Parameter symbol_semantic_type: symbol -> Type.

  (** The type of productions identifiers **)
  Parameter production : Type.
  Declare Instance ProductionAlph : Alphabet production.

  (** Accessors for productions: left hand side, right hand side,
     and semantic action. The semantic actions are given in the form
     of curryfied functions, that take arguments in the reverse order. **)
  Parameter prod_lhs: production -> nonterminal.
  (* The RHS of a production is given in reversed order, so that symbols  *)
  Parameter prod_rhs_rev: production -> list symbol.
  Parameter prod_action:
    forall p:production,
      arrows_right
        (symbol_semantic_type (NT (prod_lhs p)))
        (map symbol_semantic_type (prod_rhs_rev p)).

  (** Tokens are the atomic elements of the input stream: they contain
     a terminal and a semantic value of the type corresponding to this
     terminal. *)
  Parameter token : Type.
  Parameter token_term : token -> terminal.
  Parameter token_sem :
    forall tok : token, symbol_semantic_type (T (token_term tok)).
End T.

Module Defs(Import G:T).

  (** The semantics of a grammar is defined in two stages. First, we
    define the notion of parse tree, which represents one way of
    recognizing a word with a head symbol. Semantic values are stored
    at the leaves.

      This notion is defined in two mutually recursive flavours:
    either for a single head symbol, or for a list of head symbols. *)
  Inductive parse_tree:
    forall (head_symbol:symbol) (word:list token), Type :=

  (** Parse tree for a terminal symbol. *)
  | Terminal_pt:
    forall (tok:token), parse_tree (T (token_term tok)) [tok]

  (** Parse tree for a non-terminal symbol.  *)
  | Non_terminal_pt:
    forall (prod:production) {word:list token},
      parse_tree_list (prod_rhs_rev prod) word ->
      parse_tree (NT (prod_lhs prod)) word

  (* Note : the list head_symbols_rev is reversed. *)
  with parse_tree_list:
    forall (head_symbols_rev:list symbol) (word:list token), Type :=

  | Nil_ptl: parse_tree_list [] []

  | Cons_ptl:
    forall {head_symbolsq:list symbol} {wordq:list token},
      parse_tree_list head_symbolsq wordq ->

    forall {head_symbolt:symbol} {wordt:list token},
      parse_tree head_symbolt wordt ->

      parse_tree_list (head_symbolt::head_symbolsq) (wordq++wordt).

  (** We can now finish the definition of the semantics of a grammar,
    by giving the semantic value assotiated with a parse tree. *)
  Fixpoint pt_sem {head_symbol word} (tree:parse_tree head_symbol word) :
    symbol_semantic_type head_symbol :=
    match tree with
    | Terminal_pt tok => token_sem tok
    | Non_terminal_pt prod ptl => ptl_sem ptl (prod_action prod)
    end
  with ptl_sem {A head_symbols word} (tree:parse_tree_list head_symbols word) :
    arrows_right A (map symbol_semantic_type head_symbols) -> A :=
    match tree with
    | Nil_ptl => fun act => act
    | Cons_ptl q t => fun act => ptl_sem q (act (pt_sem t))
    end.

  Fixpoint pt_size {head_symbol word} (tree:parse_tree head_symbol word) :=
    match tree with
      | Terminal_pt _ => 1
      | Non_terminal_pt _ l => S (ptl_size l)
    end
  with ptl_size {head_symbols word} (tree:parse_tree_list head_symbols word) :=
    match tree with
      | Nil_ptl => 0
      | Cons_ptl q t =>
         pt_size t + ptl_size q
    end.
End Defs.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.

Import HaskellListNotations.
Open Scope string.

Definition whole_prog := [(NonRecursive (Decl (0,"demote") DPrim)),(NonRecursive (Decl (1,"+") DPrim)),(NonRecursive (Decl (2,"-") DPrim)),(NonRecursive (Decl (3,"*") DPrim)),(NonRecursive (Decl (4,"/") DPrim)),(NonRecursive (Decl (5,"%") DPrim)),(NonRecursive (Decl (6,"^^") DPrim)),(NonRecursive (Decl (7,"lg2") DPrim)),(NonRecursive (Decl (9,"True") DPrim)),(NonRecursive (Decl (10,"False") DPrim)),(NonRecursive (Decl (11,"negate") DPrim)),(NonRecursive (Decl (12,"complement") DPrim)),(NonRecursive (Decl (13,"<") DPrim)),(NonRecursive (Decl (14,">") DPrim)),(NonRecursive (Decl (15,"<=") DPrim)),(NonRecursive (Decl (16,">=") DPrim)),(NonRecursive (Decl (17,"==") DPrim)),(NonRecursive (Decl (18,"!=") DPrim)),(NonRecursive (Decl (19,"===") (DExpr (ETAbs (87,"a") (ETAbs (88,"b") (EAbs (89,"f") (EAbs (90,"g") (EAbs (91,"x") (EApp (EApp (ETApp (EVar (17,"==")) (TVar (TVBound 31 KType))) (EApp (EVar (89,"f")) (EVar (91,"x")))) (EApp (EVar (90,"g")) (EVar (91,"x")))))))))))),(NonRecursive (Decl (20,"!==") (DExpr (ETAbs (92,"a") (ETAbs (93,"b") (EAbs (94,"f") (EAbs (95,"g") (EAbs (96,"x") (EApp (EApp (ETApp (EVar (18,"!=")) (TVar (TVBound 41 KType))) (EApp (EVar (94,"f")) (EVar (96,"x")))) (EApp (EVar (95,"g")) (EVar (96,"x")))))))))))),(NonRecursive (Decl (21,"min") (DExpr (ETAbs (97,"a") (EAbs (98,"x") (EAbs (99,"y") (EIf (EApp (EApp (ETApp (EVar (13,"<")) (TVar (TVBound 50 KType))) (EVar (98,"x"))) (EVar (99,"y"))) (EVar (98,"x")) (EVar (99,"y"))))))))),(NonRecursive (Decl (22,"max") (DExpr (ETAbs (100,"a") (EAbs (101,"x") (EAbs (102,"y") (EIf (EApp (EApp (ETApp (EVar (14,">")) (TVar (TVBound 56 KType))) (EVar (101,"x"))) (EVar (102,"y"))) (EVar (101,"x")) (EVar (102,"y"))))))))),(NonRecursive (Decl (23,"/\\") (DExpr (EAbs (103,"x") (EAbs (104,"y") (EIf (EVar (103,"x")) (EVar (104,"y")) (EVar (10,"False")))))))),(NonRecursive (Decl (24,"\\/") (DExpr (EAbs (105,"x") (EAbs (106,"y") (EIf (EVar (105,"x")) (EVar (9,"True")) (EVar (106,"y")))))))),(NonRecursive (Decl (25,"==>") (DExpr (EAbs (107,"a") (EAbs (108,"b") (EIf (EVar (107,"a")) (EVar (108,"b")) (EVar (9,"True")))))))),(NonRecursive (Decl (26,"&&") DPrim)),(NonRecursive (Decl (27,"||") DPrim)),(NonRecursive (Decl (28,"^") DPrim)),(NonRecursive (Decl (29,"zero") DPrim)),(NonRecursive (Decl (30,"<<") DPrim)),(NonRecursive (Decl (31,">>") DPrim)),(NonRecursive (Decl (32,"<<<") DPrim)),(NonRecursive (Decl (33,">>>") DPrim)),(NonRecursive (Decl (34,"#") DPrim)),(NonRecursive (Decl (35,"splitAt") DPrim)),(NonRecursive (Decl (36,"join") DPrim)),(NonRecursive (Decl (37,"split") DPrim)),(NonRecursive (Decl (38,"reverse") DPrim)),(NonRecursive (Decl (39,"transpose") DPrim)),(NonRecursive (Decl (40,"@") DPrim)),(NonRecursive (Decl (41,"@@") DPrim)),(NonRecursive (Decl (42,"!") DPrim)),(NonRecursive (Decl (43,"!!") DPrim)),(NonRecursive (Decl (44,"update") DPrim)),(NonRecursive (Decl (45,"updateEnd") DPrim)),(NonRecursive (Decl (46,"updates") (DExpr (ETAbs (162,"a") (ETAbs (163,"b") (ETAbs (164,"c") (ETAbs (165,"d") (EAbs (166,"xs0") (EAbs (167,"idxs") (EAbs (168,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 124 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (169,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (169,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 124 KNum))) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (EList [(EVar (166,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (44,"update")) (TVar (TVBound 121 KNum))) (TVar (TVBound 122 KType))) (TVar (TVBound 123 KNum))) (EVar (170,"xs"))) (EVar (171,"i"))) (EVar (172,"b"))) [[(From (170,"xs") (EVar (169,"xss")))],[(From (171,"i") (EVar (167,"idxs")))],[(From (172,"b") (EVar (168,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (47,"updatesEnd") (DExpr (ETAbs (173,"a") (ETAbs (174,"b") (ETAbs (175,"c") (ETAbs (176,"d") (EAbs (177,"xs0") (EAbs (178,"idxs") (EAbs (179,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 159 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (180,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (180,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 159 KNum))) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (EList [(EVar (177,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (45,"updateEnd")) (TVar (TVBound 156 KNum))) (TVar (TVBound 157 KType))) (TVar (TVBound 158 KNum))) (EVar (181,"xs"))) (EVar (182,"i"))) (EVar (183,"b"))) [[(From (181,"xs") (EVar (180,"xss")))],[(From (182,"i") (EVar (178,"idxs")))],[(From (183,"b") (EVar (179,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (48,"fromThen") DPrim)),(NonRecursive (Decl (49,"fromTo") DPrim)),(NonRecursive (Decl (50,"fromThenTo") DPrim)),(NonRecursive (Decl (51,"infFrom") DPrim)),(NonRecursive (Decl (52,"infFromThen") DPrim)),(NonRecursive (Decl (53,"error") DPrim)),(NonRecursive (Decl (54,"pmult") DPrim)),(NonRecursive (Decl (55,"pdiv") DPrim)),(NonRecursive (Decl (56,"pmod") DPrim)),(NonRecursive (Decl (57,"random") DPrim)),(NonRecursive (Decl (61,"take") (DExpr (ETAbs (209,"front") (ETAbs (210,"back") (ETAbs (211,"elem") (EAbs (212,"__p1") (EWhere (EVar (214,"x")) [(NonRecursive (Decl (213,"__p2") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (TVar (TVBound 214 KNum))) (TVar (TVBound 215 KNum))) (TVar (TVBound 216 KType))) (EVar (212,"__p1")))))),(NonRecursive (Decl (214,"x") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 0))))),(NonRecursive (Decl (215,"__p0") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (62,"drop") (DExpr (ETAbs (216,"front") (ETAbs (217,"back") (ETAbs (218,"elem") (EAbs (219,"__p4") (EWhere (EVar (222,"y")) [(NonRecursive (Decl (220,"__p5") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (TVar (TVBound 231 KNum))) (TVar (TVBound 232 KNum))) (TVar (TVBound 233 KType))) (EVar (219,"__p4")))))),(NonRecursive (Decl (221,"__p3") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 0))))),(NonRecursive (Decl (222,"y") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (63,"tail") (DExpr (ETAbs (223,"a") (ETAbs (224,"b") (EAbs (225,"xs") (EApp (ETApp (ETApp (ETApp (EVar (62,"drop")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 249 KNum))) (TVar (TVBound 250 KType))) (EVar (225,"xs"))))))))),(NonRecursive (Decl (64,"width") (DExpr (ETAbs (226,"bits") (ETAbs (227,"len") (ETAbs (228,"elem") (EAbs (229,"__p6") (ETApp (ETApp (EVar (0,"demote")) (TVar (TVBound 256 KNum))) (TVar (TVBound 255 KNum)))))))))),(NonRecursive (Decl (65,"undefined") (DExpr (ETAbs (230,"a") (EApp (ETApp (ETApp (EVar (53,"error")) (TVar (TVBound 260 KType))) (TCon (TC (TCNum 9)) [])) (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 117)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 102)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 105)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) []))])))))),(NonRecursive (Decl (66,"groupBy") (DExpr (ETAbs (231,"each") (ETAbs (232,"parts") (ETAbs (233,"elem") (ETApp (ETApp (ETApp (EVar (37,"split")) (TVar (TVBound 266 KNum))) (TVar (TVBound 265 KNum))) (TVar (TVBound 267 KType))))))))),(NonRecursive (Decl (68,"trace") DPrim)),(NonRecursive (Decl (69,"traceVal") (DExpr (ETAbs (238,"n") (ETAbs (239,"a") (EAbs (240,"msg") (EAbs (241,"x") (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (68,"trace")) (TVar (TVBound 273 KNum))) (TVar (TVBound 274 KType))) (TVar (TVBound 274 KType))) (EVar (240,"msg"))) (EVar (241,"x"))) (EVar (241,"x")))))))))),(NonRecursive (Decl (242,"x") (DExpr (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 3)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 4)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 5)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 19)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 12)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 38)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 5)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 3)) [])) (TCon (TC (TCNum 8)) []))])))),(NonRecursive (Decl (243,"y") (DExpr (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 19)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 3)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 27)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 5)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 12)) [])) (TCon (TC (TCNum 8)) []))])))),(NonRecursive (Decl (244,"z") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 10)) [])) (TCon (TC (TCNum 5)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (EVar (242,"x"))) (EVar (243,"y")))))),(NonRecursive (Decl (245,"m") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 15)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 1)) [])) (EVar (244,"z"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 1)) [])))))),(NonRecursive (Decl (246,"w") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 15)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 2)) [])) (EVar (244,"z"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 2)) [])))))),(NonRecursive (Decl (247,"t") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 15)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 4)) [])) (EVar (244,"z"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 10)) [])) (TCon (TC (TCNum 4)) [])))))),(NonRecursive (Decl (248,"v") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 15)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 4)) [])) (EVar (244,"z"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 11)) [])) (TCon (TC (TCNum 4)) []))))))].

Definition m : ident := (245,"m").
Definition w : ident := (246,"w").
Definition t : ident := (247,"t").
Definition v : ident := (248,"v").

Definition ge := bind_decl_groups whole_prog gempty.

Definition v8(z : Z) := @repr 8 z.

Lemma eval_m :
  eval_expr ge empty (EVar m) (bits (v8 1)).
Proof.
  e.
  e. e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. e. g.
  e. e. e. e. g.
  e. repeat e.
  e. g.
  e. repeat e.
  repeat e.
  e. e. e. g.

  e. e. e. e.

  e. e. e.
  e.
  e.

  e. repeat e.
  e.

  eapply select_app_1.

  e.
  e. e.

Qed.


(* Formal proof of correctness of long division algorithm as
   appearing in PLCC Chapter 2:
   https://vst.cs.princeton.edu/download/PLCC-to-chapter-3.pdf *)

From Coq Require Import Strings.String ZArith.
Require Import Lia.
From LongDivision Require Import Imp Hoare.
Open Scope string_scope.

Definition a := "a".
Definition b := "b".
Definition n := "n".
Definition z := "z".
Definition q := "q".
Definition r := "r".

Open Scope imp_scope.
Open Scope hoare_spec_scope.
Open Scope Z.
Open Scope Z_scope.

Ltac obliterate :=
  repeat match goal with
  | |- {{ _ }} _ ;; _ {{ _ }} => eapply hoare_seq
  | |- {{ _ }} _ ::= _ {{ _ }} => apply hoare_floyd
  | |- {{ _ }} TEST _ THEN _ ELSE _ FI {{ _ }} => apply hoare_if
  | |- {{ _ }} SKIP {{ _ }} => apply hoare_skip
  end.

Ltac crunch_hyp :=
  repeat match goal with
  | H : ex _ |- _ => inv H
  | H : _ /\ _ |- _ => inv H
  end.

Ltac solve_neq :=
  match goal with
  | |- ?a <> ?b => unfold a, b, not; intro; discriminate
  end.

Theorem long_division_correct : forall a0 b0,
  {{ fun st => st a >= 0 /\ st b > 0 /\ st a = a0 /\ st b = b0 }}
  n ::= 0;;
  z ::= b;;
  WHILE z <= a DO
    n ::= n + 1;;
    z ::= z + z
  END;;
  q ::= 0;;
  r ::= a;;
  WHILE n > 0 DO
    n ::= n - 1;;
    z ::= z / 2;;
    q ::= q + q;;
    TEST z <= r THEN
      q ::= q + 1;;
      r ::= r - z
    ELSE
      SKIP
    FI
  END
  {{ fun st => st a = st q * st b + st r /\ 0 <= st r < st b /\ st a = a0 /\ st b = b0 }}.
Proof.
  intros; obliterate.
  - eapply hoare_consequence with (P' := fun st =>
      st z = st b * 2 ^ st n /\ st n >= 0 /\ st a >= 0 /\
      st b > 0 /\ st a = a0 /\ st b = b0).
    + unfold assert_implies; simpl; intros; crunch_hyp;
        repeat split; try (rewrite H, H2; now try solve_neq).
      * rewrite <- H in H1; try solve_neq.
        rewrite H1; simpl; symmetry; rewrite H; try lia;
            solve_neq.
      * rewrite H; try solve_neq; lia.
    + apply hoare_while; obliterate.
      eapply hoare_consequence; obliterate.
      * unfold assert_implies; intros; exact H.
      * unfold assert_implies; simpl; intros; crunch_hyp;
          repeat split; try (rewrite H, H2; now try solve_neq).
        { apply Z.leb_le in H5.
          replace (x0 z) with (x z) in *
            by (apply H2; solve_neq).
          rewrite H0 in *; clear H0.
          replace (st b) with (x0 b) by (rewrite H, H2;
            now try solve_neq).
          replace (st n) with (x n) by (symmetry; apply H;
            solve_neq).
          rewrite H1 in *; clear H1.
          rewrite Z.pow_add_r; lia. }
        { rewrite H; try solve_neq; lia. }
    + unfold assert_implies; intros; exact H.
  - eapply hoare_consequence with (P' := fun st =>
      st a = st q * st z + st r /\ 0 <= st r < st z /\
      st z = st b * 2 ^ st n /\ st n >= 0 /\ st a = a0 /\
      st b = b0).
    + unfold assert_implies; simpl; intros; repeat split;
        crunch_hyp; rewrite Z.leb_gt in H5;
        try (repeat rewrite H, H2; now try solve_neq).
      * replace (st q) with (x q) by (rewrite H;
          now try solve_neq).
        rewrite H0.
        replace (x a) with (st a) by (apply H; solve_neq);
          nia.
      * rewrite H0, H2; try solve_neq; lia.
      * rewrite H0, H; try solve_neq.
        do 2 try rewrite H2; now try solve_neq.
    + apply hoare_while; obliterate.
      * eapply hoare_consequence; obliterate;
          unfold assert_implies; simpl; intros; try exact H;
          repeat split; crunch_hyp; rewrite Z.leb_le in H5;
          rewrite Z.gtb_lt in H12;
          try (rewrite H, H2, H3, H7, H9; now try solve_neq).
        { rewrite H, H2, H3, H7, H9, H11; try solve_neq.
          rewrite H0 in *.
          rewrite H; try solve_neq.
          rewrite H1, H4 in *.
          replace (x1 q) with (x3 q) in * by (rewrite H7, H9;
            now try solve_neq).
          replace (x2 z) with (x3 z) in * by (rewrite H9;
            now try solve_neq).
          replace (st z) with (x z) in * by (rewrite H;
            now try solve_neq).
          replace (x z) with (x1 z) in * by (rewrite H2, H3;
            now try solve_neq).
          replace (x r) with (x3 r) in *
            by (rewrite H2, H3, H7, H9; now try solve_neq).
          rewrite H6, H13.
          assert (x3 n = x2 n + 1) by lia.
          rewrite H10.
          rewrite Z.pow_add_r; try lia; simpl;
            unfold Z.pow_pos; simpl.
          replace (x3 b * (2 ^ x2 n * 2))
            with (x3 b * 2 ^ x2 n * 2) in * by lia.
          rewrite Z.div_mul; lia. }
        { do 2 rewrite H2 in H0; try solve_neq; lia. }
        { rewrite H0.
          replace (x r) with (x3 r) in *
            by (rewrite H2, H3, H7, H9; now try solve_neq).
          replace (st z) with (x z) in * by (rewrite H;
            now try solve_neq).
          replace (x z) with (x1 z) in * by (rewrite H2, H3;
            now try solve_neq).
          replace (x2 z) with (x3 z) in * by (rewrite H9;
            now try solve_neq).
          assert (x3 r < 2 * x1 z -> x3 r - x1 z < x1 z)
            by lia.
          apply H10; clear H10.
          rewrite H6, H13 in *.
          assert (x3 n = x2 n + 1) by lia.
          rewrite H10 in *.
          rewrite Z.pow_add_r in *; try lia.
          replace (2 ^ 1) with 2 in * by reflexivity.
          replace (x3 b * (2 ^ x2 n * 2))
            with (x3 b * 2 ^ x2 n * 2) in * by lia.
          rewrite Z.div_mul; lia. }
        { replace (st z) with (x z) in * by (rewrite H;
            now try solve_neq).
          replace (x z) with (x0 z) in * by (rewrite H2;
            now try solve_neq).
          replace (x0 z) with (x1 z) in * by (rewrite H3;
            now try solve_neq).
          rewrite H6 in *.
          replace (x2 z) with (x3 z) in * by (rewrite H9;
            now try solve_neq).
          rewrite H13 in *.
          assert (x3 n = x2 n + 1) by lia.
          replace (st n) with (x2 n) in *
            by (rewrite H, H2, H3, H7; now try solve_neq).
          rewrite H10 in *.
          rewrite Z.pow_add_r; try lia; simpl;
            unfold Z.pow_pos; simpl.
          replace (x3 b * (2 ^ x2 n * 2))
            with (x3 b * 2 ^ x2 n * 2) by lia.
          rewrite Z.div_mul; try lia.
          now replace (st b) with (x3 b)
            by (rewrite H, H2, H3, H7, H9; now try solve_neq). }
        { replace (st n) with (x2 n)
            by (rewrite H, H2, H3, H7; now try solve_neq);
            lia. }
      * eapply hoare_consequence; obliterate;
          unfold assert_implies; intros; try exact H;
          simpl in *; repeat split; crunch_hyp;
          rewrite Z.leb_gt in H1; rewrite Z.gtb_lt in H8;
          try (rewrite H0, H3, H5; now try solve_neq); auto.
        { replace (st a) with (x1 a) in *
            by (rewrite H0, H3, H5; now try solve_neq).
          rewrite H7 in *.
          replace (x q) with (x1 q) in * by (rewrite H3, H5;
            now try solve_neq).
          rewrite H in *.
          replace (st z) with (x z) in * by (rewrite H0;
            now try solve_neq).
          replace (x0 z) with (x1 z) in * by (rewrite H5;
            now try solve_neq).
          rewrite H2, H9 in *.
          assert (x1 n = x0 n + 1) by lia.
          rewrite H6 in *.
          rewrite Z.pow_add_r; try lia; simpl;
            unfold Z.pow_pos; simpl.
          replace (st r) with (x1 r) in *
            by (rewrite H0, H3, H5; now try solve_neq).
          replace (x1 b * (2 ^ x0 n * 2))
            with (x1 b * 2 ^ x0 n * 2) in * by lia.
          rewrite Z.div_mul; lia. }
        { replace (st z) with (x z) in * by (rewrite H0;
            now try solve_neq).
          replace (x0 z) with (x1 z) in * by (rewrite H5;
            now try solve_neq).
          rewrite H2, H9.
          replace (st b) with (x1 b) in *
            by (rewrite H0, H3, H5; now try solve_neq).
          replace (st n) with (x0 n) in * by (rewrite H0, H3;
            now try solve_neq).
          assert (x1 n = x0 n + 1) by lia.
          rewrite H6 in *.
          rewrite Z.pow_add_r; try lia; simpl;
            unfold Z.pow_pos; simpl.
          replace (x1 b * (2 ^ x0 n * 2))
            with (x1 b * 2 ^ x0 n * 2) by lia.
          rewrite Z.div_mul; lia. }
        { replace (st n) with (x0 n) by (rewrite H0, H3;
            now try solve_neq); lia. }
    + unfold assert_implies; simpl; intros; repeat split;
        crunch_hyp; rewrite Z.gtb_ltb, Z.ltb_ge in H1;
        try (replace (st n) with 0 in * by lia; simpl in *);
        nia.
Qed.

Print Assumptions long_division_correct.

Close Scope Z_scope.
Close Scope Z.
Close Scope hoare_spec_scope.
Close Scope imp_scope.
Close Scope string_scope.


Require Export Quorum.
Require Export Process.

Section MicroBFT_header.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc : @DTimeContext }.

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

  Class MicroBFT_context :=
    {
       MicroBFT_digest : Set;
       MicroBFT_digestdeq : Deq MicroBFT_digest;

       MicroBFT_sending_key   : Set;
       MicroBFT_receiving_key : Set;
    }.

  Context { MicroBFT_context : MicroBFT_context }.

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

  Inductive MicroBFT_node :=
  | MicroBFT_primary
  | MicroBFT_backup1
  | MicroBFT_backup2.

  Lemma MicroBFT_nodeDeq : Deq MicroBFT_node.
  Proof.
    introv; destruct x as [a1|b1|c1], y as [a2|b2|c2]; prove_dec.
  Defined.

  Global Instance MicroBFT_I_Node : Node := MkNode MicroBFT_node MicroBFT_nodeDeq.

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

  Lemma MicroBFT_replica_inj : injective (fun (x : MicroBFT_node) => x).
  Proof.
    introv h; ginv; auto.
  Qed.

  Definition nat_3_0 : nat_n 3.
  Proof.
    exists 0; reflexivity.
  Defined.

  Definition nat_3_1 : nat_n 3.
  Proof.
    exists 1; reflexivity.
  Defined.

  Definition nat_3_2 : nat_n 3.
  Proof.
    exists 2; reflexivity.
  Defined.

  Definition node2nat (n : MicroBFT_node) : nat_n 3 :=
    match n with
    | MicroBFT_primary => nat_3_0
    | MicroBFT_backup1 => nat_3_1
    | MicroBFT_backup2 => nat_3_2
    end.

  Definition nat2node (n : nat_n 3) : MicroBFT_node.
  Proof.
    destruct n as [n p].
    apply Nat.ltb_lt in p.
    destruct n;[exact MicroBFT_primary|].
    destruct n;[exact MicroBFT_backup1|].
    destruct n;[exact MicroBFT_backup2|omega].
  Defined.

  Lemma node2nat_bij : bijective node2nat.
  Proof.
    exists nat2node; introv; simpl; auto.
    { destruct x; simpl; auto. }
    { destruct y as [y p].
      destruct y;[rewrite (UIP_refl_bool _ p); auto|];[].
      destruct y;[rewrite (UIP_refl_bool _ p); auto|];[].
      destruct y;[rewrite (UIP_refl_bool _ p); auto|];[].
      assert False; tcsp. }
  Qed.

  Definition name2node : name -> option MicroBFT_node := fun n => Some n.
  Definition node2name : MicroBFT_node -> name := fun n => n.

  Lemma node_cond1 : forall n : MicroBFT_node, name2node (node2name n) = Some n.
  Proof.
    tcsp.
  Qed.

  Lemma node_cond2 : forall (n : MicroBFT_node) (m : name), name2node m = Some n -> node2name n = m.
  Proof.
    introv h; simpl in *.
    unfold name2node in h; ginv; auto.
  Qed.

  Global Instance MicroBFT_I_Quorum : Quorum_context :=
    MkQuorumContext
      MicroBFT_node
      3
      MicroBFT_nodeDeq
      node2nat
      node2nat_bij
      node2name
      name2node
      node_cond1
      node_cond2
      MicroBFT_replica_inj.

  (* ===============================================================
     More about Nodes
     =============================================================== *)

  (* ===============================================================
     Sequence numbers
     =============================================================== *)

  Inductive SeqNum :=
  | seq_num (n : nat).
  Coercion seq_num : nat >-> SeqNum.

  Definition seqnum2nat (s : SeqNum) : nat :=
    match s with
    | seq_num n => n
    end.
  Coercion seqnum2nat : SeqNum >-> nat.

  Definition SeqNumLe (sn1 sn2 : SeqNum) : bool :=
    seqnum2nat sn1 <=? seqnum2nat sn2.

  Definition SeqNumLt (sn1 sn2 : SeqNum) : bool :=
    seqnum2nat sn1 <? seqnum2nat sn2.

  Definition next_seq (n : SeqNum): SeqNum := seq_num (S n).

  Lemma SeqNumDeq : Deq SeqNum.
  Proof.
    introv; destruct x, y; prove_dec.
    destruct (deq_nat n n0); prove_dec.
  Defined.

  Definition initial_sequence_number : SeqNum := seq_num 0.

  Definition min_seq_num (s1 s2 : SeqNum) : SeqNum :=
    if SeqNumLe s1 s2 then s1 else s2.

  Definition max_seq_num (s1 s2 : SeqNum) : SeqNum :=
    if SeqNumLe s1 s2 then s2 else s1.

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

  Definition MicroBFT_tokens := MicroBFT_digest.

  Global Instance MicroBFT_I_AuthTok : AuthTok :=
    MkAuthTok
      MicroBFT_digest
      MicroBFT_digestdeq.

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

  Global Instance MicroBFT_I_Key : Key := MkKey MicroBFT_sending_key MicroBFT_receiving_key.

  Class MicroBFT_initial_keys :=
    MkMicroBFT_initial_keys {
        microbft_initial_keys : key_map;
      }.
  Context { m_initial_keys : MicroBFT_initial_keys }.

  Class USIG_initial_keys :=
    MkUSIG_initial_keys {
        usig_initial_keys : key_map;
      }.
  Context { u_initial_keys : USIG_initial_keys }.

End MicroBFT_header.


(** * Morphisms in a functor category *)
Require Import Category.Core Functor.Core NaturalTransformation.Paths FunctorCategory.Core Category.Morphisms NaturalTransformation.Core NaturalTransformation.Composition.Core.

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

Local Open Scope path_scope.
Local Open Scope category_scope.
Local Open Scope morphism_scope.

(** ** Natural Isomorphisms - isomorphisms in a functor category *)
Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G :=
  @Isomorphic (C -> D) F G.

Arguments NaturalIsomorphism {_} [C D] F G / .

Global Instance reflexive_natural_isomorphism `{Funext} C D
: Reflexive (@NaturalIsomorphism _ C D) | 0
  := _.

Coercion natural_transformation_of_natural_isomorphism `{Funext} C D F G
         (T : @NaturalIsomorphism _ C D F G)
: NaturalTransformation F G
  := T : morphism _ _ _.

Local Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope.

(** ** If [T] is an isomorphism, then so is [T x] for any [x] *)
Definition isisomorphism_components_of `{Funext}
           `{@IsIsomorphism (C -> D) F G T} x
: IsIsomorphism (T x).
Proof.
  exists (T^-1 x).
  - exact (apD10 (ap components_of left_inverse) x).
  - exact (apD10 (ap components_of right_inverse) x).
Defined.

Hint Immediate isisomorphism_components_of : typeclass_instances.
(** When one of the functors is the identity functor, we fail to match correctly, because [apply] is stupid.  So we do its work for it. *)
Hint Extern 10 (@IsIsomorphism _ _ _ (@components_of ?C ?D ?F ?G ?T ?x))
=> apply (fun H' => @isisomorphism_components_of _ C D F G T H' x)
   : typeclass_instances.

Definition inverse `{Funext}
           C D (F G : Functor C D) (T : NaturalTransformation F G)
           `{forall x, IsIsomorphism (T x)}
: NaturalTransformation G F.
Proof.
  exists (fun x => (T x)^-1);
  abstract (
      intros;
      iso_move_inverse;
      first [ apply commutes
            | symmetry; apply commutes ]
    ).
Defined.

(** ** If [T x] is an isomorphism for all [x], then so is [T] *)
Definition isisomorphism_natural_transformation `{Funext}
           C D F G (T : NaturalTransformation F G)
           `{forall x, IsIsomorphism (T x)}
: @IsIsomorphism (C -> D) F G T.
Proof.
  exists (inverse _);
  abstract (
      path_natural_transformation;
      first [ apply left_inverse
            | apply right_inverse ]
    ).
Defined.

Hint Immediate isisomorphism_natural_transformation : typeclass_instances.

(** ** Variant of [idtoiso] for natural transformations *)
Section idtoiso.
  Context `{Funext}.
  Variables C D : PreCategory.

  Definition idtoiso_natural_transformation
             (F G : object (C -> D))
             (T : F = G)
  : NaturalTransformation F G.
  Proof.
    refine (Build_NaturalTransformation'
              F G
              (fun x => idtoiso _ (ap10 (ap object_of T) x))
              _
              _);
    intros; case T; simpl;
    [ exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^)
    | exact (right_identity _ _ _ _ @ (left_identity _ _ _ _)^) ].
  Defined.

  Definition idtoiso
             (F G : object (C -> D))
             (T : F = G)
  : F <~=~> G.
  Proof.
    exists (idtoiso_natural_transformation T).
    exists (idtoiso_natural_transformation (T^)%path);
      abstract (path_natural_transformation; case T; simpl; auto with morphism).
  Defined.

  Lemma eta_idtoiso
        (F G : object (C -> D))
        (T : F = G)
  : Morphisms.idtoiso _ T = idtoiso T.
  Proof.
    case T.
    expand; f_ap.
    exact (center _).
  Qed.
End idtoiso.

Module Export FunctorCategoryMorphismsNotations.
  Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope.
End FunctorCategoryMorphismsNotations.


Require Import Coq.Strings.String.
Require Import util.

Inductive aexp : Type :=
| ANum    : nat -> aexp
| AId     : id -> aexp
| APlus   : aexp -> aexp -> aexp
| AMult   : aexp -> aexp -> aexp.

Inductive bexp : Type :=
| BTrue   : bexp
| BFalse  : bexp
| BEq     : aexp -> aexp -> bexp
| BLe     : aexp -> aexp -> bexp
| BNot    : bexp -> bexp
| BAnd    : bexp -> bexp -> bexp.

Inductive command : Type :=
| CSkip   : command
| CAss    : id -> aexp -> command
| CSeq    : command -> command -> command
| CIf     : bexp  -> command -> command -> command
| CWhile  : bexp -> command -> command
| CCons   : id -> aexp -> command
| CLookup : id -> aexp -> command
| CMutat  : aexp -> aexp -> command
| CDispose: aexp -> command.

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".
Definition M : id := Id "M".
Definition N : id := Id "N".


(** * Additional results not mentioned in the paper *)

From Undecidability.L Require Import Encodings.

(** ** Natural numbers *)

(** *** Predecessor and multiplication *)

Definition Pred : term := .\"n"; "n" !Zero (.\"n"; "n").

Hint Unfold Pred : cbv.

Lemma Pred_correct n : Pred (enc n) ≡ enc (pred n).
Proof.
  destruct n; solveeq.
Qed.

Definition Mul := rho (.\ "Mul", "m", "n"; "m" !Zero (.\ "m"; !Add "n" ("Mul" "m" "n"))).

Lemma Mul_correct m n :
  Mul (enc n) (enc m) ≡ enc (n * m).
Proof.
  induction n.
  - solveeq.
  - transitivity (Add (enc m) (Mul (enc n) (enc m))). solveeq.
    now rewrite IHn, Add_correct.
Qed.

(** ** Trivial and finite classes are decidable *)

From Undecidability.L Require Import DecidableRecognisable Enumerable.

Lemma decidable_ext p q : (forall x, p x <-> q x) -> decidable p -> decidable q.
Proof.
  intros H [u Hu].
  exists u. intuition. intros ?. now rewrite <- H.
Qed.

Definition finite p := exists l : list term, forall x, p x <-> x el l.

Lemma decidable_finite p : finite p -> decidable p.
Proof.
  intros (l & Hl).
  revert p Hl. induction l; intros p Hl.
  - eapply decidable_ext with (p := (fun x => False)). intros. rewrite Hl. intuition.
    exists (lambda (F)). split; value. intros. right. intuition. solveeq.
  - cbn in Hl.
    destruct (IHl (fun x => x el l)) as (u & proc_u & Hu). reflexivity.
    exists (lambda ((Eq 0 (tenc a)) T (u 0))). split; value.
    intros s.
    assert ((lambda (((Eq 0) (tenc a)) T (u 0))) (tenc s) ≡
            ((benc (term_eq_bool s a)) T (u (tenc s)))).
    assert (H := Eq_correct' s a). solveeq.
    rewrite H. clear H. unfold term_eq_bool.
    decide (s = a).
    + destruct (Hu a) as [ [] | [] ]; left; ( split; [ firstorder | subst; solveeq]).
    + destruct (Hu s) as [ [] | [] ]; [ left | right ] ; ( split ; [firstorder | solveeq] ).
Qed.

Lemma decidable_empty : decidable (fun x => False).
Proof.
  eapply decidable_finite. exists []. tauto.
Qed.

Lemma decidable_full : decidable (fun x => True).
Proof.
  now eapply decidable_ext; [ | eapply decidable_complement, decidable_empty ].
Qed.

(** ** First fixed-point theorem *)

Theorem FirstFixedPoint (s : term) :  closed s -> exists t, closed t /\ s t ≡ t.
Proof.
  pose (A := .\ "x"; !s ("x" "x")).
  pose (t := A A).
  exists t. split;[subst t A;value|].
  symmetry. cbv. solvered.
Qed.

Goal exists t, closed t /\ t ≡ (tenc t).
Proof.
  destruct (SecondFixedPoint) with ( s := I) as [t [cls_t A]]. value.
  exists t.
  split; value. symmetry in A. eapply (eqTrans A). solvered.
Qed.

(** ** Some corollaries of Rice's theorem *)

Require Import Rice.

Goal forall t, ~ recognisable (fun s => ~ pi s t).
Proof.
  intros t. eapply Rice_pi.
  - hnf; intuition. eapply H1. intros. rewrite H2. eauto.
  - exists (lambda I). repeat split; value. intros H; eapply H. exists I. solveeq.
  - intros A. eapply (D_pi t); eauto.
Qed.

Goal ~ recognisable (fun s => exists t, ~ pi s t).
Proof.
  eapply Rice_pi.
  - hnf; intuition. destruct H1 as [u H1].
    exists u. now rewrite <- H2.
  - exists (lambda I). split; value. intros [? H]. eapply H. eexists; eapply evaluates_equiv; split;[|eexists;reflexivity]. solvered.
  - exists I. now rewrite D_pi.
Qed.

(** * Lines of code for major results *)

(**
    Our development consists of 1850 lines of code (630 spec and 1220 proofs), 100 of them needed to
    implement L-specific automation. We do not count the Standard library-like Preliminaries.v.

    We list the lines of code we need for some major results, always considering exactly the parts of
    the development needed to establish the result.

    - Definition of L: 400 lines
    - Rice's Theorem, including properties of decidable/recognisable classes: 900 lines
    - Step-indexed interpreter: 900 lines
    - Totality: 1200 lines
    - Parallel or, including Post's theorem and closure of recognisable classes under union: 120
    - Equivalence of enumerability and recognisability: 1500
    - Markov: 1650

*)


(* -- DEPRECATED : should use LibMap instead,
      or (yet to be written) LibMapX for computable version *)

(*

(**************************************************************************
* TLC: A library for Coq                                                  *
* Heaps: finite maps from keys to values                                  *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibReflect LibList LibSet LibExec.
Generalizable Variable K V.

(***********************************************************)
(***********************************************************)
(***********************************************************)
(* Abstract interface of a heap *)

Module Type HeapSpec.

Parameter heap : Type -> Type -> Type.

(***********************************************************)
(** Operations *)

Section HeapDef.
Variables K V : Type.

Parameter empty : heap K V.
Parameter dom : heap K V -> set K. (* --LATER: should be a finite set *)
Parameter binds : heap K V -> K -> V -> Prop.
Parameter write : heap K V -> K -> V -> heap K V.
Parameter to_list : heap K V -> list (K * V).
Definition indom h r :=	(r \in dom h).

End HeapDef.

Parameter read : forall `{Comparable K} `{Inhab V}, heap K V -> K -> V.
Parameter read_option : forall `{Comparable K} V, heap K V -> K -> option V.
Parameter rem : forall `{Comparable K} V, heap K V -> K -> heap K V.

Implicit Arguments empty [[K] [V]].

(***********************************************************)
(** Properties *)

Section HeapParameters.
Context `{Comparable K} `{Inhab V}.
Implicit Types h : heap K V.

Parameter indom_equiv_binds : forall h k,
  indom h k = (exists v, binds h k v).

Parameter dom_empty :
  dom (@empty K V) = \{}.

Parameter binds_equiv_read : forall h k,
  indom h k -> (forall v, (binds h k v) = (read h k = v)).

Parameter dom_write : forall h r v,
  dom (write h r v) = dom h \u \{r}.

Parameter binds_write_eq : forall h k v,
  binds (write h k v) k v.

Parameter binds_write_neq : forall h k v k' v',
  binds h k v -> k <> k' ->
  binds (write h k' v') k v.

Parameter binds_write_inv : forall h k v k' v',
  binds (write h k' v') k v ->
  (k = k' /\ v = v') \/ (k <> k' /\ binds h k v).

Parameter binds_rem : forall h k k' v,
  binds h k v -> k <> k' -> binds (rem h k') k v.

Parameter binds_rem_inv : forall h k v k',
  binds (rem h k') k v -> k <> k' /\ binds h k v.

(* --TODO: need to add the instance BagRemove to LibSet
Parameter dom_rem : forall h k,
  dom (rem h k) = (dom h) \- k.
For now, we used this derived form:
*)

Parameter not_indom_rem : forall h k,
  ~ indom (rem h k) k.

Parameter binds_equiv_read_option : forall h k v,
  (binds h k v) = (read_option h k = Some v).

Parameter not_indom_equiv_read_option : forall h k,
  (~ indom h k) = (read_option h k = None).

Parameter read_option_def : forall h k,
  read_option h k = (If indom h k then Some (read h k) else None).

End HeapParameters.

Parameter indom_decidable : forall `{Comparable K} V (h:heap K V) k,
  Decidable (indom h k).
Existing Instance indom_decidable.

End HeapSpec.

(***********************************************************)
(***********************************************************)
(***********************************************************)
(** Implementation of heaps as lists *)

Module HeapList : HeapSpec.

Definition heap K V := list (K*V).

Section HeapDefs.
(*Variables K V : Type.*)
Context `{Comparable K} `{Inhab V}.
Definition empty : heap K V := nil.
Definition dom (l : heap K V) : set K :=
  fold_right (fun p acc => acc \u \{fst p}) \{} l.
Definition binds (l : heap K V) k v :=
  Assoc k v l.
Definition to_list (l : heap K V) := l.

(* --TODO: move *)
Generalizable Variable A B.
Fixpoint assoc `{Comparable A} `{Inhab B} k (l:list (A*B)) : B :=
  match l with
  | nil => arbitrary
  | (x, v) :: l' => ifb x = k then v else assoc k l'
  end.
Definition read (l : heap K V) k :=
  assoc k l.
Definition write (l : heap K V) k v :=
  (k, v) :: l.
Definition rem K `{Comparable K} V (l : heap K V) k :=
  LibList.filter (fun p => ifb (fst p) = k then false else true) l.
Definition indom h r := (r \in dom h).
Fixpoint read_option (l : heap K V) k :=
  match l with
  | nil => None
  | (x, v) :: l' => ifb x = k then Some v else read_option l' k
  end.

End HeapDefs.

Implicit Arguments empty [[K] [V]].

Section HeapParameters.
Context `{HK: Comparable K} `{IV: Inhab V}.
Implicit Types h : heap K V.
(* --TODO: do the right proof using *)

Lemma indom_equiv_binds : forall h k,
  indom h k = (exists v, binds h k v).
Proof using.
Admitted. (* File will be soon deprecated *)

Lemma dom_empty :
  dom (@empty K V) = \{}.
Proof using. auto. Qed.

Lemma binds_equiv_read : forall h k,
  indom h k -> (forall v, (binds h k v) = (read h k = v)).
Proof using HK IV.
Admitted. (* File will be soon deprecated *)

Lemma dom_write : forall h r v,
  dom (write h r v) = dom h \u \{r}.
Proof. intros. unfold dom, write. rew_list. auto. Qed.

Lemma binds_write_eq : forall h k v,
  binds (write h k v) k v.
Proof. unfolds @binds, @write. intros. constructors. Qed.

Lemma binds_write_neq : forall h k v k' v',
  binds h k v -> k <> k' ->
  binds (write h k' v') k v.
Proof. unfolds @binds, @write. intros. constructors~. Qed.

Lemma binds_write_inv : forall h k v k' v',
  binds (write h k' v') k v ->
  (k = k' /\ v = v') \/ (k <> k' /\ binds h k v).
Proof. unfolds @binds, @write. introv M. inverts* M. Qed.

Lemma binds_rem : forall h k k' v,
  binds h k v -> k <> k' -> binds (rem h k') k v.
Proof using HK.
Admitted. (* File will be soon deprecated *)

Lemma binds_rem_inv : forall h k v k',
  binds (rem h k') k v -> k <> k' /\ binds h k v.
Proof using HK.
Admitted. (* File will be soon deprecated *)

(* --TODO: need to add the instance BagRemove to LibSet
Lemma dom_rem : forall h k,
  dom (rem h k) = (dom h) \- k.
For now, we used this derived form:
*)

Lemma not_indom_rem : forall h k,
  ~ indom (rem h k) k.
Proof using HK.
Admitted. (* File will be soon deprecated *)

Lemma binds_equiv_read_option : forall h k v,
  (binds h k v) = (read_option h k = Some v).
Proof using. clear IV.
  unfolds @binds. introv. extens.
  induction h as [|(x&v0)].
   splits ; intro N ; invert* N.
   simpl. case_if.
     subst. splits ; intro N ; inverts* N. constructors.
     splits ; intro N.
      inverts* N.
      constructors*.
Qed.

Lemma not_indom_equiv_read_option : forall h k,
  (~ indom h k) = (read_option h k = None).
Proof using.
  introv. apply* injective_not. rew_logic. rewrite indom_equiv_binds.
  splits ; intro N.
   lets (v & B): rm N.
    rewrite binds_equiv_read_option in B. rewrite* B. discriminate.
   asserts (v & E): (exists v, read_option h k = Some v).
     destruct* @read_option.
    rewrite* <- binds_equiv_read_option in E.
Qed.

Lemma read_option_def : forall h k,
  read_option h k = (If indom h k then Some (read h k) else None).
Proof using.
(* --TODO
  introv. cases_if.
   rewrite* <- binds_equiv_read_option.
    rewrites* binds_equiv_read.
   rewrite* <- @not_indom_equiv_read_option.
*)
Admitted. (* File will be soon deprecated *)

(* --TODO: move *)
Generalizable Variable A.
Fixpoint mem_assoc B `{Comparable A} k (l : list (A * B)) : bool :=
  match l with
  | nil => false
  | (x, _) :: l' => decide (x = k) || mem_assoc k l'
  end.

Definition indom_dec `{Comparable K} V (h:heap K V) (k:K) : bool :=
  mem_assoc k h.

Lemma indom_dec_spec : forall `{Comparable K} V (h:heap K V) k,
  indom_dec h k = isTrue (indom h k).
Proof.
  intros. unfold indom, dom, indom_dec.
  induction h as [|[k' v'] h]; simpl.
  rewrite in_empty_eq. rew_refl~.
  rewrite in_union_eq. rewrite in_single_eq. rewrite IHh.
   extens. rew_refl*.
Qed.

End HeapParameters.

Lemma indom_decidable : forall `{Comparable K} V (h:heap K V) k,
  Decidable (indom h k).
Proof.
  intros. applys decidable_make (indom_dec h k).
  applys indom_dec_spec.
Qed.

End HeapList.

Export HeapList.

(***********************************************************)
(** Facts *)

Global Instance Inhab_heap : forall (K V : Type), Inhab (heap K V).
Proof using. introv. apply (Inhab_of_val empty). Qed.

Section HeapFacts.
Context `{HK:Comparable K} `{HV:Inhab V}.
Implicit Types h : heap K V.

(** indom *)

Lemma indom_binds : forall h k,
  indom h k -> exists v, binds h k v.
Proof using. introv H. rewrite~ @indom_equiv_binds in H. Qed.

Lemma binds_indom : forall h k v,
  binds h k v -> indom h k.
Proof using. introv H. rewrite* @indom_equiv_binds. Qed.

(** binds-func *)

Lemma binds_functional : forall h k v v',
  binds h k v -> binds h k v' -> v = v'.
Proof using HK HV.
  introv B1 B2. forwards: binds_indom B1. forwards: binds_indom B2.
  rewrite binds_equiv_read in B1,B2; congruence.
Qed.

(** read--binds *)

Lemma binds_read : forall h k v,
  binds h k v -> read h k = v.
Proof using. introv H. rewrite~ <- binds_equiv_read. apply* binds_indom. Qed.

Lemma read_binds : forall h k v,
  read h k = v -> indom h k -> binds h k v.
Proof using. introv H D. rewrite~ binds_equiv_read. Qed.

(** read-write *)

Lemma read_write_eq : forall h k v,
  read (write h k v) k = v.
Proof using. introv. apply binds_read. apply binds_write_eq. Qed.

Lemma read_write_neq : forall h k k' v',
  indom h k -> k <> k' -> read (write h k' v') k = read h k.
Proof using.
  introv. rewrite indom_equiv_binds. introv [v B] N.
  rewrite (binds_read B).
  forwards B': @binds_write_neq B N. rewrite~ (binds_read B').
Qed.

(** indom-write *)

Lemma indom_write_eq : forall h k v,
  indom (write h k v) k.
Proof using.
  intros. rewrite indom_equiv_binds. exists v.
  apply* @binds_write_eq.
Qed.

Lemma indom_write : forall h k k' v',
  indom h k -> indom (write h k' v') k.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B]. tests: (k = k').
    subst. exists v'. apply* @binds_write_eq.
    exists v. apply* @binds_write_neq.
Qed.

Lemma indom_write_inv : forall h k k' v',
  indom (write h k' v') k -> k <> k' -> indom h k.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B] N. lets [[? ?]|[? ?]]: @binds_write_inv B.
  false. eauto.
Qed.

(** binds-write *)

Lemma binds_write_eq_inv : forall h k v v',
  binds (write h k v') k v -> v = v'.
Proof using.
  introv B. lets [[? ?]|[? ?]]: @binds_write_inv B; auto_false.
Qed.

Lemma binds_write_neq_inv : forall h k v k' v',
  binds (write h k' v') k v -> k <> k' -> binds h k v.
Proof using.
  introv B. lets [[? ?]|[? ?]]: @binds_write_inv B; auto_false.
Qed.

(** indom-rem *)

Lemma indom_rem : forall h k k',
  indom h k -> k <> k' -> indom (rem h k') k.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B] N. exists v. apply* @binds_rem.
Qed.

Lemma indom_rem_inv : forall h k k',
  indom (rem h k) k' -> k <> k' /\ indom h k'.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B]. lets [? ?]: @binds_rem_inv B. eauto.
Qed.

(** read-rem *)

Lemma read_rem_neq : forall h k k',
  indom h k -> k <> k' -> read (rem h k') k = read h k.
Proof using HK HV.
  introv. rewrite indom_equiv_binds. introv [v B] N.
  rewrite (binds_read B).
  forwards B': @binds_rem B N. rewrite~ (binds_read B').
Qed.

(** indom-empty, binds-empty *)

Lemma not_indom_empty : forall k,
  ~ indom (@empty K V) k.
Proof using HV. introv H. unfold indom in H. rewrite dom_empty in H.
Admitted. (* File will be soon deprecated *)
  (* --TODO: add an instance for in_empty_eq in LibSet.
  apply* in_empty_eq. *)

Lemma not_binds_empty : forall k v,
  ~ binds (@empty K V) k v.
Proof using HV. introv H. eapply not_indom_empty. apply* binds_indom. Qed.

(** binds--read_option **)

Lemma binds_read_option : forall h k v,
  binds h k v -> read_option h k = Some v.
Proof using. introv. rewrite* <- @binds_equiv_read_option. Qed.

Lemma read_option_binds : forall h k v,
  read_option h k = Some v -> binds h k v.
Proof using. introv R. rewrite* <- @binds_equiv_read_option in R. Qed.

(** indom--read_option **)

Lemma not_indom_read_option : forall h k,
  ~ indom h k -> read_option h k = None.
Proof using. introv. rewrite not_indom_equiv_read_option. autos*. Qed.

Lemma read_option_not_indom : forall h k,
  read_option h k = None -> ~ indom h k.
Proof using. introv. rewrite not_indom_equiv_read_option. autos*. Qed.

End HeapFacts.

*)


Require Import list_examples.

(* Splitting the code into several definitions
   reduces proof time by reducing the size of
   terms at any single point in the proof *)
Definition delete_loop2 :=
  (SWhile (arr_next "y"<>0)
  (Seq ("z"<-arr_next "y")
       (SIf (arr_val "z"="v")
          (Seq ("y"<<-build_node (arr_val "y") (arr_next "z"))
               (HDealloc "z"))
          ("y"<-"z"))))%code.
Definition delete_tail1 :=
 {{SIf ("x"=0) (SReturn 0) Skip
  ;Decl "z"
  ;"y"<-"x"
  ;delete_loop2
  ;SReturn "x"}}%code.
Definition delete_def := FunDef "delete" ["x";"v"]
 (Seq (Decl "y")
 (Seq (SWhile (("x"<>0) && (arr_val "x"="v"))
   {{"y"<-arr_next "x";HDealloc "x";"x"<-"y"}})
   delete_tail1))%code.

Fixpoint delete (v : Z) (l : list Z) : list Z :=
  match l with
    | nil => nil
    | (x :: l') => if Z_eq_dec v x then delete v l'
                   else x :: delete v l'
  end.
Arguments delete v l : simpl nomatch.

Inductive delete_spec : Spec kcfg :=
  delete_claim : forall l x v, heap_fun delete_spec nil
  delete_def [Int x;Int v] (rep_list l x) (rep_list (delete v l))
 |loop1_claim : forall l x v y, heap_loop delete_spec
  delete_def 0 ("x" s|-> KInt x :* "v" s|-> KInt v :* "y" s|-> y)
    (rep_list l x) (rep_list (delete v l))
 |loop2_claim : forall v A x yv B y z, heap_loop delete_spec
  delete_def 1 ("x" s|-> KInt x :* "v" s|-> KInt v
             :* "y" s|-> KInt y :* "z" s|-> z)
    (rep_seg A y x :* constraint (y <> 0) :* existsP q,
     y h|-> list_node yv q :* constraint (yv <> v) :* rep_list B q)
    (rep_list (A++yv::delete v B)).

Lemma delete_eq : forall v l, delete v (v :: l) = delete v l.
Proof. unfold delete;intros;destruct (Z.eq_dec v v);congruence. Qed.
Lemma delete_ne : forall v z l, v<>z -> delete v (z::l) = z::delete v l.
Proof. unfold delete;intros;destruct (Z.eq_dec v z);congruence. Qed.

Lemma delete_proof : sound kstep delete_spec.
Proof. list_solver;
rewrite ?delete_eq, ?delete_ne by congruence;
try rewrite app_ass in * |-;
list_run. 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                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Summation.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)

From Coq Require Import Arith ArithRing.
From Bertrand Require Export Misc.

(**  	Iterated Sum:
         (sum_nm n m) = f(n)+f(n+1)+...+f(n+m+1)
*)

Fixpoint sum_nm (n m : nat) {struct m} : (nat -> nat) -> nat :=
  fun f : nat -> nat =>
  match m with
  | O => f n
  | S m' => f n + sum_nm (S n) m' f
  end.

Lemma sum_nm_i :
 forall (m n : nat) (f : nat -> nat),
 sum_nm n (S m) f = f n + sum_nm (S n) m f.
Proof.
auto.
Qed.

Lemma sum_nm_f :
 forall (n m : nat) (f : nat -> nat),
 sum_nm n (S m) f = sum_nm n m f + f (n + S m).
Proof.
intros n m; generalize n; clear n; elim m; simpl in |- *; auto with arith.
intros n f; repeat rewrite (fun x y => Nat.add_comm x (S y)); simpl in |- *;
 auto.
intros n Rec m' f.
rewrite Rec; repeat (rewrite (Nat.add_comm m'); simpl in |- *); auto with arith.
Qed.

Lemma sum_nm_ext :
 forall (n m : nat) (f g : nat -> nat),
 (forall x : nat, x <= m -> f (n + x) = g (n + x)) ->
 sum_nm n m f = sum_nm n m g.
Proof.
intros n m; generalize n; clear n; elim m; simpl in |- *; auto.
intros n f g H0; generalize (H0 0); rewrite Nat.add_comm; simpl in |- *;
 auto with arith.
intros m' Rec n f g H0.
rewrite (Rec (S n) f g).
generalize (H0 0); rewrite Nat.add_comm; simpl in |- *; intros tmp;
 auto with arith.
intros x H'; simpl in |- *; rewrite plus_n_Sm; auto with arith.
Qed.

Lemma sum_nm_add :
 forall (n m : nat) (f g : nat -> nat),
 sum_nm n m f + sum_nm n m g = sum_nm n m (fun i : nat => f i + g i).
Proof.
intros n m f g; generalize n; clear n; elim m; simpl in |- *; auto.
intros m' Rec n.
rewrite <- Rec.
ring.
Qed.

Lemma sum_nm_times :
 forall (n m x : nat) (f : nat -> nat),
 x * sum_nm n m f = sum_nm n m (fun i : nat => x * f i).
Proof.
intros n m x f; generalize n; clear n; elim m; simpl in |- *; auto.
intros m' Rec n.
rewrite <- Rec; auto with arith.
ring.
Qed.

Lemma inv_sum_nm :
 forall (P : nat -> Prop) (n i : nat) (f : nat -> nat),
 (forall a b : nat, P a -> P b -> P (a + b)) ->
 (forall x : nat, x <= i -> P (f (n + x))) -> P (sum_nm n i f).
Proof.
intros P n i f; generalize n; clear n; elim i; simpl in |- *; auto.
intros n H H0; generalize (H0 0); rewrite Nat.add_comm; simpl in |- *;
 auto with arith.
intros i' Rec n Pi Hx.
apply Pi; auto.
generalize (Hx 0); rewrite Nat.add_comm; simpl in |- *; intros tmp;
 auto with arith.
apply Rec; auto.
intros x H'; simpl in |- *; rewrite plus_n_Sm; auto with arith.
Qed.

Lemma t_sum_Svars :
 forall (n m : nat) (f : nat -> nat),
 sum_nm n m f = sum_nm (S n) m (fun i : nat => f (pred i)).
Proof.
intros n m f; generalize n; clear n; elim m; simpl in |- *; auto.
Qed.

Theorem sum_nm_split :
 forall (f : nat -> nat) (p q r : nat),
 r < q -> sum_nm p q f = sum_nm p r f + sum_nm (1 + (p + r)) (q - (1 + r)) f.
Proof.
intros f p q; elim q.
intros r H; inversion H; simpl in |- *.
intros n H r H0; inversion H0.
rewrite sum_nm_f.
rewrite Nat.sub_diag; rewrite <- plus_n_Sm; simpl in |- *; auto.
rewrite sum_nm_f; rewrite (H r); auto with arith.
rewrite Nat.sub_succ_l; auto with arith.
rewrite sum_nm_f; auto with arith.
replace (1 + (p + r) + S (n - (1 + r))) with (p + S n); auto with arith.
rewrite <- Nat.sub_succ_l; auto with arith.
replace (1 + (p + r) + (S n - (1 + r))) with (p + (1 + r + (S n - (1 + r))));
  [ idtac | ring ].
simpl.
rewrite <- (Nat.add_comm (n - r)).
rewrite Nat.sub_add; auto with arith.
Qed.

Theorem sum_nm_c : forall c p q : nat, sum_nm p q (fun x => c) = S q * c.
Proof.
intros c p q; generalize p; elim q; clear p q; simpl in |- *; auto.
Qed.

Theorem sum_nm_sum_nm_f :
 forall (i j k l : nat) (f : nat -> nat -> nat),
 sum_nm i j (fun x => sum_nm k (S l) (fun y => f x y)) =
 sum_nm i j (fun x => sum_nm k l (fun y => f x y) + f x (k + S l)).
Proof.
intros; apply sum_nm_ext; intros; rewrite sum_nm_f; auto.
Qed.

Theorem sum_nm_com :
 forall (i j k l : nat) (f : nat -> nat -> nat),
 sum_nm i j (fun x => sum_nm k l (fun y => f x y)) =
 sum_nm k l (fun y => sum_nm i j (fun x => f x y)).
Proof.
intros i j; elim j.
simpl in |- *; auto.
intros j1 Rec; intros k l; case l.
simpl in |- *; auto.
intros l1 f; repeat rewrite sum_nm_f || rewrite sum_nm_sum_nm_f.
rewrite <-
 sum_nm_add
            with
            (f := fun x => sum_nm k l1 (fun y : nat => f x y))
           (g := fun x => f x (k + S l1)).
rewrite (Rec k l1).
(* pre V8.1 only: rewrite sum_nm_sum_nm_f with (f := fun x y => f y x). *)
rewrite <-
 sum_nm_add
            with
            (f := fun x => sum_nm i j1 (fun y : nat => f y x))
           (g := fun x => f (i + S j1) x).
replace
 (sum_nm k l1 (fun y : nat => sum_nm i j1 (fun x : nat => f x y)) +
  sum_nm i j1 (fun x : nat => f x (k + S l1)) +
  (sum_nm k l1 (fun y : nat => f (i + S j1) y) + f (i + S j1) (k + S l1)))
 with
 (sum_nm k l1 (fun y : nat => sum_nm i j1 (fun x : nat => f x y)) +
  sum_nm k l1 (fun y : nat => f (i + S j1) y) +
  (sum_nm i j1 (fun x : nat => f x (k + S l1)) + f (i + S j1) (k + S l1))).
auto.
ring; auto.
Qed.

Theorem sum_nm_le :
 forall (n m : nat) (f g : nat -> nat),
 (forall x : nat, n <= x -> x <= n + m -> f x <= g x) ->
 sum_nm n m f <= sum_nm n m g.
Proof.
intros n m f g; generalize n; elim m; clear n m.
simpl in |- *; auto with arith.
intros m H n H0; repeat rewrite sum_nm_f; auto with arith.
apply Nat.add_le_mono; auto with arith.
apply H; auto with arith.
intros x H1 H2; apply H0; auto with arith.
apply Nat.le_trans with (1 := H2); auto with arith.
Qed.

Theorem sum_nm_minus :
 forall (n m : nat) (f g : nat -> nat),
 (forall x : nat, n <= x -> x <= n + m -> g x <= f x) ->
 sum_nm n m f - sum_nm n m g = sum_nm n m (fun x => f x - g x).
Proof.
intros n m f g; generalize n; elim m; clear n m.
simpl in |- *; auto.
intros m H n H0; try assumption.
repeat rewrite sum_nm_f.
rewrite minus_plus_le; auto with arith.
rewrite H; auto.
intros x H1 H2; apply H0; auto with arith.
apply Nat.le_trans with (1 := H2); auto with arith.
apply sum_nm_le; auto.
intros x H1 H2; apply H0; auto with arith.
apply Nat.le_trans with (1 := H2); auto with arith.
Qed.


(* Tree on Ssreflect *)
Require Import
Ssreflect.ssreflect
Ssreflect.ssrfun
Ssreflect.ssrbool
Ssreflect.eqtype
Ssreflect.ssrnat
Ssreflect.seq.

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

Delimit Scope tree_scope with tree.
Open Scope tree_scope.

(** * Definition of [tree] and [forest] *)
Inductive tree (T: Type) :=
| node (x: T)(c: forest T)
with
forest (T: Type) :=
| leaf
| sibl (t: tree T)(f: forest T).
Arguments leaf {T}.

(** ** Notations *)
Infix "-:" := node (at level 60, no associativity): tree_scope.
Notation "[*]" := leaf: tree_scope.
Infix "~+" := sibl (at level 60, right associativity): tree_scope.
Notation "[~ X + .. + Y ~]" := (X ~+ ( .. (Y ~+ [*]) ..)) (at level 60, right associativity): tree_scope.

(** ** Induction principles  *)
Scheme tree_forest_ind := Induction for tree Sort Prop
  with forest_tree_ind := Induction for forest Sort Prop.
Scheme tree_forest_rec := Induction for tree Sort Set
  with forest_tree_rec := Induction for forest Sort Set.
Scheme tree_forest_rect := Induction for tree Sort Type
  with forest_tree_rect := Induction for forest Sort Type.

(** *** Mutual Induction Principle *)
Combined Scheme tree_forest_mut_ind from
         tree_forest_ind, forest_tree_ind.

(** * Traverse [tree] and [forest] by pre- and post- order *)
Section Traverse.

  Variables (T: Type).
  Implicit Type t : tree T.
  Implicit Type f : forest T.

  Fixpoint size_tree t: nat :=
    match t with
      | x -: f => (size_forest f).+1
    end with
  size_forest f: nat :=
    match f with
      | [*] => 0
      | t ~+ f => size_tree t + size_forest f
    end.

  Lemma size_tree_ltn0 t:
    0 < size_tree t.
  Proof.
    by move: t => [x f] //.
  Qed.

  Lemma size_forest0leaf f:
    size_forest f = 0 -> f = [*].
  Proof.
    move: f => [| t f] //= Heq.
    by move: Heq (ltn_addr (size_forest f) (size_tree_ltn0 t)) => <-; rewrite ltnn.
  Qed.

  Fixpoint cat_forest f1 f2 :=
    match f1 with
      | [*] => f2
      | t ~+ f => t ~+ (cat_forest f f2)
    end.
  Infix "+++" := cat_forest (at level 50, left associativity).

  Lemma cat_forest_leaf f:
    f +++ [*] = f.
  Proof.
    by elim: f => [| t f /= ->] //.
  Qed.

  Lemma cat_forest_app f1 f2 f3:
    (f1 +++ f2) +++ f3 = f1 +++ (f2 +++ f3).
  Proof.
    by elim: f1 => [| t f /= ->] //.
  Qed.

  Fixpoint rev_tree t :=
    match t with
      | x -: f => x -: rev_forest f
    end with
  rev_forest f :=
    match f with
      | [*] => [*]
      | t ~+ f => rev_forest f +++ (rev_tree t ~+[*])
    end.

  Lemma cat_rev_forest f1 f2:
    rev_forest (f1 +++ f2) = rev_forest f2 +++ rev_forest f1.
  Proof.
    by elim: f1 => [/= | t f /= ->] //;
      rewrite ?cat_forest_leaf ?cat_forest_app.
  Qed.

  Lemma rev_rev_id:
    (forall t, rev_tree (rev_tree t) = t)
    /\(forall f, rev_forest (rev_forest f) = f).
  Proof.
    apply: tree_forest_mut_ind.
    by move => a c //= ->.
    done.
    by move => t Heqt f Heqf //=; rewrite cat_rev_forest /= Heqt Heqf.
  Qed.

  Fixpoint preorder_tree t :=
    let: x -: f := t in [:: x & preorder_forest f ]
  with preorder_forest f :=
    if f is t ~+ f
    then preorder_tree t ++ preorder_forest f
    else [::].

  Lemma preorder_f_forest_cat f1 f2:
      preorder_forest (f1 +++ f2) = preorder_forest f1 ++ preorder_forest f2.
  Proof.
    by elim: f1 => [| t f /= ->] //; rewrite catA.
  Qed.

  Fixpoint postorder_tree t :=
    let: x -: f := t in rcons (postorder_forest f) x
  with postorder_forest f :=
    if f is t ~+ f
    then postorder_tree t ++ postorder_forest f
    else [::].

  Lemma pre_rev_eq_rev_post:
    (forall t, preorder_tree (rev_tree t) = rev (postorder_tree t))/\
    (forall f, preorder_forest (rev_forest f) = rev (postorder_forest f)).
  Proof.
    apply: tree_forest_mut_ind => [x c /= -> || /= t Heqt f Heqf] //;
      first by rewrite rev_rcons.
    by rewrite rev_cat -Heqt -Heqf preorder_f_forest_cat //= catA cats0.
  Qed.

  Lemma pre_rev_eq_rev_post_tree t:
    preorder_tree (rev_tree t) = rev (postorder_tree t).
  Proof.
    apply pre_rev_eq_rev_post.
  Qed.

  Lemma pre_rev_eq_rev_post_forest f:
    preorder_forest (rev_forest f) = rev (postorder_forest f).
  Proof.
    apply pre_rev_eq_rev_post.
  Qed.

End Traverse.

Infix "+++" := cat_forest (at level 50, left associativity).

Lemma tree_forest_mut_rect:
  forall (T: Type)(P : tree T -> Type) (Q : forest T -> Type),
    (forall (x : T) (c : forest T), Q c -> P (node x c)) ->
    Q leaf ->
    (forall t, P t -> forall f, Q f -> Q (sibl t f)) ->
    (forall t, P t) * (forall f, Q f).
Proof.
  move => T P Q IHn IHl IHs.
  exact (tree_forest_rect IHn IHl IHs, forest_tree_rect IHn IHl IHs).
Qed.

Section EqTree.

  Variable T: eqType.
  Implicit Type t : tree T.
  Implicit Type f : forest T.

  Fixpoint eqtree t1 t2 :=
    match t1, t2 with
      | x1-:c1, x2-:c2 => (x1 == x2) && (eqforest c1 c2)
    end with
  eqforest f1 f2 :=
    match f1, f2 with
      | [*], [*] => true
      | t1 ~+ f1, t2 ~+ f2 => (eqtree t1 t2) && (eqforest f1 f2)
      | _, _ => false
    end.

  Lemma eqtreeP_eqforestP:
    (Equality.axiom eqtree)*(Equality.axiom eqforest).
  Proof.
    apply: tree_forest_mut_rect
    => [x f IHf [x' f'] | [| t f] | t IHt f IHf [|t' f']] /=; try by constructor.
    - case: (x =P x') => [<- | Hneq]; last by right; case.
        by case: (IHf f') => [<- | Hneq] /=; [ left | right; case ].
    - move: (IHt t') => [<- | Hneq]; last by right; case.
        by move: (IHf f') => [<- | Hneq]; [left | right; case].
  Qed.

  Definition eqtreeP: Equality.axiom eqtree := fst eqtreeP_eqforestP.
  Definition eqforestP: Equality.axiom eqforest := snd eqtreeP_eqforestP.

  Canonical tree_eqMixin := EqMixin eqtreeP.
  Canonical tree_eqType :=  Eval hnf in EqType (tree T) (EqMixin eqtreeP).

  Lemma eqtreeE : eqtree = eq_op.
  Proof.
      by [].
  Qed.

  Canonical forest_eqMixin := EqMixin eqforestP.
  Canonical forest_eqType := Eval hnf in EqType (forest T) forest_eqMixin.

  Lemma eqforestE : eqforest = eq_op.
  Proof.
      by [].
  Qed.

  Lemma eqtree_node x1 x2 f1 f2:
    (x1 -: f1 == x2 -: f2) = (x1 == x2) && (f1 == f2).
  Proof.
      by [].
  Qed.

  Lemma eqforest_sibl t1 t2 f1 f2:
    (t1 ~+ f1 == t2 ~+ f2) = (t1 == t2) && (f1 == f2).
  Proof.
      by [].
  Qed.

  Fixpoint mem_tree (t: tree T): pred T :=
    match t with
      | node y f => xpredU1 y (mem_forest f)
    end
  with mem_forest (f: forest T): pred T :=
    match f with
      | leaf => xpred0
      | sibl t f => xpredU (mem_tree t) (mem_forest f)
    end.

  Definition eqtree_class := tree T.
  Identity Coercion tree_of_eqtree : eqtree_class >-> tree.

  Coercion pred_of_eq_tree (t : eqtree_class) : pred_class := [eta mem_tree t].
  Canonical tree_predType := @mkPredType T (tree T) pred_of_eq_tree.
  Canonical mem_tree_predType := mkPredType mem_tree.

  Definition eqforest_class := forest T.
  Identity Coercion forest_of_eqforest : eqforest_class >-> forest.

  Coercion pred_of_eq_forest (f : eqforest_class) : pred_class := [eta mem_forest f].
  Canonical forest_predType := @mkPredType T (forest T) pred_of_eq_forest.
  Canonical mem_forest_predType := mkPredType mem_forest.

  Lemma in_node y f x:
    (x \in node y f) = (x == y) || (x \in f).
  Proof.
    by [].
  Qed.

  Lemma in_leaf x:
    (x \in leaf) = false.
  Proof.
    by [].
  Qed.

  Lemma in_sibl x t f:
    (x \in sibl t f) = (x \in t) || (x \in f).
  Proof.
    by [].
  Qed.

  Lemma mem_tree1 x y:
    (x \in node y leaf) = (x == y).
  Proof.
    by rewrite in_node orbF //.
  Qed.

  Let inE := (mem_tree1, in_node, inE).

  Lemma mem_f_cat x f1 f2 :
    (x \in f1 +++ f2) = (x \in f1) || (x \in f2).
  Proof.
    elim: f1 => [//=| t f /= Heq].
    by rewrite in_sibl in_sibl Heq orbA //=.
  Qed.

End EqTree.
Definition inE := (mem_tree1, in_node, inE).

Section TravIn.

  Variables (T: eqType).
  Implicit Type t : tree T.
  Implicit Type f : forest T.

  Lemma traverse_correct_pre:
    (forall t x, (x \in t) == (x \in preorder_tree t))/\
    (forall f x, (x \in f) == (x \in preorder_forest f)).
  Proof.
    apply tree_forest_mut_ind.
    - move=> x f Heq y.
      by rewrite in_node in_cons; move: (Heq y) => /eqP ->.
    - move=> x //=.
    - move=> t Heqt f Heqf x /=.
      by rewrite in_sibl mem_cat; move: (Heqt x) (Heqf x) => /eqP -> /eqP ->.
  Qed.

  Theorem traverse_correct_pre_tree t x:
    (x \in t) == (x \in preorder_tree t).
  Proof.
    move: t x; apply traverse_correct_pre.
  Qed.

  Lemma traverse_correct_post:
    (forall t x, (x \in t) == (x \in postorder_tree t))/\
    (forall f x, (x \in f) == (x \in postorder_forest f)).
  Proof.
    apply tree_forest_mut_ind.
    - move=> x f Heq y.
      by rewrite in_node mem_rcons; move: (Heq y) => /eqP ->.
    - move=> x //=.
    - move=> t Heqt f Heqf x.
      by rewrite in_sibl mem_cat; move: (Heqt x) (Heqf x) => /eqP -> /eqP ->.
  Qed.

  Theorem traverse_correct_post_tree t x:
    (x \in t) == (x \in postorder_tree t).
  Proof.
    move: t x; apply traverse_correct_post.
  Qed.

End TravIn.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                               RoundRobin.v                               *)
(****************************************************************************)

Require Export NextPort.

Set Implicit Arguments.
Unset Strict Implicit.

Section Round_Robin_function.

  Variable i o : nat. (* Number of inputs and outputs *)
  Let Inportno := T_Inportno i.
  Let Outportno := T_Outportno o.

  Variable k : nat. (* Length of the list containing the input ports to arbitrate *)

  (** Round robin function **)

 Fixpoint RoundRobin (n : nat) (requests_set : d_list Inportno k)
  (last : Inportno) {struct n} : Inportno :=
   match n with
   | O => last
   | S p =>
       match
         In_or_not eq_nat_dec (no_in (SUC_MODN last))
           (d_map (no_in (i:=i)) requests_set)
       with
       | left _ => SUC_MODN last
       | right _ => RoundRobin p requests_set (SUC_MODN last)
       end
   end.

 (** Arbitration on a Round Robin basis **)

  Definition RoundRobinArbiter (requests_set : d_list Inportno k)
    (last : Inportno) :=
    match requests_set with
    | d_nil => last
    | d_cons p _ _ => RoundRobin i requests_set last
    end.

End Round_Robin_function.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (@map.Map.map Z _ a a_WT) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): (@map.Map.map
  Z _ a a_WT) := match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z)
  (v:a): (@array a a_WT) := (mk_array (length a1) (map.Map.set (elts a1) i
  v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (@array a a_WT) :=
  (mk_array n (map.Map.const v:(@map.Map.map Z _ a a_WT))).

(* Why3 assumption *)
Definition decrease1 (a:(@array Z _)): Prop := forall (i:Z), ((0%Z <= i)%Z /\
  (i < ((length a) - 1%Z)%Z)%Z) -> (((get a i) - 1%Z)%Z <= (get a
  (i + 1%Z)%Z))%Z.

(* Why3 goal *)
Theorem decrease1_induction : forall (a:(@array Z _)), (decrease1 a) ->
  forall (i:Z) (j:Z), ((0%Z <= i)%Z /\ ((i <= j)%Z /\ (j < (length a))%Z)) ->
  ((((get a i) + i)%Z - j)%Z <= (get a j))%Z.
(* Why3 intros a h1 i j (h2,(h3,h4)). *)
(* YOU MAY EDIT THE PROOF BELOW *)
unfold decrease1.
intros a Ha i j Hij.
generalize Hij; pattern j.
apply (Zlt_lower_bound_ind _ i).
2: omega.
intuition.
assert (x = i \/ i < x)%Z by omega.
destruct H5.
subst x.
ring_simplify.
omega.
apply Zle_trans with (get a (x-1) - 1)%Z.
assert (i <= x-1 < x)%Z by omega.
assert (0 <= i /\ i <= x-1 < length a)%Z by omega.
generalize (H0 (x-1)%Z H8 H9); clear H0; intuition.
apply Zle_trans with (get a (x-1+1))%Z.
apply (Ha (x-1)%Z); omega.
ring_simplify (x-1+1)%Z.
omega.
Qed.


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

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

Import GRing.Theory Num.Theory Order.Theory.

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

(* -------------------------------------------------------------------- *)
Section Couplings.
Context {A B : choiceType} (μ1 : Distr A) (μ2 : Distr B).

Definition iscoupling (ν : Distr (A * B)) :=
  dfst ν = μ1 /\ dsnd ν = μ2.
End Couplings.

(* -------------------------------------------------------------------- *)
Section CouplingsTheory.
Context {A B C D : choiceType}.

Lemma iscoupling_eq (μ1 μ2 μ1' μ2' : Distr _) (ν : Distr (A * B)) :
  μ1 =1 μ1' -> μ2 =1 μ2' -> iscoupling μ1 μ2 ν -> iscoupling μ1' μ2' ν.
Proof. by do 2! move=> /distr_eqP->. Qed.

Lemma iscoupling_prod (μ : Distr (A * B)) :
  iscoupling (dfst μ) (dsnd μ) μ.
Proof. by []. Qed.

Lemma iscoupling_dnull : @iscoupling A B dnull dnull dnull.
Proof. by split; rewrite dmarginE dlet_null. Qed.

Lemma iscoupling_dunit a b :
  @iscoupling A B (dunit a) (dunit b) (dunit (a, b)).
Proof. by split; rewrite dmarginE dlet_unit. Qed.

Lemma iscoupling_swap (μ1 μ2 : Distr A) (ν : Distr (A * A)) :
  iscoupling μ1 μ2 ν -> iscoupling μ2 μ1 (dswap ν).
Proof.
case=> <- <-; split; apply/distr_eqP => m;
  by rewrite (dfst_dswap, dsnd_dswap).
Qed.

Lemma iscoupling_dlet
  (μ1 μ2 : Distr _) (ν : Distr (A * B))
  (θ1 θ2 : _ -> Distr _) (ν' : _ -> Distr (C * D)) :

     iscoupling μ1 μ2 ν
  -> (forall x, x \in dinsupp ν ->
        iscoupling (θ1 x.1) (θ2 x.2) (ν' x))
  -> iscoupling
       (\dlet_(x <- μ1) (θ1 x))
       (\dlet_(x <- μ2) (θ2 x))
       (\dlet_(x <- ν ) (ν' x)).
Proof.
move=> [eq1 eq2] hC; split; rewrite !dmargin_dlet; subst μ1 μ2.
+ by rewrite dlet_dmargin; apply/eq_in_dlet => // x /hC [<- _].
+ by rewrite dlet_dmargin; apply/eq_in_dlet => // x /hC [_ <-].
Qed.

Lemma iscoupling_dlim
  (μ1 μ2 : nat -> Distr _) (ν : nat -> Distr (A * B)) :

     (forall n, iscoupling (μ1 n) (μ2 n) (ν n))
  -> (forall n m, (n <= m)%N -> ν n <=1 ν m)
  -> iscoupling (dlim μ1) (dlim μ2) (dlim ν).
Proof.
move=> hC mono; rewrite /iscoupling !dmarginE !dlet_lim //.
by split; apply/eq_dlim => n; case: (hC n).
Qed.
End CouplingsTheory.

(* -------------------------------------------------------------------- *)
Implicit Types P Q S I : rassn.
Implicit Types c       : cmd.

(* -------------------------------------------------------------------- *)
Definition prhl P c1 c2 Q :=
  forall m : rmem, P m ->
    exists2 ν,
        iscoupling (ssem c1 m.1) (ssem c2 m.2) ν
      & range Q ν.

(* -------------------------------------------------------------------- *)
Lemma prhlw P c1 c2 Q m :
  prhl P c1 c2 Q -> P m ->
    { ν | iscoupling (ssem c1 m.1) (ssem c2 m.2) ν & range Q ν }.
Proof. move=> h Pm.
have: exists ν, iscoupling (ssem c1 m.1) (ssem c2 m.2) ν /\ range Q ν.
+ by case: (h _ Pm) => ν h1 h2; exists ν; split.
by case/cid=> ν [h1 h2]; exists ν.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_sem P c1 c2 c'1 c'2 Q :
     (forall m, P m -> ssem c1 m.1 = ssem c'1 m.1)
  -> (forall m, P m -> ssem c2 m.2 = ssem c'2 m.2)
  -> prhl P c1  c2  Q
  -> prhl P c'1 c'2 Q.
Proof.
move=> eq1 eq2 h m Pm; case: (h _ Pm) => [ν hC hR].
by exists ν => //; rewrite -!(eq1, eq2).
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_conseq P P' c1 c2 Q Q' :
     (forall m, P' m -> P  m)
  -> (forall m, Q  m -> Q' m)
  -> prhl P  c1 c2 Q
  -> prhl P' c1 c2 Q'.
Proof.
move=> hP hQ h m /hP /h [ν hC hR]; exists ν => //.
by apply/range_weaken/hQ: hR.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_swap P c1 c2 Q :
  prhl P c2 c1 Q <-> prhl (pswap P) c1 c2 (pswap Q).
Proof.
move: P Q c1 c2 => [:hG] P Q c1 c2; split; last first.
+ move: P Q c1 c2; abstract: hG => P Q c1 c2 h -[m1 m2] Pm.
  case: (h (m2, m1))=> //= ν [hC1 hC2] hR; exists (dswap ν) => /=.
  * by apply/iscoupling_swap.
  * by move/range_pswap: hR; apply/range_weaken; case.
+ by move=> h; apply/hG; apply/prhl_conseq: h; case.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_lepr P c1 c2 (E1 E2 : assn) m:
     P m
  -> prhl P c1 c2 [pred m | E1 m.1 ==> E2 m.2]
  -> \P_[ssem c1 m.1] E1 <= \P_[ssem c2 m.2] E2.
Proof.
case: m => /= m1 m2 Pm h; case/h: Pm => {h} /= ν [<- <-] h.
by rewrite !pr_dmargin le_in_pr //= => m /h /implyP.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_eqpr P c1 c2 (E1 E2 : assn) m:
     P m
  -> prhl P c1 c2 [pred m | E1 m.1 == E2 m.2]
  -> \P_[ssem c1 m.1] E1 = \P_[ssem c2 m.2] E2.
Proof.
case: m => [m1 m2] Pm h; rewrite (rwP eqP) eq_le (@prhl_lepr P) //=.
+ apply/prhl_conseq: h => // {m1 m2 Pm} -[m1 m2] /=.
  by move/eqP=> ->; apply/implyP.
apply/(prhl_lepr (P := pswap P) (m := (m2, m1))) => //.
move/prhl_swap: h; apply/prhl_conseq=> // {m1 m2 Pm} -[m1 m2] /=.
by move/eqP=> ->; apply/implyP.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_exfalso c1 c2 Q : prhl pred0 c1 c2 Q.
Proof. by []. Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_abort P c1 c2 Q : prhl P abort abort Q.
Proof.
move=> m _; exists dnull; last by apply/range_dnull.
by rewrite !ssemE; split; rewrite dmarginE dlet_null.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_case P A c1 c2 Q :
     prhl (P /\   A)%A c1 c2 Q
  -> prhl (P /\ ~ A)%A c1 c2 Q
  -> prhl P c1 c2 Q.
Proof.
move=> hA hNA m Pm; case/boolP: (A m) => [Am | NAm].
+ by apply/hA; rewrite -(rwP andP).
+ by apply/hNA; rewrite -(rwP andP).
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_skip P : prhl P skip skip P.
Proof.
move=> m Pm; exists (dunit m); last by apply/range_dunit.
by rewrite !ssemE -!dmargin_dunit; apply/iscoupling_prod.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_assignL {t : ihbType} (x : vars t) (e : expr t) Q :
  prhl [pred m : rmem | Q m.[~1 x <- `[{ e }] m.1]] (x <<- e) skip Q.
Proof.
move=> m /= Qmxe; exists (dunit (m.[~1 x <- `[{ e }] m.1])); last first.
+ by apply/range_dunit.
rewrite !ssemE; apply/(iscoupling_eq _ _ (iscoupling_prod _)).
+ by apply/distr_eqP; rewrite dmargin_dunit -/(mselect '1 _) mselect_mset.
+ by apply/distr_eqP; rewrite dmargin_dunit -/(mselect '2 _) mselect_mset.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_rndL {t : ihbType} P (x : vars t) (d : dexpr t) Q :
     P =1 [pred m : rmem
       |  dweight (`[{ d }] m.1) == 1
       & `[< range [pred v | Q m.[~1 x <- v]] (`[{ d }] m.1) >]]
  -> prhl P (x <$- d) skip Q.
Proof.
move=> PE -[m1 m2] /=; rewrite {}PE => /andP[/= /eqP wgt1] /asboolP hrg.
rewrite !ssemE; set μ := `[{ d }] m1.
pose ν := \dlet_(v <- μ) dunit (m1.[x <- v], m2); exists ν.
+ apply/(iscoupling_eq _ _ (iscoupling_prod _)).
  * apply/distr_eqP; rewrite dmargin_dlet; apply/eq_in_dlet=> //=.
    by move=> v _; rewrite dmargin_dunit.
  * move=> m; rewrite dmargin_dlet -[RHS]mul1r -wgt1 -dletC.
    apply/distr_eqP: m; apply/eq_in_dlet => // v _.
    by rewrite dmargin_dunit.
+ case=> m'1 m'2 /dinsupp_dlet[v vμ]; rewrite dunit1E.
  rewrite pnatr_eq0 eqb0 negbK; case/eqP=> <- <-.
  by move/(_ v vμ): hrg => /= {vμ}; case: {ν} x v.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_if P e1 e2 c1 c'1 c2 c'2 Q :
     prhl (P /\ `[{    e1#'1 &&    e2#'2 }])%A c1  c2  Q
  -> prhl (P /\ `[{ ~~ e1#'1 && ~~ e2#'2 }])%A c'1 c'2 Q
  -> prhl (P /\ `[{ e1#'1 =b e2#'2 }])%A
       (If e1 then c1 else c'1)
       (If e2 then c2 else c'2)
     Q.
Proof.
move=> h1 h2 m /andP[/= Pm /eqP]; rewrite !ssemE => eqe.
rewrite -eqe; case: ifPn => hc.
+ by apply/h1 => /=; rewrite Pm !ssemE -eqe hc.
+ by apply/h2 => /=; rewrite Pm !ssemE -eqe hc.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_ifL P e c1 c2 c Q :
     prhl (P /\ `[{    e#'1 }])%A c1 c Q
  -> prhl (P /\ `[{ ~~ e#'1 }])%A c2 c Q
  -> prhl P (If e then c1 else c2) c Q.
Proof.
move=> h1 h2 m Pm; rewrite !ssemE; case: ifPn => he.
+ by apply/h1 => /=; rewrite ssemE Pm.
+ by apply/h2 => /=; rewrite ssemE Pm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_seq R P c1 c1' c2 c2' Q :
     prhl P c1  c2  R
  -> prhl R c1' c2' Q
  -> prhl P (c1 ;; c1') (c2 ;; c2') Q.
Proof.
move=> h1 h2 m Pm; case: (h1 _ Pm) => ν hC hR.
pose ν' m :=
  if @idP (m \in dinsupp ν) is ReflectT Rm then
    tag (prhlw h2 (hR _ Rm))
  else dnull.
exists (\dlet_(m <- ν) ν' m); last first.
+ apply/(range_dlet hR) => m' Rm'; rewrite /ν'.
  case: {-}_ / idP; first by move=> p; case: prhlw.
  by move=> _ x /dinsuppP; rewrite dnullE.
rewrite !ssemE; apply/iscoupling_dlet => //.
move=> m' hm'; rewrite /ν'; case: {-}_ / idP => //.
by move=> p; case: prhlw.
Qed.

(* -------------------------------------------------------------------- *)
Lemma prhl_while I e1 e2 c1 c2 :
     (forall m : rmem, I m -> `[{ e1#'1 =b e2#'2 }] m)
  -> (prhl (I /\ `[{ e1#'1 && e2#'2 }])%A c1 c2 I)
  ->

  prhl
    I
      (While e1 Do c1)
      (While e2 Do c2)
    (I /\ `[{ ~~ e1#'1}] /\ `[{ ~~ e2#'2 }])%A.
Proof. set J := (I /\ _)%A => hs h.
pose ν1 m := if @idP (J m) is ReflectT Rm then tag (prhlw h Rm) else dunit m.
pose νn := fix νn n m {struct n} :=
  if n is n.+1 then \dlet_(m' <- νn n m) ν1 m' else dunit m.
pose νe n m := \dlet_(m' <- νn n m) if esem e1 m'.1 then dnull else dunit m'.
move=> m Im; pose ν n := νe n m.
have rg_νn: forall n, range I (νn n m).
+ elim=> [|n ih] /=; first by apply/range_dunit.
  apply/(range_dlet ih) => {Im ν ih} m Im; rewrite /ν1.
  case: {-}_ / idP; first by move=> p; case: prhlw.
  by move=> _; apply/range_dunit.
have mono_ν n : ν n <=1 ν n.+1.
+ move=> /= m'; rewrite /ν /νe dlet_dlet -/(νn _ _).
  apply/le_dlet => //= {}m' Im' m''.
  case: ifPn => [he1|hNe1]; first by apply/lef_dnull.
  rewrite dunit1E; case: eqP => /= [<-|_]; last by apply/ge0_mu.
  have /distr_eqP ->: ν1 m' =1 dunit m'.
  * rewrite /ν1; case: {-}_ / idP => // p; move: {-}p.
    by rewrite /J /= ssemE (negbTE hNe1) andbF.
  by rewrite dlet_unit (negbTE hNe1) dunit1E eqxx.
exists (dlim ν).
+ rewrite !ssemE;
    rewrite -(iffLR (distr_eqP _ _) (dlim_bump (fun _ => _ m.1)));
    rewrite -(iffLR (distr_eqP _ _) (dlim_bump (fun _ => _ m.2))).
  apply/iscoupling_dlim => [n|n k le_nk]; last first.
  * move=> m'; rewrite -[k](subnK le_nk); elim: (_ - _)%N => //.
    by move=> n' ihn'; rewrite addSn; apply/(le_trans ihn').
  rewrite !whilen_iterc !ssemE; apply/iscoupling_dlet => /=; last first.
  * move=> m' Im'; rewrite !ssemE; move/rg_νn/hs: Im'.
    rewrite !ssemE => /eqP <-; case: ifPn => _.
    - by apply/iscoupling_dnull.
    - by case: m' => a b; apply/iscoupling_dunit.
  elim: n => /= [|n ihn]; rewrite !(iterc0, itercSr) !ssemE.
  * by case: {+}m => a b; apply/iscoupling_dunit.
  apply/iscoupling_dlet => //= m' /rg_νn Im'; move/hs: (Im').
  rewrite !ssemE => /eqP eqe; rewrite -eqe /ν1.
  case: {-}_ / idP => /= [p|]; first case/and3P: {+}p.
  * by rewrite !ssemE => _ -> _; case: prhlw.
  rewrite !ssemE -eqe Im' /= andbb => /negP/negbTE => ->/=.
  by case: {+}m' => a b; apply/iscoupling_dunit.
+ apply/range_dlim => n; apply/(range_dlet (rg_νn n)) => m' Im'.
  case: ifPn => [he1|hNe1]; first by apply/range_dnull.
  apply/range_dunit=> /=; rewrite Im' /= !ssemE.
  by move: (hs _ Im'); rewrite !ssemE => /eqP <-; rewrite hNe1.
Qed.