From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality.
Require Import Sequences IMP.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope list_scope.

(** * 2. The target language: a stack machine *)

(** Our compiler will translate IMP to the language of a simple stack
  machine.  This machine is similar to the "Reverse Polish Notation"
  used by old HP pocket calculators: a stack holds intermediate
  results, and individual instructions pop arguments off the stack and
  push results back on the stack. *)

(** ** 2.1 Instruction set *)

(** Here is the instruction set of the machine: *)

Inductive instr : Type :=
  | Iconst (n: Z)           (**r push the integer [n] *)
  | Ivar (x: ident)         (**r push the current value of variable [x] *)
  | Isetvar (x: ident)      (**r pop an integer and assign it to variable [x] *)
  | Iadd                    (**r pop two integers, push their sum *)
  | Iopp                    (**r pop one integer, push its opposite *)
  | Ibranch (d: Z)          (**r skip forward or backward [d] instructions *)
  | Ibeq (d1: Z) (d0: Z)    (**r pop two integers, skip [d1] instructions if equal, [d0] if not equal *)
  | Ible (d1: Z) (d0: Z)    (**r pop two integer, skip [d1] instructions if less or equal, [d0] if greater *)
  | Ihalt.                  (**r stop execution *)

(** A piece of machine code is a list of instructions. *)

Definition code := list instr.

(** The length (number of instructions) of a piece of code. *)

Definition codelen (c: code) : Z := Z.of_nat (List.length c).

(** ** 2.2 Operational semantics *)

(** The machine operates on a code [C] (a fixed list of instructions)
  and three variable components:
- a program counter [pc], denoting a position in [C]
- an evaluation stack, containing integers
- a store assigning integer values to variables.
*)

Definition stack : Type := list Z.

Definition config : Type := (Z * stack * store)%type.

(** [instr_at C pc = Some i] if [i] is the instruction at position [pc] in [C]. *)

Fixpoint instr_at (C: code) (pc: Z) : option instr :=
  match C with
  | nil => None
  | i :: C' => if pc =? 0 then Some i else instr_at C' (pc - 1)
  end.

(** The semantics of the machine is given in small-step style as a transition system:
  a relation between machine configurations "before" and "after" execution
  of the instruction at the current program point.
  The transition relation is parameterized by the code [C] for the whole program.
  There is one transition for each kind of instruction,
  except [Ihalt], which has no transition. *)

Inductive transition (C: code): config -> config -> Prop :=
  | trans_const: forall pc stk s n,
      instr_at C pc = Some(Iconst n) ->
      transition C (pc    , stk     , s)
                   (pc + 1, n :: stk, s)
  | trans_var: forall pc stk s x,
      instr_at C pc = Some(Ivar x) ->
      transition C (pc    , stk       , s)
                   (pc + 1, s x :: stk, s)
  | trans_setvar: forall pc stk s x n,
      instr_at C pc = Some(Isetvar x) ->
      transition C (pc    , n :: stk, s)
                   (pc + 1, stk     , update x n s)
  | trans_add: forall pc stk s n1 n2,
      instr_at C pc = Some(Iadd) ->
      transition C (pc    , n2 :: n1 :: stk , s)
                   (pc + 1, (n1 + n2) :: stk, s)
  | trans_opp: forall pc stk s n,
      instr_at C pc = Some(Iopp) ->
      transition C (pc    , n :: stk    , s)
                   (pc + 1, (- n) :: stk, s)
  | trans_branch: forall pc stk s d pc',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , stk, s)
                   (pc', stk, s)
  | trans_beq: forall pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = Some(Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 =? n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)
  | trans_ble: forall pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = Some(Ible d1 d0) ->
      pc' = pc + 1 + (if n1 <=? n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s).

(** As usual with small-step semantics, we form sequences of machine transitions
  to define the behavior of a code.  Zero, one or several transitions
  correspond to the reflexive transitive closure of relation [transition C]. *)

Definition transitions (C: code): config -> config -> Prop :=
  star (transition C).

(** We always start with [pc = 0] and an empty evaluation stack.
    We stop successfully if [pc] points to an [Ihalt] instruction
    and the evaluation stack is empty. *)

Definition machine_terminates (C: code) (s_init: store) (s_final: store) : Prop :=
  exists pc, transitions C (0, nil, s_init) (pc, nil, s_final)
          /\ instr_at C pc = Some Ihalt.

(** The machine can also run forever, making infinitely many transitions. *)
Definition machine_diverges (C: code) (s_init: store) : Prop :=
  infseq (transition C) (0, nil, s_init).

(** Yet another possibility is that the machine gets stuck after some transitions. *)

Definition machine_goes_wrong (C: code) (s_init: store) : Prop :=
  exists pc stk s,
      transitions C (0, nil, s_init) (pc, stk, s)
   /\ irred (transition C) (pc, stk, s)
   /\ (instr_at C pc <> Some Ihalt \/ stk <> nil).

(** *** Exercise (2 stars, recommended). *)

(** To quickly see how a machine program executes, it is convenient
  to redefine the semantics of the machine as an executable function
  instead of inductively-defined relations.  This is similar to the
  [cinterp] function for the IMP language.

  To ensure termination of the machine interpreter, we need to bound
  the number of instructions it can execute.  The result of the
  machine interpreter, therefore, is of the following type:
*)

Inductive machine_result : Type :=
  | Timeout                (**r the interpreter ran out of fuel *)
  | Stuck                  (**r the machine goes wrong on an impossible case *)
  | Terminates (s: store). (**r the machine successfully stops with the given store *)

(** Please fill in the blanks in the following definition for a machine interpreter: *)

Fixpoint mach_interp (C: code) (fuel: nat)
                     (pc: Z) (stk: stack) (s: store) : machine_result :=
  match fuel with
  | O => Timeout
  | S fuel' =>
      match instr_at C pc, stk with
      | Some Ihalt, nil => Terminates s
      | Some (Iconst n), stk => mach_interp C fuel' (pc + 1) (n :: stk) s
      (* FILL IN HERE *)
      | _, _ => Stuck
      end
  end.

(** * 3. The compilation scheme *)

(** We now define the compilation of IMP expressions and commands to sequence of machine instructions. *)

(** The code for an arithmetic expression [a] executes in sequence (no branches),
  and deposits the value of [a] at the top of the stack.
  This is the familiar translation to "reverse Polish notation".
  The only twist here is that the machine has no "subtract" instruction.
  However, it can compute the difference [a - b] by adding [a] and the opposite of [b].
*)

Fixpoint compile_aexp (a: aexp) : code :=
  match a with
  | CONST n => Iconst n :: nil
  | VAR x => Ivar x :: nil
  | PLUS a1 a2  => compile_aexp a1 ++ compile_aexp a2 ++ Iadd :: nil
  | MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Iopp :: Iadd :: nil
  end.

(** Some examples *)

Eval compute in (compile_aexp (PLUS (CONST 1) (CONST 2))).

(** Result is: [Iconst 1 :: Iconst 2 :: Iadd :: nil] *)

Eval compute in (compile_aexp (PLUS (VAR "x") (MINUS (VAR "y") (CONST 1)))).

(** Result is: [Ivar "x" :: Ivar "x" :: Iconst 1 :: Iopp :: Iadd :: Iadd :: nil]. *)

(** For Boolean expressions [b], we could produce code that deposits [1] or [0]
  at the top of the stack, depending on whether [b] is true or false.
  The compiled code for [IFTHENELSE] and [WHILE] commands would, then,
  compare this 0/1 value against 0 and branch to the appropriate piece of code.

  However, it is simpler and more efficient to compile a Boolean expression [b]
  to a piece of code that directly jumps [d1] or [d0] instructions forward,
  depending on whether [b] is true or false.  The actual value of [b] is
  never computed as an integer, and the stack is unchanged.
*)

Fixpoint compile_bexp (b: bexp) (d1: Z) (d0: Z) : code :=
  match b with
  | TRUE => if d1 =? 0 then nil else Ibranch d1 :: nil
  | FALSE => if d0 =? 0 then nil else Ibranch d0 :: nil
  | EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ibeq d1 d0 :: nil
  | LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ible d1 d0 :: nil
  | NOT b1 => compile_bexp b1 d0 d1
  | AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0 in
      let code1 := compile_bexp b1 0 (codelen code2 + d0) in
      code1 ++ code2
  end.

(** See the slides for an explanation of the mysterious offsets in the [AND] case. *)

(** Examples are in order. *)

Eval compute in (compile_bexp (EQUAL (VAR "x") (CONST 1)) 12 34).

(** Result is: [ Ivar "x" :: Iconst 1 :: Ibeq 12 34 :: nil ]. *)

Eval compute in (compile_bexp (AND (LESSEQUAL (CONST 1) (VAR "x"))
                                   (LESSEQUAL (VAR "x") (CONST 10))) 0 10).

(** Result is: [ Iconst 1 :: Ivar "x" :: Ible 0 13 ::
                 Ivar "x" :: Iconst 10 :: Ible 0 10 :: nil ] *)

Eval compute in (compile_bexp (OR (LESSEQUAL (CONST 1) (VAR "x"))
                                  (LESSEQUAL (VAR "x") (CONST 10))) 0 10).

(** Result is: [ Iconst 1 :: Ivar "x" :: Ible 3 0 ::
                 Ivar "x" :: Iconst 10 :: Ible 0 10 :: nil ] *)

Eval compute in (compile_bexp (NOT (AND TRUE FALSE)) 12 34).

(** Result is: [ Ibranch 12 :: nil ] *)

(** The code for a command [c]:
  - updates the store (the values of variables) as prescribed by [c]
  - preserves the stack
  - finishes "at the end" of the generated code: the next instruction
    executed is the instruction that will follow the generated code.

  Again, see the slides for explanations of the generated branch offsets.
*)

Fixpoint compile_com (c: com) : code :=
  match c with
  | SKIP =>
      nil
  | ASSIGN x a =>
      compile_aexp a ++ Isetvar x :: nil
  | SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso in
      let code_ifnot := compile_com ifnot in
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ Ibranch (codelen code_ifnot)
      :: code_ifnot
  | WHILE b body =>
      let code_body := compile_com body in
      let code_test := compile_bexp b 0 (codelen code_body + 1) in
      code_test
      ++ code_body
      ++ Ibranch (- (codelen code_test + codelen code_body + 1)) :: nil
  end.

(** The code for a program [p] (a command) is similar, but terminates
  cleanly on an [Ihalt] instruction. *)

Definition compile_program (p: com) : code :=
  compile_com p ++ Ihalt :: nil.

(** Examples of compilation: *)

Eval compute in (compile_program (ASSIGN "x" (PLUS (VAR "x") (CONST 1)))).

(** Result is: [ Ivar "x" :: Iconst 1 :: Iadd :: Isetvar "x" :: Ihalt :: nil ] *)

Eval compute in (compile_program (WHILE TRUE SKIP)).

(** Result is: [ Ibranch (-1) :: Ihalt :: nil ]. *)

Eval compute in (compile_program (IFTHENELSE (EQUAL (VAR "x") (CONST 1)) (ASSIGN "x" (CONST 0)) SKIP)).

(** Result is: [ Ivar "x" :: Iconst 1 :: Ibeq 0 3 ::
                 Iconst 0 :: Isetvar "x" :: Ibranch 0 :: Ihalt :: nil ]. *)

(** *** Exercise (1 star, recommended) *)

(** The last example shows a slight inefficiency in the code generated for
  [IFTHENELSE b c SKIP].  How would you change [compile_com]
  to generate better code?  Hint: the following function could be useful. *)

Definition smart_Ibranch (d: Z) : code :=
  if d =? 0 then nil else Ibranch d :: nil.

(** * 4. First compiler correctness proofs *)

(** To reason about the execution of compiled code, we need to consider
  code sequences [C2] that are at position [pc] in a bigger code
  sequence [C = C1 ++ C2 ++ C3].  The following predicate
  [code_at C pc C2] does just this. *)

Inductive code_at: code -> Z -> code -> Prop :=
  | code_at_intro: forall C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2.

(** We show a number of simple lemmas about [instr_at] and [code_at],
  then populate a "hint database" so that Coq can use them automatically. *)

Lemma codelen_cons:
  forall i c, codelen (i :: c) = codelen c + 1.
Proof.
  unfold codelen; intros; cbn; lia.
Qed.

Lemma codelen_app:
  forall c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2.
Proof.
  induction c1; intros.
- auto.
- cbn [app]. rewrite ! codelen_cons. rewrite IHc1. lia.
Qed.

Lemma instr_at_app:
  forall i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ i :: c2) pc = Some i.
Proof.
  induction c1; simpl; intros; subst pc.
