Set Warnings "-notation-overriden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.

(* PLF Imports *)
Require Import Maps.
Require Import Imp.

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st : state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st : state),
    beval st b1 = beval st b2.

Theorem aequiv_example :
  aequiv (X - X) 0.
Proof.
  unfold aequiv.
  intros.
  simpl.
  omega.
Qed.

Theorem bequiv_example :
  bequiv (X - X = 0) true.
Proof.
  intros st.
  unfold beval.
  rewrite aequiv_example. reflexivity.
Qed.

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (c1 / st \\ st') <-> (c2 / st \\ st').

(* Simple Examples *)

Theorem skip_left : forall c,
  cequiv
    (SKIP;; c)
    c.
Proof.
  unfold cequiv.
  intros.
  split; intros H.
  - inversion H; subst. inversion H2; subst. assumption.
  - apply E_Seq with st.
    + apply E_Skip.
    + assumption.
Qed.

(* Exercise: 2 stars (skip_right) *)

Theorem skip_right: forall c,
  cequiv
    (c ;; SKIP)
    c.
Proof.
  unfold cequiv.
  intros c st st'.
  split; intros H.
  - inversion H; subst. inversion H5; subst. assumption.
  - apply E_Seq with st'.
    + assumption.
    + apply E_Skip.
Qed.

Theorem IFB_true_simple: forall c1 c2,
  cequiv
    (IFB BTrue THEN c1 ELSE c2 FI)
    c1.
Proof.
  intros c1 c2 st st'.
  split; intros H.
  - inversion H; subst; try auto.
    + inversion H5.
  - apply E_IfTrue; try auto.
Qed.

(*
Theorem: If b is equivalent to BTrue, then IFB b THEN c1 ELSE c2 FI is equivalent to c1

Proof.
  * -> We must show that for all st and st', that if IFB b THEN c1 ELSE c2 FI / st \\ st' then c1 / st \\ st'.

  Proceed by cases on the rules that could have been possibly used to show IFB b THEN c1 ELSE c2 FI / st \\ st', namely E_IfTrue and E_IfFalse.

  - Suppose the final rule in the derivation of IFB b THEN c1 ELSE c2 FI / st \\ st' was E_IfTrue. We then have, by the premises of E_IfTrue, that c1 / st \\ st'. This is exactly what we set out to prove.

  - On the other hand, suppose the final rule of the derivation of IFB b THEN c1 ELSE c2 FI / st \\ st' was E_IfFalse. We then know that beval st b = false and c2 / st \\ st'.
   Recall that b is equivalent to BTrue, that is, forall st, beval st b = beval st BTrue. In particular this means that beval st b = true, but this is a contradiction since E_IfFalse requires that beval st b = false. Thus, the final rule could not have been E_IfFalse.

  * <- We must show that for all st and st', that if c1 / st \\ st' then IFB b THEN c1 ELSE c2 FI / st \\ st'.

  Since b is equivalent to BTrue, we also know that beval st b = beval st BTrue = true.
  Togather with the assumption that c1 / st \\ st' we can apply E_IfTrue to derive that IFB b THEN c1 ELSE c2 FI / st \\ st'.
  *)

Theorem IFB_true : forall b c1 c2,
  bequiv b BTrue ->
  cequiv (IFB b THEN c1 ELSE c2 FI) c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - inversion H; subst; try auto.
    + unfold bequiv in Hb. simpl in Hb. rewrite Hb in H5. inversion H5.
  - apply E_IfTrue; try auto. unfold bequiv in Hb. simpl in Hb. apply Hb.
Qed.

(* Exercise: 2 stars, recommended (IFB false) *)
Theorem IFB_false : forall b c1 c2,
  bequiv b BFalse ->
  cequiv (IFB b THEN c1 ELSE c2 FI) c2.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - unfold bequiv in Hb. simpl in Hb. inversion H; subst; try auto.
    rewrite Hb in H5. inversion H5.
  - apply E_IfFalse; try auto. unfold bequiv in Hb. simpl in Hb. apply Hb.
Qed.

(* Exercise: 3 stars (swap_if_branches) *)
Theorem swap_if_branches : forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).
Proof.
  intros b e1 e2.
  intros st st'; split.
  - (* -> *) intros E. inversion E; subst.
    + induction b;
      try (apply E_IfFalse; auto);
      try (simpl in *; rewrite <- negb_involutive; apply f_equal; assumption).
    + induction b;
      try (apply E_IfTrue; auto);
      try (simpl in *; rewrite <- negb_involutive; apply f_equal; assumption).
  - (* <- *) intros E. inversion E; subst.
    + induction b;
      try (apply E_IfFalse; auto);
      try (simpl in *; rewrite negb_true_iff in H4; assumption).
    + induction b;
      try (apply E_IfTrue; auto);
      try (simpl in *; rewrite negb_false_iff in H4; assumption).
Qed.

Theorem WHILE_false : forall b c,
  bequiv b BFalse ->
  cequiv (WHILE b DO c END) SKIP.
Proof.
  intros b c Hb.
  intros st st'.
  split; intros H; unfold bequiv in Hb; simpl in Hb.
  - inversion H; subst.
    + apply E_Skip.
    + rewrite Hb in H2. inversion H2.
  - inversion H; subst. apply E_WhileFalse. apply Hb.
Qed.

(* Exercise: 2 stars, advanced, optional (WHILE_false_informal) *)

(*
Theorem: if b is equivalent to BFalse then (WHILE b DO c END) / st \\ st' is equivalent to SKIP / st \\ st'.

Proof:
  In order to show that if b is equivalent to BFalse then (WHILE b DO c END) / st \\ st' is equivalent to SKIP / st \\ st' we need to show that  and .

  * -> If b is equivalent to BFalse then (WHILE b DO c END) / st \\ st' implies SKIP / st \\ st'.

  + Suppose (WHILE b DO c END) / st \\ st' is derived via E_WhileFalse then st = st'. This shows SKIP / st \\ st' from the definition of E_Skip.
  + Suppose (WHILE b DO c END) / st \\ st' is derived via E_WhileTrue then that implies that beval b = true. But from our hypothesis, beval b = false, a contradiction.

  * <- If b is equivalent to BFalse then SKIP / st \\ st' implies (WHILE b DO c END) / st \\ st'.

  If we apply E_WhileFalse to (WHILE b DO c END) / st \\ st' we get st = st'. also SKIP / st \\ st' implies st = st'. Therefore (WHILE b DO c END) / st \\ st'.
*)

(* Lemma: If b is equivalent to BTrue, then it cannot be the case that (WHILE b DO c END) / st \\ st'.

  Proof: Suppose (WHILE b DO c END) / st \\ st'. We can show my induction on the derivation of (WHILE b DO c END) / st \\ st' that this assumption leads to a contradiction.

    * Suppose (WHILE b DO c END) / st \\ st' is proven by E_WhileFalse. This implies that beval b = false. But we know that b = BTrue, that means beval BTrue = false, a contradiction.
    * Suppose (WHILE b DO c END) / st \\ st' is proven by E_WhileTrue. Then we are given the induction hypothesis that (WHILE b DO c END) / st \\ st' is not true, which is exactly what we are trying to prove!
    * Since these are the only rules that could have been used to prove (WHILE b DO c END) / st \\ st', the other cases of the induction are immediately contradictory.
*)