- auto.
- assert (A: codelen (a :: c1) =? 0 = false).
  { apply Z.eqb_neq. unfold codelen. cbn [length]. lia. }
  rewrite A. rewrite codelen_cons. apply IHc1. lia.
Qed.

Lemma code_at_head:
  forall C pc i C',
  code_at C pc (i :: C') ->
  instr_at C pc = Some i.
Proof.
  intros. inversion H. simpl. apply instr_at_app. auto.
Qed.

Lemma code_at_tail:
  forall C pc i C',
  code_at C pc (i :: C') ->
  code_at C (pc + 1) C'.
Proof.
  intros. inversion H.
  change (C1 ++ (i :: C') ++ C3)
    with (C1 ++ (i :: nil) ++ C' ++ C3).
  rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_left:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C pc C1.
Proof.
  intros. inversion H. rewrite app_ass. constructor. auto.
Qed.

Lemma code_at_app_right:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. inversion H. rewrite app_ass. rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_right2:
  forall C pc C1 C2 C3,
  code_at C pc (C1 ++ C2 ++ C3) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. apply code_at_app_right. apply code_at_app_left with (C2 := C3). rewrite app_ass; auto.
Qed.

Lemma code_at_nil:
  forall C pc C1,
  code_at C pc C1 -> code_at C pc nil.
Proof.
  intros. inversion H. subst. change (C1 ++ C3) with (nil ++ C1 ++ C3).
  constructor. auto.
Qed.

Lemma instr_at_code_at_nil:
  forall C pc i, instr_at C pc = Some i -> code_at C pc nil.
Proof.
  induction C; cbn; intros.
- discriminate.
- destruct (pc =? 0) eqn:PC.
+ assert (pc = 0) by (apply Z.eqb_eq; auto). subst pc.
  change (a :: C) with (nil ++ nil ++ (a :: C)). constructor. auto.
+ assert (A: code_at C (pc - 1) nil) by eauto.
  inversion A; subst.
  apply code_at_intro with (C1 := a :: C1) (C3 := C3). rewrite codelen_cons. lia.
Qed.

Hint Resolve code_at_head code_at_tail code_at_app_left code_at_app_right
             code_at_app_right2 code_at_nil instr_at_code_at_nil: code.
Hint Rewrite codelen_app codelen_cons Z.add_assoc Z.add_0_r : code.

(** ** 4.1 Correctness of generated code for expressions. *)

(** Remember the informal specification we gave for the code generated
  for an arithmetic expression [a].  It should
- execute in sequence (no branches)
- deposit the value of [a] at the top of the stack
- preserve the variable state.

We now prove that the code [compile_aexp a] fulfills this contract.
The proof is a nice induction on the structure of [a]. *)

Lemma compile_aexp_correct:
  forall C s a pc stk,
  code_at C pc (compile_aexp a) ->
  transitions C
       (pc, stk, s)
       (pc + codelen (compile_aexp a), aeval s a :: stk, s).
Proof.
  induction a; simpl; intros.

- (* CONST *)
  apply star_one. apply trans_const. eauto with code.

- (* VAR *)
  apply star_one. apply trans_var. eauto with code.

- (* PLUS *)
  eapply star_trans. apply IHa1. eauto with code.
  eapply star_trans. apply IHa2. eauto with code.
  apply star_one. autorewrite with code. apply trans_add. eauto with code.

- (* MINUS *)
  eapply star_trans. apply IHa1. eauto with code.
  eapply star_trans. apply IHa2. eauto with code.
  eapply star_trans.
  apply star_one. apply trans_opp. eauto with code.
  apply star_one.
  replace (aeval s a1 - aeval s a2)
     with (aeval s a1 + (- aeval s a2))
       by lia.
  autorewrite with code. apply trans_add. eauto with code.
Qed.

(** The proof for the compilation of Boolean expressions is similar.  We recall the
  informal specification for the code generated by [compile_bexp b d1 d0]: it should
- skip [d1] instructions if [b] evaluates to true, [d0] if [b] evaluates to false
- leave the stack unchanged
- leave the store unchanged.
*)

Lemma compile_bexp_correct:
  forall C s b d1 d0 pc stk,
  code_at C pc (compile_bexp b d1 d0) ->
  transitions C
       (pc, stk, s)
       (pc + codelen (compile_bexp b d1 d0) + (if beval s b then d1 else d0), stk, s).
Proof.
  induction b; cbn; intros.

- (* TRUE *)
  destruct (d1 =? 0) eqn:Z.
  + (* distance is zero, no branch is generated *)
    assert (d1 = 0) by (apply Z.eqb_eq; auto). subst d1.
    autorewrite with code. apply star_refl.
  + (* a branch is generated *)
    apply star_one. apply trans_branch with (d := d1). eauto with code. auto.

- (* FALSE *)
  destruct (d0 =? 0) eqn:Z.
  + (* distance is zero, no branch is generated *)
    assert (d0 = 0) by (apply Z.eqb_eq; auto). subst d0.
    autorewrite with code. apply star_refl.
  + (* a branch is generated *)
    apply star_one. apply trans_branch with (d := d0). eauto with code. auto.

- (* EQUAL *)
  eapply star_trans. apply compile_aexp_correct with (a := a1). eauto with code.
  eapply star_trans. apply compile_aexp_correct with (a := a2). eauto with code.
  apply star_one. apply trans_beq with (d1 := d1) (d0 := d0). eauto with code.
  autorewrite with code. auto.

- (* LESSEQUAL *)
  eapply star_trans. apply compile_aexp_correct with (a := a1). eauto with code.
  eapply star_trans. apply compile_aexp_correct with (a := a2). eauto with code.
  apply star_one. apply trans_ble with (d1 := d1) (d0 := d0). eauto with code.
  autorewrite with code. auto.

- (* NOT *)
  replace (if negb (beval s b) then d1 else d0)
     with (if beval s b then d0 else d1).
  apply IHb. auto.
  destruct (beval s b); auto.

- (* AND *)
  set (code2 := compile_bexp b2 d1 d0) in *.
  set (code1 := compile_bexp b1 0 (codelen code2 + d0)) in *.
  eapply star_trans. apply IHb1. eauto with code.
  fold code1. destruct (beval s b1); cbn.
  + (* b1 evaluates to true, the code for b2 is executed *)
    autorewrite with code. apply IHb2. eauto with code.
  + (* b2 evaluates to true, the code for b2 is skipped *)
    autorewrite with code. apply star_refl.
Qed.

(** ** 4.2 Correctness of generated code for commands, terminating case. *)

Lemma compile_com_correct_terminating:
  forall s c s',
  cexec s c s' ->
  forall C pc stk,
  code_at C pc (compile_com c) ->
  transitions C
      (pc, stk, s)
      (pc + codelen (compile_com c), stk, s').
Proof.
  induction 1; cbn; intros.

- (* SKIP *)
  autorewrite with code. apply star_refl.

- (* ASSIGN *)
  eapply star_trans. apply compile_aexp_correct with (a := a). eauto with code.
  apply star_one. autorewrite with code. apply trans_setvar. eauto with code.

- (* SEQUENCE *)
  eapply star_trans.
  apply IHcexec1. eauto with code.
  autorewrite with code. apply IHcexec2. eauto with code.

- (* IFTHENELSE *)
  set (code1 := compile_com c1) in *.
  set (code2 := compile_com c2) in *.
  set (codeb := compile_bexp b 0 (codelen code1 + 1)) in *.
  eapply star_trans.
  apply compile_bexp_correct with (b := b). eauto with code.
  fold codeb. destruct (beval s b); autorewrite with code.
  + (* the "then" branch is selected *)
    eapply star_trans. apply IHcexec. eauto with code.
    fold code1. apply star_one. apply trans_branch with (d := codelen code2). eauto with code. lia.
  + (* then "else" branch is selected *)
    replace (pc + codelen codeb + codelen code1 + codelen code2 + 1)
       with (pc + codelen codeb + codelen code1 + 1 + codelen code2) by lia.
    apply IHcexec. eauto with code.

- (* WHILE stop *)
  set (code_body := compile_com c) in *.
  set (code_branch := compile_bexp b 0 (codelen code_body + 1)) in *.
  set (d := - (codelen code_branch + codelen code_body + 1)) in *.
  eapply star_trans. apply compile_bexp_correct with (b := b). eauto with code.
  rewrite H. fold code_branch. autorewrite with code. apply star_refl.

- (* WHILE loop *)
  set (code_body := compile_com c) in *.
  set (code_branch := compile_bexp b 0 (codelen code_body + 1)) in *.
  set (d := - (codelen code_branch + codelen code_body + 1)) in *.
  eapply star_trans. apply compile_bexp_correct with (b := b). eauto with code.
  rewrite H. fold code_branch. autorewrite with code.
  eapply star_trans. apply IHcexec1. eauto with code.
  eapply star_trans.
  apply star_one. apply trans_branch with (d := d). eauto with code. eauto.
  replace (pc + codelen code_branch + codelen code_body + 1 + d)
     with pc
       by lia.
  replace (pc + codelen code_branch + codelen code_body + 1)
     with (pc + codelen (compile_com (WHILE b c)))
       by (cbn; autorewrite with code; auto).
  apply IHcexec2. auto.
Qed.

(** As a corollary, we obtain the correctness of the compilation of whole
  programs, assuming they terminate. *)

Theorem compile_program_correct_terminating:
  forall s c s',
  cexec s c s' ->
  machine_terminates (compile_program c) s s'.
Proof.
  intros.
  set (C := compile_program c).
  assert (CODEAT: code_at C 0 (compile_com c ++ Ihalt :: nil)).
  { replace C with (nil ++ compile_program c ++ nil).
    apply code_at_intro. auto.
    rewrite app_nil_r; auto. }
  unfold machine_terminates.
  exists (0 + codelen (compile_com c)); split.
- apply compile_com_correct_terminating. auto. eauto with code.
- eauto with code.
Qed.

(** *** Exercise (2 stars, recommended). *)

(** In a previous exercise, you modified [compile_com] to use
  [smart_Ibranch] instead of [Ibranch] so as to generate better code.
  Adapt the proof of [compile_com_correct_terminating] accordingly.
  Hint: first prove the following lemma, then use it! *)

Lemma transitions_smart_Ibranch:
  forall C pc d pc' stk s,
  code_at C pc (smart_Ibranch d) ->
  pc' = pc + 1 + d ->
  transitions C (pc, stk, s) (pc', stk, s).
Proof.
  unfold smart_Ibranch; intros.
  (* FILL IN HERE *)
Abort.

(** *** Exercise (4 stars, optional). *)

(** Consider a loop with a simple test, such as [WHILE (LESSEQUAL a1 a2) c].
  Currently, the compiled code executes two branch instructions per iteration
  of the loop: one [Ible] to test the condition and one [Ibranch] to go back to
  the beginning of the loop.  We can reduce this to one [Ible] instruction
  per iteration, by putting the code for [c] before the code for the test:
<<
     compile_com c ++ compile_bexp b delta1 0
>>
  with [delta1] chosen so as to branch back to the beginning of [compile_com c]
  when [b] is true.

  By itself, this would compile while loops like do-while loops, which is
  incorrect.  On the first iteration, we must skip over the code for [c]
  and branch to the code that tests [b]:
<<
    Ibranch (codesize(compile_com c)) :: compile_com c ++ compile_bexp b delta1 0
>>
  In this exercise, you should modify [compile_com] to implement this
  alternate compilation schema for loops, then show its correctness
  by updating the statement and proof of [compile_com_correct_terminating].
  The difficulty (and the reason for the 4 stars) is that the hypothesis
  [code_at C pc (compile_com c)] no longer holds if [c] is a while loop
  and we are at the second iteration of the loop.  You need to come up
  with a more flexible way to relate the command [c] and the PC.
*)

(** * 7.  Full proof of compiler correctness *)

(** We would like to strengthen the correctness result above so that it
  is not restricted to terminating source programs, but also applies to
  source program that diverge.  To this end, we abandon the big-step
  semantics for commands and switch to the small-step semantics with
  continuations.  We then show a simulation theorem, establishing that
  every transition of the small-step semantics in the source program
  is simulated (in a sense to be made precise below) by zero, one or
  several transitions of the machine executing the compiled code for
  the source program. *)

(** Our first task is to relate configurations [(c, k, s)] of the small-step
  semantics with configurations [(C, pc, stk, s)] of the machine.
  We already know how to relate a command [c] with the machine code,
  using the [codeseq_at] predicate.  What needs to be defined is a relation
  between the continuation [k] and the machine code.

  Intuitively, when the machine finishes executing the generated code for
  command [c], that is, when it reaches the program point
  [pc + length(compile_com c)], the machine should continue by executing
  instructions that perform the pending computations described by
  continuation [k], then reach an [Ihalt] instruction to stop cleanly.

  We formalize this intution by the following inductive predicate
  [compile_cont C k pc], which states that, starting at program point [pc],
  there are instructions that perform the computations described in [k]
  and reach an [Ihalt] instruction. *)

Inductive compile_cont (C: code): cont -> Z -> Prop :=
  | ccont_stop: forall pc,
      instr_at C pc = Some Ihalt ->
      compile_cont C Kstop pc
  | ccont_seq: forall c k pc pc',
      code_at C pc (compile_com c) ->
      pc' = pc + codelen (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (Kseq c k) pc
  | ccont_while: forall b c k pc d pc' pc'',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      code_at C pc' (compile_com (WHILE b c)) ->
      pc'' = pc' + codelen (compile_com (WHILE b c)) ->
      compile_cont C k pc'' ->
      compile_cont C (Kwhile b c k) pc
  | ccont_branch: forall d k pc pc',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      compile_cont C k pc' ->
      compile_cont C k pc.

(** Then, a configuration [(c,k,s)] of the small-step semantics matches
  a configuration [(C, pc, stk, s')] of the machine if the following conditions hold:
- The stores are identical: [s' = s].
- The machine stack is empty: [stk = nil].
- The machine code at point [pc] is the compiled code for [c]:
  [code_at C pc (compile_com c)].
- The machine code at point [pc + codelen (compile_com c)] matches continuation
  [k], in the sense of [compile_cont] above.
*)

Inductive match_config (C: code): com * cont * store -> config -> Prop :=
  | match_config_intro: forall c k st pc,
      code_at C pc (compile_com c) ->
      compile_cont C k (pc + codelen (compile_com c)) ->
      match_config C (c, k, st) (pc, nil, st).

(** We are now ready to prove the expected simulation property.
  Since some transitions in the source command correspond to zero transitions
  in the compiled code, we need a simulation diagram of the "star" kind
  (see the slides).
<<
                      match_config
     c / k / st  ----------------------- machconfig
       |                                   |
       |                                   | + or ( * and |c',k'| < |c,k} )
       |                                   |
       v                                   v
    c' / k' / st' ----------------------- machconfig'
                      match_config
>>
Note the stronger conclusion on the right:
- either the virtual machine does one or several transitions
- or it does zero, one or several transitions, but the size of the [c,k]
  pair decreases strictly.

It would be equivalent to state:
- either the virtual machine does one or several transitions
- or it does zero transitions, but the size of the [c,k] pair decreases strictly.

However, the formulation above, with the "star" case, is often more convenient.
*)

(** Finding an appropriate "anti-stuttering" measure is a bit of a black art.
  After trial and error, we find that the following measure works.  It is
  the sum of the sizes of the command [c] under focus and all the commands
  appearing in the continuation [k]. *)

Fixpoint com_size (c: com) : nat :=
  match c with
  | SKIP => 1%nat
  | ASSIGN x a => 1%nat
  | (c1 ;; c2) => (com_size c1 + com_size c2 + 1)%nat
  | IFTHENELSE b c1 c2 => (com_size c1 + com_size c2 + 1)%nat
  | WHILE b c1 => (com_size c1 + 1)%nat
  end.

Remark com_size_nonzero: forall c, (com_size c > 0)%nat.
Proof.
  induction c; cbn; lia.
Qed.

Fixpoint cont_size (k: cont) : nat :=
  match k with
  | Kstop => 0%nat
  | Kseq c k' => (com_size c + cont_size k')%nat
  | Kwhile b c k' => cont_size k'
  end.

Definition measure (impconf: com * cont * store) : nat :=
  match impconf with (c, k, m) => (com_size c + cont_size k)%nat end.

(** A few technical lemmas to help with the simulation proof. *)

Lemma compile_cont_Kstop_inv:
  forall C pc s,
  compile_cont C Kstop pc ->
  exists pc',
  star (transition C) (pc, nil, s) (pc', nil, s)
  /\ instr_at C pc' = Some Ihalt.
Proof.
  intros. dependent induction H.
- exists pc; split. apply star_refl. auto.
- destruct IHcompile_cont as (pc'' & A & B); auto.
  exists pc''; split; auto. eapply star_step; eauto. eapply trans_branch; eauto.
Qed.

Lemma compile_cont_Kseq_inv:
  forall C c k pc s,
  compile_cont C (Kseq c k) pc ->
  exists pc',
  star (transition C) (pc, nil, s) (pc', nil, s)
  /\ code_at C pc' (compile_com c)
  /\ compile_cont C k (pc' + codelen(compile_com c)).
Proof.
  intros. dependent induction H.
- exists pc; split. apply star_refl. split; congruence.
- edestruct IHcompile_cont as (pc'' & A & B). eauto.
  exists pc''; split; auto. eapply star_step; eauto. eapply trans_branch; eauto.
Qed.

Lemma compile_cont_Kwhile_inv:
  forall C b c k pc s,
  compile_cont C (Kwhile b c k) pc ->
  exists pc',
  plus (transition C) (pc, nil, s) (pc', nil, s)
  /\ code_at C pc' (compile_com (WHILE b c))
  /\ compile_cont C k (pc' + codelen(compile_com (WHILE b c))).
Proof.
  intros. dependent induction H.
- exists (pc + 1 + d); split.
  apply plus_one. eapply trans_branch; eauto.
  split; congruence.
- edestruct IHcompile_cont as (pc'' & A & B & D). eauto.
  exists pc''; split; auto. eapply plus_left. eapply trans_branch; eauto. apply plus_star; auto.
Qed.

Lemma match_config_skip:
  forall C k s pc,
  compile_cont C k pc ->
  match_config C (SKIP, k, s) (pc, nil, s).
Proof.
  intros. constructor.
- cbn. inversion H; eauto with code.
- cbn. autorewrite with code. auto.
Qed.

(** At last, we can state and prove the simulation diagram. *)

Lemma simulation_step:
  forall C impconf1 impconf2 machconf1,
  step impconf1 impconf2 ->
  match_config C impconf1 machconf1 ->
  exists machconf2,
      (plus (transition C) machconf1 machconf2
       \/ (star (transition C) machconf1 machconf2
           /\ (measure impconf2 < measure impconf1)%nat))
   /\ match_config C impconf2 machconf2.
Proof.
  intros until machconf1; intros STEP MATCH.
  inversion STEP; clear STEP; subst; inversion MATCH; clear MATCH; subst; cbn in *.

- (* assign *)
  econstructor; split.
  left. eapply plus_right. eapply compile_aexp_correct; eauto with code.
  eapply trans_setvar; eauto with code.
  autorewrite with code in *. apply match_config_skip. auto.

- (* seq *)
  econstructor; split.
  right; split. apply star_refl. lia.
  autorewrite with code in *. constructor. eauto with code. eapply ccont_seq; eauto with code.

- (* if *)
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b 0 (codelen code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  autorewrite with code in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b). eauto with code.
  destruct (beval s b); lia.
  fold codeb. destruct (beval s b).
  + autorewrite with code. constructor. eauto with code.
    eapply ccont_branch. eauto with code. eauto.
    fold code1.
    replace (pc + codelen codeb + codelen code1 + 1 + codelen code2)
       with (pc + codelen codeb + codelen code1 + codelen code2 + 1) by lia.
    auto.
  + autorewrite with code. constructor. eauto with code. auto.
    fold code2.
    replace (pc + codelen codeb + codelen code1 + 1 + codelen code2)
       with (pc + codelen codeb + codelen code1 + codelen code2 + 1) by lia.
    auto.

- (* while stop *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b 0 (codelen codec + 1)) in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b). eauto with code.
  assert (com_size c > 0)%nat by apply com_size_nonzero. lia.
  rewrite H. fold codeb. autorewrite with code in *. apply match_config_skip. auto.

- (* while loop *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b 0 (codelen codec + 1)) in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b). eauto with code.
  lia.
  rewrite H. fold codeb. autorewrite with code in *.
  constructor. eauto with code.
  eapply ccont_while with (pc' := pc). eauto with code. fold codec. lia.
  auto.
  cbn. fold codec; fold codeb. eauto.
  autorewrite with code. auto.

- (* skip seq *)
  autorewrite with code in *.
  edestruct compile_cont_Kseq_inv as (pc' & X & Y & Z). eauto.
  econstructor; split.
  right; split. eauto. lia.
  constructor; auto.

- (* skip while *)
  autorewrite with code in *.
  edestruct compile_cont_Kwhile_inv as (pc' & X & Y & Z). eauto.
  econstructor; split.
  left. eauto.
  constructor; auto.
Qed.

(** The hard work is done!  Nice consequences will follow. *)

(** First, we get an alternate proof of [compile_program_correct_terminating],
  using the continuation semantics instead of the big-step semantics
  to characterize termination of the source program. *)

Lemma simulation_steps:
  forall C impconf1 impconf2, star step impconf1 impconf2 ->
  forall machconf1, match_config C impconf1 machconf1 ->
  exists machconf2,
     star (transition C) machconf1 machconf2
  /\ match_config C impconf2 machconf2.
Proof.
  induction 1; intros.
- exists machconf1; split; auto. apply star_refl.
- edestruct simulation_step as (machconf2 & STEPS2 & MATCH2); eauto.
  edestruct IHstar as (machconf3 & STEPS3 & MATCH3); eauto.
  exists machconf3; split; auto.
  eapply star_trans; eauto.
  destruct STEPS2 as [A | [A B]]. apply plus_star; auto. auto.
Qed.

Lemma match_initial_configs:
  forall c s,
  match_config (compile_program c) (c, Kstop, s) (0, nil, s).
Proof.
  intros. set (C := compile_program c).
  assert (code_at C 0 (compile_com c ++ Ihalt :: nil)).
  { replace C with (nil ++ (compile_com c ++ Ihalt :: nil) ++ nil).
    constructor; auto.
    rewrite app_nil_r; auto. }
  constructor.
- eauto with code.
- apply ccont_stop. eauto with code.
Qed.

Theorem compile_program_correct_terminating_2:
  forall c s s',
  star step (c, Kstop, s) (SKIP, Kstop, s') ->
  machine_terminates (compile_program c) s s'.
Proof.
  intros. set (C := compile_program c).
  edestruct (simulation_steps C) as (ms & A & B). eauto. apply match_initial_configs.
  inversion B; subst.
  edestruct compile_cont_Kstop_inv as (pc' & D & E). eauto.
  exists pc'; split; auto.
  eapply star_trans. eauto. cbn in D; autorewrite with code in D. eauto.
Qed.

(** Second, and more importantly, we get a proof of semantic preservation
  for diverging source programs: if the program makes infinitely many steps,
  the generated code makes infinitely many machine transitions. *)

Lemma simulation_infseq_inv:
  forall C n impconf1 machconf1,
  infseq step impconf1 -> match_config C impconf1 machconf1 ->
  (measure impconf1 < n)%nat ->
  exists impconf2 machconf2,
      infseq step impconf2
   /\ plus (transition C) machconf1 machconf2
   /\ match_config C impconf2 machconf2.
Proof.
  induction n; intros impconf1 machconf1 INFSEQ MATCH MEASURE.
- exfalso; lia.
- inversion INFSEQ; clear INFSEQ; subst.
  edestruct simulation_step as (machconf2 & [PLUS | [STAR LESS]] & MATCH2). eauto. eauto.
+ exists b, machconf2; auto.
+ edestruct IHn as (impconf3 & machconf3 & X & Y & Z). eauto. eauto. lia.
  exists impconf3, machconf3.
  split. auto.
  split. eapply star_plus_trans; eauto.
  auto.
Qed.

Theorem compile_program_correct_diverging:
  forall c s,
  infseq step (c, Kstop, s) ->
  machine_diverges (compile_program c) s.
Proof.
  intros. set (C := compile_program c).
  apply infseq_coinduction_principle_2 with
    (X := fun machconf =>
          exists impconf, infseq step impconf /\ match_config C impconf machconf).
- intros machconf (impconf & INFSEQ & MATCH).
  edestruct (simulation_infseq_inv C (S (measure impconf)))
  as (impconf2 & machconf2 & INFSEQ2 & PLUS & MATCH2).
  eauto. eauto. lia.
  exists machconf2; split. auto. exists impconf2; auto.
- exists (c, Kstop, s); split. auto. apply match_initial_configs.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: Int.v 12363 2009-09-28 15:04:07Z letouzey $ *)

(** * An light axiomatization of integers (used in FSetAVL). *)

(** We define a signature for an integer datatype based on [Z].
    The goal is to allow a switch after extraction to ocaml's
    [big_int] or even [int] when finiteness isn't a problem
    (typically : when mesuring the height of an AVL tree).
*)

Require Import ZArith.
Delimit Scope Int_scope with I.

(** * a specification of integers *)

Module Type Int.

  Open Scope Int_scope.

  Parameter int : Set.

  Parameter i2z : int -> Z.
  Arguments Scope i2z [ Int_scope ].

  Parameter _0 : int.
  Parameter _1 : int.
  Parameter _2 : int.
  Parameter _3 : int.
  Parameter plus : int -> int -> int.
  Parameter opp : int -> int.
  Parameter minus : int -> int -> int.
  Parameter mult : int -> int -> int.
  Parameter max : int -> int -> int.

  Notation "0" := _0 : Int_scope.
  Notation "1" := _1 : Int_scope.
  Notation "2" := _2 : Int_scope.
  Notation "3" := _3 : Int_scope.
  Infix "+" := plus : Int_scope.
  Infix "-" := minus : Int_scope.
  Infix "*" := mult : Int_scope.
  Notation "- x" := (opp x) : Int_scope.

  (** For logical relations, we can rely on their counterparts in Z,
      since they don't appear after extraction. Moreover, using tactics
      like omega is easier this way. *)

  Notation "x == y" := (i2z x = i2z y)
    (at level 70, y at next level, no associativity) : Int_scope.
  Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
  Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
  Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
  Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.
  Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope.
  Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
  Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
  Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.

  (** Some decidability fonctions (informative). *)

  Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}.
  Axiom ge_lt_dec :  forall x y : int, {x >= y} + {x < y}.
  Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }.

  (** Specifications *)

  (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality
      [==] and the generic [=] are in fact equivalent. We define [==]
      nonetheless since the translation to [Z] for using automatic tactic is easier. *)

  Axiom i2z_eq : forall n p : int, n == p -> n = p.

   (** Then, we express the specifications of the above parameters using their
       Z counterparts. *)

  Open Scope Z_scope.
  Axiom i2z_0 : i2z _0 = 0.
  Axiom i2z_1 : i2z _1 = 1.
  Axiom i2z_2 : i2z _2 = 2.
  Axiom i2z_3 : i2z _3 = 3.
  Axiom i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.
  Axiom i2z_opp : forall n, i2z (-n) = -i2z n.
  Axiom i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p.
  Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p.
  Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).

End Int.

(** * Facts and  tactics using [Int] *)

Module MoreInt (I:Int).
  Import I.

  Open Scope Int_scope.

  (** A magic (but costly) tactic that goes from [int] back to the [Z]
      friendly world ... *)

  Hint Rewrite ->
    i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.

  Ltac i2z := match goal with
		| H : (eq (A:=int) ?a ?b) |- _ =>
		  generalize (f_equal i2z H);
		    try autorewrite with i2z; clear H; intro H; i2z
		| |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z
		| H : _ |- _ => progress autorewrite with i2z in H; i2z
		| _ => try autorewrite with i2z
	      end.

  (** A reflexive version of the [i2z] tactic *)

  (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a
      [i2z] is buried deep inside a subterm, [i2z_refl] may miss it.
      See also the limitation about [Set] or [Type] part below.
      Anyhow, [i2z_refl] is enough for applying [romega]. *)

  Ltac i2z_gen := match goal with
    | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen
    | H : (eq (A:=int) ?a ?b) |- _ =>
       generalize (f_equal i2z H); clear H; i2z_gen
    | H : (eq (A:=Z) ?a ?b) |- _ => revert H; i2z_gen
    | H : (Zlt ?a ?b) |- _ => revert H; i2z_gen
    | H : (Zle ?a ?b) |- _ => revert H; i2z_gen
    | H : (Zgt ?a ?b) |- _ => revert H; i2z_gen
    | H : (Zge ?a ?b) |- _ => revert H; i2z_gen
    | H : _ -> ?X |- _ =>
      (* A [Set] or [Type] part cannot be dealt with easily
         using the [ExprP] datatype. So we forget it, leaving
         a goal that can be weaker than the original. *)
      match type of X with
       | Type => clear H; i2z_gen
       | Prop => revert H; i2z_gen
      end
    | H : _ <-> _ |- _ => revert H; i2z_gen
    | H : _ /\ _ |- _ => revert H; i2z_gen
    | H : _ \/ _ |- _ => revert H; i2z_gen
    | H : ~ _ |- _ => revert H; i2z_gen
    | _ => idtac
   end.

  Inductive ExprI : Set :=
    | EI0 : ExprI
    | EI1 : ExprI
    | EI2 : ExprI
    | EI3 : ExprI
    | EIplus : ExprI -> ExprI -> ExprI
    | EIopp : ExprI -> ExprI
    | EIminus : ExprI -> ExprI -> ExprI
    | EImult : ExprI -> ExprI -> ExprI
    | EImax : ExprI -> ExprI -> ExprI
    | EIraw : int -> ExprI.

  Inductive ExprZ : Set :=
    | EZplus : ExprZ -> ExprZ -> ExprZ
    | EZopp : ExprZ -> ExprZ
    | EZminus : ExprZ -> ExprZ -> ExprZ
    | EZmult : ExprZ -> ExprZ -> ExprZ
    | EZmax : ExprZ -> ExprZ -> ExprZ
    | EZofI : ExprI -> ExprZ
    | EZraw : Z -> ExprZ.

  Inductive ExprP : Type :=
    | EPeq : ExprZ -> ExprZ -> ExprP
    | EPlt : ExprZ -> ExprZ -> ExprP
    | EPle : ExprZ -> ExprZ -> ExprP
    | EPgt : ExprZ -> ExprZ -> ExprP
    | EPge : ExprZ -> ExprZ -> ExprP
    | EPimpl : ExprP -> ExprP -> ExprP
    | EPequiv : ExprP -> ExprP -> ExprP
    | EPand : ExprP -> ExprP -> ExprP
    | EPor : ExprP -> ExprP -> ExprP
    | EPneg : ExprP -> ExprP
    | EPraw : Prop -> ExprP.

  (** [int] to [ExprI] *)

  Ltac i2ei trm :=
    match constr:trm with
      | 0 => constr:EI0
      | 1 => constr:EI1
      | 2 => constr:EI2
      | 3 => constr:EI3
      | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey)
      | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey)
      | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey)
      | max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey)
      | - ?x => let ex := i2ei x in constr:(EIopp ex)
      | ?x => constr:(EIraw x)
    end

  (** [Z] to [ExprZ] *)

    with z2ez trm :=
    match constr:trm with
      | (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
      | (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
      | (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
      | (Zmax ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
      | (-?x)%Z =>  let ex := z2ez x in constr:(EZopp ex)
      | i2z ?x => let ex := i2ei x in constr:(EZofI ex)
      | ?x => constr:(EZraw x)
    end.

  (** [Prop] to [ExprP] *)

  Ltac p2ep trm :=
    match constr:trm with
      | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey)
      | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey)
      | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey)
      | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey)
      | (~ ?x) => let ex := p2ep x in constr:(EPneg ex)
      | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey)
      | (?x<?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey)
      | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)
      | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)
      | (?x>=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey)
      | ?x =>  constr:(EPraw x)
    end.

  (** [ExprI] to [int] *)

  Fixpoint ei2i (e:ExprI) : int :=
    match e with
      | EI0 => 0
      | EI1 => 1
      | EI2 => 2
      | EI3 => 3
      | EIplus e1 e2 => (ei2i e1)+(ei2i e2)
      | EIminus e1 e2 => (ei2i e1)-(ei2i e2)
      | EImult e1 e2 => (ei2i e1)*(ei2i e2)
      | EImax e1 e2 => max (ei2i e1) (ei2i e2)
      | EIopp e => -(ei2i e)
      | EIraw i => i
    end.

  (** [ExprZ] to [Z] *)

  Fixpoint ez2z (e:ExprZ) : Z :=
    match e with
      | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
      | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
      | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
      | EZmax e1 e2 => Zmax (ez2z e1) (ez2z e2)
      | EZopp e => (-(ez2z e))%Z
      | EZofI e => i2z (ei2i e)
      | EZraw z => z
    end.

  (** [ExprP] to [Prop] *)

  Fixpoint ep2p (e:ExprP) : Prop :=
    match e with
      | EPeq e1 e2 => (ez2z e1) = (ez2z e2)
      | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z
      | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z
      | EPgt e1 e2 => ((ez2z e1)>(ez2z e2))%Z
      | EPge e1 e2 => ((ez2z e1)>=(ez2z e2))%Z
      | EPimpl e1 e2 => (ep2p e1) -> (ep2p e2)
      | EPequiv e1 e2 => (ep2p e1) <-> (ep2p e2)
      | EPand e1 e2 => (ep2p e1) /\ (ep2p e2)
      | EPor e1 e2 => (ep2p e1) \/ (ep2p e2)
      | EPneg e => ~ (ep2p e)
      | EPraw p => p
    end.

  (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *)

  Fixpoint norm_ei (e:ExprI) : ExprZ :=
    match e with
      | EI0 => EZraw (0%Z)
      | EI1 => EZraw (1%Z)
      | EI2 => EZraw (2%Z)
      | EI3 => EZraw (3%Z)
      | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2)
      | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2)
      | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2)
      | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
      | EIopp e => EZopp (norm_ei e)
      | EIraw i => EZofI (EIraw i)
    end.

  (** [ExprZ] to a simplified [ExprZ] *)

  Fixpoint norm_ez (e:ExprZ) : ExprZ :=
    match e with
      | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2)
      | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2)
      | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2)
      | EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2)
      | EZopp e => EZopp (norm_ez e)
      | EZofI e =>  norm_ei e
      | EZraw z => EZraw z
    end.

  (** [ExprP] to a simplified [ExprP] *)

  Fixpoint norm_ep (e:ExprP) : ExprP :=
    match e with
      | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2)
      | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2)
      | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2)
      | EPgt e1 e2 => EPgt (norm_ez e1) (norm_ez e2)
      | EPge e1 e2 => EPge (norm_ez e1) (norm_ez e2)
      | EPimpl e1 e2 => EPimpl (norm_ep e1) (norm_ep e2)
      | EPequiv e1 e2 => EPequiv (norm_ep e1) (norm_ep e2)
      | EPand e1 e2 => EPand (norm_ep e1) (norm_ep e2)
      | EPor e1 e2 => EPor (norm_ep e1) (norm_ep e2)
      | EPneg e => EPneg (norm_ep e)
      | EPraw p => EPraw p
    end.

  Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e).
  Proof.
    induction e; simpl; intros; i2z; auto; try congruence.
  Qed.

  Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e.
  Proof.
    induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct.
  Qed.

  Lemma norm_ep_correct :
    forall e:ExprP, ep2p (norm_ep e) <-> ep2p e.
  Proof.
    induction e; simpl; repeat (rewrite norm_ez_correct); intuition.
  Qed.

  Lemma norm_ep_correct2 :
    forall e:ExprP, ep2p (norm_ep e) -> ep2p e.
  Proof.
    intros; destruct (norm_ep_correct e); auto.
  Qed.

  Ltac i2z_refl :=
    i2z_gen;
    match goal with |- ?t =>
      let e := p2ep t in
      change (ep2p e); apply norm_ep_correct2; simpl
    end.

  (* i2z_refl can be replaced below by (simpl in *; i2z).
     The reflexive version improves compilation of AVL files by about 15%  *)

End MoreInt.

(** * An implementation of [Int] *)

(** It's always nice to know that our [Int] interface is realizable :-) *)

Module Z_as_Int <: Int.
  Open Scope Z_scope.
  Definition int := Z.
  Definition _0 := 0.
  Definition _1 := 1.
  Definition _2 := 2.
  Definition _3 := 3.
  Definition plus := Zplus.
  Definition opp := Zopp.
  Definition minus := Zminus.
  Definition mult := Zmult.
  Definition max := Zmax.
  Definition gt_le_dec := Z_gt_le_dec.
  Definition ge_lt_dec := Z_ge_lt_dec.
  Definition eq_dec := Z_eq_dec.
  Definition i2z : int -> Z := fun n => n.
  Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed.
  Lemma i2z_0 : i2z _0 = 0.  Proof. auto. Qed.
  Lemma i2z_1 : i2z _1 = 1.  Proof. auto. Qed.
  Lemma i2z_2 : i2z _2 = 2.  Proof. auto. Qed.
  Lemma i2z_3 : i2z _3 = 3.  Proof. auto. Qed.
  Lemma i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.  Proof. auto. Qed.
  Lemma i2z_opp : forall n, i2z (- n)  = - i2z n.  Proof. auto. Qed.
  Lemma i2z_minus : forall n p, i2z (n - p)  = i2z n - i2z p.  Proof. auto. Qed.
  Lemma i2z_mult : forall n p, i2z (n * p)  = i2z n * i2z p.  Proof. auto. Qed.
  Lemma i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). Proof. auto. Qed.