Lemma WHILE_true_nonterm : forall b c st st',
  bequiv b BTrue ->
  ~( (WHILE b DO c END) / st \\ st' ).
Proof.
  intros b c st st' Hb.
  intros H.
  remember (WHILE b DO c END) as cw eqn:Heqcw.
  induction H;
  (* Most rules don't apply; we rule them out by inversion: *)
  inversion Heqcw; subst; clear Heqcw.
  (* The two interesting cases are the ones for WHILE loops: *)
  - (* E_WhileFalse *) (* contradictory -- b is always true! *)
    unfold bequiv in Hb.
    (* rewrite is able to instantiate the quantifier in st *)
    rewrite Hb in H. inversion H.
  - (* E_WhileTrue *) (* immediate from the IH *)
    apply IHceval2. reflexivity. Qed.

(* Exercise: 2 stars, optional (WHILE_true_nonterm_informal) *)

(* Lemma WHILE_true_nonterm means that if the term b of (WHILE b DO c END) / st \\ st' is literally equal to BTrue, then the loop will never terminate. *)

(* Exercise: 2 stars, recommended (WHILE_true) *)
Theorem WHILE_true: forall b c,
  bequiv b true ->
  cequiv
    (WHILE b DO c END)
    (WHILE true DO SKIP END).
Proof.
  intros b c Hb.
  intros st st'.
  split; intros H.
  - (* -> *) simpl. apply WHILE_true_nonterm with (c:=c) (st:=st) (st':=st') in Hb. unfold not in Hb. exfalso. apply Hb. apply H.
  - (* <- *) simpl. simpl in H. apply WHILE_true_nonterm in H.
    + exfalso. assumption.
    + unfold bequiv. intros. reflexivity.
Qed.

Theorem loop_unrolling: forall b c,
  cequiv
    (WHILE b DO c END)
    (IFB b THEN (c ;; WHILE b DO c END) ELSE SKIP FI).
Proof.
  intros b c st st'.
  remember (WHILE b DO c END) as cw eqn:Heqcw.
  split; intros H.
  - (* -> *) induction H;
    try (inversion Heqcw; subst; clear Heqcw).
    + apply E_IfFalse; auto. apply E_Skip.
    + apply E_IfTrue; auto. apply E_Seq with st'; auto.
  - (* <- *) inversion H; subst.
    + inversion H6; subst. apply E_WhileTrue with st'0; auto.
    + inversion H6; subst. apply E_WhileFalse; auto.
Qed.

(* Exercise: 2 stars, optional (seq_assoc) *)
Theorem seq_assoc : forall c1 c2 c3,
  cequiv ((c1;;c2);;c3) (c1;;(c2;;c3)).
Proof.
  intros c1 c2 c3 st st'.
  split; intros.
  - (* -> *) inversion H; subst. inversion H2; subst.
    apply E_Seq with st'1; auto. apply E_Seq with st'0; auto.
  - (* <- *) inversion H; subst. inversion H5; subst.
    apply E_Seq with st'1; auto. apply E_Seq with st'0; auto.
Qed.

Theorem identity_assignment : forall (X:string),
  cequiv
    (X ::= X)
    SKIP.
Proof.
  intros X st st'.
  split; intros H.
  - (* -> *) inversion H; subst. simpl in *.
    replace (st & {X --> st X}) with st.
    + apply E_Skip.
    + apply functional_extensionality.
      rewrite t_update_same. reflexivity.
  - (* <- *) replace st' with (st' & {X --> st' X}).
    + inversion H; subst. apply E_Ass. reflexivity.
    + apply functional_extensionality. rewrite t_update_same. reflexivity.
Qed.

(* Exercise: 2 stars, recommended (assign_aequiv) *)
Theorem assign_aequiv : forall (X:string) e,
  aequiv X e ->
  cequiv SKIP (X ::= e).
Proof.
  intros X e Ha st st'.
  split; intros H.
  - (* -> *) replace st' with (st' & {X --> st' X}).
    + inversion H; subst. apply E_Ass.
      unfold aequiv in Ha. simpl in Ha. rewrite Ha. reflexivity.
    + apply functional_extensionality. rewrite t_update_same. reflexivity.
  - (* -> *) replace st with (st & {X --> st X}).
    + inversion H; subst. unfold aequiv in Ha. simpl in Ha. rewrite Ha. apply E_Skip.
    + apply functional_extensionality. rewrite t_update_same. reflexivity.
Qed.

(* Exercise: 2 stars (equiv_classes) *)
Definition prog_a : com :=
  WHILE ! (X <= 0) DO
    X ::= X + 1
  END.
Definition prog_b : com :=
  IFB X = 0 THEN
    X ::= X + 1;;
    Y ::= 1
  ELSE
    Y ::= 0
  FI;;
  X ::= X - Y;;
  Y ::= 0.
Definition prog_c : com :=
  SKIP.
Definition prog_d : com :=
  WHILE ! (X = 0) DO
    X ::= (X * Y) + 1
  END.
Definition prog_e : com :=
  Y ::= 0.
Definition prog_f : com :=
  Y ::= X + 1;;
  WHILE ! (X = Y) DO
    Y ::= X + 1
  END.
Definition prog_g : com :=
  WHILE true DO
    SKIP
  END.
Definition prog_h : com :=
  WHILE ! (X = X) DO
    X ::= X + 1
  END.
Definition prog_i : com :=
  WHILE ! (X = Y) DO
    X ::= Y + 1
  END.

Definition equiv_classes : list (list com) :=
  [ [prog_a;prog_g;prog_f;prog_d] ;
    [prog_c;prog_h] ;
    [prog_b;prog_e] ;
    [prog_i] ].

(* Properties of Behavioral Equivalence *)
Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof.
  intros a st. reflexivity.
Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  intros a1 a2 Ha st.
  unfold aequiv in Ha. rewrite Ha. reflexivity.
Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
  aequiv a1 a2 ->
  aequiv a2 a3 ->
  aequiv a1 a3.
Proof.
  intros a1 a2 a3 Ha1 Ha2 st.
  unfold aequiv in *. rewrite Ha1. rewrite Ha2. reflexivity.
Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof.
  intros b st.
  reflexivity.
Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 ->
  bequiv b2 b1.
Proof.
  intros b1 b2 Hb st.
  unfold bequiv in Hb. rewrite Hb. reflexivity.
Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 ->
  bequiv b2 b3 ->
  bequiv b1 b3.
Proof.
  intros b1 b2 b3 Hb1 Hb2 st.
  unfold bequiv in *. rewrite Hb1. rewrite Hb2. reflexivity.
Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof.
  intros c st st'.
  split; intros H; assumption.
Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 ->
  cequiv c2 c1.
Proof.
  intros c1 c2 Hc st st'. unfold cequiv in Hc.
  split; intros H.
  - rewrite Hc; assumption.
  - rewrite <- Hc; assumption.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
  (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros P1 P2 P3 H1 H2.
  split; rewrite H1; rewrite H2; intros; assumption.
Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 ->
  cequiv c2 c3 ->
  cequiv c1 c3.
Proof.
  intros c1 c2 c3 Hc1 Hc2 st st'.
  unfold cequiv in *.
  split; intros H.
  - rewrite <- Hc2. rewrite <- Hc1. assumption.
  - rewrite Hc1. rewrite Hc2. assumption.
Qed.

(* Behavioral Equivalence is a Congruence *)

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Proof.
  intros i a1 a1' Heqv st st'.
  unfold aequiv in Heqv.
  split; intros Hceval;
  try (inversion Hceval; subst; apply E_Ass; rewrite Heqv; reflexivity).
Qed.

(* Theorem: Equivalence is a congruence for WHILE - that is, if b1 is equivalent to b1' and c1 is equivalent to c1', then WHILE b1 DO c1 END is equivalent to WHILE b1' DO c1' END.

Proof: Suppose b1 is equivalent to b1' and c1 is equivalent to c1'. We must show that for every st and st,
  WHILE b1 DO c1 END / st \\ st'
  is equivalent to
  WHILE b1' DO c1' END / st \\ st'.

  * (->) We show that WHILE b1 DO c1 END / st \\ st' implies WHILE b1' DO c1' END / st \\ st', by induction on the derivation of WHILE b1 DO c1 END / st \\ st'. The only non-trivial cases are when the final rule of the derivation is E_WhileTrue and E_WhileFalse.
    + Lets suppose that WHILE b1 DO c1 END / st \\ st' is proven by E_WhileFalse. This implies that beval b1 = false and that st = st'. This implies that beval b1' = false, since b1 and b1' are equivalent. From this we can infer that WHILE b1' DO c1' END / st \\ st'.
    + Lets suppose that WHILE b1 DO c1 END / st \\ st' is proven by E_WhileTrue. This implies that beval b1 = true and beval b1' = true, and also WHILE b1 DO c1 END / st'0 \\ st' for some st'0, with the induction hypothesis WHILE b1' DO c1' END / st'0 \\ st'.
     Since c1 and c1' are equivalent, we know that c1 / st \\ st'0. And since b1 and b1' are equivalent, we have beval b1' = true.
     Applying E_WhileTrue, we get WHILE b1' DO c1' END / st \\ st'.

  * (<-) Similar.
*)

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  unfold bequiv, cequiv.
  intros b1 b1' c1 c1' Hb Hc st st'.
  split; intros Hce.
  - (* -> *) remember (WHILE b1 DO c1 END) as cwhile eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileFalse *) apply E_WhileFalse. rewrite <- Hb. assumption.
    + (* E_WhileTrue *) apply E_WhileTrue with st'.
      * (* show loop runs *) rewrite <- Hb. assumption.
      * (* body execution *) rewrite <- Hc. assumption.
      * (* subsequent loop execution *) apply IHHce2. reflexivity.
  - (* <- *) remember (WHILE b1' DO c1' END) as cwhile eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileFalse *) apply E_WhileFalse. rewrite Hb. assumption.
    + (* E_WhileTrue *) apply E_WhileTrue with st'.
      * (* show loop runs *) rewrite Hb. assumption.
      * (* body execution *) rewrite Hc. assumption.
      * (* subsequent loop execution *) apply IHHce2. reflexivity.
Qed.

(* Exercise: 3 stars, optional (CSeq_congruence) *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  intros c1 c1' c2 c2' Hc1 Hc2 st st'.
  unfold cequiv in *.
  split; intros H.
  - (* -> *) remember (c1';;c2') as cseq eqn:Hcseq.
    inversion H; subst.
    induction H;
      try (apply E_Seq with st'0;
        try (rewrite <- Hc1; auto);
        try(rewrite <- Hc2; auto)).
   - (* <- *) remember (c1;;c2) as cseq eqn:Hcseq.
     inversion H; subst.
     induction H;
      try (apply E_Seq with st'0;
        try (rewrite Hc1; auto);
        try(rewrite Hc2; auto)).
Qed.

(* Exercise: 3 stars, (CIf_congruence) *)
Theorem CIf_congruence : forall b1 b1' c1 c1' c2 c2',
  bequiv b1 b1' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (IFB b1 THEN c1 ELSE c2 FI) (IFB b1' THEN c1' ELSE c2' FI).
Proof.
  intros b1 b1' c1 c1' c2 c2' Hb Hc1 Hc2 st st'.
  unfold bequiv, cequiv in *.
  split; intros Hceval.
  - (* -> *) remember (IFB b1' THEN c1' ELSE c2' FI) as cif eqn:Hcif.
    inversion Hceval; subst.
    + (* E_IfTrue *) apply E_IfTrue.
      * (* condition evaluation *) rewrite <- Hb. assumption.
      * (* then body *) rewrite <- Hc1. assumption.
    + (* E_IfFalse *) apply E_IfFalse.
      * (* condition evaluation *) rewrite <- Hb. assumption.
      * (* else body *) rewrite <- Hc2. assumption.
   - (* <- *) remember (IFB b1 THEN c1 ELSE c2 FI) as cif eqn:Hcif.
    inversion Hceval; subst.
    + (* E_IfTrue *) apply E_IfTrue.
      * (* condition evaluation *) rewrite Hb. assumption.
      * (* then body *) rewrite Hc1. assumption.
    + (* E_IfFalse *) apply E_IfFalse.
      * (* condition evaluation *) rewrite Hb. assumption.
      * (* else body *) rewrite Hc2. assumption.
Qed.

Example congruence_example:
  cequiv
    (* Program 1: *)
    (X ::= 0;;
     IFB X = 0
     THEN
      Y ::= 0
     ELSE
      Y ::= 42
     FI)
    (* Program 2: *)
    (X ::= 0;;
     IFB X = 0
     THEN
      Y ::= X - X (* <--- changed here *)
     ELSE
      Y ::= 42
     FI).
Proof.
  apply CSeq_congruence.
  - apply refl_cequiv.
  - apply CIf_congruence.
    + apply refl_bequiv.
    + apply CAss_congruence. unfold aequiv. simpl. symmetry. apply minus_diag.
    + apply refl_cequiv.
Qed.

(* Exercise: 3 strars, advanced, optional (not_congr) *)

(* We've shown that the cequiv relation is both an equivalence and a congruence on commands. Can you think of a relation on commands that is an equivalence but not a congruence? *)

(* Program Transformations *)

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

(* Consant-Folding Transformation *)
Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | AId i => AId i
  | APlus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => APlus a1' a2'
    end
  | AMinus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => AMinus a1' a2'
    end
  | AMult a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => AMult a1' a2'
    end
  end.

(* needed for parsing the examples below *)
Local Open Scope aexp_scope.
Local Open Scope bexp_scope.

Example fold_aexp_ex1 :
  fold_constants_aexp ((1 + 2) * X) = (3 * X).
Proof.
  reflexivity.
Qed.

Example fold_aexp_ex2 :
  fold_constants_aexp (X - ((0 * 6) + Y)) = (X - (0 + Y)).
Proof.
  reflexivity.
Qed.

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => if beq_nat n1 n2 then BTrue else BFalse
    | (a1', a2') => BEq a1' a2'
    end
   | BLe a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (ANum n1, ANum n2) => if leb n1 n2 then BTrue else BFalse
    | (a1', a2') => BLe a1' a2'
    end
   | BNot b =>
      match (fold_constants_bexp b) with
      | BTrue => BFalse
      | BFalse => BTrue
      | b' => BNot b'
      end
   | BAnd b1 b2 =>
      match (fold_constants_bexp b1, fold_constants_bexp b2) with
      | (BTrue, BTrue) => BTrue
      | (BTrue, BFalse) => BFalse
      | (BFalse, BTrue) => BFalse
      | (BFalse, BFalse) => BFalse
      | (b1', b2') => BAnd b1' b2'
      end
  end.

Example fold_bexp_ex1 :
  fold_constants_bexp (true && ! (false && true)) = true.
Proof.
  reflexivity.
Qed.

Example fold_bexp_ex2 :
  fold_constants_bexp ((X = Y) && (0 = (2 - (1 + 1)))) = ((X = Y) && true).
Proof.
  reflexivity.
Qed.

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP => SKIP
  | i ::= a => CAss i (fold_constants_aexp a)
  | c1;;c2 => (fold_constants_com c1);;(fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match (fold_constants_bexp b) with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN (fold_constants_com c1)
                     ELSE (fold_constants_com c2) FI
      end
  | WHILE b DO c END =>
      match (fold_constants_bexp b) with
      | BFalse => SKIP
      | BTrue => WHILE BTrue DO SKIP END
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    (X ::= 4 + 5;;
     Y ::= X - 3;;
     IFB (X - Y) = (2 + 4) THEN
       SKIP
     ELSE
       Y ::= 0
     FI;;
     IFB 0 <= (4 - (2 + 1))
     THEN
       Y ::= 0
     ELSE
       SKIP
     FI;;
     WHILE Y = 0 DO
       X ::= X + 1
     END)
  = (* After constant folding: *)
    (X ::= 9;;
     Y ::= X - 3;;
     IFB (X - Y) = 6 THEN
       SKIP
     ELSE
       Y ::= 0
     FI;;
     Y ::= 0;;
     WHILE Y = 0 DO
       X ::= X + 1
     END).
Proof. reflexivity. Qed.

(* Soundness of Constant Folding *)
Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  intros a st.
  induction a; auto;
    try (simpl; rewrite IHa1, IHa2;
         induction (fold_constants_aexp a1);
         induction (fold_constants_aexp a2); auto).
Qed.

(* Exercise: 3 stars, optional (fold_bexp_Eq_informal) *)

(* Theorem: The constant folding function for booleans, fold_constants_bexp, is sound.

Proof: We must show that b is equivalent to fold_constants_bexp, for all boolean expression b.

  We will do that by performing induction on b. The cases for BTrue and BFalse are trivial.

  * (BEq) In this case we must show that
    beval st (BEq a1 a2)
    = beval st (fold_constants_bexp (BEq a1 a2)).

    There are two cases to consider.
    + Suppose fold_constants_aexp a1 = ANum n1 and fold_constants_aexp a2 = ANum n2 for some n1 and n2.

    In this case we have
    fold_constants_bexp (BEq a1 a2)
    = if beq_nat n1 n2 then BTrue else BFalse

    and

    beval st (BEq a1 a2)
    = beq_nat (aeval st a1) (aeval st a2).

    By the soundness of constant folding for the arithmatic expressions (Lemma fold_constants_aexp_sound), we know
      aeval st a1
    = aeval st (fold_constants_aexp a1)
    = aeval st (ANum n1)
    = n1

    and

      aeval st a2
    = aeval st (fold_constants_aexp a2)
    = aeval st (ANum n2)
    = n2

    beval st (BEq a1 a2)
    = beq_nat n1 n2.

    Similarly,
    beval st (fold_constants_bexp (BEq a1 a2))
    = beval st (if beq_nat n1 n2 then BTrue else BFalse).

    Consider n1 = n2.

    beval st (fold_constants_bexp (BEq a1 a2))
    = beval st BTrue
    = true

  also
    beval st (BEq a1 a2)
    = beq_nat n1 n2 = true

    Similarly n1 =/= n2

    beval st (fold_constants_bexp (BEq a1 a2))
    = beval st BFalse
    = false

  also
    beval st (BEq a1 a2)
    = beq_nat n1 n2 = false

  Therefore
    beval st (BEq a1 a2)
    = beval st (fold_constants_bexp (BEq a1 a2)).

   + Otherwise one of fold_constants_aexp a1 and fold_constants_aexp a2 is not a constant. In this case we must show.

    beval st (BEq a1 a2)
    = beval st (BEq (fold_constants_aexp a1) (fold_constants_aexp a2))

    which, by the definition of beval, is the same as showing

    beq_nat (aeval st a1) (aeval st a2)
    = beq_nat (aeval st (fold_constants_aexp a1))
              (aeval st (fold_constants_aexp a2))

    By the soundness of constant folding for arithmatic expressions (Lemma fold_constants_aexp_sound), we know

    aeval st a1
    = aeval st (fold_constants_aexp a1)

    and

    aevla st a2
    = aeval st (fold_constants_aexp a2)

    Replacing these definitions in our equation we get,

    beq_nat (aeval st a1) (aeval st a2)
    = beq_nat (aeval st a1) (aeval st a2)

    thereby completing the case.
*)

Theorem fold_constants_bexp_sound :
  btrans_sound fold_constants_bexp.
Proof.
  intros b st.
  induction b; auto.
  - (* BEq *) simpl.
    rewrite fold_constants_aexp_sound;
    rewrite fold_constants_aexp_sound with (a:=a0).
    induction (fold_constants_aexp a); induction (fold_constants_aexp a0); auto.
    + (* The only interesting case is when both a1 and a2
       become constants after folding *)
      simpl. induction (n =? n0); auto.
  - (* BLe *) simpl.
    rewrite fold_constants_aexp_sound;
    rewrite fold_constants_aexp_sound with (a:=a0).
    induction (fold_constants_aexp a); induction (fold_constants_aexp a0); auto.
    + (* The only interesting case is when both a1 and a2
       become constants after folding *)
      simpl. induction (n <=? n0); auto.
  - (* BNot *) simpl. rewrite IHb.
    induction (fold_constants_bexp b); auto.
  - (* BAnd *) simpl. rewrite IHb1, IHb2.
    induction (fold_constants_bexp b1); induction (fold_constants_bexp b2); auto.
Qed.

(* Exercise: 3 stars (fold_constants_com_sound) *)

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. induction c.
  - (* SKIP *) apply refl_cequiv.
  - (* ::= *) apply CAss_congruence. apply fold_constants_aexp_sound.
  - (* ;; *) apply CSeq_congruence; auto.
  - (* IFB *) assert (bequiv b (fold_constants_bexp b)).
    { apply fold_constants_bexp_sound. }
      destruct (fold_constants_bexp b) eqn:Heqb;
        try (simpl; rewrite Heqb; apply CIf_congruence; auto).
      + simpl. rewrite Heqb. unfold cequiv in *. unfold bequiv in H.
        split; intros.
        * apply IHc1. inversion H0; subst; auto. rewrite H in H6. inversion H6.
        * simpl in *. rewrite <- IHc1 in H0. induction b; constructor; auto.
      + simpl. rewrite Heqb. unfold cequiv in *. unfold bequiv in H.
        split; intros.
        * apply IHc2. inversion H0; subst; auto. rewrite H in H6. inversion H6.
        * simpl in *. rewrite <- IHc2 in H0.
          induction b;
            try (apply E_IfFalse; auto).
  - (* WHILE *) assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. } simpl.
      destruct (fold_constants_bexp b) eqn:Heqb;
        try (apply CWhile_congruence; assumption).
      + apply WHILE_true. assumption.
      + apply WHILE_false. assumption.
Qed.

(* Exercise: 4 stars, advanced, optional (optimize_0plus) *)

(*
Fixpoint optimize_0plus (e:aexp) : aexp :=
  match e with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.
*)

Fixpoint optimize_0plus_aexp (e:aexp) : aexp :=
  match e with
  | ANum n =>
      ANum n
  | AId x =>
      AId x
  | APlus (ANum 0) e2 =>
      optimize_0plus_aexp e2
  | APlus e1 e2 =>
      APlus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  end.

Theorem optimize_0plus_aexp_sound :
  atrans_sound optimize_0plus_aexp.
Proof.
  unfold atrans_sound. intros a.
  induction a; simpl;
    try (apply refl_aequiv).
  - (* APlus *) unfold aequiv in *. intros. simpl. rewrite IHa1. rewrite IHa2.
    induction a1; induction a2; simpl;
      try (induction n; auto);
      try (auto).
  - (* AMinus *) unfold aequiv in *. intros. simpl. rewrite IHa1, IHa2. reflexivity.
  - (* AMult *) unfold aequiv in *. intros. simpl. rewrite IHa1, IHa2. reflexivity.
Qed.

Fixpoint optimize_0plus_bexp (e : bexp) : bexp :=
  match e with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BLe a1 a2 => BLe (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BNot b => BNot (optimize_0plus_bexp b)
  | BAnd b1 b2 => BAnd (optimize_0plus_bexp b1) (optimize_0plus_bexp b2)
  end.

Theorem optimize_0plus_bexp_sound :
  btrans_sound optimize_0plus_bexp.
Proof.
  unfold btrans_sound. intros b.
  induction b; simpl;
    try (apply refl_bequiv);
    try (intros st; simpl; rewrite <- optimize_0plus_aexp_sound; rewrite <- optimize_0plus_aexp_sound; reflexivity).
  - (* ! *) intros st. simpl. apply f_equal. unfold bequiv in IHb. apply IHb.
  - (* && *) unfold bequiv in *. simpl. intros st. rewrite <- IHb1. rewrite <- IHb2. reflexivity.
Qed.

Fixpoint optimize_0plus_com (c : com) : com :=
  match c with
  | SKIP => SKIP
  | x ::= a => x ::= (optimize_0plus_aexp a)
  | c1;;c2 => (optimize_0plus_com c1) ;; (optimize_0plus_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      IFB  (optimize_0plus_bexp b)
      THEN (optimize_0plus_com c1)
      ELSE (optimize_0plus_com c2) FI
  | WHILE b DO c END => WHILE (optimize_0plus_bexp b) DO (optimize_0plus_com c) END
  end.

Theorem optimize_0plus_com_sound :
  ctrans_sound optimize_0plus_com.
Proof.
  unfold ctrans_sound. intros c.
  intros st st'; split; intros H.
  - (* -> *) induction H.
    + (* SKIP *) simpl. constructor.
    + (* ::= *) simpl. constructor.  rewrite <- H. rewrite <- optimize_0plus_aexp_sound. reflexivity.
    + (* ;; *) simpl. apply E_Seq with st'; assumption.
    + (* IFB true *) simpl. apply E_IfTrue; auto.
      rewrite <- optimize_0plus_bexp_sound. assumption.
    + (* IF false *) simpl. apply E_IfFalse; auto.
      rewrite <- optimize_0plus_bexp_sound. assumption.
    + (* WHILE true *) simpl. apply E_WhileFalse. rewrite <- optimize_0plus_bexp_sound. assumption.
    + (* WHILE false *) simpl. apply E_WhileTrue with st'; auto. rewrite <- optimize_0plus_bexp_sound. assumption.
  - (* <- *) generalize dependent st. generalize dependent st'.
    induction c; intros.
    + (* SKIP *) simpl in H. assumption.
    + (* ::= *) simpl in H. inversion H; subst. rewrite <- optimize_0plus_aexp_sound. apply E_Ass. reflexivity.
    + (* ;; *) inversion H; subst. apply IHc1 in H2. apply IHc2 in H5.
    apply E_Seq with st'0; auto.
    + (* IFB *) inversion H; subst.
      * (* true *) apply E_IfTrue.
        { rewrite optimize_0plus_bexp_sound. assumption. }
        { apply IHc1 in H6. assumption. }
      * (* false *) apply E_IfFalse.
        { rewrite optimize_0plus_bexp_sound. assumption. }
        { apply IHc2 in H6. assumption. }
    + (* WHILE *) assert (bequiv b (optimize_0plus_bexp b)). {
      apply optimize_0plus_bexp_sound. }
      simpl in *. induction b.
      * exfalso. apply WHILE_true_nonterm in H; auto.
      * simpl in *. apply WHILE_false; auto. inversion H; subst.
        { constructor. }
        { inversion H3. }
      * simpl in *. inversion H; subst.
        { apply E_WhileFalse. simpl in *. rewrite <- optimize_0plus_aexp_sound in H5. rewrite <- optimize_0plus_aexp_sound in H5. assumption. }
        { apply E_WhileTrue with st'0.
          admit.
          admit.
          - simpl in *. rewrite <- optimize_0plus_aexp_sound in *. rewrite <- optimize_0plus_aexp_sound in *. unfold bequiv in *.

inversion H; subst.
      * (* false *) apply E_WhileFalse. rewrite optimize_0plus_bexp_sound. assumption.
      * (* true *)
      apply E_WhileTrue with st'0.
        { rewrite optimize_0plus_bexp_sound. assumption. }
        { apply IHc. assumption. }
        { apply IHc in H3. inversion H3; subst.
          - simpl in *. rewrite <- optimize_0plus_bexp_sound in H2. apply E_WhileTrue with st'0; auto. simpl in H6.
            +

induction b; simpl in *.
          - subst. apply WHILE_true_nonterm in H.
            + exfalso. apply H.
            + apply refl_bequiv.
          - inversion H2.
          - rewrite <- optimize_0plus_aexp_sound in H2. rewrite <- optimize_0plus_aexp_sound in H2. apply IHc in H3. inversion H3; subst.
            + simpl.
        inversion H6; subst.
          - apply E_WhileFalse. rewrite optimize_0plus_bexp_sound. assumption.
          -

Qed.


Require Import List.
Import ListNotations.

Require Import Verdi.Net.
Require Import StructTact.StructTactics.

Class TraceRelation `{State : Type} `{Event : Type} (step : step_relation State Event) :=
  {
    init : State;
    T : (list Event) -> Prop;
    T_dec : forall l, {T l} + {~ T l};
    R : State -> Prop;
    R_monotonic : forall s s' tr o, refl_trans_1n_trace step init s tr ->
                               step s s' o ->
                               R s ->
                               R s';
    T_false_init : ~ T [];
    T_implies_R : forall tr s s' o,
                    refl_trans_1n_trace step init s tr ->
                    ~ T tr ->
                    step s s' o ->
                    T (tr ++ o) ->
                    R s'
  }.

Section TraceRelations.
  Context `{TR : TraceRelation}.

  Theorem trace_relations_work :
    forall s tr,
      refl_trans_1n_trace step init s tr ->
      T tr -> R s.
  Proof using.
    intros.
    find_copy_apply_lem_hyp refl_trans_1n_n1_trace.
    remember init as s'.
    induction H1.
    - intros; exfalso; pose T_false_init; auto.
    - subst. destruct (T_dec cs); intuition eauto using R_monotonic, refl_trans_n1_1n_trace, T_implies_R.
  Qed.
End TraceRelations.


(* Piet programming language *)

(*

Coloure cycles:
* Hue Cycle: red -> yellow -> green -> cyan -> blue -> magenta -> red
* Lightness Cycle: light -> normal -> dark -> light
*)

Inductive Hue : Type :=
  | Red
  | Yellow
  | Green
  | Cyan
  | Blue
  | Magenta
  | Black
  | White
  .

Inductive Lightness : Type :=
  | Light
  | Normal
  | Dark
  .

Definition hue_cycle (h : Hue) : Hue :=
  match h with
  | Red => Yellow
  | Yellow => Green
  | Green => Cyan
  | Cyan => Blue
  | Blue => Magenta
  | Magenta => Red
  | Black => Black
  | White => White
  end.

Definition lightness_cycle (l : Lightness) : Lightness :=
  match l with
  | Light => Normal
  | Normal => Dark
  | Dark => Light
  end.

Lemma hue_one_loop (h : Hue) : (hue_cycle (hue_cycle (hue_cycle (hue_cycle (hue_cycle (hue_cycle h)))))) = h.
  destruct h.
  all: simpl.
  all: reflexivity.
Qed.

Lemma lightness_one_loop (l : Lightness) : (lightness_cycle (lightness_cycle (lightness_cycle l))) = l.
  destruct l.
  all: simpl.
  all: reflexivity.
Qed.

Lemma foo : forall A:Type, forall P:A->Prop, forall x y:A, (x=y) -> (P x = P y).
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Partial_Order.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Ensembles.
Require Export Relations_1.

Section Partial_orders.
  Variable U : Type.

  Definition Carrier := Ensemble U.

  Definition Rel := Relation U.

  Record PO : Type := Definition_of_PO
    { Carrier_of : Ensemble U;
      Rel_of : Relation U;
      PO_cond1 : Inhabited U Carrier_of;
      PO_cond2 : Order U Rel_of }.
  Variable p : PO.

  Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y.

  Inductive covers (y x:U) : Prop :=
    Definition_of_covers :
    Strict_Rel_of x y ->
    ~ (exists z : _, Strict_Rel_of x z /\ Strict_Rel_of z y) ->
    covers y x.

End Partial_orders.

Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets v62.
Hint Resolve Definition_of_covers: sets v62.

Section Partial_order_facts.
  Variable U : Type.
  Variable D : PO U.

  Lemma Strict_Rel_Transitive_with_Rel :
    forall x y z:U,
      Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
  Proof.
    unfold Strict_Rel_of at 1 in |- *.
    red in |- *.
    elim D; simpl in |- *.
    intros C R H' H'0; elim H'0.
    intros H'1 H'2 H'3 x y z H'4 H'5; split.
    apply H'2 with (y := y); tauto.
    red in |- *; intro H'6.
    elim H'4; intros H'7 H'8; apply H'8; clear H'4.
    apply H'3; auto.
    rewrite H'6; tauto.
  Qed.

  Lemma Strict_Rel_Transitive_with_Rel_left :
    forall x y z:U,
      Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
  Proof.
    unfold Strict_Rel_of at 1 in |- *.
    red in |- *.
    elim D; simpl in |- *.
    intros C R H' H'0; elim H'0.
    intros H'1 H'2 H'3 x y z H'4 H'5; split.
    apply H'2 with (y := y); tauto.
    red in |- *; intro H'6.
    elim H'5; intros H'7 H'8; apply H'8; clear H'5.
    apply H'3; auto.
    rewrite <- H'6; auto.
  Qed.

  Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D).
    red in |- *.
    intros x y z H' H'0.
    apply Strict_Rel_Transitive_with_Rel with (y := y);
      [ intuition | unfold Strict_Rel_of in H', H'0; intuition ].
  Qed.
End Partial_order_facts.


From Coq.Logic Require Import ConstructiveEpsilon.
Require Import Lia Nat.
From stdpp Require Import numbers list list_numbers.
From Undecidability Require Import SemiDecidabilityFacts DecidabilityFacts EnumerabilityFacts halting reductions Axioms.axioms.

(** * CT in relation to other axioms  *)

(** ** Provable choice axioms  *)

Lemma decidable_AC X :
  forall R : X -> nat -> Prop, decidable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  destruct (decider_AC _ f R) as [g Hg]; eauto.
Qed.

Lemma semi_decidable_AC X :
  forall R : X -> nat -> Prop, semi_decidable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  destruct (semi_decider_AC _ f R) as [g Hg]; eauto.
Qed.

Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros Hp Hq Hpq.
  edestruct (semi_decidable_AC X (fun x n => if n is 0 then p x else q x)) as [f Hf].
  - destruct Hp as [f1 H1], Hq as [f2 H2]. red in H1, H2.
    exists (fun '(x,n) m => if n is 0 then f1 x m else f2 x m).
    now intros (x,[]); cbn; rewrite ?H1, ?H2.
  - intros x. destruct (Hpq x). now exists 0. now exists 1.
  - exists (fun x => if f x is 0 then true else false). intros x.
    specialize (Hf x). destruct (f x); firstorder.
Qed.

Lemma inspect_opt {X} (o : option X) :
  {x | o = Some x} + {o = None}.
Proof.
  destruct o; eauto.
Qed.

Lemma enumerable_AC :
  forall X, discrete X -> forall Y, forall R : X -> Y -> Prop, enumerable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros X [d Hd] Y R [f Hf] Htot.
  destruct (enumerator_AC _ _ f d _ Hd Hf Htot) as [g Hg].
  now exists g.
Qed.

(** ** Extensionality axioms  *)

Definition Fext := forall X Y (f g : X -> Y), (forall x, f x = g x) -> f = g.
Definition Pext := forall P Q : Prop, P <-> Q -> P = Q.
Definition hProp (P : Prop) := forall x1 x2 : P, x1 = x2.
Definition PI := forall P : Prop, hProp P.

Lemma Pext_to_PI :
  Pext -> PI.
Proof.
  intros pext P x1 x2.
  assert (P = True) as -> by firstorder.
  now destruct x1, x2.
Qed.

Lemma hProp_disj P Q :
  hProp P -> hProp Q -> ~ (P /\ Q) -> hProp (P \/ Q).
Proof.
  unfold hProp.
  intros hP hQ H [H1 | H1] [H2 | H2]; f_equal; firstorder; exfalso; tauto.
Qed.

Lemma Fext_hProp_neg P :
  Fext -> hProp (~ P).
Proof.
  intros fext H1 H2.
  eapply fext. intros x. exfalso. tauto.
Qed.

Lemma Fext_hProp_disj P :
  Fext -> hProp P -> hProp (P \/ ~ P).
Proof.
  intros. now eapply hProp_disj; [ | eapply Fext_hProp_neg | ].
Qed.

Lemma Fext_hProp_wdisj P :
  Fext -> hProp (~ P \/ ~~ P).
Proof.
  intros. now eapply Fext_hProp_disj; [ | eapply Fext_hProp_neg].
Qed.

Section CT_wrong.

  Variable model : model_of_computation.

  Definition CT_Sigma := forall f : nat -> nat, {n : nat | computes n f }.

  Lemma CT_Sigma_wrong : CT_Sigma -> Fext -> False.
  Proof.
    intros CT fext.
    eapply K_forall_undec. eapply CT_to_EA. { intros f. destruct (CT f) as [c Hc]. exists c. eapply Hc. }
    exists (fun f => Nat.eqb (proj1_sig (CT f)) (proj1_sig (CT (fun _ => 0)))).
    intros f.
    destruct (PeanoNat.Nat.eqb_spec (` (CT f)) (` (CT (fun _ : nat => 0)))).
    - unfold reflects. intuition.
      destruct (CT f) as [cf Hf].
      destruct (CT (fun _ => 0)) as [cc Hc]. cbn in *. subst.
      exact (computes_ext _ _ _ Hf Hc n).
    - unfold reflects. intuition try congruence.
      assert (f = fun x => 0) as -> by now apply fext.
      congruence.
  Qed.

End CT_wrong.

(** ** Classical logical axioms  *)

Definition LEM := forall P, P \/ ~ P.
Definition DNE := forall P, ~~P -> P.
Definition DGP := forall P Q : Prop, (P -> Q) \/ (Q -> P).
Definition WLEM := forall P, ~~P \/ ~ P.

Definition IP := forall (P : Prop), forall p : nat -> Prop, (P -> exists n, p n) -> exists n, P -> p n.

Lemma LEM_to_DGP :
  LEM -> DGP.
Proof.
  intros H P Q.
  destruct (H P), (H Q); tauto.
Qed.

Lemma DGP_to_WLEM :
  DGP -> WLEM.
Proof.
  intros H P.
  destruct (H P (~ P)); tauto.
Qed.

Lemma LEM_to_IP : LEM -> IP.
Proof.
  intros H P p.
  destruct (H P) as [H0 | H0].
  - intros [n H1] % (fun H1 => H1 H0). eauto.
  - exists 0. tauto.
Qed.

(*

    LEM --> DGP --> WLEM
     |               |
     |               |
     v               v
    LPO     -->    WLPO   -->   LLPO
     ^               ^
     |               |
     v               v
  MP /\ WLPO     PFP /\ LLPO

     ^
     |

  MP /\ IP

 *)

Definition LPO := forall f : nat -> bool, (exists n, f n = true) \/ ~ (exists n, f n = true).
Definition WLPO := forall f : nat -> bool, (forall n, f n = false) \/ ~ (forall n, f n = false).

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  split.
  - intros H [n Hn]. rewrite H in Hn. congruence.
  - intros H n. destruct (f n) eqn:E; try reflexivity.
    destruct H. eauto.
Qed.

Lemma LEM_to_LPO : LEM -> LPO.
Proof.
  cbv. intuition.
Qed.

Lemma WLEM_to_WLPO : WLEM -> WLPO.
Proof.
  intros H f. rewrite forall_neg_exists_iff.
  edestruct H; eauto.
Qed.

Lemma LPO_to_WLPO : LPO -> WLPO.
Proof.
  intros H f. rewrite forall_neg_exists_iff.
  edestruct H; eauto.
Qed.

Definition LPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, p x \/ ~ p x.

Lemma LPO_semidecidable_iff :
  LPO <-> LPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. eapply H.
  - intros H f.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~ p x \/ ~~ p x.

Lemma WLPO_semidecidable_iff :
  WLPO <-> WLPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite <- forall_neg_exists_iff.
    eapply H.
  - intros H f.
    rewrite forall_neg_exists_iff.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_cosemidecidable := forall X (p : X -> Prop), co_semi_decidable p -> forall x, p x \/ ~ p x.

Lemma WLPO_cosemidecidable_iff :
  WLPO_cosemidecidable <-> WLPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite <- forall_neg_exists_iff.
    eapply (H _ (fun x => forall n, f x n = false)).
    exists f. red. reflexivity.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite forall_neg_exists_iff.
    eapply (H _ (fun x => exists n, f x n = true)).
    exists f. intros x'. reflexivity.
Qed.

Definition LLPO := forall f g : nat -> bool, ((exists n, f n = true) -> (exists n, g n = true)) \/ ((exists n, g n = true) -> (exists n, f n = true)).
Definition DM_Sigma_0_1 := forall f g : nat -> bool, ~ ((exists n, f n = true) /\ (exists n, g n = true)) -> ~ (exists n, f n = true) \/ ~ (exists n, g n = true).
Definition DGP_sdec := forall X (p : X -> Prop), semi_decidable p -> forall x y, (p x -> p y) \/ (p y -> p x).
Definition DM_sdec := forall X (p q : X -> Prop), semi_decidable p -> semi_decidable q -> forall x, ~ (p x /\ q x) -> ~ p x \/ ~ q x.
Definition LLPO_split := forall f : nat -> bool, (forall n m, f n = true -> f m = true -> n = m) -> (forall n, f (2 * n) = false) \/ (forall n, f (1 + 2 * n) = false).

Lemma LLPO_to_DM_Sigma_0_1 :
  LLPO -> DM_Sigma_0_1.
Proof.
  intros H f g Hfg.
  destruct (H f g); tauto.
Qed.

Lemma LLPO_iff_DGP_sdec :
  LLPO <-> DGP_sdec.
Proof.
  split.
  - intros H X p [f Hf] x y.
    unfold semi_decider in *.
    rewrite !Hf. eapply H.
  - intros H f g.
    unshelve eapply (H bool (fun b => if b then exists n, f n = true else exists n, g n = true) _ true false).
    + exists (fun b : bool => if b then f else g). red. intros []; reflexivity.
Qed.

Lemma DM_Sigma_0_1_iff_DM_sdec :
  DM_Sigma_0_1 <-> DM_sdec.
Proof.
  split.
  - intros H X p q [f Hf] [g Hg] x.
    unfold semi_decider in *.
    rewrite Hf, Hg. eapply H.
  - intros H f g Hfg.
    eapply (H unit (fun _ => exists n, f n = true) (fun _ => exists n, g n = true)).
    + exists (fun _ => f). red. reflexivity.
    + exists (fun _ => g). red. reflexivity.
    + econstructor.
    + eassumption.
Qed.

Lemma neg_neg_XM P :
  ~~ (P \/ ~ P).
Proof.
  tauto.
Qed.

Lemma DM_Sigma_0_1_iff_totality :
  DM_Sigma_0_1 <-> (forall X (R : X -> bool -> Prop), co_semi_decidable (curry R) -> forall n, ~~ (exists b, R n b) -> exists b, R n b).
Proof.
  split.
  - intros H X R [f Hf'] n.
    assert (Hf : forall n b, R n b <-> forall m, f (n, b) m = false) by (intros; eapply (Hf' (_, b))).
    setoid_rewrite Hf. clear - H. intros Hb.
    destruct (H (f (n, true)) (f (n, false))) as [H1 | H1].
    + intros [ [n1 ?] [n2 ?]]. eapply Hb. intros [[] ?]; congruence.
    + exists true. now eapply forall_neg_exists_iff.
    + exists false. now eapply forall_neg_exists_iff.
  - intros H f g Hfg.
    edestruct (H nat (fun _ b => if b then forall n, f n = false else forall n, g n = false)) with (n := 0) as [[] H1].
    + exists (fun '(n,b) => if b : bool then f else g). now intros (n, []).
    + intros H0. eapply (neg_neg_XM (exists n, f n = true)). intros [H1 | H1].
      * eapply (neg_neg_XM (exists n, g n = true)). intros [H2 | H2].
        -- eauto.
        -- eapply H0. exists false. now eapply forall_neg_exists_iff.
      * eapply H0. exists true. now eapply forall_neg_exists_iff.
    + left. now eapply forall_neg_exists_iff.
    + right. now eapply forall_neg_exists_iff.
Qed.

Lemma DM_Sigma_0_1_to_LLPO_split :
  DM_Sigma_0_1 -> LLPO_split.
Proof.
  intros H f Huni.
  destruct (H (fun n => f (2 * n)) (fun n => (f (1 + 2 * n)))).
  - intros [[n Hn] [m Hm]].
    eapply Huni in Hn; eauto. lia.
  - left. now rewrite forall_neg_exists_iff.
  - right. now rewrite forall_neg_exists_iff.
Qed.

Lemma dec_bounded_quant P n :
  (forall m, m <= n -> P m \/ ~ P m) -> (forall m, m <= n -> ~ P m) \/ exists m, m <= n /\ P m.
Proof.
  intros H.
  induction n.
  - destruct (H 0 (Nat.le_refl 0)).
    + right. exists 0. split. lia. eauto.
    + left. intros m Hm. enough (m = 0) by now subst. lia.
  - destruct IHn as [H1 | [m [Hle Hm]]].
    + intros. eapply H. lia.
    + destruct (H (S n) (Nat.le_refl _)).
      * right. eauto.
      * left. intros m [Hle |  ->] % le_lt_or_eq; eauto.
        eapply H1. lia.
    + right. exists m. split. lia. eassumption.
Qed.

Lemma least_ex (P : nat -> Prop) n : P n -> (forall m, m < n -> P m \/~ P m) -> exists n, P n /\ forall m, P m -> m >= n.
Proof.
  induction n using lt_wf_rec.
  intros Hn Hlt.
  destruct n.
  - exists 0. split. eauto. intros. lia.
  - edestruct dec_bounded_quant with (n := n).
    + intros. eapply (Hlt m). lia.
    + exists (S n). split. eauto. intros.
      destruct (le_lt_dec (S n) m); eauto. eapply H0 in H1; lia.
    + destruct H0 as (m & Hle & Hm).
      eapply (H m).
      * lia.
      * eassumption.
      * intros. eapply Hlt. lia.
Qed.

Lemma LLPO_split_to_LLPO :
  LLPO_split -> LLPO.
Proof.
  intros H f g.
  pose (alpha := (fun n => if n `mod` 2 =? 0 then f (n `div` 2) else g (n `div` 2))).
  pose (alpha' n := alpha n && forallb negb (map alpha (seq 0 n))).
  destruct (H alpha') as [H0 | H0].
  - intros n m [Ha1 Ha2] % andb_true_iff [Ha3 Ha4] % andb_true_iff.
    destruct (lt_eq_lt_dec n m) as [ [Hl | ] | Hl]; eauto.
    + rewrite forallb_forall in Ha4.
      setoid_rewrite in_map_iff in Ha4.
      setoid_rewrite in_seq in Ha4.
      enough (false = true) by congruence.
      eapply (Ha4 true). cbn. exists n. repeat split; eauto with arith.
    + rewrite forallb_forall in Ha2.
      setoid_rewrite in_map_iff in Ha2.
      setoid_rewrite in_seq in Ha2.
      enough (false = true) by congruence.
      eapply (Ha2 true). cbn. exists m. repeat split; eauto with arith.
  - left. intros [m Hm].
    destruct (least_ex (fun n => f n = true) _ Hm) as [n [Hn Hle]].
    { intros x. destruct (f x); firstorder congruence. }
    clear m Hm.
    assert (alpha (n * 2) = true). {
      unfold alpha. rewrite Nat.mod_mul. rewrite Nat.eqb_refl.
      rewrite Nat.div_mul. eauto. lia. lia.
    }
    destruct (dec_bounded_quant (fun n => g n = true) n).
    + intros m ?; destruct (g m); firstorder congruence.
    + exfalso. enough (alpha' (2 * n) = true). rewrite H0 in H3. congruence.
      rewrite mult_comm. unfold alpha'.
      eapply andb_true_iff. split. eauto.
      eapply forallb_forall.
      intros b. rewrite in_map_iff. setoid_rewrite in_seq.
      intros [k [H3 [_ H4] ]]. destruct b; try reflexivity.
      unfold alpha in H3.
      exfalso. destruct (k `mod` 2) eqn:Em.
      * cbn [Nat.eqb] in H3. eapply Hle in H3. cbn in H4.
        pose proof (Nat.div_lt_upper_bound k 2 n).
        lia.
      * cbn [Nat.eqb] in H3. eapply H2 in H3. lia.
        eapply Nat.div_le_upper_bound. lia. lia.
    + firstorder.
  - right. intros [m Hm].
    destruct (least_ex (fun n => g n = true) _ Hm) as [n [Hn Hle]].
    { intros x. destruct (g x); firstorder congruence. }
    clear m Hm.
    assert (alpha (1 + n * 2) = true). {
      unfold alpha. rewrite Nat.mod_add; try lia.
      change (1 `mod` 2 =? 0) with false. hnf.
      rewrite Nat.div_add. cbn. eauto. lia.
    }
    destruct (dec_bounded_quant (fun n => f n = true) (S n)).
    + intros m ?; destruct (f m); firstorder congruence.
    + exfalso. enough (H3 : alpha' (1 + 2 * n) = true). rewrite H0 in H3. congruence.
      rewrite mult_comm. unfold alpha'.
      eapply andb_true_iff. split. eauto.
      eapply forallb_forall.
      intros b. rewrite in_map_iff. setoid_rewrite in_seq.
      intros [k [H3 [_ H4] ]]. destruct b; try reflexivity.
      unfold alpha in H3.
      exfalso. destruct (k `mod` 2) eqn:Em.
      * cbn [Nat.eqb] in H3. eapply H2 in H3. cbn in H4. eauto.
        eapply Nat.div_le_upper_bound. lia. lia.
      * cbn [Nat.eqb] in H3. eapply Hle in H3. cbn in H4.
        rewrite Nat.mod_eq in Em; lia.
    + firstorder.
Qed.

Definition PFP := forall f : nat -> bool, exists g : nat -> bool, (forall n, f n = false) <-> exists n, g n = true.

Lemma WLPO_PFP_LLPO_iff :
  WLPO <-> PFP /\ LLPO.
Proof.
  split.
  - intros H. split.
    + intros f. destruct (H f).
      * exists (fun _ => true).
        split.
        -- now exists 0.
        -- eauto.
      * exists (fun _ => false).
        split.
        -- tauto.
        -- intros [? [=]].
    + eapply LLPO_split_to_LLPO, DM_Sigma_0_1_to_LLPO_split.
      intros f g Hfg.
      destruct (H f).
      * left. firstorder congruence.
      * destruct (H g).
        -- right. firstorder congruence.
        -- left. intros Hf.
           assert (H2 : ~~ ((exists n, g n = true) \/ ~ (exists n, g n = true))) by tauto.
           eapply H2. intros [Hg | Hg].
           now eapply Hfg. now rewrite <- forall_neg_exists_iff in Hg.
  - intros [PFP LLPO % LLPO_to_DM_Sigma_0_1] f.
    destruct (PFP f) as [g Hg].
    destruct (LLPO f g).
    + rewrite <- Hg. intros [[n Hn] H]. rewrite H in Hn. congruence.
    + left. now rewrite forall_neg_exists_iff.
    + right. now rewrite <- Hg in H.
Qed.

Definition KS := forall P, exists f : nat -> bool, P <-> exists n, f n = true.

Lemma LEM_to_KS :
  LEM -> KS.
Proof.
  intros xm P.
  destruct (xm P) as [H | H].
  - exists (fun _ => true). firstorder. econstructor.
  - exists (fun _ => false). firstorder.
Qed.

Lemma KS_LPO_to_LEM :
  KS -> LPO -> LEM.
Proof.
  intros ks lpo P.
  destruct (ks P) as [f ->].
  eapply lpo.
Qed.

Lemma KS_WLPO_to_WLEM :
  KS -> LPO -> LEM.
Proof.
  intros ks lpo P.
  destruct (ks P) as [f ->].
  eapply lpo.
Qed.

Lemma KS_LLPO_to_DGP :
  KS -> LLPO -> DGP.
Proof.
  intros ks lpo P Q.
  destruct (ks P) as [f ->].
  destruct (ks Q) as [g ->].
  eapply lpo.
Qed.

(** ** Axioms of russian constructivism  *)

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

Definition MP_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~~ p x -> p x.
Definition Post_logical := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> forall x, p x \/ ~ p x.
Definition Post := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> decidable p.

Lemma LPO_MP_WLPO_iff :
  LPO <-> MP /\ WLPO.
Proof.
  split.
  - intros H. split.
    + intros f Hf. destruct (H f); tauto.
    + intros f. rewrite forall_neg_exists_iff. destruct (H f); tauto.
  - intros [MP WLPO] f.
    destruct (WLPO f).
    + right. now rewrite <- forall_neg_exists_iff.
    + left. eapply MP. now rewrite <- forall_neg_exists_iff.
Qed.

Lemma MP_IP_LPO : IP -> MP -> LPO.
Proof.
  intros IP MP f.
  assert (exists n, forall k, f k = true -> f n = true) as [n Hn].
  - specialize (MP f). apply IP in MP as [n Hn].
    exists n. intros k H. apply Hn. intros H'. apply H'. now exists k.
  - destruct (f n) eqn:E.
    + eauto.
    + right. intros [m Hm].
      specialize (Hn m Hm). congruence.
Qed.

Lemma MP_to_MP_semidecidable :
  MP -> MP_semidecidable.
Proof.
  intros H X p [f Hf] x. red in Hf.
  rewrite Hf. eapply H.
Qed.

Definition MP_semidecidable_ex := forall (p : nat -> Prop), semi_decidable p -> ~~ (exists x, p x) -> exists x, p x.

Lemma MP_semidecidable_to_MP_semidecidable_ex :
  MP_semidecidable -> MP_semidecidable_ex.
Proof.
  intros mp p [f Hf]. red in Hf. setoid_rewrite Hf.
  eapply (mp unit (fun _ => exists x n, f x n = true)).
  exists (fun _ => fun! ⟨x,n⟩ => f x n). intros _.
  split.
  - intros (x & n & Hxn). exists ⟨x,n⟩. now rewrite embedP.
  - intros (xn & Hxn). destruct (unembed xn) as [x n]. eauto.
  - exact tt.
Qed.

Lemma MP_semidecidable_ex_to_MP_semidecidable :
  MP_semidecidable_ex -> MP_semidecidable.
Proof.
  intros mp X p [f Hf] x. red in Hf. setoid_rewrite Hf.
  eapply mp. eapply decidable_semi_decidable.
  exists (fun x0 => f x x0). intros ?. red. reflexivity.
Qed.

Lemma MP_semidecidable_to_Post_logical :
  MP_semidecidable -> Post_logical.
Proof.
  intros H X p Hp Hcp x. pattern x.
  eapply H.
  - now eapply semi_decidable_or.
  - tauto.
Qed
.
Definition MP_enumerable_ex := forall X (p : X -> Prop), enumerable p -> ~~ (exists x, p x) -> exists x, p x.

Lemma MP_semi_decidable_enumerable :
  MP_semidecidable_ex -> MP_enumerable_ex.
Proof.
  intros mp X p [f Hf]. red in Hf.
  setoid_rewrite Hf. intros H.
  destruct (mp (fun n => f n <> None)) as [n Hn].
  - eapply decidable_semi_decidable. eapply decidable_iff.
    econstructor. intros n. destruct (f n); firstorder.
  - intros HH. apply H. intros (x & n & HHH). eapply HH. exists n. congruence.
  - destruct (f n) eqn:E; try congruence. now exists x, n.
Qed.

Lemma MP_enumerable_semi_decidable :
  MP_enumerable_ex -> MP_semidecidable_ex.
Proof.
  intros mp p Hp.
  eapply mp. eapply semi_decidable_enumerable; eauto.
Qed.

Lemma Post_logical_to_Post :
  Post_logical -> Post.
Proof.
  intros H X p Hp Hcp.
  destruct (sdec_compute_lor Hp Hcp) as [f Hf].
  - eapply H; eauto.
  - exists f. intros x. red. specialize (Hf x). destruct (f x); firstorder congruence.
Qed.

Lemma Post_to_MP :
  Post -> MP.
Proof.
  intros H f Hf.
  destruct (H unit (fun _ => exists n, f n = true)) as [d Hd].
  - exists (fun _ => f). now intros x.
  - exists (fun _ _ => false). firstorder.
  - destruct (decider_decide Hd tt); tauto.
Qed.

Lemma semi_decidable_ext {X} (p q : X -> Prop) :
  p ≡{X -> Prop} q -> semi_decidable p -> semi_decidable q.
Proof.
  intros H [f Hf]. exists f. intros x. cbv -[iff] in H.
  rewrite <- H. eapply Hf.
Qed.

Lemma MP_iff_sdec_weak_total :
  MP_semidecidable <-> (forall X (R : X -> bool -> Prop), semi_decidable (curry R) -> forall x, ~~ (exists b, R x b) -> exists b, R x b).
Proof.
  split.
  - intros H X R [f Hf] x Hx.
    eapply H with (x := x).
    eapply semi_decidable_ext.
    2: eapply (@semi_decidable_or _ (fun x => R x true) (fun x => R x false)).
    + clear. intros x. split. firstorder. intros [[] ?]; firstorder.
    + exists (fun x n => f (x, true) n). intros x0. red in Hf.
      now rewrite (Hf (x0, true)).
    + exists (fun x n => f (x, false) n). intros x0. red in Hf.
      now rewrite (Hf (x0, false)).
    + eassumption.
  - intros H X p [f Hf] x Hx.
    edestruct (H X (fun x b => p x)).
    + exists (fun '(x, b) n => f x n). intros (?, b). cbn. eapply Hf.
    + intros Hp. eapply Hx. intros Hpx. eapply Hp. exists true. eassumption.
    + eassumption.
Qed.

Lemma MP_cosdec_to_sdec :
  MP ->
  (forall X (p : X -> Prop), co_semi_decidable p -> semi_decidable (compl p)).
Proof.
  intros mp X p [f Hf]. exists f. unfold semi_decider, compl.
  intros x. red in Hf. rewrite Hf. rewrite forall_neg_exists_iff.
  split; eauto.
Qed.

Lemma DNE_sdec_to_cosdec :
  DNE ->
  (forall X (p : X -> Prop), semi_decidable (compl p) -> co_semi_decidable p).
Proof.
  intros mp X p [f Hf]. exists f. unfold semi_decider, compl in *.
  intros x. rewrite forall_neg_exists_iff. rewrite <- Hf.
  split; eauto. eapply mp.
Qed.

Require Import Undecidability.Synthetic.FinitenessFacts.

Require Import Undecidability.Shared.Dec.

Lemma semi_decidable_generative (p : nat -> Prop) :
  MP -> semi_decidable p ->
  ~ exhaustible p -> generative p.
Proof.
  intros mp % MP_to_MP_semidecidable % MP_semidecidable_to_MP_semidecidable_ex Hs Hl l.
  eapply mp.
  - eapply semi_decidable_and. eauto. eapply decidable_semi_decidable, decidable_complement, listable_decidable.
    eapply discrete_nat. exists l. red. reflexivity.
  - apply non_finite_spec; eauto. intros. destruct (Nat.eqb_spec x1 x2); firstorder.
Qed.

(*
Lemma rev :
  (forall X (p : X -> Prop), discrete X -> semi_decidable p -> ~ exhaustible p -> generative p) ->
  MP_semidecidable.
Proof.
  intros H X p Hp x Hx.
  destruct (P_inf_spec (p x)) as [_ [HH | HH]]; try tauto.
  eapply unbounded_inhabited, generative_unbounded, H.
  - exact discrete_nat.
  - eapply decidable_semi_decidable. exists Nat.even.
    intros n. red. unfold P_inf. destruct Nat.even; try now firstorder congruence.
*)

(** ** Choice axioms *)

Definition AC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC := forall X Y, AC_on X Y.

Definition AUC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists! y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC_0_0 :=
  AC_on nat nat.

Definition AC_1_0 :=
  AC_on (nat -> nat) nat.

Definition ADC_on X := forall R : X -> X -> Prop, forall x0, (forall x, exists x', R x x') -> exists f : nat -> X, f 0 = x0 /\ forall n, R (f n) (f (S n)).

Definition ADC := forall X, ADC_on X.
Definition ACC := forall X, AC_on nat X.

Lemma total_list {X Y} {R : X -> Y -> Prop} L :
  (forall x, exists y, R x y) -> exists L', Forall2 R L L'.
Proof.
  intros HTot. induction L as [ | x L [L' IH]].
  - exists []. econstructor.
  - destruct (HTot x) as [y H]. exists (y :: L').
    now econstructor.
Qed.

Lemma AC_rel_to_ADC : forall X, AC_on X X -> ADC_on X.
Proof.
  intros X C R x0 Htot.
  eapply C in Htot as [f].
  exists (fun n => Nat.iter n f x0).
  split. reflexivity. intros n. eapply H.
Qed.

Goal AC -> ADC.
Proof.
  intros ? X Inh.
  eapply AC_rel_to_ADC, H.
Qed.

Goal ADC -> ACC.
Proof.
  intros C X R Htot.
  destruct (Htot 0) as [y0 Hy0].
  unshelve specialize (C (∑ '(n, x), R n x) (fun '(exist _  (n, x) H) '(exist _ (m, y) H2) => m = S n)) as [f].
  - eexists (_, _). eauto.
  - intros [(n, x) H]. destruct (Htot (S n)) as [y Hy]. now exists (exist _ (S n, y) Hy).
  - destruct H as [H0 H].
    pose (N n := fst (proj1_sig (f n))).
    pose (s n := snd (proj1_sig (f n))).
    assert (HN : forall n, N (S n) = S (N n)). {
      intros n. cbv.
      pose proof (H (S n)) as Hsn.
      pose proof (H n) as Hn.
      destruct (f n) as [(m', y') H'].
      destruct (f (S n)) as [(m, y) Hmy]. eassumption.
    }
    assert (HN0 : forall n, N n = N 0 + n) by (induction n; rewrite ?HN; lia).
    assert (H1 : forall n, R (N n) (s n)). {
      intros n. unfold N, s.
      specialize (H n).
      destruct (f n) as [(m, y) Hmy]. exact Hmy.
    }
    pose proof (total_list (seq 0 (N 0)) Htot) as [L' HL'].
    exists (fun n => if le_lt_dec (N 0) n is left _ then s (n - N 0) else (nth n L' (s 0))). intros n.
    destruct (le_lt_dec (N 0) n) as [Hl | Hl].
    + specialize (H1 (n - N 0)). rewrite HN0 in H1.
      now replace n with (N 0 + (n - N 0)) at 1 by lia.
    + rewrite nth_lookup.
      destruct (L' !! n) as [x|] eqn:E.
      * cbn.
        edestruct (Forall2_lookup_l R (seq 0 (N 0)) L') as [? []]. eassumption.
        rewrite lookup_seq; eauto.
        rewrite E in H2. inv H2. eassumption.
      * eapply lookup_ge_None in E. erewrite <- Forall2_length in E; eauto.
        rewrite seq_length in E. lia.
Qed.

Goal ACC -> AC_0_0.
Proof.
  unfold ACC, AC_0_0.
  intros H. eapply H.
Qed.

Goal AC_1_0 -> AC_0_0.
Proof.
  intros C R Htot.
  destruct (C (fun g x => R (g 0) x)) as [f].
  - intros g. eapply Htot.
  - exists (fun x => f (fun _ => x)).
    intros x. eapply (H (fun _ => x)).
Qed.

Lemma Diaconescu :
  (forall X Y, AC_on X Y) -> Fext -> Pext -> LEM.
Proof.
  intros C fext pext P.
  pose (U (x : bool) := x = true \/ P).
  pose (V (x : bool) := x = false \/ P).
  destruct (C ({ p : bool -> Prop | p = U \/ p = V}) bool (fun p b => (proj1_sig p b))) as [f Hf].
  - intros (p & [-> | ->]); cbn.
    + exists true. now left.
    + exists false. now left.
  - pose proof (Hf (exist _ U (or_introl eq_refl))) as H1.
    pose proof (Hf (exist _ V (or_intror eq_refl))) as H2. cbn in *.
    assert (f (exist _ U (or_introl eq_refl)) <> f (exist _ V (or_intror eq_refl)) \/ P) as [H3 | H3]; eauto.
    {
      destruct H1 as [H1 | H1], H2 as [H2 | H2]; eauto.
      firstorder congruence.
    }
    right. intros H.
    assert (U = V) as ->. {
      eapply fext. intros b. eapply pext.
      unfold U, V. intuition.
    }
    eapply H3. repeat f_equal.
    eapply (Pext_to_PI pext).
Qed.

(* *** Compatibility  *)

Lemma enumerable_code (ax : EA) p :
  enumerable p -> exists c, enumerator (proj1_sig ax c) p.
Proof.
  rewrite (W_spec ax p). unfold W. cbn.
  intros [c H]. exists c. intros x.
  now rewrite H.
Qed.

Lemma AC_1_0_Fext :
  AC_1_0 -> Fext -> EA -> decidable (compl K_nat).
Proof.
  intros C Fext EA.
  pose proof (fun f => enumerable_code EA _ (enumerable_graph' f)).
  eapply C in H as [code Hcode].
  exists (fun f => Nat.eqb (code f) (code (fun _ => 0))).
  eapply Proper_decider. intros ?. reflexivity.
  eapply (K_nat_equiv_compl EA).
  intros f. split; rewrite NPeano.Nat.eqb_eq.
  - intros E.
    eapply f_equal, Fext, E.
  - intros E n.
    generalize (Hcode f), (Hcode (fun _ => 0)).
    rewrite E. clear E.
    intros Hf H.
    pose proof(enumerator_ext Hf H (ltac:(reflexivity)) ⟨ n, f n ⟩) as E.
    destruct E as [[x E%(f_equal unembed)] _]; eauto.
    rewrite !embedP in E. now inv E.
Qed.

Lemma AC_1_0_Fext_incompat :
  AC_1_0 -> Fext -> EA -> False.
Proof.
  intros C Fext EA.
  eapply (K_compl_undec EA).
  eapply red_m_transports. 2:now eapply AC_1_0_Fext.
  eapply red_m_complement. eapply K_nat_equiv.
Qed.

Lemma AUC_to_dec (p : nat -> Prop) :
  AUC_on nat bool -> (forall n, p n \/ ~ p n) -> decidable p.
Proof.
  intros C Hp.
  destruct (C (fun n b => (p n /\ b = true) \/ (~ p n /\ b = false))) as [f Hf].
  - intros n. destruct (Hp n) as [H | H].
    + exists true.  split. left. eauto. intros [];  firstorder congruence. congruence.
    + exists false. split. right. eauto. intros []; firstorder congruence. congruence.
  - exists f. intros n. destruct (Hf n) as [[H ->] | [H ->]]; firstorder congruence. congruence.
Qed.

Lemma AC_0_0_LPO_incompat' (ax : EA) :
  AUC_on nat bool -> WLPO -> decidable (compl (K0 ax)).
Proof.
  intros C LPO % WLPO_semidecidable_iff.
  eapply AUC_to_dec; eauto.
  eapply LPO, sec_enum, K0_enum.
Qed.

Lemma AC_0_0_LPO_incompat :
  AUC_on nat bool -> WLPO -> EA -> False.
Proof.
  intros C LPO EA.
  now eapply (K0_compl_undec EA), AC_0_0_LPO_incompat'.
Qed.

(** ** Brouwer's intuitionism *)

Definition WC_N :=
  forall R : (nat -> nat) -> nat -> Prop,
    (forall α, exists x, R α x) -> forall α, exists L, exists y, forall β, map α L = map β L -> R β y.

Lemma max_list_with_spec' {X} (l : list X) f :
  l <> nil -> In (max_list_with f l) (map f l).
Proof.
  destruct l as [ | x l] using rev_ind; try congruence.
  clear IHl. intros _. induction l; cbn in *.
  - lia.
  - destruct (Nat.max_dec (f a) (max_list_with f (l ++ [x]))) as [H1 | H1].
    + now left.
    + right. rewrite H1 in *. eauto.
Qed.

Lemma max_list_spec' l :
  l <> nil -> In (max_list l) l.
Proof.
  intros H % (max_list_with_spec' _ id).
  now rewrite map_id in H.
Qed.

Lemma max_list_with_spec {X} (x : X) l f :
  In x l -> f x <= max_list_with f l.
Proof.
  intros H.
  induction l in x, H |- *.
  - inv H.
  - inv H; cbn.
    + lia.
    + eapply IHl in H0. lia.
Qed.

Lemma max_list_spec x l :
  In x l -> x <= max_list l.
Proof.
  eapply (max_list_with_spec x l id).
Qed.

Lemma WC_N_CT_inc {model : model_of_computation} :
  WC_N -> CT -> False.
Proof.
  intros WC CT.
  destruct (WC (fun α c => computes c α) CT (fun x => 0)) as [L [c H]].
  - unshelve epose proof (H (fun x => if ListDec.In_dec Nat.eq_dec x L is left _ then 0 else 1) _).
    + eapply map_ext_in. intros a Ha. now destruct List.In_dec.
    + eapply computes_ext with (f2 := fun _ => 0) (x := 1 + max_list L) in H0; eauto.
      destruct ListDec.In_dec as [H1 | H1].
      * eapply max_list_spec in H1. lia.
      * lia.
Qed.

Definition Cont := forall F : (nat -> nat) -> nat, forall f, exists L, forall g, map f L = map g L -> F f = F g.

Lemma WC_N_to_Cont :
  WC_N -> Cont.
Proof.
  intros H F f.
  edestruct (H (fun f n => F f = n)) as (L & c & Hc).
  + eauto.
  + exists L. intros g Hg.
    eapply Hc in Hg. rewrite Hg.
    now eapply Hc.
Qed.

Definition ADC_on' X := forall R : list X -> X -> Prop, (forall x, exists x', R x x') -> exists f : nat -> X, forall n, R (map f (seq 0 n)) (f n).

Lemma ADC_on'_iff :
  AC_on nat bool -> ADC_on' bool.
Proof.
  intros C R Htot.
  assert (datatype (list bool)) as (G & F & HFG). {
      eapply enumerable_discrete_datatype; eauto.
      eapply discrete_iff. econstructor. exact _.
  }
  pose (F' n := match F n with Some u => u | _ => [] end).
  destruct (C (fun n b => R (F' n) b)) as [f Hf]; eauto.
  pose (f' := fix f' n := match n with 0 => [] | S n => f' n ++ [f (G (f' n))] end).
  assert (Hlen : forall n, length (f' n) = n) by (induction n; cbn; rewrite ?app_length; cbn; lia).
  exists (fun n => nth n (f' (S n)) false).
  cbn. intros n.
  rewrite app_nth2. 2: rewrite Hlen; lia.
  assert (n - length (f' n) = 0) as -> by (rewrite Hlen; lia). cbn.
  specialize (Hf (G (f' n))).
  enough ((F' (G (f' n))) = map (λ n0 : nat, nth n0 (f' n0 ++ [f (G (f' n0))]) false) (seq 0 n)) by congruence.
  unfold F'. rewrite HFG.
  erewrite map_ext. 2:{
    intros a. rewrite app_nth2. 2: rewrite Hlen; lia.
    assert (a - length (f' a) = 0) as -> by (rewrite Hlen; lia). cbn. reflexivity.
  }
  clear.
  induction n.
  - reflexivity.
  - cbn [f']. replace (S n) with (n + 1) by lia.
    rewrite seq_app, map_app. cbn. congruence.
Qed.


Require Export Coq.Arith.EqNat.
Require Export Coq.Arith.Le.
Require Export Coq.Arith.Lt.
Require Export Coq.MSets.MSetList.
Require Export Coq.FSets.FMapList.
Require Export Coq.Strings.String.
Require Export Coq.Logic.Decidable.
Require Export Omega.
Require Export SfLib.
Set Implicit Arguments.
Require Export Setoid SetoidClass.
Require Export SetoidDec.

Module UOT_to_OrderedTypeLegacy (UOT:OrderedType) <: (IsEqOrig UOT) <: OrderedType.OrderedType.
  Definition t := UOT.t.
  Definition lt := UOT.lt.
  Definition eq := UOT.eq.
  Definition eq_refl := let (r, _, _) := UOT.eq_equiv in r.
  Definition eq_sym := let (_, s, _) := UOT.eq_equiv in s.
  Definition eq_trans := let (_, _, t) := UOT.eq_equiv in t.
  Lemma lt_trans : forall x y z : t, UOT.lt x y -> UOT.lt y z -> UOT.lt x z.
  Proof. destruct UOT.lt_strorder as [i t]. apply t. Qed.
  Lemma lt_not_eq : forall x y : t, UOT.lt x y -> ~ UOT.eq x y.
  Proof. destruct UOT.lt_strorder as [i t]. intros. intro. rewrite H0 in *. exact (i y H). Qed.
  Definition compare (x y : t) : OrderedType.Compare UOT.lt UOT.eq x y :=
    match (CompareSpec2Type (UOT.compare_spec x y)) with
      | CompLtT l => OrderedType.LT l
      | CompEqT e => OrderedType.EQ e
      | CompGtT g => OrderedType.GT g
    end.
  Definition eq_dec := UOT.eq_dec.
  Definition eq_equiv := UOT.eq_equiv.
  Definition lt_strorder := UOT.lt_strorder.
  Definition lt_compat := UOT.lt_compat.
End UOT_to_OrderedTypeLegacy.

Module Type ATOM.

  Parameter atom : Set.
  Declare Module AtomUOT : Orders.UsualOrderedType
      with Definition t := atom.
  Module Atom_as_OT : OrderedType.OrderedType
    with Definition t := atom
    with Definition eq := AtomUOT.eq
      := UOT_to_OrderedTypeLegacy(AtomUOT).
  Parameter atom_fresh_for_list : forall (xs : list atom),
    exists x : atom, ~ List.In x xs.
  Definition atom_eq_dec := AtomUOT.eq_dec.
  Lemma atom_dec_eq : forall (a1 a2 : atom), AtomUOT.eq a1 a2 \/ ~ AtomUOT.eq a1 a2.
  Proof. intros. assert (H := atom_eq_dec a1 a2). unfold AtomUOT.eq. destruct H; subst; auto. Qed.

End ATOM.

Module Type STRING.

  Parameter string : Set.
  Declare Module String : Orders.UsualOrderedType with Definition t := string.
  Module String_as_OT : OrderedType.OrderedType with Definition t := string := UOT_to_OrderedTypeLegacy(String).
  Definition string_eq_dec := String.eq_dec.
  Lemma string_dec_eq : forall (s1 s2 : string), s1 = s2 \/ s1 <> s2.
  Proof. intros. assert (H := string_eq_dec s1 s2). destruct H; subst; auto. Qed.

End STRING.


From Equations Require Import Equations.
Require Import Arith List ListSet Lia Program.
Import ListNotations.
Set Keyed Unification.

Definition fvar : Type := nat.
Definition bvar : Type := nat.

Inductive sort : Type :=
| N : sort
| ArrowS : sort -> sort -> sort.

Definition eq_sort_dec (s1 s2 : sort) : {s1 = s2} + {s1 <> s2}.
Proof. do 2 decide equality. Defined.

(* A very simple language with locally nameless binder representation *)
Inductive index : Type :=
| IBVar : bvar -> index
| IFVar : fvar -> index
| Z : index
| Plus1 : index -> index
| IAbs : sort -> index -> index
| IApp : index -> index -> index.

(* Set notations *)
Notation "\{}" := (empty_set fvar).

Notation "\{ x }" := ([x]).

Notation "E \u F" := (set_union eq_nat_dec E F)
                       (at level 37, right associativity).

Notation "x \in E" := (set_In x E) (at level 38).

Notation "x \notin E" := (~ (x \in E)) (at level 38).

(* Environments *)
Definition env := list (fvar * sort).

Definition get (x : fvar) (e : env) : option sort :=
  match
    find (fun p => if eq_nat_dec x (fst p) then true else false) e
  with
    | Some p => Some (snd p)
    | None => None
  end.

Definition dom (e : env) : set fvar := fold_left (fun s x => \{fst x} \u s) e \{}.

(* Free variables *)
Fixpoint ifv (i : index) : set fvar :=
  match i with
    | IFVar x => \{x}
    | IBVar _ | Z => \{}
    | Plus1 i => ifv i
    | IAbs _ i => ifv i
    | IApp i1 i2 => ifv i1 \u ifv i2
  end.

Definition var_gen (E : set fvar) :=
  1 + fold_right max O E.

Lemma var_gen_spec : forall E, (var_gen E) \notin E.
Proof.
  intros E.
  assert (Hlt : forall n, n \in E -> n < var_gen E).
  { intros n H. induction E as [|x xs IHxs];
      unfold var_gen in *; simpl in *; try (now exfalso; auto).
    destruct H; subst;
    rewrite Nat.succ_max_distr, Nat.max_lt_iff; auto. }
  intros contra. apply Hlt in contra. lia.
Qed.

Fixpoint ii_open_rec (k : nat) (i : index) (x : fvar) : index :=
  match i with
    | IBVar n => if eq_nat_dec k n then (IFVar x) else (IBVar n)
    | IFVar _ | Z => i
    | Plus1 i => Plus1 (ii_open_rec k i x)
    | IAbs s i => IAbs s (ii_open_rec (S k) i x)
    | IApp i1 i2 => IApp (ii_open_rec k i1 x) (ii_open_rec k i2 x)
  end.

Definition ii_open_var (i : index) (x : fvar) := ii_open_rec 0 i x.

(* Typing rules *)
Inductive sorting (e : env) : index -> sort -> Prop :=
| IFVarRule :
    forall (x : fvar) (s : sort),
      get x e = Some s ->
      sorting e (IFVar x) s
| ZRule : sorting e Z N
| Plus1Rule : forall (I : index),
                sorting e I N -> sorting e (Plus1 I) N
| IAbsRule : forall (I : index) (s1 s2 : sort),
               (* Cheating a bit to make the proof easier, but this
                  rule should be equivalent with the previous one -
                  the proof must be cumbersome though *)
               let x := var_gen (dom e \u ifv I) in
               sorting ((x, s1) :: e) (ii_open_var I x) s2 ->
               sorting e (IAbs s1 I) (ArrowS s1 s2)
| IAppRule : forall (I1 I2 : index) (S1 S2 : sort),
               sorting e I1 (ArrowS S1 S2) -> sorting e I2 S1 ->
               sorting e (IApp I1 I2) S2.

Fixpoint index_size (i : index) : nat :=
  match i with
    | IBVar _ | IFVar _ | Z => 0
    | Plus1 i | IAbs _ i  => 1 + index_size i
    | IApp i1 i2 => 1 + (index_size i1 + index_size i2)
  end.

Lemma size_ii_open_rec :
  forall (i : index) (x : fvar) (rec :nat),
    index_size (ii_open_rec rec i x) = index_size i.
Proof.
  intros i x.
  induction i; intros n; simpl;
  repeat
    (match goal with
       | [ H : forall (_ : nat), _ = _ |- _ ] =>
         rewrite H
     end); try lia.
  now destruct (eq_nat_dec _ _).
Qed.

Lemma size_ii_open_rec_lt :
  forall (i : index) (x : fvar),
    index_size (ii_open_var i x) < S (index_size i).
Proof.
  intros; unfold ii_open_var; rewrite size_ii_open_rec. auto with arith.
Defined.

(** Hints for automatically solving recursive call obligations *)
#[local] Hint Extern 3 => progress cbn : Below.
#[local] Hint Resolve size_ii_open_rec_lt : Below.
#[local] Hint Extern 3 => progress auto with arith : Below.
(*
Equations infer_sort (ie : env) (i : index) : option sort :=
infer_sort ie i by wf i (MR lt index_size) := (** Need to strengthen the subst *)
infer_sort ie (IBVar x) := None ;
infer_sort ie (IFVar x) := get x ie;
infer_sort ie Z := Some N;
infer_sort ie (Plus1 i) <= infer_sort ie i => {
                     | Some N := Some N;
                     | _ := None };
infer_sort ie (IAbs s i) <= infer_sort ((0, s) :: ie) (ii_open_var i 0) => {
  infer_sort ie (IAbs s i) (Some s2) := Some (ArrowS s s2) ;
  infer_sort _ _ _ := None } ;
infer_sort ie (IApp i1 i2) <= infer_sort ie i1 => {
  | Some (ArrowS s1 s2) <= infer_sort ie i2 =>
    { | None := None;
      | Some s1' <= sort_eq_dec s1 s1' => {
               | (left _) := Some s2;
               | (right _) := None } };
  | _ := None }.
*)
(* BUG! not general enough, need to inverse the order of arguments so that ie can change
  at recursive calls.
 *)
#[local]
Obligation Tactic := program_simpl; try typeclasses eauto 10 with Below subterm_relation.

Equations infer_sort (i : index) (ie : env) : option sort
 by wf i (MR lt index_size) :=
infer_sort (IBVar x) ie := None ;
infer_sort (IFVar x) ie := get x ie;
infer_sort Z ie := Some N;
infer_sort (Plus1 i) ie with infer_sort i ie => {
                     | Some N := Some N;
                     | _ := None };
infer_sort (IAbs s i) ie with let x := (var_gen (dom ie \u ifv i)) in
                            infer_sort (ii_open_var i x)  ((x, s) :: ie)  => {
  infer_sort (IAbs s i) ie (Some s2) := Some (ArrowS s s2) ;
  infer_sort _ _ _ := None } ;
infer_sort (IApp i1 i2) ie with infer_sort i1 ie := {
infer_sort (IApp i1 i2) ie (Some (ArrowS s1 s2)) with infer_sort i2 ie :=
  { | None := None;
    | Some s1' with eq_sort_dec s1 s1' := {
                 | (left Heq) := Some s2;
                 | (right _) := None } };
infer_sort (IApp i1 i2) ie _ := None }.

Lemma infer_sort_sound:
  forall (i : index) (ie: env)  (s : sort),
    infer_sort i ie = Some s ->
    sorting ie i s.
Proof.
  intros i ie.
  funelim (infer_sort i ie); intros s' Heqs;
  try (noconf Heqs || (rewrite Heq in *; noconf Heqs)).
  - now constructor.
  - now constructor.
  - specialize (Hind _ Heq). now constructor.
  - specialize (Hind _ Heq). now constructor.
  - pose proof (Hind _ Heq1). pose proof (Hind0 _ Heq2). subst s1.
    econstructor; eauto.
Qed.


Require Import ZArith Znumtheory.
Require Import Coq.setoid_ring.Field.
From Coqprime Require Import GZnZ.
From Coqprime Require Import Pmod.
Require Import Crypto.Algebra.Hierarchy.
Require Import Crypto.Algebra.Ring.
Require Import Theory.Fields.QuadraticFieldExtensions.
Require Import Znat.
Require Import Lia.

(*Relates the specification of a ring in the standard library to that of fiatCrypto. *)
Section Ring.
    Context {R Rzero Rone Radd Rmul Rsub Ropp}
            {std_ring: @ring_theory R Rzero Rone Radd Rmul Rsub Ropp (@eq R)}.

    Add Ring R : std_ring.

    Instance std_to_fiatCrypto_ring : @ring R (@eq R) Rzero Rone Ropp Radd Rsub Rmul.
    Proof. repeat split; try (intros; ring); try apply (_ (std_ring)). Qed.

End Ring.

(*Relates to specification of a field in the standard library to that of fiatCrypto. *)
Section Field.
    Context {F Fzero Fone Fadd Fmul Fsub Fopp Fdiv Finv}
            {std_field: @field_theory F Fzero Fone Fadd Fmul Fsub Fopp Fdiv Finv (@eq F)}.

    Add Field F : std_field.

    Instance std_to_fiatCrypto_field : @field F (@eq F) Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv.
    Proof.
        repeat split; try apply (Fdiv_def std_field); try (intros ; field); try apply (_ (std_field)); auto.
        - symmetry; apply (F_1_neq_0 (std_field)).
    Qed.
End Field.

(* Few elementary results on the characteristics of prime order fields and their binary extensions. *)
Section Characteristic.

    Context {n : Z}.
    Notation "x + y" := (add n x y).
    Notation "x 'zmod' n" := (mkznz n (x mod n) (modz n x)) (at level 90).
    Notation char_znz_n_ge := (@char_ge (znz n)%type (@eq (znz n)) (zero n) (one n) (opp n) (add n) (sub n) (mul n)).
    Notation ZnZ_of_Z := (@of_Z (znz n) (zero n) (one n) (opp n) (add n)).
    Notation ZnZ_of_nat := (@of_nat (znz n) (zero n) (one n) (add n)).

    Section RZnZ.

        Context {n_pos: 0 < n}.

        Add Ring Zn : (RZnZ n n_pos).
        Notation ZnZ := (RZnZ n n_pos).

        Instance ZnZfc : @ring (znz n) (@eq (znz n)) (zero n) (one n) (opp n) (add n) (sub n) (mul n).
        Proof. apply @std_to_fiatCrypto_ring, ZnZ. Qed.

        Lemma of_nat_ZnZ : forall m, ZnZ_of_nat m = ((Z.of_nat m) zmod n).
        Proof.
            intros. induction m as [|m' IHm'].
                - reflexivity.
                - assert (((Z.of_nat (S m')) zmod n) = add n (Z.of_nat m' zmod n) (one n)) as H0 by
                (apply zirr; simpl; rewrite <- Zplus_mod; lia).
                rewrite H0; simpl; apply zirr; rewrite IHm'; reflexivity.
        Qed.

        Lemma of_Z_ZnZ : forall m, ZnZ_of_Z m = (m zmod n).
        Proof.
            intros m. destruct m.
                - reflexivity.
                - simpl; rewrite of_nat_ZnZ, positive_nat_Z; reflexivity.
                - simpl. rewrite of_nat_ZnZ, positive_nat_Z. unfold opp. apply zirr. simpl.
                assert (Z.neg p = -1 * p) by lia. rewrite H. rewrite Zmult_mod.
                assert (- (p mod n) = -1 * (p mod n)) by lia. rewrite H0. rewrite Zmult_mod.
                rewrite Zmod_mod. reflexivity.
        Qed.

        Lemma Char_geq_n :forall (m : positive), m < n ->
        char_znz_n_ge m.
        Proof.
            unfold char_ge, Hierarchy.char_ge.
            intros m H p Hp; simpl.
            remember (Pos.to_nat p) as pnat eqn:Hp'. induction (pnat) as [| p' IHp'].
            - apply (f_equal (fun y => Z.of_nat y)) in Hp';
            rewrite positive_nat_Z in Hp'; discriminate.
            - assert (Z.of_nat (S p') < n) as H0 by lia; rewrite of_nat_ZnZ; intros contra.
            assert (Z.of_nat (S p') mod n = Z.of_nat (S p')) as H2 by (apply Zmod_small; lia).
            inversion contra as [H3]; rewrite Zmod_0_l in H3; simpl in H0; lia.
        Qed.
    End RZnZ.

    Section Field.

        Notation p := n.
        Hypothesis p_prime : prime p.

        Instance ZpZfc : @field (znz p) (@eq (znz p)) (zero p) (one p) (opp p) (add p) (sub p) (mul p) (inv p) (div p).
        Proof. apply @std_to_fiatCrypto_field, FZpZ; apply p_prime. Qed.

        Section FZpZ.

            Lemma Char_geq_p : forall (m : positive), m < p -> char_znz_n_ge m.
            Proof. apply Char_geq_n. Qed.

        End FZpZ.

        Section Fp2.

            Hypothesis p_odd: 2 < p.
            Hypothesis p_mod: (p mod 4 =? 3) = true.
            Add Field Fp2 : (FFp2 p p_prime p_odd p_mod).
            Add Field Fp : (FZpZ p p_prime).

            Notation char_Fp2_p_ge := (@char_ge (znz p * znz p)%type (@eq (znz p * znz p)) (zerop2 p) (onep2 p) (oppp2 p) (addp2 p) (subp2 p) (mulp2 p)).

            Instance Fp2fc : @field (znz p * znz p) (@eq (znz p * znz p)) (zerop2 p)
                (onep2 p) (oppp2 p) (addp2 p) (subp2 p) (mulp2 p) (invp2 p) (divp2 p).
            Proof. apply @std_to_fiatCrypto_field, (FFp2 p p_prime p_odd p_mod). Qed.

            Notation Fp2_of_nat := (@of_nat (znz p * znz p) (zerop2 p) (onep2 p) (addp2 p)).

            Lemma of_nat_Fp2 : forall m, (Fp2_of_nat m) = (ZnZ_of_nat m, zero p).
            Proof. intros; induction m as [| m IHm]; try reflexivity;
                simpl; rewrite IHm; rewrite of_nat_ZnZ; apply Fp2irr; simpl; field.
            Qed.

            Theorem Char_Fp2_geq_p : forall (m : positive), m < p -> char_Fp2_p_ge m.
            Proof.
                intros m Hm p Hp contra; unfold of_Z in contra; rewrite of_nat_Fp2 in contra;
                inversion contra; pose proof Char_geq_n (p + 1) as H1; assert (p + 1 < Field.p) as H2 by lia;
                apply H1 in H2; assert (ZnZ_of_Z p <> zero Field.p) by (apply H2; lia); contradiction.
            Qed.

        End Fp2.

    End Field.

End Characteristic.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat utils_list crt pos vec.

From Undecidability.MuRec
  Require Import recalg ra_utils ra_enum recomp ra_recomp beta ra_godel_beta.

From Undecidability.DiophantineConstraints
  Require Import H10C Util.h10c_utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Definition h10uc_eq a' b' (c : nat*nat*nat) :=
  match c with (x,y,z) =>
    let vx := godel_beta a' b' x in
    let vy := godel_beta a' b' y in
    let vz := godel_beta a' b' z
    in 1+vx+vy*vy = vz
  end.

Definition h10uc_test a' b' x y z :=
  let vx := godel_beta a' b' x in
  let vy := godel_beta a' b' y in
  let vz := godel_beta a' b' z
  in if eq_nat_dec (1+vx+vy*vy) vz then 0 else 1.

Definition idx_h10uc a b p : h10uc :=
  (godel_beta a b (3*p), godel_beta a b (1+3*p), godel_beta a b (2+3*p)).

Definition nat_h10luc k :=
   let n := decomp_r k           in
   let a := decomp_l (decomp_l k) in
   let b := decomp_r (decomp_l k)
   in  map (fun p => idx_h10uc a b (pos2nat p)) (pos_list n).

(* nat_h10luc is surjective

    needed to map an H10UC instance to a instance of the universal solver

*)

Fact nat_h10luc_surj lc : { k | lc = nat_h10luc k }.
Proof.
  destruct (list_vec_full lc) as (v & <-).
  set (n := length lc).
  set (f p := match le_lt_dec n p with
    | left _   => (0,0,0)
    | right Hp => vec_pos v (nat2pos Hp)
  end).
  destruct godel_beta_fun_inv_triples with (n := n) (f := f)
    as (a & b & Hab).
  exists (recomp (recomp a b) n).
  unfold nat_h10luc.
  repeat (rewrite decomp_l_recomp).
  repeat rewrite decomp_r_recomp.
  rewrite map_pos_list_vec; f_equal.
  apply vec_pos_ext; intros p; rewrite vec_pos_set.
  unfold idx_h10uc; rewrite <- Hab; auto.
  2: apply pos2nat_prop.
  unfold f, n.
  destruct (le_lt_dec (length lc) (pos2nat p)) as [ H | H ].
  + generalize (pos2nat_prop p); lia.
  + rewrite nat2pos_pos2nat; auto.
Qed.

Section ra_h10uc.

  Let s : recalg 1.
  Proof.
    ra root ra_mult; ra arg pos0.
  Defined.

  Let s_val x : ⟦s⟧ (x##vec_nil) (x*x).
  Proof.
    unfold s.
    exists (x##x##vec_nil); split; auto.
    pos split; simpl; auto.
  Qed.

  Definition ra_h10uc : recalg 5.
  Proof.
    ra root ra_not.
    ra root ra_not.
    ra root ra_eq.
    + ra root ra_succ.
      ra root ra_plus.
      * ra root ra_godel_beta.
        - ra arg pos3.
        - ra arg pos4.
        - ra arg pos0.
      * ra root s.
        ra root ra_godel_beta.
        - ra arg pos3.
        - ra arg pos4.
        - ra arg pos1.
    + ra root ra_godel_beta.
      * ra arg pos3.
      * ra arg pos4.
      * ra arg pos2.
  Defined.

  Opaque ra_not ra_eq ra_plus ra_mult ra_cst_n ra_godel_beta.

  Fact ra_h10uc_prim_rec : prim_rec ra_h10uc.
  Proof. ra prim rec. Qed.

  Opaque s.

  Variable x y z a' b' : nat.

  Let vx := godel_beta a' b' x.
  Let vy := godel_beta a' b' y.
  Let vz := godel_beta a' b' z.

  Fact ra_h10uc_val  : ⟦ra_h10uc⟧ (x##y##z##a'##b'##vec_nil) (h10uc_test a' b' x y z).
  Proof.
    exists (1-ite_rel (1+vx+vy*vy-vz) (vz-(1+vx+vy*vy)) 1##vec_nil); split.
    { generalize (ra_not_val (1-ite_rel (1+vx+vy*vy-vz) (vz-(1+vx+vy*vy)) 1)).
      intros H; eq goal H; f_equal.
      unfold ite_rel, h10uc_test.
      fold vx; fold vy; fold vz.
      case_eq (1 + vx + vy * vy - vz); destruct (eq_nat_dec (1+vx+vy*vy) vz); intros; lia. }
    pos split; simpl.
    exists (ite_rel (1+vx+vy*vy-vz) (vz-(1+vx+vy*vy)) 1##vec_nil); split.
    { apply ra_not_val. }
    pos split; simpl.
    exists (1+vx+vy*vy##vz##vec_nil); split; auto.
    { apply ra_eq_val. }
    pos split; simpl; auto.
    + exists (vx+vy*vy##vec_nil); split; auto.
      { simpl; auto. }
      pos split; simpl; auto.
      exists (vx##vy*vy##vec_nil); split; auto.
      pos split; simpl; auto.
      * exists (a'##b'##x##vec_nil); split; auto.
        { apply ra_godel_beta_val. }
        pos split; simpl; auto.
      * exists (vy##vec_nil); split; auto.
        pos split.
        exists (a'##b'##y##vec_nil); split; auto.
        { apply ra_godel_beta_val. }
        pos split; simpl; auto.
    + exists (a'##b'##z##vec_nil); split; auto.
      { apply ra_godel_beta_val. }
      pos split; simpl; auto.
  Qed.

End ra_h10uc.

Local Hint Resolve ra_h10uc_prim_rec ra_h10uc_val : core.
Opaque ra_h10uc.

Section ra_iter_h10uc.

  Let t3 : recalg 1.
  Proof.
    ra root ra_mult.
    - ra cst 3.
    - ra arg pos0.
  Defined.

  Let t3_val n : ⟦t3⟧ (n##vec_nil) (3*n).
  Proof.
    exists (3##n##vec_nil); split; auto.
    pos split; simpl; auto.
    apply ra_cst_n_val.
  Qed.

  Let f : recalg 5.
  Proof.
    ra root ra_h10uc.
    + ra root ra_godel_beta.
      * ra arg pos1.
      * ra arg pos2.
      * ra root t3.
        ra arg pos0.
    + ra root ra_godel_beta.
      * ra arg pos1.
      * ra arg pos2.
      * ra root ra_succ.
        ra root t3.
        ra arg pos0.
    + ra root ra_godel_beta.
      * ra arg pos1.
      * ra arg pos2.
      * ra root ra_succ.
        ra root ra_succ.
        ra root t3.
        ra arg pos0.
    + ra arg pos3.
    + ra arg pos4.
  Defined.

  Opaque ra_godel_beta ra_mult ra_cst_n.

  Let f_pr : prim_rec f.
  Proof. ra prim rec. Qed.

  Opaque t3 mult.

  Let f_val n a b a' b' : ⟦f⟧ (n##a##b##a'##b'##vec_nil)
                            (h10uc_test a' b' (godel_beta a b (3*n))
                                              (godel_beta a b (1+3*n))
                                              (godel_beta a b (2+3*n))).
  Proof.
    exists (godel_beta a b (3*n)##godel_beta a b (1+3*n)##godel_beta a b (2+3*n)##a'##b'##vec_nil); split; auto.
    pos split; simpl; auto.
    + exists (a##b##3*n##vec_nil); split; auto.
      pos split; simpl; auto.
      exists (n##vec_nil); split; auto.
      pos split; simpl; auto.
    + exists (a##b##1+3*n##vec_nil); split; auto.
      pos split; simpl; auto.
      exists (3*n##vec_nil); split; auto.
      { simpl; auto. }
      pos split; simpl.
      exists (n##vec_nil); split; auto.
      pos split; simpl; auto.
    + exists (a##b##2+3*n##vec_nil); split; auto.
      pos split; simpl; auto.
      exists (1+3*n##vec_nil); split; auto.
      { simpl; auto. }
      pos split; simpl; auto.
      exists (3*n##vec_nil); split; auto.
      { simpl; auto. }
      pos split; simpl.
      exists (n##vec_nil); split; auto.
      pos split; simpl; auto.
  Qed.

  Opaque f.

  Definition ra_iter_h10uc : recalg 5.
  Proof.
    ra root ra_not.
    ra root ra_not.
    apply (ra_lsum f).
  Defined.

  Fact ra_iter_h10uc_prim_rec : prim_rec ra_iter_h10uc.
  Proof. ra prim rec. Qed.

  Section ra_iter_spec.

    Variable (n a b a' b' : nat).

    Fact ra_iter_h10uc_val_0 :
          (forall p, p < n -> h10uc_eq a' b' (idx_h10uc a b p))
       -> ⟦ra_iter_h10uc⟧ (n##a##b##a'##b'##vec_nil) 0.
    Proof.
      intros H2; simpl.
      exists (1##vec_nil); split.
      { apply ra_not_val. }
      pos split; simpl; auto.
      exists (0##vec_nil); split.
      { apply ra_not_val. }
      pos split; simpl; auto.
      apply ra_lsum_0.
      intros p Hp.
      specialize (H2 _ Hp).
      unfold h10uc_eq, idx_h10uc in H2.
      generalize (f_val p a b a' b').
      unfold h10uc_test.
      match type of H2 with
        | ?a = ?b => destruct (eq_nat_dec a b)
      end; auto; lia.
    Qed.

    Fact ra_iter_h10uc_val_1 :
          (exists p, p < n /\ ~ h10uc_eq a' b' (idx_h10uc a b p))
       -> ⟦ra_iter_h10uc⟧ (n##a##b##a'##b'##vec_nil) 1.
    Proof.
      intros H2; simpl.
      exists (0##vec_nil); split.
      { apply ra_not_val. }
      pos split; simpl; auto.
      destruct ra_lsum_S with (1 := f_pr) (i := n) (v := a##b##a'##b'##vec_nil)
        as (k & Hk).
      { destruct H2 as (p & H2 & H3).
        exists p, 0; split; auto.
        unfold h10uc_eq, idx_h10uc in H3.
        generalize (f_val p a b a' b').
        unfold h10uc_test.
        match type of H3 with
          | ?a <> ?b => destruct (eq_nat_dec a b)
        end; auto; lia. }
      exists (S k##vec_nil); split.
      { apply ra_not_val. }
      pos split; simpl; auto.
    Qed.

  End ra_iter_spec.

End ra_iter_h10uc.

Local Hint Resolve ra_iter_h10uc_prim_rec : core.
Opaque ra_iter_h10uc.

Section ra_univ_ad.

  Let f : recalg 2.
  Proof.
    ra root ra_iter_h10uc.
    + ra root ra_decomp_r.
      ra arg pos1.
    + ra root ra_decomp_l.
      ra root ra_decomp_l.
      ra arg pos1.
    + ra root ra_decomp_r.
      ra root ra_decomp_l.
      ra arg pos1.
    + ra root ra_decomp_l.
      ra arg pos0.
    + ra root ra_decomp_r.
      ra arg pos0.
  Defined.

  Opaque ra_decomp_l ra_decomp_r.

  Let Hf_pr : prim_rec f.
  Proof. ra prim rec. Qed.

  Variables (lc : list h10uc) (k : nat)
            (Hlc : lc = nat_h10luc k).

  Let Hf_val_0 v :
        (forall c, In c lc -> h10uc_sem (godel_beta (decomp_l v) (decomp_r v)) c)
     -> ⟦f⟧ (v##k##vec_nil) 0.
  Proof.
    intros H2.
    exists (decomp_r k##decomp_l (decomp_l k)##decomp_r (decomp_l k)##
            decomp_l v##decomp_r v##vec_nil); split.
    + apply ra_iter_h10uc_val_0.
      intros p Hp.
      apply H2; subst.
      unfold idx_h10uc.
      apply in_map_iff.
      exists (nat2pos Hp); split.
      * rewrite pos2nat_nat2pos; auto.
      * apply pos_list_prop.
    + pos split; simpl; auto.
      * exists (k##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (decomp_l k##vec_nil); split; auto.
        pos split; simpl; auto.
        exists (k##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (decomp_l k##vec_nil); split; auto.
        pos split; simpl; auto.
        exists (k##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (v##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (v##vec_nil); split; auto.
        pos split; simpl; auto.
  Qed.

  Let Hf_val_1 v :
        (exists c, In c lc /\ ~ h10uc_sem (godel_beta (decomp_l v) (decomp_r v)) c)
     -> ⟦f⟧ (v##k##vec_nil) 1.
  Proof.
    intros H2.
    exists (decomp_r k##decomp_l (decomp_l k)##decomp_r (decomp_l k)##
            decomp_l v##decomp_r v##vec_nil); split.
    + apply ra_iter_h10uc_val_1.
      destruct H2 as (c & H1 & H2).
      rewrite Hlc in H1.
      unfold nat_h10luc in H1.
      apply in_map_iff in H1.
      destruct H1 as (p & H1 & _).
      exists (pos2nat p); split.
      * apply pos2nat_prop.
      * rewrite H1; auto.
    + pos split; simpl; auto.
      * exists (k##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (decomp_l k##vec_nil); split; auto.
        pos split; simpl; auto.
        exists (k##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (decomp_l k##vec_nil); split; auto.
        pos split; simpl; auto.
        exists (k##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (v##vec_nil); split; auto.
        pos split; simpl; auto.
      * exists (v##vec_nil); split; auto.
        pos split; simpl; auto.
  Qed.

  Let Hf_tot v : ⟦f⟧ (v##k##vec_nil) 0 \/ ⟦f⟧ (v##k##vec_nil) 1.
  Proof.
    destruct (h10luc_sem_dec lc (godel_beta (decomp_l v) (decomp_r v)))
      as [ (c & H) | H ].
    + right; apply Hf_val_1; exists c; auto.
    + left; apply Hf_val_0; auto.
  Qed.

  Definition ra_univ_ad : recalg 1.
  Proof. apply ra_min, f. Defined.

  Opaque f.

  Theorem ra_univ_ad_spec : ex (⟦ra_univ_ad⟧ (k##vec_nil))
                     <-> exists φ, forall c, In c lc -> h10uc_sem φ c.
  Proof using Hf_tot.
    split.
    + intros (v & Hv).
      simpl in Hv; red in Hv.
      destruct Hv as (H1 & H2).
      destruct (h10luc_sem_dec lc (beta v))
        as [ (c & H) | H ].
      * assert (⟦ f ⟧ (v ## k ## vec_nil) 1) as C.
        { apply Hf_val_1; exists c; auto. }
        generalize (ra_rel_fun _ _ _ _ H1 C); discriminate.
      * exists (beta v); auto.
    + intros (phi & Hphi).
      destruct (godel_beta_fun_inv (h10luc_bound lc) phi)
        as (a & b & Hab).
      generalize (h10luc_bound_prop _ _ Hab); clear Hab; intros Hab.
      apply ra_min_ex; auto.
      exists (recomp a b); simpl.
      apply Hf_val_0.
      intros c Hc; rewrite decomp_l_recomp, decomp_r_recomp; apply Hab; auto.
  Qed.

End ra_univ_ad.