End Z_as_Int.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Equality                                                                  *
**************************************************************************)

Set Implicit Arguments.
From SLF (* TLC *) Require Import LibTactics LibAxioms.
Generalizable Variables A.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Definition of equality *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition of Leibnitz' equality *)

(* Recall that the prelude defines equality [eq], with the notation
   [x = y] and [x = y :> A].
*)

Arguments eq {A}.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Partial application of Leibnitz' equality *)

(** [= x] is a unary predicate which holds of values equal to [x].
    It simply denotes the partial application of equality.
    [= x :> A] allows to specify the type. *)

Notation "'=' x :> A" := (fun y => y = x :> A)
  (at level 71, x at next level).
Notation "'=' x" := (fun y => y = x)
  (at level 71).

(** [<> x] is a unary predicate which holds of values disequal to [x].
    It simply denotes the partial application of disequality.
    [<> x :> A] allows to specify the type. *)

Notation "'<>' x :> A" := (fun y => y <> x :> A)
  (at level 71, x at next level).
Notation "'<>' x" := (fun y => y <> x)
  (at level 71).

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Typeclass to exploit extensionality *)

(** The property [Extensionality A] captures the fact that the type [A]
    features an extensional equality, in the sense that to prove the
    equality between two values of type [A] it suffices to prove that
    those two values are related by some binary relation. *)

Class Extensionality (A:Type) := Extensionality_make {
  extensionality_hyp : A -> A -> Prop;
  extensionality : forall (x y : A), extensionality_hyp x y -> x = y }.

Arguments extensionality [A].
Arguments Extensionality_make [A] [extensionality_hyp].

(** Instance for propositional extensionality *)

Global Instance extensionatity_prop : Extensionality Prop.
Proof using. intros. apply (Extensionality_make prop_ext). Defined.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic to exploit extensionality *)

Ltac extens_reveal_eq tt :=
  match goal with
  | |- _ = _ => idtac
  | _ => first [ intro; extens_reveal_eq tt
               | fail 2 "extens needs hnf to reveal an equality" ]
  end.

Ltac extens_core tt :=
  extens_reveal_eq tt;
  applys extensionality;
  simpl extensionality_hyp.

Tactic Notation "extens" :=
  extens_core tt.
Tactic Notation "extens" "~" :=
  extens; auto_tilde.
Tactic Notation "extens" "*" :=
  extens; auto_star.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties of equality *)

(** This section contains a reformulation of the lemmas provided by
    the standard library concerning equality. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Equality as an equivalence relation *)

(** See also sectin [Eq] from [LibRelation] for reformulation of theses
    results using high-level definitions. *)

Section EqualityProp.
Variables (A : Type).
Implicit Types x y z : A.

(** Reflexivity is captured by the constructor [eq_refl]. *)

(** Symmetry *)

Lemma eq_sym : forall x y,
  x = y ->
  y = x.
Proof using. introv H. destruct~ H. Qed.

(** Transitivity *)

Lemma eq_trans_ll : forall y x z,
  x = y ->
  y = z ->
  x = z.
Proof using. introv H1 H2. destruct~ H2. Qed.

Definition eq_trans := eq_trans_ll.

Lemma eq_trans_lr : forall y x z,
  x = y ->
  z = y ->
  x = z.
Proof using. introv H1 H2. destruct~ H2. Qed.

Lemma eq_trans_rl : forall y x z,
  y = x ->
  y = z ->
  x = z.
Proof using. introv H1 H2. destruct~ H2. Qed.

Lemma eq_trans_rr : forall y x z,
  y = x ->
  z = y ->
  x = z.
Proof using. introv H1 H2. destruct~ H2. Qed.

End EqualityProp.

Arguments eq_trans_ll [A].
Arguments eq_trans_lr [A].
Arguments eq_trans_rl [A].
Arguments eq_trans_rr [A].
Arguments eq_trans [A].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of disequality *)

Section DisequalityProp.
Variables (A : Type).
Implicit Types x y : A.

(** Symmetry *)

Lemma neq_sym : forall x y,
  x <> y ->
  y <> x.
Proof using. introv H K. destruct~ K. Qed.

End DisequalityProp.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Symmetrized induction principles *)

(* Remark: it is not clear if these results are any useful in practice. *)

Section EqInductionSym.
Variables (A : Type) (x : A).

Definition eq_ind_r : forall (P:A -> Prop),
  P x -> forall y, y = x -> P y.
Proof using. intros. subst*. Qed.

Definition eq_rec_r : forall (P:A -> Set),
  P x -> forall y, y = x -> P y.
Proof using. intros. subst*. Qed.

Definition eq_rect_r : forall (P:A -> Type),
  P x -> forall y, y = x -> P y.
Proof using. intros. subst*. Qed.

End EqInductionSym.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Functional extensionality *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Dependent functional extensionality *)

Section FuncExtDep.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).
Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type).
Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).

Lemma fun_ext_1 : forall (f g : forall (x1:A1), A2 x1),
  (forall x1, f x1 = g x1) ->
  f = g.
Proof using. repeat (intros; apply fun_ext_dep). auto. Qed.

Lemma fun_ext_2 : forall (f g : forall (x1:A1) (x2:A2 x1), A3 x2),
  (forall x1 x2, f x1 x2 = g x1 x2) ->
  f = g.
Proof using. repeat (intros; apply fun_ext_dep). auto. Qed.

Lemma fun_ext_3 : forall (f g : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), A4 x3),
  (forall x1 x2 x3, f x1 x2 x3 = g x1 x2 x3) ->
  f = g.
Proof using. repeat (intros; apply fun_ext_dep). auto. Qed.

Lemma fun_ext_4 : forall (f g: forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3), A5 x4),
  (forall x1 x2 x3 x4, f x1 x2 x3 x4 = g x1 x2 x3 x4) ->
  f = g.
Proof using. repeat (intros; apply fun_ext_dep). auto. Qed.

Lemma fun_ext_5 : forall (f g: forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3) (x5:A5 x4), A6 x5),
  (forall x1 x2 x3 x4 x5, f x1 x2 x3 x4 x5 = g x1 x2 x3 x4 x5) ->
  f = g.
Proof using. repeat (intros; apply fun_ext_dep). auto. Qed.

Global Instance Extensionality_fun_1 :
  Extensionality (forall (x1:A1), A2 x1).
Proof using. intros. apply (Extensionality_make fun_ext_1). Defined.

Global Instance Extensionality_fun_2 :
  Extensionality (forall (x1:A1) (x2:A2 x1), A3 x2).
Proof using. intros. apply (Extensionality_make fun_ext_2). Defined.

Global Instance Extensionality_fun_3 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2), A4 x3).
Proof using. intros. apply (Extensionality_make fun_ext_3). Defined.

Global Instance Extensionality_fun_4 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2) (x4:A4 x3), A5 x4).
Proof using. intros. apply (Extensionality_make fun_ext_4). Defined.

Global Instance Extensionality_fun_5 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3) (x5:A5 x4), A6 x5).
Proof using. intros. apply (Extensionality_make fun_ext_5). Defined.

End FuncExtDep.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Non-dependent functional extensionality *)

(* Remark: are these lemmas really useful, given that they are subsumed
   by their more general versions above? Probably could do without. *)

Lemma fun_ext_nondep_1 : forall A1 B (f g : A1 -> B),
  (forall x1, f x1 = g x1) ->
  f = g.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma fun_ext_nondep_2 : forall A1 A2 B (f g : A1 -> A2 -> B),
  (forall x1 x2, f x1 x2 = g x1 x2) ->
  f = g.
Proof using. intros. apply~ fun_ext_2. Qed.

Lemma fun_ext_nondep_3 : forall A1 A2 A3 B (f g : A1 -> A2 -> A3 -> B),
  (forall x1 x2 x3, f x1 x2 x3 = g x1 x2 x3) ->
  f = g.
Proof using. intros. apply~ fun_ext_3. Qed.

Lemma fun_ext_nondep_4 : forall A1 A2 A3 A4 B (f g : A1 -> A2 -> A3 -> A4 -> B),
  (forall x1 x2 x3 x4, f x1 x2 x3 x4 = g x1 x2 x3 x4) ->
  f = g.
Proof using. intros. apply~ fun_ext_4. Qed.

Lemma fun_ext_nondep_5 : forall A1 A2 A3 A4 A5 B (f g : A1 -> A2 -> A3 -> A4 -> A5 -> B),
  (forall x1 x2 x3 x4 x5, f x1 x2 x3 x4 x5 = g x1 x2 x3 x4 x5) ->
  f = g.
Proof using. intros. apply~ fun_ext_5. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Eta-conversion *)

Lemma fun_eta_dep_1 : forall (A:Type) (B:A->Type) (f : forall x, B x),
  (fun x1 => f x1) = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma fun_eta_1 : forall A1 B (f : A1 -> B),
  (fun x1 => f x1) = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma fun_eta_2 : forall A1 A2 B (f : A1 -> A2 -> B),
  (fun x1 x2 => f x1 x2) = f.
Proof using. intros. apply~ fun_ext_2. Qed.

Lemma fun_eta_3 : forall A1 A2 A3 B (f : A1 -> A2 -> A3 -> B),
  (fun x1 x2 x3 => f x1 x2 x3) = f.
Proof using. intros. apply~ fun_ext_3. Qed.

Lemma fun_eta_4 : forall A1 A2 A3 A4 B (f : A1 -> A2 -> A3 -> A4 -> B),
  (fun x1 x2 x3 x4 => f x1 x2 x3 x4) = f.
Proof using. intros. apply~ fun_ext_4. Qed.

Lemma fun_eta_5 : forall A1 A2 A3 A4 A5 B (f : A1 -> A2 -> A3 -> A4 -> A5 -> B),
  (fun x1 x2 x3 x4 x5 => f x1 x2 x3 x4 x5) = f.
Proof using. intros. apply~ fun_ext_4. Qed.

Hint Rewrite fun_eta_1 fun_eta_2 fun_eta_3 fun_eta_4 fun_eta_5 : rew_eta.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Predicate extensionality *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Dependend predicates *)

Section PropExt.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).
Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type).
Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).

Lemma pred_ext_1 : forall (P Q : forall (x1:A1), Prop),
  (forall x1, P x1 <-> Q x1) ->
  P = Q.
Proof using. repeat (intros; apply fun_ext_dep). intros. apply~ prop_ext. Qed.

Lemma pred_ext_2 : forall (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 <-> Q x1 x2) ->
  P = Q.
Proof using. repeat (intros; apply fun_ext_dep). intros. apply~ prop_ext. Qed.

Lemma pred_ext_3 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), Prop),
  (forall x1 x2 x3, P x1 x2 x3 <-> Q x1 x2 x3) ->
  P = Q.
Proof using. repeat (intros; apply fun_ext_dep). intros. apply~ prop_ext. Qed.

Lemma pred_ext_4 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3), Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 <-> Q x1 x2 x3 x4) ->
  P = Q.
Proof using. repeat (intros; apply fun_ext_dep). intros. apply~ prop_ext. Qed.

Lemma pred_ext_5 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3) (x5:A5 x4), Prop),
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5 <-> Q x1 x2 x3 x4 x5) ->
  P = Q.
Proof using. repeat (intros; apply fun_ext_dep). intros. apply~ prop_ext. Qed.

Lemma pred_ext_6 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3) (x5:A5 x4) (x6:A6 x5), Prop),
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6 <-> Q x1 x2 x3 x4 x5 x6) ->
  P = Q.
Proof using. repeat (intros; apply fun_ext_dep). intros. apply~ prop_ext. Qed.

Global Instance Extensionality_pred_1 :
  Extensionality (forall (x1:A1), Prop).
Proof using. intros. apply (Extensionality_make pred_ext_1). Defined.

Global Instance Extensionality_pred_2 :
  Extensionality (forall (x1:A1) (x2:A2 x1), Prop).
Proof using. intros. apply (Extensionality_make pred_ext_2). Defined.

Global Instance Extensionality_pred_3 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2), Prop).
Proof using. intros. apply (Extensionality_make pred_ext_3). Defined.

Global Instance Extensionality_pred_4 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2) (x4:A4 x3), Prop).
Proof using. intros. apply (Extensionality_make pred_ext_4). Defined.

Global Instance Extensionality_pred_5 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3) (x5:A5 x4), Prop).
Proof using. intros. apply (Extensionality_make pred_ext_5). Defined.

Global Instance Extensionality_pred_6 :
  Extensionality (forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
  (x4:A4 x3) (x5:A5 x4) (x6:A6 x5), Prop).
Proof using. intros. apply (Extensionality_make pred_ext_6). Defined.

End PropExt.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Non-dependend predicate extensionality *)

(* Remark: are these lemmas really useful, given that they are subsumed
   by their more general versions above? Probably could do without. *)

Lemma pred_ext_nondep_1 :
  forall A1 (P Q : A1 -> Prop),
  (forall x1, P x1 <-> Q x1) ->
  P = Q.
Proof using. intros. apply~ pred_ext_1. Qed.

Lemma pred_ext_nondep_2 :
  forall A1 A2 (P Q : A1 -> A2 -> Prop),
  (forall x1 x2, P x1 x2 <-> Q x1 x2) ->
  P = Q.
Proof using. intros. apply~ pred_ext_2. Qed.

Lemma pred_ext_nondep_3 :
  forall A1 A2 A3 (P Q : A1 -> A2 -> A3 -> Prop),
  (forall x1 x2 x3, P x1 x2 x3 <-> Q x1 x2 x3) ->
  P = Q.
Proof using. intros. apply~ pred_ext_3. Qed.

Lemma pred_ext_nondep_4 :
  forall A1 A2 A3 A4 (P Q : A1 -> A2 -> A3 -> A4 -> Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 <-> Q x1 x2 x3 x4) ->
  P = Q.
Proof using. intros. apply~ pred_ext_4. Qed.

Lemma pred_ext_nondep_5 :
  forall A1 A2 A3 A4 A5 (P Q : A1 -> A2 -> A3 -> A4 -> A5 -> Prop),
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5 <-> Q x1 x2 x3 x4 x5) ->
  P = Q.
Proof using. intros. apply~ pred_ext_5. Qed.

Lemma pred_ext_nondep_6 :
  forall A1 A2 A3 A4 A5 A6 (P Q : A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> Prop),
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6 <-> Q x1 x2 x3 x4 x5 x6)  ->
  P = Q.
Proof using. intros. apply~ pred_ext_6. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Equality of function and predicate applications *)

(* --TODO: generalize this section to dependent arguments *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** A same function applied to equal arguments yield equal result *)

Section ArgsEq.
Variables (A1 A2 A3 A4 A5 B : Type).

Lemma args_eq_1 : forall (f:A1->B) x1 y1,
  x1 = y1 ->
  f x1 = f y1.
Proof using. intros. subst~. Qed.

Lemma args_eq_2 : forall (f:A1->A2->B) x1 y1 x2 y2,
  x1 = y1 ->
  x2 = y2 ->
  f x1 x2 = f y1 y2.
Proof using. intros. subst~. Qed.

Lemma args_eq_3 : forall (f:A1->A2->A3->B) x1 y1 x2 y2 x3 y3,
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  f x1 x2 x3 = f y1 y2 y3.
Proof using. intros. subst~. Qed.

Lemma args_eq_4 : forall (f:A1->A2->A3->A4->B) x1 y1 x2 y2 x3 y3 x4 y4,
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  x4 = y4 ->
  f x1 x2 x3 x4 = f y1 y2 y3 y4.
Proof using. intros. subst~. Qed.

Lemma args_eq_5 : forall (f:A1->A2->A3->A4->A5->B) x1 y1 x2 y2 x3 y3 x4 y4 x5 y5,
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  x4 = y4 ->
  x5 = y5 ->
  f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
Proof using. intros. subst~. Qed.

End ArgsEq.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Equal functions applied to same arguments return equal results *)

(** These results are exploited by tactic [fequals] (see LibTactics);
    however the lemmas remain useful for forward-reasoning. *)

Section FuncEq.
Variables (A1 A2 A3 A4 A5 B:Type).
Variables (x1:A1) (x2:A2) (x3:A3) (x4:A4) (x5:A5).

Lemma fun_eq_1 : forall f g,
  f = g ->
  f x1 = g x1 :> B.
Proof using. intros. subst~. Qed.

Lemma fun_eq_2 : forall f g,
  f = g ->
  f x1 x2 = g x1 x2 :> B.
Proof using. intros. subst~. Qed.

Lemma fun_eq_3 : forall f g,
  f = g ->
  f x1 x2 x3 = g x1 x2 x3 :> B.
Proof using. intros. subst~. Qed.

Lemma fun_eq_4 : forall f g,
  f = g ->
  f x1 x2 x3 x4 = g x1 x2 x3 x4 :> B.
Proof using. intros. subst~. Qed.

Lemma fun_eq_5 : forall f g,
  f = g ->
  f x1 x2 x3 x4 x5 = g x1 x2 x3 x4 x5 :> B.
Proof using. intros. subst~. Qed.

End FuncEq.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Equal predicates applied to same arguments return equivalent results *)

(** These results are exploited by tactic [fequals] (see LibTactics);
    however the lemmas remain useful for forward-reasoning. *)

Section PredEq.
Variables (A1 A2 A3 A4 A5 B:Type).
Variables (x1:A1) (x2:A2) (x3:A3) (x4:A4) (x5:A5).

Lemma pred_eq_1 : forall P Q,
  P = Q ->
  P x1 <-> Q x1.
Proof using. intros. subst*. Qed.

Lemma pred_eq_2 : forall P Q,
  P = Q ->
  P x1 x2 <-> Q x1 x2.
Proof using. intros. subst*. Qed.

Lemma pred_eq_3 : forall P Q,
  P = Q ->
  P x1 x2 x3 <-> Q x1 x2 x3.
Proof using. intros. subst*. Qed.

Lemma pred_eq_4 : forall P Q,
  P = Q ->
  P x1 x2 x3 x4 <-> Q x1 x2 x3 x4.
Proof using. intros. subst*. Qed.

Lemma pred_eq_5 : forall P Q,
  P = Q ->
  P x1 x2 x3 x4 x5 <-> Q x1 x2 x3 x4 x5.
Proof using. intros. subst*. Qed.

End PredEq.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Proof Irrelevance *)

(** The proof irrelevance lemma states that two proofs of a same
    proposition are always equal.
      [forall (P : Prop) (p q : P), p = q]
   This result is a consequence of propositional extensionality.
*)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Proof of the proof-irrelevance result *)

Module PIfromExt.

Implicit Types P : Prop.

(** First, we prove that on an inhabited proposition type,
    there exists a fixpoint combinator. *)

Lemma prop_eq_self_impl_when_true : forall P,
  P ->
  P = (P -> P).
Proof using. intros. apply* prop_ext. Qed.

Record has_fixpoint (P:Prop) : Prop := has_fixpoint_make
  { has_fixpoint_F : (P -> P) -> P;
    has_fixpoint_fix : forall f, has_fixpoint_F f = f (has_fixpoint_F f) }.

Lemma prop_has_fixpoint_when_true : forall P,
  P ->
  has_fixpoint P.
Proof using.
  intros P a. set (P' := P).
  set (g1 := id : P' -> P). set (g2 := id : P -> P').
  asserts~ Fix: (forall x, g1 (g2 x) = x).
  clearbody g1 g2. gen g1 g2.
  rewrite (prop_eq_self_impl_when_true a).
  subst P'. intros.
  set (Y := fun f => (fun x => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
  applys (has_fixpoint_make Y). (* --TODO: why [applys has_fixpoint_make Y] fails *)
  { intros f. unfold Y at 1. rewrite~ Fix. }
Qed.

(** We exploit the fixpoint combinator on the negation function, applied
    to the following special proposition type (isomorphic to booleans,
    but living in Prop). *)

Inductive boolP : Prop :=
  | trueP : boolP
  | falseP : boolP.

Lemma trueP_eq_falseP : trueP = falseP.
Proof using.
  lets (Y&Yfix): (@prop_has_fixpoint_when_true boolP trueP).
  set (neg := fun b => match b with| trueP => falseP | falseP => trueP end).
  lets F: ((rm Yfix) neg).
  set (b := Y neg).
  asserts~ E: (b = Y neg).
  destruct b.
  { change (trueP = neg trueP) in |- *. rewrite E. rewrite~ <- F. }
  { change (neg falseP = falseP) in |- *. rewrite E. rewrite~ <- F. }
Qed.

(** We now have two distinct constructors [trueP] and [falseP],
    which we can distinguish in the logic using [match] for
    any goal concluding on a proposition; and, at the same time,
    these two constructors are provably equal. We can exploit
    these properties to prove that two proofs of a same theorem
    are equal. *)

Lemma proof_irrelevance :
  forall (P : Prop) (p q : P), p = q.
Proof using.
  intros P p q.
  set (f := fun b => match b with | trueP => p | falseP => q end).
  change p with (f trueP).
  change q with (f falseP).
  rewrite~ trueP_eq_falseP.
Qed.

End PIfromExt.

Lemma proof_irrelevance : forall (P : Prop) (p q : P), p = q.
Proof using. exact PIfromExt.proof_irrelevance. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Consequences of proof irrelevance *)

(** Uniqueness of identity proofs *)

Lemma identity_proofs_unique :
  forall (A : Type) (x y : A) (p q : x = y),
  p = q.
Proof using. intros. apply proof_irrelevance. Qed.

(** Uniqueness of reflexive identity proofs (special case) *)

Lemma reflexive_identity_proofs_unique :
  forall (A : Type) (x : A) (p : x = x),
  p = refl_equal x.
Proof using. intros. applys identity_proofs_unique. Qed.

(** Invariance by substitution of reflexive equality proofs *)

Lemma eq_rect_refl_eq :
  forall (A : Type) (p : A) (Q : A -> Type) (x : Q p) (h : p = p),
  eq_rect p Q x p h = x.
Proof using. intros. rewrite~ (reflexive_identity_proofs_unique h). Qed.

(** Streicher's axiom K *)

Lemma streicher_K :
  forall (A : Type) (x : A) (P : x = x -> Prop),
  P (refl_equal x) ->
  forall (p : x = x), P p.
Proof using. intros. rewrite~ (reflexive_identity_proofs_unique p). Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Injectivity of equality on dependent pairs *)

(** This section establishes that [existT P p x = existT P p y] implies
    that [x] is equal to [y]. It indirectly results from the proof
    irrelevance property. *)

(** Definition of dependent equality, with non-dependent return type *)

Inductive eq_dep_nd (A : Type) (P : A -> Type)
    (p : A) (x : P p) (q : A) (y : P q) : Prop :=
 | eq_dep_nd_intro : forall (h : q = p),
    x = eq_rect q P y p h -> eq_dep_nd P p x q y.

Arguments eq_dep_nd [A] [P] [p] x [q] y.
Arguments eq_dep_nd_intro [A] [P] [p] [x] [q] [y].

(** Reflexivity of [eq_dep_nd] *)

Lemma eq_dep_nd_refl : forall (A : Type) (P : A -> Type) (p : A) (x : P p),
  eq_dep_nd x x.
Proof using. intros. apply (eq_dep_nd_intro (refl_equal p)). auto. Qed.

(** Injectivity of [eq_dep_nd] *)

Lemma eq_dep_nd_same_inv :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  eq_dep_nd x y ->
  x = y.
Proof using. introv H. inversions H. rewrite~ eq_rect_refl_eq. Qed.

(** Equality on dependent pairs implies [eq_dep_nd] *)

Lemma eq_existT_inv :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  existT P p x = existT P q y ->
  eq_dep_nd x y.
Proof using. introv E. dependent rewrite E. simpl. apply eq_dep_nd_refl. Qed.

(** Injectivity of equality on dependent pairs *)

Lemma eq_existT_same_inv :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  existT P p x = existT P p y ->
  x = y.
Proof using. intros. apply eq_dep_nd_same_inv. apply~ eq_existT_inv. Qed.

(** Reformulated as an equality *)

Lemma eq_existT_same_eq :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  (existT P p x = existT P p y) = (x = y).
Proof using.
  extens. iff M.
  { apply eq_dep_nd_same_inv. apply~ eq_existT_inv. }
  { subst*. }
Qed.

(* ----------------------------------------------------------------------

    Irrelevance of the membership property for subsets types *)

(** This is another consequence of proof irrelevance *)

Scheme eq_indd := Induction for eq Sort Prop.

Lemma exist_eq_exist : forall (A:Type) (P : A->Prop) (x y : A) (p : P x) (q : P y),
  x = y ->
  exist P x p = exist P y q.
Proof using.
  intros. rewrite (proof_irrelevance q (eq_rect x P p y H)). subst*.
Qed.

Lemma existT_eq_existT : forall (A:Type) (P:A->Prop) (x y:A) (p:P x) (q:P y),
  x = y ->
  existT P x p = existT P y q.
Proof using.
  intros. rewrite (proof_irrelevance q (eq_rect x P p y H)). subst*.
Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Dependent equality *)

(** In this section, we prove that [eq_dep x y] implies [x = y]. *)

(** Definition of [eq_dep] (copied from the Prelude) *)

Inductive eq_dep (A : Type) (P : A -> Type) (p : A) (x : P p)
  : forall q, P q -> Prop :=
  | eq_dep_refl : eq_dep P p x p x.

Arguments eq_dep [A] [P] [p] x [q].

(** Symmetry of [eq_dep] *)

Lemma eq_dep_sym : forall (A : Type) (P : A -> Type)
 (p q : A) (x : P p) (y : P q),
  eq_dep x y ->
  eq_dep y x.
Proof using. introv E. destruct E. constructor. Qed.

(** Transitivity of [eq_dep] *)

Lemma eq_dep_trans : forall (A : Type) (P : A -> Type)
 (p q r : A) (y : P q) (x : P p) (z : P r),
  eq_dep x y ->
  eq_dep y z ->
  eq_dep x z.
Proof using. introv E F. destruct~ E. Qed.

(** Proof of equivalence between [eq_dep_nd] and [eq_dep] *)

Scheme eq_induction := Induction for eq Sort Prop.

Lemma eq_dep_of_eq_dep_nd :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  eq_dep_nd x y ->
  eq_dep x y.
Proof using.
  introv E. destruct E as (h,H).
  destruct h using eq_induction. subst~. constructor.
Qed.

Lemma eq_dep_nd_of_eq_dep :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  eq_dep x y ->
  eq_dep_nd x y.
Proof using. introv H. destruct H. apply (eq_dep_nd_intro (refl_equal p)); auto. Qed.

(** Injectivity of dependent equality *)

Lemma eq_dep_same_inv :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  eq_dep x y ->
  x = y.
Proof using.
  introv R. inversion R. apply eq_dep_nd_same_inv. apply~ eq_dep_nd_of_eq_dep.
Qed.

(** Equality on dependent pairs implies dependent equality *)

Lemma eq_dep_of_eq_existT :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  existT P p x = existT P q y ->
  eq_dep x y.
Proof using. introv E. dependent rewrite E. simple~. constructor. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * John Major's equality *)

Require Import Coq.Logic.JMeq.

(** The module above defines John Major's equality:

  Inductive JMeq (A : Type) (x : A) : forall B : Type, B -> Prop :=
     | JMeq_refl : JMeq x x.
*)

(** In this section, we prove that [JMeq x y] implies [x = y]
    when [x] and [y] have the same type. *)

(** Symmetry, transitivity of [JMeq] *)

Lemma JMeq_sym : forall (A B : Type) (x : A) (y : B),
  JMeq x y ->
  JMeq y x.
Proof using. introv E. destruct~ E. Qed.

Lemma JMeq_trans : forall (A B C : Type) (y : B) (x : A) (z : C),
  JMeq x y ->
  JMeq y z ->
  JMeq x z.
Proof using. introv E F. destruct~ E. Qed.

Local Hint Immediate JMeq_sym.

(** Relation between [JMeq] and [eq_dep] *)

Lemma eq_dep_of_JMeq : forall (A B : Type) (x : A) (y : B),
  JMeq x y ->
  @eq_dep Type (fun T => T) A x B y.
Proof using. introv E. destruct E. constructor. Qed.

Lemma JMeq_of_eq_dep : forall (A B : Type) (x : A) (y : B),
  @eq_dep Type (fun T => T) A x B y ->
  JMeq x y.
Proof using. introv E. destruct~ E. Qed.

(** Injectivity of [JMeq] *)

Lemma JMeq_same_inv : forall (A : Type) (x y : A),
  JMeq x y ->
  x = y.
Proof using.
  introv E. apply (@eq_dep_same_inv Type (fun T => T)).
  apply~ eq_dep_of_JMeq.
Qed.

(* 2020-03-09 15:04:11 (UTC+01) *)


Require Import Metalib.Metatheory.
Require Import Linear.Data.Subsequence.

Set Implicit Arguments.

(* Remove Operation *)

Fixpoint assoc_remove {A : Type} (x1 : atom) (E1 : list (atom * A)) : list (atom * A) :=
  match E1 with
  | nil            => nil
  | (x2, T2) :: E1 => if x1 == x2
                      then assoc_remove x1 E1
                      else (x2, T2) :: assoc_remove x1 E1
  end.

Lemma assoc_remove_notin : forall {A : Type} (E1 : list (atom * A)) x1,
    x1 `notin` dom E1 ->
    assoc_remove x1 E1 = E1.
Proof.
  induction E1 as [| [x2 v2] E1 IH]; intros x1 H1; simpl; auto.
  destruct (x1 == x2) as [| H2]; subst; analyze_binds H1.
  rewrite IH; auto.
Qed.

Lemma assoc_remove_dom_neq : forall {A : Type} (E1 : list (atom * A)) x1 x2,
    x1 `notin` dom E1 ->
    x1 `notin` dom (assoc_remove x2 E1).
Proof.
  induction E1 as [| [x3 v3] E1 IH]; intros x1 x2 H1; simpl; auto.
  destruct (x2 == x3) as [| H2]; subst; simpl in *; eauto.
Qed.

Lemma assoc_remove_uniq : forall {A : Type} (E1 : list (atom * A)) x1,
    uniq E1 ->
    uniq (assoc_remove x1 E1).
Proof.
  induction 1 as [| x2 T2]; simpl; auto.
  destruct (x1 == x2); subst; auto.
  constructor; eauto using assoc_remove_dom_neq.
Qed.

Lemma subseq_assoc_remove : forall A x1 (E1 E2 : list (atom * A)),
    subsequence E1 E2 ->
    subsequence (assoc_remove x1 E1) E2.
Proof.
  induction 1 as [| | [x2 P2]]; simpl; eauto.
  destruct (x1 == x2); subst; eauto.
Qed.

Lemma assoc_remove_notin_eq : forall A (E1 : list (atom * A)) x1,
    x1 `notin` dom (assoc_remove x1 E1).
Proof.
  induction E1 as [| [x2 T2] E1 IH]; intros x1; simpl; auto.
  - destruct (x1 == x2); subst; auto.
Qed.

Lemma assoc_remove_swap_cons : forall A (E1 E2 : list (atom * A)) x1 T1,
    x1 `notin` dom E1 ->
    (x1, T1) :: E1 = E2 ->
    E1 = assoc_remove x1 E2.
Proof.
  intros A E1 E2 x1 T1 H1 H2.
  destruct E2 as [| [x2 T2] E2].
  - discriminate.
  - inversion H2; subst; simpl.
    destruct (x2 == x2); [| congruence].
    rewrite (assoc_remove_notin _ H1). auto.
Qed.

Lemma assoc_remove_notin_inv : forall A (E1 : list (atom * A)) x1 x2,
    x1 `notin` dom (assoc_remove x2 E1) ->
    x1 = x2 \/ x1 `notin` dom E1.
Proof.
  induction E1 as [| [x3 T3] E1 IH]; simpl; intros x1 x2 H1; auto.
  destruct (x2 == x3); subst.
  - destruct (x1 == x3) as [| H2]; subst; auto.
    apply IH in H1 as [? | H3]; subst; auto.
  - simpl in H1. pose proof (notin_add_2 _ _ _ H1) as H2.
    apply IH in H2 as [| H3]; subst; auto.
Qed.

Lemma assoc_remove_binds : forall A (E1 : list (atom * A)) x1 x2 T1,
    binds x1 T1 (assoc_remove x2 E1) ->
    x1 <> x2 /\ binds x1 T1 E1.
Proof.
  induction E1 as [| [x3 T3] E1 IH]; simpl; intros x1 x2 T1 H1; auto.
  destruct (x2 == x3) as [| H2]; subst.
  - apply IH in H1 as [H2 H3]; auto.
  - analyze_binds H1.
    apply IH in BindsTac as [H3 H4]; auto.
Qed.

Lemma assoc_remove_subseq_both : forall A (E1 E2 : list (atom * A)) x1,
    subsequence E1 E2 ->
    subsequence (assoc_remove x1 E1) (assoc_remove x1 E2).
Proof.
  intros A E1 E2 x1 H1.
  induction H1 as [| [x2 T2] | [x2 T2]]; simpl; auto.
  - destruct (x1 == x2); subst; auto.
  - destruct (x1 == x2); subst; auto.
Qed.

Lemma assoc_remove_subseq_left : forall A (E1 E2 : list (atom * A)) x1,
    subsequence E1 E2 ->
    subsequence (assoc_remove x1 E1) E2.
Proof.
  induction 1 as [| [x2 T2] | [x2 T2]]; simpl; auto.
  - destruct (x1 == x2); subst; auto.
Qed.

Lemma assoc_remove_cons_eq : forall A (E1 : list (atom * A)) x1 T1,
    x1 `notin` dom E1 ->
    assoc_remove x1 ((x1 ~ T1) ++ E1) = E1.
Proof.
  intros A E1 x1 T1 H1.
  induction E1 as [| [x2 T2] E1 IH]; simpl in *.
  - destruct (x1 == x1); subst; congruence.
  - destruct (x1 == x1); subst; try congruence.
    destruct (x1 == x2); subst.
    + analyze_binds H1.
    + f_equal. auto.
Qed.

Lemma assoc_remove_mid_eq : forall A (E1 E2 : list (atom * A)) x1 T1,
    x1 `notin` dom (E1 ++ E2) ->
    assoc_remove x1 (E1 ++ (x1, T1) :: E2) = E1 ++ E2.
Proof.
  intros A E1 E2 x1 T1 H1.
  induction E1 as [| [x2 T2] E1 IH]; simpl in *.
  - destruct (x1 == x1); [subst | congruence].
    apply (assoc_remove_notin _ H1).
  - destruct (x1 == x2); [subst |].
    + analyze_binds H1.
    + f_equal. auto.
Qed.

(* Submap Relation *)

Definition submap {A : Type} (A1 A2 : list (var * A)) : Prop :=
  forall x1 y1, binds x1 y1 A1 -> binds x1 y1 A2.

Hint Unfold submap.

Lemma submap_nil : forall {A : Type} (E1 : list (atom * A)),
    submap E1 nil ->
    E1 = nil.
Proof.
  intros A [| [x1 v1] E1] H1; auto.
  - exfalso. eapply H1. eauto.
Qed.

Lemma submap_cons : forall {A : Type} (E1 E2 : list (atom * A)) x1 v1,
    submap E1 E2 ->
    submap ((x1 ~ v1) ++ E1) ((x1 ~ v1) ++ E2).
Proof.
  intros A E1 E2 x1 v1 H1 x2 v2 H2. analyze_binds H2.
Qed.

Lemma submap_trans : forall {A : Type} (E1 E2 E3 : list (atom * A)),
    submap E1 E2 ->
    submap E2 E3 ->
    submap E1 E3.
Proof.
  auto.
Qed.

Lemma submap_notin : forall {A : Type} (E1 E2 : list (atom * A)) x1,
    submap E1 E2 ->
    x1 `notin` dom E2 ->
    x1 `notin` dom E1.
Proof.
  intros A E1 E2 x1 H1 H2.
  destruct (binds_lookup _ x1 E1) as [[v1 H3] | H3].
  - apply H1 in H3. eauto.
  - intros H4. apply binds_In_inv in H4 as [v1 H4]. apply H3 in H4. tauto.
Qed.

Lemma uniq_submap_app : forall {A : Type} (E1 E2 E3 : list (atom * A)),
    submap E1 E2 ->
    uniq E1 ->
    uniq (E3 ++ E2) ->
    uniq (E3 ++ E1).
Proof.
  intros A E1 E2 E3 H1 H2 H3.
  induction E3 as [| [x1 T1] E3 IH]; simpl; auto.
  inversion H3. subst. constructor; auto.
  rewrite dom_app. apply notin_union_3; eauto.
  rewrite dom_app in H6. apply notin_union_2 in H6.
  eapply submap_notin; eauto.
Qed.

Lemma submap_assoc_remove : forall {A : Type} (E1 : list (atom * A)) x1,
    submap (assoc_remove x1 E1) E1.
Proof.
  induction E1 as [| [x2 T2] E1 IH]; simpl; intros x1 x3 T3 H1; auto.
  destruct (x1 == x2); subst.
  - apply IH in H1. auto.
  - analyze_binds H1. apply IH in BindsTac. auto.
Qed.

Lemma subseq_submap : forall A (E1 E2 : list (atom * A)),
    subsequence E1 E2 ->
    submap E1 E2.
Proof.
  induction 1 as [| [x2 T2] | [x2 T2]]; intros x1 T1 H1.
  - analyze_binds H1.
  - eapply binds_cons_3, subseq_binds; eauto.
  - analyze_binds H1.
Qed.

(* List Difference Operation *)

Fixpoint diff_list {A : Type} (E1 E2 : list (atom * A)) : list (atom * A) :=
  match E2 with
  | nil            => E1
  | (x1, T1) :: E2 => assoc_remove x1 (diff_list E1 E2)
  end.

Ltac destruct_eq_decs :=
  repeat (simpl in *; auto;
          match goal with
          | [ _ : context [ eq_dec ?A ?B ] |- _ ] =>
            destruct (eq_dec A B); subst
          | [ |- context [eq_dec ?A ?B] ]         =>
            destruct (eq_dec A B); subst
          end).

Lemma assoc_remove_swap : forall A (E1 : list (atom * A)) x1 x2,
    assoc_remove x1 (assoc_remove x2 E1) = assoc_remove x2 (assoc_remove x1 E1).
Proof.
  induction E1 as [| [x3 T3] E1 IH]; intros;
    destruct_eq_decs; congruence.
Qed.

Lemma assoc_remove_diff_eq : forall A (E1 E2 : list (atom * A)) x1 T1,
    assoc_remove x1 (diff_list ((x1, T1) :: E1) E2) = assoc_remove x1 (diff_list E1 E2).
Proof.
  induction E2 as [| [x2 T2] E2 IH]; intros x1 T1;
    destruct_eq_decs; simpl; try congruence.
  - rewrite assoc_remove_swap, IH, assoc_remove_swap. auto.
Qed.

Lemma assoc_remove_diff_neq : forall A (E1 E2 : list (atom * A)) x1 x2 T1,
    x1 <> x2 ->
    x1 `notin` dom E2 ->
    assoc_remove x2 (diff_list ((x1, T1) :: E1) E2) = (x1, T1) :: assoc_remove x2 (diff_list E1 E2).
Proof.
  induction E2 as [| [x3 T3] E2 IH]; intros x1 x2 T1 H1 H2;
    destruct_eq_decs; simpl; try congruence.
  - rewrite IH; auto. destruct_eq_decs. congruence.
Qed.

Lemma diff_list_nil : forall A (E1 : list (atom * A)),
    diff_list E1 E1 = nil.
Proof.
  induction E1 as [| [x1 T1] E1 IH]; auto.
  - simpl. rewrite assoc_remove_diff_eq, IH. auto.
Qed.

Lemma diff_list_equate_cons : forall A (E1 : list (atom * A)) x1 T1,
    x1 `notin` dom E1 ->
    diff_list ((x1, T1) :: E1) E1 = (x1 ~ T1).
Proof.
  destruct E1 as [| [x2 T2] E1]; intros x1 T1 H1; simpl; auto.
  - rewrite assoc_remove_diff_neq; auto.
    rewrite assoc_remove_diff_eq, diff_list_nil; auto.
Qed.

Lemma diff_list_equate_mid : forall A (E1 E2 : list (atom * A)) x1 T1,
    x1 `notin` dom (E1 ++ E2) ->
    diff_list (E1 ++ (x1, T1) :: E2) (E1 ++ E2) = (x1 ~ T1).
Proof.
  induction E1 as [| [x2 T2] E1 IH]; intros E2 x1 T1 H1; simpl.
  - rewrite diff_list_equate_cons; auto.
  - rewrite assoc_remove_diff_eq, IH; destruct_eq_decs. fsetdec.
Qed.

Lemma diff_list_notin_cons : forall A (E1 E2 : list (atom * A)) x1 T1,
    x1 `notin` dom E2 ->
    diff_list ((x1, T1) :: E1) E2 = (x1, T1) :: diff_list E1 E2.
Proof.
  intros A E1 E2 x1 T1 H1.
  induction E2 as [| [x2 T2] E2 IH]; simpl; auto.
  rewrite assoc_remove_diff_neq; auto.
Qed.

Lemma diff_list_notin_left : forall A (E1 E2 : list (atom * A)) x1,
    x1 `notin` dom E1 ->
    x1 `notin` dom (diff_list E1 E2).
Proof.
  intros A E1 E2 x1 H1.
  induction E2 as [| [x2 T2] E2 IH]; simpl; auto.
  - apply assoc_remove_dom_neq. auto.
Qed.

Lemma diff_list_nil_left : forall A (E1 : list (atom * A)),
    diff_list nil E1 = nil.
Proof.
  induction E1 as [| [x1 T1] E1 IH]; simpl; auto.
  - rewrite IH; auto.
Qed.

Lemma diff_list_subseq_nil : forall A (E1 E2 : list (atom * A)),
    subsequence E1 E2 ->
    diff_list E1 E2 = nil.
Proof.
  induction 1 as [| [x1 T1] | [x1 T1]]; simpl; auto.
  - apply diff_list_nil_left.
  - rewrite IHsubsequence; auto.
  - rewrite assoc_remove_diff_eq, IHsubsequence; auto.
Qed.

Lemma diff_list_binds_cons : forall A (E1 E2 : list (atom * A)) x1 T1,
    x1 `in` dom E2 ->
    diff_list ((x1, T1) :: E1) E2 = diff_list E1 E2.
Proof.
  induction E2 as [| [x2 T2] E2 IH]; simpl; intros x1 T1 H1.
  - fsetdec.
  - apply add_iff in H1 as [H1 | H1]; subst.
    + rewrite assoc_remove_diff_eq. auto.
    + rewrite (IH x1 T1 H1). auto.
Qed.

Lemma diff_list_notin_remove : forall A (E1 E2 : list (atom * A)) x1,
    x1 `notin` dom E1 ->
    diff_list E1 (assoc_remove x1 E2) = diff_list E1 E2.
Proof.
  induction E2 as [| [x2 T2] E2 IH]; simpl; intros x1 H1; auto.
  - destruct (x1 == x2) as [| H2]; subst; simpl.
    + rewrite IH, assoc_remove_notin; auto.
      apply diff_list_notin_left; auto.
    + rewrite IH; auto.
Qed.

Lemma diff_list_subseq : forall A (E1 E2 : list (atom * A)),
    subsequence (diff_list E1 E2) E1.
Proof.
  induction E2 as [| [x2 T2] E2 IH]; simpl; auto.
  - apply subseq_refl.
  - apply assoc_remove_subseq_left, IH.
Qed.

Lemma notin_dec : forall A (E1 : list (atom * A)) x1,
    x1 `notin` dom E1 \/ exists T1, binds x1 T1 E1.
Proof.
  induction E1 as [| [x2 T2] E1 IH]; intros x1; auto.
  destruct (x1 == x2) as [| H1]; subst.
  - right. exists T2. auto.
  - destruct (IH x1) as [H2 | [T1 H2]].
    + left. auto.
    + right. exists T1. auto.
Qed.

Lemma subseq_diff_left : forall A (E1 E2 E3 : list (atom * A)),
    subsequence E1 E3 ->
    subsequence (diff_list E1 E2) E3.
Proof.
  induction 1 as [| [x1 T1] | [x1 T1]]; simpl; auto.
  - rewrite diff_list_nil_left. auto.
  - destruct (notin_dec E2 x1) as [H1 | [T2 H1]].
    + rewrite diff_list_notin_cons; auto.
    + rewrite diff_list_binds_cons; eauto using binds_In.
Qed.

Lemma diff_list_uniq : forall A (E1 E2 : list (atom * A)),
    uniq E1 ->
    uniq (diff_list E1 E2).
Proof.
  induction E2 as [| [x1 T1] E2 IH]; simpl; intros H1; auto.
  - apply assoc_remove_uniq. auto.
Qed.

Lemma binds_assoc_remove : forall A (E1 : list (atom * A)) x1 x2 T1,
    x1 <> x2 ->
    binds x1 T1 E1 ->
    binds x1 T1 (assoc_remove x2 E1).
Proof.
  induction E1 as [| [x3 T3] E1 IH]; simpl; intros x1 x2 T1 H1 H2.
  - analyze_binds H2.
  - destruct (x2 == x3); subst; auto.
    + analyze_binds H2.
    + analyze_binds H2.
Qed.

Lemma diff_list_binds_spec : forall A (E1 E2 : list (atom * A)) x1 T1,
    binds x1 T1 (diff_list E1 E2) <-> binds x1 T1 E1 /\ x1 `notin` dom E2.
Proof.
  induction E2 as [| [x2 T2] E2 IH]; simpl; intros x1 T1.
  - split; [intros H1 | intros [H1 H2]]; auto.
  - split; [intros H1 | intros [H1 H2]].
    + apply assoc_remove_binds in H1 as [H1 H2].
      apply IH in H2 as [H2 H3]. split; auto.
    + apply binds_assoc_remove; auto. apply IH; auto.
Qed.

Lemma diff_list_notin_spec : forall A (E1 E2 : list (atom * A)) x1,
    x1 `notin` dom (diff_list E1 E2) <-> x1 `notin` dom E1 \/ x1 `in` dom E2.
Proof.
  induction E2 as [| [x2 T2] E2 IH]; simpl; intros x1.
  - split; [intros | intros [? | ?]]; auto. fsetdec.
  - split; [intros H1 | intros [H1 | H1]].
    + apply assoc_remove_notin_inv in H1 as [| H1]; auto.
      apply IH in H1 as [? | ?]; auto.
    + apply assoc_remove_dom_neq.
      apply (diff_list_notin_left _ _ H1).
    + apply add_iff in H1 as [? | H1]; subst.
      * apply assoc_remove_notin_eq.
      * apply assoc_remove_dom_neq, IH; auto.
Qed.

(* Decomposition Lemmas *)

Lemma binds_inv : forall {A : Type} (E1 : list (atom * A)) x1 T1,
    binds x1 T1 E1 ->
    exists E2 E3, E1 = E2 ++ (x1 ~ T1) ++ E3.
Proof.
  induction E1 as [| [x2 T2] E1 IH];
  intros x1 T1 H1; simpl; analyze_binds H1.
  - exists nil, E1. auto.
  - destruct (IH x1 T1 BindsTac) as [E4 [E5 H1]]. subst.
    exists ((x2, T2) :: E4), E5. auto.
Qed.

Lemma assoc_equate_uniq : forall A (E1 E2 F1 F2 : list (atom * A)) (x1 : atom) (v1 v2 : A),
    uniq (E1 ++ (x1 ~ v1) ++ E2) ->
    E1 ++ (x1 ~ v1) ++ E2 = F1 ++ (x1 ~ v2) ++ F2 ->
    E1 = F1 /\ v1 = v2 /\ E2 = F2.
Proof.
  induction E1 as [| [x3 v3] E1 IH];
  intros E2 F1 F2 x1 v1 v2 H1 H2;
  destruct F1 as [| [x4 v4] F1];
  try solve [inversion H2; solve_uniq].
  - rewrite H2 in H1. inversion H2. solve_uniq.
  - inversion H1. inversion H2. subst.
    destruct (IH _ _ _ _ _ _ H3 H9). solve_uniq.
Qed.

Lemma assoc_equate_split_uniq : forall A (E1 E2 F1 F2 : list (atom * A)) (x1 x2 : atom) (v1 v2 : A),
    x1 <> x2 ->
    uniq (E1 ++ (x1 ~ v1) ++ E2) ->
    E1 ++ (x1 ~ v1) ++ E2 = F1 ++ (x2 ~ v2) ++ F2 ->
    exists G1 G2, F1 = G1 ++ (x1 ~ v1) ++ G2 \/
                  F2 = G1 ++ (x1 ~ v1) ++ G2.
Proof.
  induction E1 as [| [x3 v3] E1 IH];
  intros E2 F1 F2 x1 x2 v1 v2 H1 H2 H3;
  destruct F1 as [| [x4 v4] F1];
  inversion H3; subst; simpl in *.
  - congruence.
  - exists nil, F1. intuition.
  - exists E1, E2. intuition.
  - apply uniq_cons_iff in H2 as [H6 H7].
    destruct (IH _ _ _ _ _ _ _ H1 H6 H5) as [G1 [G2 [H8 | H8]]]; subst.
    + exists ((x4 ~ v4) ++ G1), G2. intuition.
    + exists G1, G2. intuition.
Qed.


Theorem converse_negative_proposition_not_result_in_origin : (forall (P Q : Prop), ((~Q -> ~P) -> P -> Q)) -> (forall (D : Prop), (~~D -> D)).
Proof.
  intuition.
  apply (H True D).
  intros.
  apply (H0 H1).
  apply I.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e285m9_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e495m31_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e194m33_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e495m31_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e255m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.