Require Import SQIR.DensitySem.
Require Import RzQGateSet.
Require Import Coq.Reals.ROrderedType.

Module RzQProps := NUListProofs RzQGateSet.
Export RzQProps.

Local Open Scope com_scope.

(* 'reset' and measurement put a qubit in a classical state and subsequent X / Rz
   gates leave the qubit in a classical state. Using this idea, this optimization
   tracks classical states to determine the effect of subsequent CNOTs and measurements.

   It currently only tracks the state of a single qubit at a time, but could be extended
   to handle qubit interactions.
*)

(** Useful facts about super and pad. *)

Local Coercion Nat.b2n : bool >-> nat.

Lemma super_Zero : forall {n} (ρ : Square n),
  super Zero ρ = (@Zero n n).
Proof. intros. unfold super. Msimpl. reflexivity. Qed.

Lemma super_I : forall {n} (ρ : Square n),
  WF_Matrix ρ -> super (I _) ρ = ρ.
Proof. intros. unfold super. Msimpl. reflexivity. Qed.

Lemma super_Mplus : forall {n} (A : Square n) ρ ρ',
  super A ρ .+ super A ρ' = super A (ρ .+ ρ').
Proof.
  intros. unfold super.
  rewrite <- Mmult_plus_distr_r.
  rewrite <- Mmult_plus_distr_l.
  reflexivity.
Qed.

Lemma super_Mmult : forall {n} (A B : Square n)  ρ,
  super (A × B) ρ = super A (super B ρ).
Proof.
  intros. unfold super.
  Msimpl. repeat rewrite Mmult_assoc.
  reflexivity.
Qed.

Lemma double_pad : forall dim n (b : bool) ρ, super (@pad 1 n dim (∣ b ⟩ × (∣ b ⟩) †)) (super (@pad 1 n dim (∣ b ⟩ × (∣ b ⟩) †)) ρ) = super (@pad 1 n dim (∣ b ⟩ × (∣ b ⟩) †)) ρ.
Proof.
  intros.
  rewrite <- super_Mmult.
  unfold pad; destruct b; simpl; gridify.
  all: Qsimpl; reflexivity.
Qed.

Lemma double_pad01 : forall dim n ρ, super (@pad 1 n dim (∣ 0 ⟩ × (∣ 0 ⟩) †)) (super (@pad 1 n dim (∣ 1 ⟩ × (∣ 1 ⟩) †)) ρ) = Zero.
Proof.
  intros. rewrite <- super_Mmult.
  unfold pad; simpl; gridify.
  Qsimpl.
  all: apply super_Zero.
Qed.

Lemma double_pad10 : forall dim n ρ, super (@pad 1 n dim (∣ 1 ⟩ × (∣ 1 ⟩) †)) (super (@pad 1 n dim (∣ 0 ⟩ × (∣ 0 ⟩) †)) ρ) = Zero.
Proof.
  intros. rewrite <- super_Mmult.
  unfold pad; simpl; gridify.
  Qsimpl.
  all: apply super_Zero.
Qed.

(** Track classical states to remove unreachable code. **)

(* Inputs: list l, qubit q, classical state b (false = ∣0⟩, true = ∣1⟩)
   Outputs: modified list l', resulting classical state b' of qubit q
            (or None if we don't know whether q is in a classical state) *)
Fixpoint propagate_classical_through_ucom {dim} (l : RzQ_ucom_l dim) q b
    : RzQ_ucom_l dim * option bool :=
  match l with
  | App1 u q' :: t =>
      if q =? q'
      then match u with
           (* X flips the classical state *)
           | URzQ_X =>
               let (l', b') := propagate_classical_through_ucom t q (negb b) in
               (App1 u q' :: l', b')
           (* Rz maintains the classical state *)
           | URzQ_Rz _ =>
               let (l', b') := propagate_classical_through_ucom t q b in
               (App1 u q' :: l', b')
           (* H takes the qubit out of a classical state *)
           | URzQ_H => (App1 u q' :: t, None)
           end
      else let (l' ,b') := propagate_classical_through_ucom t q b in
           (App1 u q' :: l', b')
  | App2 u q1 q2 :: t =>
      (* If the control of a CNOT is in a classical state, we can either remove
         the CNOT or replace it with an X gate; being used as the target of a CNOT
         potentially takes q out of a classical state *)
      if q =? q1
      then let (l', b') := propagate_classical_through_ucom t q b in
           if b
           then (App1 URzQ_X q2 :: l', b')
           else (l', b')
      else if q =? q2
           then (App2 u q1 q2 :: t, None)
           else let (l', b') := propagate_classical_through_ucom t q b in
                (App2 u q1 q2 :: l', b')
  | _ => ([], Some b)
  end.

(* Inputs: list l, qubit q, classical state b (false = ∣0⟩, true = ∣1⟩)
   Outputs: modified list l', resulting classical state b' of qubit q
            (or None if we don't know whether q is in a classical state) *)
Fixpoint propagate_classical_through_com {dim} (l : RzQ_com_l dim) q b n
    : RzQ_com_l dim * option bool :=
match n with
| O => (l, None) (* should be unreachable *)
| S n' =>
  match l with
  (* For unitary expressions, use the ucom function above *)
  | UC u :: t => let (u', b') := propagate_classical_through_ucom u q b in
               match b' with
               | None => (UC u' :: t, None)
               | Some b => let (t', b') := propagate_classical_through_com t q b n' in
                          (UC u' :: t', b')
               end
  (* For measurement, if we are measuring q:
     - Determine the branch that will be taken depending on b
     - Track the state of q through this branch, and possibly continue through
       the rest of the instructions
     Otherwise:
     - Track the state of q through both branches
     - If both branches end up in the same state, continue through the rest of
       the instructions *)
  | Meas n l1 l2 :: t =>
      if q =? n
      then if b
           then let (l1', b') := propagate_classical_through_com l1 q b n' in
                match b' with
                | None => (l1' ++ t, None)
                | Some b => let (t', b') := propagate_classical_through_com t q b n' in
                           (l1' ++ t', b')
                end
           else let (l2', b') := propagate_classical_through_com l2 q b n' in
                match b' with
                | None => (l2' ++ t, None)
                | Some b => let (t', b') := propagate_classical_through_com t q b n' in
                           (l2' ++ t', b')
                end
      else let (l1', b1) := propagate_classical_through_com l1 q b n' in
           let (l2', b2) := propagate_classical_through_com l2 q b n' in
           match b1, b2 with
           | Some true, Some true =>
               let (t', b') := propagate_classical_through_com t q true n' in
               (Meas n l1' l2' :: t', b')
           | Some false, Some false =>
               let (t', b') := propagate_classical_through_com t q false n' in
               (Meas n l1' l2' :: t', b')
           | _, _ => (Meas n l1' l2' :: t, None)
           end
  | _ => ([], Some b)
  end
end.

(* Call propagate_classical_through_com for every branch of every measurement. *)
Fixpoint track_classical_state' {dim} (l : RzQ_com_l dim) n :=
match n with
| O => l (* should be unreachable *)
| S n' =>
  match l with
  | [] => []
  | UC u :: t => UC u :: track_classical_state' t n'
  | Meas n l1 l2 :: t =>
      (* propagate true/false through the appropriate branch *)
      let (l1', b1) := propagate_classical_through_com l1 n true n' in
      let (l2', b2) := propagate_classical_through_com l2 n false n' in
      (* make recursive calls on the optimized branches *)
      let l1'' := track_classical_state' l1' n' in
      let l2'' := track_classical_state' l2' n' in
      match b1, b2 with
      (* in certain cases (e.g. 'reset') both branches will end up with q
         in the same classical state *)
      | Some true, Some true =>
          let (t', _) := propagate_classical_through_com t n true n' in
          Meas n l1'' l2'' :: track_classical_state' t' n'
      | Some false, Some false =>
          let (t', _) := propagate_classical_through_com t n false n' in
          Meas n l1'' l2'' :: track_classical_state' t' n'
      | _, _ => Meas n l1'' l2'' :: track_classical_state' t n'
      end
  end
end.

Definition track_classical_state {dim} (l : RzQ_com_l dim) :=
  track_classical_state' l (count_ops l).

(** Examples **)

(* Output: X 1 ; mif 1 then (H 2; X 0) else skip *)
Definition test1 : RzQ_com_l 3 := UC [X 1] :: Meas 1 [UC (H 2 :: [CNOT 1 0])] [UC [CNOT 1 2]] :: [].
Compute (track_classical_state test1).
(* Output: mif 0 then X 0 else skip *)
Definition test2 : RzQ_com_l 3 := Meas 0 [UC [X 0]] [] :: Meas 0 [UC [X 0]] [] :: [].
Compute (track_classical_state test2).
(* Output: reset 0 ; H 1 ; H 0 ; reset 0 *)
Definition test3 : RzQ_com_l 3 := Meas 0 [UC [X 0]] [] :: UC (H 1 :: [CNOT 0 1]) :: UC [H 0] :: Meas 0 [UC [X 0]] [] :: [].
Compute (track_classical_state test3).
(* Output: mif 1 then (X 2 ; Z 1 ; CNOT 2 0) else (H 0 ; X 1 ; X 2) ; reset 1 *)
Definition test4 : RzQ_com_l 3 := Meas 1 [UC (X 2 :: Z 1 :: [CNOT 2 0])] [UC (H 0 :: X 1 :: [CNOT 1 2])] :: Meas 1 [] [UC [X 1]] :: [].
Compute (track_classical_state test4).
(* Output: mif 0 then T 0 else PDAG 0 *)
Definition test5 : RzQ_com_l 3 := [Meas 0 [Meas 0 [UC [T 0]] [UC [TDAG 0]]] [Meas 0 [UC [P 0]] [UC [PDAG 0]]]].
Compute (track_classical_state test5).

(** Proofs **)

(* If qubit q is initially in classical state b and propagate_classical_through_ucom
   returns boolean b', then qubit q will be in classical state b' after running
   program u. *)
Lemma propagate_classical_through_ucom_preserves_classical : forall dim (u : RzQ_ucom_l dim) q b u' b' ρ,
  uc_well_typed_l u ->
  WF_Matrix ρ ->
  propagate_classical_through_ucom u q b = (u', Some b') ->
  super (@pad 1 q dim (∣ b ⟩ × (∣ b ⟩)†)) ρ = ρ ->
  let ρ' := super (uc_eval (list_to_ucom u)) ρ in
  super (@pad 1 q dim (∣ b' ⟩ × (∣ b' ⟩)†)) ρ' = ρ'.
Proof.
  intros dim u q b u' b' ρ WT WFρ res Hρ ρ'.
  generalize dependent ρ.
  generalize dependent u'.
  generalize dependent b.
  induction u; intros b u' res ρ WFρ Hρ ρ'; subst ρ'; rewrite <- Hρ.
  - (* u = [] *)
    apply uc_well_typed_l_implies_dim_nonzero in WT.
    inversion res; subst; simpl.
    rewrite denote_SKIP; auto.
    rewrite super_I.
    2: destruct b';  auto with wf_db.
    rewrite <- super_Mmult.
    apply f_equal2; try reflexivity.
    unfold pad; destruct b'; simpl; gridify.
    all: Qsimpl; reflexivity.
  - (* u = a :: u *)
    simpl in res; destruct a as [p | p | p]; inversion WT; subst.
    + (* a = App1 p n *)
      bdestruct (q =? n).
      2: { destruct (propagate_classical_through_ucom u q b) eqn:prop.
           inversion res; subst; simpl.
           repeat rewrite super_Mmult.
           erewrite IHu; try apply prop; destruct b; auto with wf_db.
           all: repeat rewrite <- super_Mmult;
                apply f_equal2; try reflexivity;
                autorewrite with eval_db;
                bdestruct (q + 1 <=? dim).
           2,4: Msimpl; reflexivity.
           all: dependent destruction p; simpl.
           all: autorewrite with eval_db.
           all: gridify; Qsimpl; reflexivity. }
      dependent destruction p; simpl; subst.
      * (* p = H *)
        inversion res.
      * (* p = X *)
        destruct (propagate_classical_through_ucom u n (negb b)) eqn:prop.
        inversion res; subst; simpl.
        repeat rewrite super_Mmult.
        erewrite IHu; try apply prop; destruct b;  auto with wf_db.
        all: repeat rewrite <- super_Mmult;
             apply f_equal2; try reflexivity;
             autorewrite with eval_db; gridify.
        all: Qsimpl; reflexivity.
      * (* p = Rz *)
        destruct (propagate_classical_through_ucom u n b) eqn:prop.
        inversion res; subst; simpl.
        repeat rewrite super_Mmult.
        erewrite IHu; try apply prop; destruct b; auto with wf_db.
        all: repeat rewrite <- super_Mmult;
             apply f_equal2; try reflexivity;
             autorewrite with eval_db; gridify.
        all: do 2 (apply f_equal2; try reflexivity).
        all: solve_matrix.
    + (* a = App2 u n n0 *)
      dependent destruction p; simpl.
      bdestruct (q =? n).
      2: { bdestruct (q =? n0).
           inversion res.
           destruct (propagate_classical_through_ucom u q b) eqn:prop.
           inversion res; subst; simpl.
           repeat rewrite super_Mmult.
           erewrite IHu; try apply prop; destruct b; auto with wf_db.
           all: repeat rewrite <- super_Mmult;
                apply f_equal2; try reflexivity;
                autorewrite with eval_db;
                bdestruct (q + 1 <=? dim).
           2,4: Msimpl; reflexivity.
           all: gridify; Qsimpl; reflexivity. }
      destruct (propagate_classical_through_ucom u q b) eqn:prop.
      destruct b; inversion res; subst; simpl.
      * repeat rewrite super_Mmult.
        erewrite IHu; try apply prop; auto with wf_db.
        repeat rewrite <- super_Mmult.
        apply f_equal2; try reflexivity.
        autorewrite with eval_db.
        gridify.
        all: Qsimpl; reflexivity.
      * repeat rewrite super_Mmult.
        erewrite IHu; try apply prop; auto with wf_db.
        repeat rewrite <- super_Mmult.
        apply f_equal2; try reflexivity.
        autorewrite with eval_db.
        gridify.
        all: Qsimpl; reflexivity.
    + dependent destruction p.
Qed.

(* If qubit q is initially in classical state b then the program u' returned by
   propagate_classical_through_ucom will compute the same result as the original
   program u. *)
Lemma propagate_classical_through_ucom_sound: forall dim (u : RzQ_ucom_l dim) q b u' b' ρ,
  uc_well_typed_l u ->
  propagate_classical_through_ucom u q b = (u', b') ->
  super (@pad 1 q dim (∣ b ⟩ × (∣ b ⟩)†)) ρ = ρ ->
  super (uc_eval (list_to_ucom u)) ρ = super (uc_eval (list_to_ucom u')) ρ.
Proof.
  intros dim u q b u' b' ρ WT.
  generalize dependent ρ.
  generalize dependent u'.
  generalize dependent b.
  induction u; intros b u' ρ res Hρ.
  inversion res; reflexivity.
  simpl in res.
  destruct a as [p | p | p].
  - inversion WT; subst.
    bdestruct (q =? n).
    2: { destruct (propagate_classical_through_ucom u q b) eqn:prop.
         inversion res; subst; simpl.
         repeat rewrite super_Mmult.
         erewrite IHu; try apply prop; auto.
         rewrite <- Hρ.
         repeat rewrite <- super_Mmult.
         apply f_equal2; try reflexivity.
         autorewrite with eval_db.
         bdestruct (q + 1 <=? dim).
         2: Msimpl; reflexivity.
         dependent destruction p; simpl.
         all: autorewrite with eval_db.
         all: destruct b; gridify; Qsimpl; reflexivity. }
    dependent destruction p; simpl; subst.
    + inversion res; subst; simpl. reflexivity.
    + destruct (propagate_classical_through_ucom u n (negb b)) eqn:prop.
      inversion res; subst; simpl.
      repeat rewrite super_Mmult.
      erewrite IHu; try apply prop; auto.
      rewrite <- Hρ.
      repeat rewrite <- super_Mmult.
      apply f_equal2; try reflexivity.
      autorewrite with eval_db.
      destruct b; simpl; gridify.
      all: Qsimpl; reflexivity.
    + destruct (propagate_classical_through_ucom u n b) eqn:prop.
      inversion res; subst; simpl.
      repeat rewrite super_Mmult.
      erewrite IHu; try apply prop; auto.
      rewrite <- Hρ.
      repeat rewrite <- super_Mmult.
      apply f_equal2; try reflexivity.
      autorewrite with eval_db.
      destruct b; simpl; gridify.
      all: do 2 (apply f_equal2; try reflexivity).
      all: solve_matrix.
  - dependent destruction p; simpl.
    inversion WT; subst.
    bdestruct (q =? n).
    2: { bdestruct (q =? n0).
         inversion res; subst; simpl. reflexivity.
         destruct (propagate_classical_through_ucom u q b) eqn:prop.
         inversion res; subst; simpl.
         repeat rewrite super_Mmult.
         erewrite IHu; try apply prop; auto.
         rewrite <- Hρ.
         repeat rewrite <- super_Mmult.
         apply f_equal2; try reflexivity.
         autorewrite with eval_db.
         bdestruct (q + 1 <=? dim).
         2: Msimpl; reflexivity.
         destruct b; gridify; Qsimpl; reflexivity. }
    destruct (propagate_classical_through_ucom u q b) eqn:prop.
    destruct b; inversion res; subst; simpl.
    all: repeat rewrite super_Mmult;
         erewrite IHu; try apply prop; auto.
    all: rewrite <- Hρ;
         repeat rewrite <- super_Mmult;
         repeat rewrite Mmult_assoc.
    all: apply f_equal2; try reflexivity.
    1, 3: apply f_equal2; try reflexivity.
    all: try rewrite pauli_x_rotation; simpl;
         autorewrite with eval_db.
    all: gridify.
    all: Qsimpl; reflexivity.
  - dependent destruction p.
Qed.

Lemma propagate_classical_through_com_preserves_classical : forall dim (l : RzQ_com_l dim) q b n l' b' ρ,
  (dim > 0)%nat ->
  c_well_typed_l l ->
  WF_Matrix ρ ->
  propagate_classical_through_com l q b n = (l', Some b') ->
  super (@pad 1 q dim (∣ b ⟩ × (∣ b ⟩)†)) ρ = ρ ->
  let ρ' := c_eval (list_to_com l) ρ in
  super (@pad 1 q dim (∣ b' ⟩ × (∣ b' ⟩)†)) ρ' = ρ'.
Proof.
  intros dim l q b n l' b' ρ Hdim WT WFρ res Hρ ρ'.
  generalize dependent ρ.
  generalize dependent b'.
  generalize dependent l'.
  generalize dependent b.
  generalize dependent l.
  induction n; intros l WT b l' b' res ρ WFρ Hρ ρ'.
  inversion res.
  simpl in res.
  destruct l; subst ρ'.
  inversion res; subst; simpl. assumption.
  destruct i.
  - (* i = UC u *)
    inversion WT; subst.
    simpl.
    rewrite instr_to_com_UC.
    destruct (propagate_classical_through_ucom g q b) eqn:prop_u.
    destruct o.
    2: inversion res.
    destruct (propagate_classical_through_com l q b0) eqn:prop_c.
    inversion res; subst.
    unfold compose_super; simpl.
    eapply IHn; try apply prop_c; auto with wf_db.
    eapply propagate_classical_through_ucom_preserves_classical; try apply prop_u; auto.
  - (* i = Meas n0 l1 l2 *)
    inversion WT; subst.
    simpl.
    rewrite instr_to_com_Meas.
    bdestruct (q =? n0).
    + (* measurement on qubit q *)
      subst. destruct b; simpl; unfold compose_super, Splus.
      all: unfold proj, pad_u;
           rewrite <- Hρ; simpl;
           try rewrite double_pad with (b:=true);
           try rewrite double_pad with (b:=false);
           try rewrite double_pad01;
           try rewrite double_pad10;
           repeat rewrite c_eval_0;
           Msimpl.
      * (* take the true branch *)
        destruct (propagate_classical_through_com l0 n0 true n) eqn:propl0.
        destruct o.
        2: inversion res.
        destruct (propagate_classical_through_com l n0 b n) eqn:propl.
        inversion res; subst.
        eapply IHn; try apply propl; auto with wf_db.
        eapply IHn; try apply propl0; auto with wf_db.
        apply double_pad.
      * (* take the false branch *)
        destruct (propagate_classical_through_com l1 n0 false n) eqn:propl1.
        destruct o.
        2: inversion res.
        destruct (propagate_classical_through_com l n0 b n) eqn:propl.
        inversion res; subst.
        eapply IHn; try apply propl; auto with wf_db.
        eapply IHn; try apply propl1; auto with wf_db.
        apply double_pad.
    + (* measurement on a different qubit *)
      destruct (propagate_classical_through_com l0 q b n) eqn:propl0.
      destruct (propagate_classical_through_com l1 q b n) eqn:propl1.
      destruct o; destruct o0; try destruct b0; try destruct b1; simpl; unfold compose_super, Splus.
      (* most cases return None instead of Some b *)
      all: inversion res.
      (* two cases require the inductive hypothesis *)
      * destruct (propagate_classical_through_com l q true n) eqn:propl.
        inversion res; subst.
        eapply IHn; try apply propl; auto with wf_db.
        rewrite <- super_Mplus.
        apply f_equal2.
        1: eapply IHn; try apply propl0; auto with wf_db.
        2: eapply IHn; try apply propl1; auto with wf_db.
        all: rewrite <- Hρ; repeat rewrite <- super_Mmult; apply f_equal2; try reflexivity.
        all: unfold proj, pad_u, pad; destruct b; gridify.
        all: Qsimpl; reflexivity.
      * destruct (propagate_classical_through_com l q false n) eqn:propl.
        inversion res; subst.
        eapply IHn; try apply propl; auto with wf_db.
        rewrite <- super_Mplus.
        apply f_equal2.
        1: eapply IHn; try apply propl0; auto with wf_db.
        2: eapply IHn; try apply propl1; auto with wf_db.
        all: rewrite <- Hρ; repeat rewrite <- super_Mmult; apply f_equal2; try reflexivity.
        all: unfold proj, pad_u, pad; destruct b; gridify.
        all: Qsimpl; reflexivity.
Qed.

Lemma propagate_classical_through_com_sound: forall dim (l : RzQ_com_l dim) q b n l' b' ρ,
  (dim > 0)%nat ->
  c_well_typed_l l ->
  WF_Matrix ρ ->
  propagate_classical_through_com l q b n = (l', b') ->
  super (@pad 1 q dim (∣ b ⟩ × (∣ b ⟩)†)) ρ = ρ ->
  c_eval (list_to_com l) ρ = c_eval (list_to_com l') ρ.
Proof.
  intros dim l q b n l' b' ρ Hdim WT WFρ res Hρ.
  generalize dependent ρ.
  generalize dependent b'.
  generalize dependent l'.
  generalize dependent b.
  generalize dependent l.
  induction n; intros l WT b l' b' res ρ WFρ Hρ.
  inversion res; subst. reflexivity.
  simpl in res.
  destruct l.
  inversion res; subst. reflexivity.
  destruct i.
  - (* i = UC u *)
    inversion WT; subst.
    simpl.
    destruct (propagate_classical_through_ucom g q b) eqn:prop_u.
    destruct o.
    destruct (propagate_classical_through_com l q b0 n) eqn:prop_c.
    all: inversion res; subst; simpl; unfold compose_super.
    all: repeat rewrite instr_to_com_UC; simpl.
    all: erewrite <- propagate_classical_through_ucom_sound with (u:=g) (u':=r);
         try apply prop_u; auto.
    eapply IHn; try apply prop_c; auto with wf_db.
    eapply propagate_classical_through_ucom_preserves_classical; try apply prop_u; auto.
  - (* i = Meas n0 l1 l2 *)
    inversion WT; subst.
    simpl.
    rewrite instr_to_com_Meas.
    bdestruct (q =? n0).
    + (* measurement on qubit q *)
      subst. destruct b; simpl; unfold compose_super, Splus.
      all: unfold proj, pad_u;
           rewrite <- Hρ; simpl;
           try rewrite double_pad with (b:=true);
           try rewrite double_pad with (b:=false);
           try rewrite double_pad01;
           try rewrite double_pad10;
           repeat rewrite c_eval_0;
           Msimpl.
      * (* take the true branch *)
        destruct (propagate_classical_through_com l0 n0 true n) eqn:propl0.
        destruct o.
        destruct (propagate_classical_through_com l n0 b n) eqn:propl.
        all: inversion res; subst.
        all: rewrite list_to_com_append; auto with wf_db;
             simpl; unfold compose_super.
        all: erewrite <- IHn with (l:=l0) (l':=r); try apply propl0; auto with wf_db.
        erewrite <- propagate_classical_through_com_preserves_classical with (l:=l0); try apply propl0; auto with wf_db.
        all: try apply double_pad with (b:=true).
        eapply IHn; try apply propl; destruct b; auto with wf_db.
        all: apply double_pad.
      * (* take the false branch *)
        destruct (propagate_classical_through_com l1 n0 false n) eqn:propl1.
        destruct o.
        destruct (propagate_classical_through_com l n0 b n) eqn:propl.
        all: inversion res; subst.
        all: rewrite list_to_com_append; auto with wf_db;
             simpl; unfold compose_super.
        all: erewrite <- IHn with (l:=l1) (l':=r); try apply propl1; auto with wf_db.
        erewrite <- propagate_classical_through_com_preserves_classical with (l:=l1); try apply propl1; auto with wf_db.
        all: try apply double_pad.
        eapply IHn; try apply propl; destruct b; auto with wf_db.
        all: apply double_pad.
    + (* measurement on a different qubit *)
      destruct (propagate_classical_through_com l0 q b n) eqn:propl0.
      destruct (propagate_classical_through_com l1 q b n) eqn:propl1.
      assert (Haux1 : super (@pad 1 q dim (∣ b ⟩ × (∣ b ⟩) †)) (super (@pad 1 n0 dim (∣1⟩ × (∣1⟩) †)) ρ) = super (@pad 1 n0 dim (∣1⟩ × (∣1⟩) †)) ρ).
      { rewrite <- Hρ; clear - H.
        repeat rewrite <- super_Mmult; apply f_equal2; try reflexivity.
        unfold pad; destruct b; gridify.
        all: Qsimpl; reflexivity. }
      assert (Haux2 : super (@pad 1 q dim (∣ b ⟩ × (∣ b ⟩) †)) (super (@pad 1 n0 dim (∣0⟩ × (∣0⟩) †)) ρ) = super (@pad 1 n0 dim (∣0⟩ × (∣0⟩) †)) ρ).
      { rewrite <- Hρ; clear - H.
        repeat rewrite <- super_Mmult; apply f_equal2; try reflexivity.
        unfold pad; destruct b; gridify.
        all: Qsimpl; reflexivity. }
      destruct o; destruct o0; try destruct b0; try destruct b1.
      destruct (propagate_classical_through_com l q true n) eqn:propl.
      4: destruct (propagate_classical_through_com l q false n) eqn:propl.
      all: inversion res; subst; simpl.
      all: rewrite instr_to_com_Meas.
      all: simpl; unfold compose_super, Splus.
      (* most cases only require (IHn l0) and (IHn l1) *)
      all: erewrite <- IHn with (l:=l0) (l':=r); try apply propl0; auto with wf_db.
      all: erewrite <- IHn with (l:=l1) (l':=r0); try apply propl1; auto with wf_db.
      (* two cases require propagate_classical_through_com_preserves_classical *)
      * eapply IHn; try apply propl; auto with wf_db.
        rewrite <- super_Mplus.
        apply f_equal2.
        eapply propagate_classical_through_com_preserves_classical; try apply propl0; auto with wf_db.
        eapply propagate_classical_through_com_preserves_classical; try apply propl1; auto with wf_db.
      * eapply IHn; try apply propl; auto with wf_db.
        rewrite <- super_Mplus.
        apply f_equal2.
        eapply propagate_classical_through_com_preserves_classical; try apply propl0; auto with wf_db.
        eapply propagate_classical_through_com_preserves_classical; try apply propl1; auto with wf_db.
Qed.

Lemma propagate_classical_through_ucom_WT: forall dim (u : RzQ_ucom_l dim) q b u' b',
  uc_well_typed_l u ->
  propagate_classical_through_ucom u q b = (u', b') ->
  uc_well_typed_l u'.
Proof.
  intros dim u q b u' b' WT.
  generalize dependent u'.
  generalize dependent b.
  induction u; intros b u' res.
  inversion res; constructor.
  apply (uc_well_typed_l_implies_dim_nonzero _ WT).
  simpl in res.
  destruct a as [p | p | p]; inversion WT; subst.
  - bdestruct (q =? n).
    2: destruct (propagate_classical_through_ucom u q b) eqn:prop.
    dependent destruction p; subst.
    2: destruct (propagate_classical_through_ucom u n (negb b)) eqn:prop.
    3: destruct (propagate_classical_through_ucom u n b) eqn:prop.
    all: inversion res; subst; constructor; auto.
    all: eapply IHu; try apply prop; auto.
  - bdestruct (q =? n).
    destruct (propagate_classical_through_ucom u q b) eqn:prop.
    destruct b.
    3: bdestruct (q =? n0).
    4: destruct (propagate_classical_through_ucom u q b) eqn:prop.
    all: inversion res; subst; try constructor; auto.
    all: eapply IHu; try apply prop; auto.
  - dependent destruction p.
Qed.

Lemma c_well_typed_l_app : forall {dim} (l1 l2 : RzQ_com_l dim),
  c_well_typed_l l1 /\ c_well_typed_l l2 <-> c_well_typed_l (l1 ++ l2).
Proof.
  intros; split.
  - intros [Hl1 Hl2].
    induction Hl1; simpl; try constructor; assumption.
  - intros H.
    induction l1.
    + split; simpl in H; try constructor; try assumption.
    + inversion H; subst;
      match goal with
      | H : c_well_typed_l (?l1 ++ ?l2) |- _ => apply IHl1 in H as [? ?]
      end;
      split; try constructor; assumption.
Qed.

Lemma propagate_classical_through_com_WT : forall dim (l : RzQ_com_l dim) q b n l' b',
  c_well_typed_l l ->
  propagate_classical_through_com l q b n = (l', b') ->
  c_well_typed_l l'.
Proof.
  intros.
  generalize dependent b'.
  generalize dependent l'.
  generalize dependent b.
  generalize dependent l.
  induction n; intros l WT b l' b' res.
  inversion res; subst. assumption.
  simpl in res.
  destruct l.
  inversion res; subst. assumption.
  destruct i; inversion WT; subst.
  - (* i = UC u *)
    destruct (propagate_classical_through_ucom g q b) eqn:prop_u.
    destruct o.
    destruct (propagate_classical_through_com l q b0 n) eqn:prop_c.
    all: inversion res; subst; constructor; auto.
    all: try eapply propagate_classical_through_ucom_WT; try apply prop_u; auto.
    eapply IHn; try apply prop_c; auto.
  - (* i = Meas n0 l1 l2 *)
    bdestruct (q =? n0).
    + destruct b.
      all: try destruct (propagate_classical_through_com l0 q true n) eqn:propl0.
      all: try destruct (propagate_classical_through_com l1 q false n) eqn:propl1.
      all: try destruct o; try destruct o0.
      all: try destruct (propagate_classical_through_com l q b n) eqn:propl.
      all: try destruct (propagate_classical_through_com l q b0 n) eqn:propl'.
      all: inversion res; subst.
      all: try (apply c_well_typed_l_app; split).
      all: try constructor; auto.
      all: eapply IHn; try apply propl0; try apply propl1; try apply propl; try apply propl'; auto.
    + destruct (propagate_classical_through_com l0 q b n) eqn:propl0.
      destruct (propagate_classical_through_com l1 q b n) eqn:propl1.
      destruct o; try destruct o0; try destruct b0; try destruct b1.
      all: try destruct (propagate_classical_through_com l q true n) eqn:proplT.
      all: try destruct (propagate_classical_through_com l q false n) eqn:proplF.
      all: inversion res; subst; constructor; auto.
      all: eapply IHn; try apply propl0; try apply propl1; try apply proplT; try apply proplF; auto.
Qed.

Lemma track_classical_state_sound : forall dim (l : RzQ_com_l dim),
  c_well_typed_l l ->
  track_classical_state l =l= l.
Proof.
  intros.
  unfold track_classical_state.
  remember (count_ops l) as n; clear Heqn.
  generalize dependent l.
  induction n; try reflexivity.
  intros l WT; simpl.
  destruct l; try reflexivity.
  destruct i.
  inversion WT; subst.
  rewrite IHn; try assumption; reflexivity.
  inversion WT; subst.
  destruct (propagate_classical_through_com l0 n0 true n) eqn:propl0.
  destruct (propagate_classical_through_com l1 n0 false n) eqn:propl1.
  unfold c_equiv_l, c_equiv.
  intros Hdim ρ WFρ.
  destruct o; destruct o0; try destruct b; try destruct b0.
  (* two cases where we call propagate on the tail of the list *)
  1: destruct (propagate_classical_through_com l n0 true n) eqn:propl.
  4: destruct (propagate_classical_through_com l n0 false n) eqn:propl.
  1,4: simpl;
       repeat rewrite instr_to_com_Meas;
       simpl; unfold compose_super, Splus;
       repeat rewrite IHn; auto with wf_db.
  all: try eapply propagate_classical_through_com_WT;
       try apply propl0; try apply propl1; try apply propl; auto.
  1,2: erewrite <- propagate_classical_through_com_sound with (l':=r);
       try apply propl0; auto with wf_db; try apply double_pad.
  1,2: erewrite <- propagate_classical_through_com_sound with (l':=r0);
       try apply propl1; auto with wf_db; try apply double_pad.
  1,2: erewrite propagate_classical_through_com_sound with (l:=l);
       try apply propl; auto with wf_db.
  1,2: erewrite <- propagate_classical_through_com_preserves_classical with (l:=l0);
       try apply propl0; auto with wf_db; try apply double_pad.
  1,2: erewrite <- propagate_classical_through_com_preserves_classical with (l:=l1);
       try apply propl1; auto with wf_db; try apply double_pad.
  1,2: rewrite super_Mplus.
  1,2: apply double_pad.
  (* all other cases are the same *)
  all: apply Meas_cons_congruence; try apply IHn; auto.
  all: intros; unfold c_eval_l, project_onto.
  all: try rewrite (IHn r); auto with wf_db.
  all: try eapply propagate_classical_through_com_WT with (l:=l0) (l':=r); try apply propl0; auto.
  all: try erewrite propagate_classical_through_com_sound with (l:=l0) (l':=r); try apply propl0; auto with wf_db.
  all: try apply double_pad.
  all: try rewrite (IHn r0); auto with wf_db.
  all: try eapply propagate_classical_through_com_WT with (l:=l1) (l':=r0); try apply propl1; auto.
  all: try erewrite propagate_classical_through_com_sound with (l:=l1) (l':=r0); try apply propl1; auto with wf_db.
  all: try apply double_pad.
Qed.


Require Import XR_Rabs.
Require Import XR_Rabs_minus_sym.
Require Import XR_Rabs_triang_inv.
Require Import XR_Rcase_abs.
Require Import XR_Rminus.
Require Import XR_Ropp_plus_distr.
Require Import XR_Ropp_involutive.
Require Import XR_Rle_trans.

Local Open Scope R_scope.

Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b).
Proof.
  intros x y.
  unfold Rabs at 1.
  destruct (Rcase_abs (Rabs x - Rabs y)) as [ h | h ].
  {
    rewrite Rabs_minus_sym.
    eapply Rle_trans.
    2:apply Rabs_triang_inv.
    unfold Rminus.
    rewrite Ropp_plus_distr.
    rewrite Ropp_involutive.
    rewrite Rplus_comm.
    right.
    reflexivity.
  }
  { apply Rabs_triang_inv. }
Qed.


Require Import generic_soundness.

Require Import reduction.

Require Import proofsystem.
Set Implicit Arguments.

Require Import Setoid.
Require Import Relation_Definitions.

Axiom cfg : Set.
Axiom S : cfg -> cfg -> Prop.

(* Showing one-path soundness.
  The final notion of one-path soundness considers a reachability rule
  satisfied if the initial configuration admits a diverging execution, so
  in the non-vacuous case we might as well assume the initial configuration
  terminates on all execution paths, and then this termination is itself
  a well-ordering we can use to justify circularity.
  (see "holds" for the unconditional definition)
 *)

(* Lemmas *)
Lemma clos_lift (A B : Type) (R1 : relation A) (R2 : relation B)
  (f : B -> A) :
  (forall x y, R1 x y -> forall x', x = f x' -> exists y', R2 x' y' /\ y = f y') ->
  forall strict x y,
  clos R1 strict x y ->
  forall x', x = f x' ->
  exists y', clos R2 strict x' y' /\ y = f y'.
induction 2;intros;
repeat match goal with
         | [H : _ -> _ -> ?R _ _ -> _, H1 : ?R _ _ |- _] => specialize (H _ _ H1)
         | [H : forall x, ?a = f x -> _, H1 : ?a = f _ |- _] => specialize (H _ H1)
         | [H : exists y', _ /\ _ = f y' |-_] =>
           destruct H as [? []]
       end;
eauto using clos.
Qed.

Lemma terminates_next : forall {A : Set} {R : relation A} (a : A),
  terminates a R -> forall b, R a b -> terminates b R.
destruct 1.
assumption.
Qed.

Lemma under_terminates : forall {A : Set} {R : relation A} (a : A),
  terminates a R -> forall (P : A -> Prop),
  (forall a0, clos R false a a0 ->
              (forall a', R a0 a' -> P a') ->
              P a0)
  -> P a.
intros A R a term P.
move term after P.
induction term as [a HAcc IH].
intro Hlater.
apply Hlater.
constructor.
intros a' Raa.
apply IH.
assumption.
intros a0 Ha'a0 Hnext.
apply Hlater.
clear -Raa Ha'a0. eauto using clos.
assumption.
Qed.

Lemma clos_cat'
     : forall (A : Type) (R : relation A) (a : A) (s1 : bool)
         (b : A) (s2 s3 : bool) (c : A),
       clos R s1 a b -> clos R s2 b c -> implb s3 (s1 || s2) = true -> clos R s3 a c.
intros.
pose proof (clos_cat H H0) as H2; clear -H1 H2.
destruct s3. simpl in H1; rewrite H1 in H2;assumption.
destruct (orb s1 s2);auto using clos_unstrict.
Qed.

Module ExReachability <: StateBasedReachability.

Definition cfg := cfg.
Definition S := S.

Definition index : Set := {gamma : cfg | terminates gamma S}.
Definition ix_rel (i1 i2 : index) : Prop :=
  S (proj1_sig i1) (proj1_sig i2).

Definition state_reaches strict (i : index) gamma P :=
  clos S false (proj1_sig i) gamma ->
  exists gamma', clos S strict gamma gamma' /\ P gamma'.

Definition holds strict env (phi phi' : formula cfg env) i :=
  forall rho gamma,
    phi rho gamma ->
    state_reaches strict i gamma (phi' rho).

(* Nontrivial proofs *)
(** Circularity **)
Lemma ix_rel_ind : forall env (phi phi' : formula cfg env),
      forall i0,
      (forall i, clos ix_rel false i0 i ->
                   (forall i', ix_rel i i' -> holds true phi phi' i') ->
                   holds true phi phi' i)
       -> holds true phi phi' i0.
unfold holds, state_reaches; intros env phi phi' i Hix_later.
destruct i as [a Hterm].
simpl.
apply (under_terminates Hterm).
intros a0 Haa0 Hnext.

assert (exists i', clos ix_rel false (exist _ a Hterm) i' /\ a0 = proj1_sig i').
  clear -Haa0. apply clos_lift with (R1:=S) (x:=a);[|assumption|reflexivity].
  intros.
  destruct x';simpl in *|- *;subst.
  assert (terminates y S) by (destruct t as [H0]; apply H0; assumption).
  exists (exist _ y H0). split;[|reflexivity].
  unfold ix_rel;simpl. assumption.
destruct H as [i' [Hreach Hend]].
specialize (Hix_later i' Hreach).
rewrite Hend.
apply Hix_later.
intros.
subst a0.
eauto.
Qed.

Ltac clear_except_path :=
repeat match goal with
  | [H : ?Hyp |- _] =>
    match Hyp with
      | terminates _ _ => fail 1
      | clos _ _ _ _ => fail 1
      | S ?x ?y => apply (clos_step _ true) in H
      | _ => clear H
    end
  end.
Ltac clos_solve :=
  clear_except_path;
match goal with
  | [|- clos _ false ?x ?x] => apply clos_refl
  | [|- clos _ false _ _] =>
    repeat match goal with
             | [H : clos _ true _ _ |- _] => apply clos_unstrict in H
           end;
    repeat match goal with
             | [H : clos ?S _ ?x ?y |- clos ?S _ ?x ?y ] => assumption
             | [H : clos ?S _ ?x ?y, H2 : clos ?S _ ?y _ |- clos ?S _ ?x _ ] =>
               pose proof (clos_trans H H2); clear H2
           end
  | [|- clos _ _ _ _] =>
    repeat match goal with
         | [H : clos ?S ?f ?x ?y |- clos ?S ?f ?x ?y ] => assumption
         | [H : clos ?S true ?x ?y, H2 : clos ?S _ ?y _ |- clos ?S _ ?x _ ] =>
           pose proof (clos_cons_lt H H2); clear H H2
         | [H : clos ?S _ ?x ?y, H2 : clos ?S true ?y _ |- clos ?S _ ?x _ ] =>
           pose proof (clos_cons_rt H H2); clear H H2
      end
end.

Hint Extern 0 (clos _ _ _ _) => clos_solve : holds_solve.

Ltac holds_start := intros;
  repeat match goal with
  (* open unnecessary uses of holds/indices *)
  | [i : index |- _] => destruct i
  | [H : ix_rel (exist _ _ _) _ |- _] => unfold ix_rel in H; simpl proj1_sig in H
  | [H : ix_rel _ (exist _ _ _) |- _] => unfold ix_rel in H; simpl proj1_sig in H
  | [H : state_reaches _ (exist _ _ _) _ _ |- _] =>
    unfold state_reaches in H;simpl proj1_sig in H
  | [|- state_reaches  _ (exist _ _ _) _ _] =>
    unfold state_reaches;simpl proj1_sig;intros
  (* Use hypotheses *)
  | [H : (clos S ?f ?x ?y) -> _ |- _] =>
    match goal with
      | [H' : clos S f x y |- _] =>
        specialize (H H')
      | _ =>
        let Hpath := fresh "Hpath" in
        assert (clos S f x y) as Hpath by clos_solve;
          specialize (H Hpath)
    end
  (* Open results *)
  | [H : exists gamma : _, _ |- _] =>
    destruct H
  | [H : _ /\ _ |- _] =>
    destruct H
  end.

Lemma reach_later : forall i i', ix_rel i i' ->
    forall gamma P,
      state_reaches true i gamma P ->
      state_reaches true i' gamma P.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.
  Lemma reach_unstrict : forall i gamma P,
    state_reaches true i gamma P -> state_reaches false i gamma P.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.

  Lemma reach_refl : forall i gamma (P : cfg -> Prop),
                           P gamma -> state_reaches false i gamma P.
  Proof.
    holds_start; firstorder with holds_solve.
  Qed.

  Lemma reach_step : forall i gamma (P : cfg -> Prop),
    (exists gamma', S gamma gamma') ->
    (forall gamma', S gamma gamma' -> P gamma') ->
      state_reaches true i gamma P.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.

  Lemma reach_impl : forall (P Q : cfg -> Prop),
                           (forall c, P c -> Q c) ->
                           forall strict i gamma,
                             state_reaches strict i gamma P ->
                             state_reaches strict i gamma Q.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.

  Lemma reach_join : forall i gamma P,
    state_reaches false i gamma
     (fun gamma' => state_reaches false i gamma' P) ->
    state_reaches false i gamma P.
  Proof.
    holds_start;eauto with holds_solve.
  Qed.

  Lemma reach_join_strict : forall i gamma P,
    state_reaches true i gamma
     (fun gamma' => forall i', ix_rel i i' -> state_reaches false i' gamma' P) ->
    state_reaches true i gamma P.
  Proof.
    holds_start.
    unfold ix_rel in H1; simpl proj1_sig in H1.
    assert (clos S true x x0) by clos_solve;clear H0.
    destruct (clos_true_step H2) as [x' [Hxx' Hx'x0]].
    specialize (H1 (exist _ x' (terminates_next t _ Hxx')) Hxx' Hx'x0).
    firstorder with holds_solve.
  Qed.

End ExReachability.

Module ExPathSemantics := StateBasedSemantics ExReachability.
Module ExPathSoundness := Soundness ExPathSemantics.

Definition holds cfg S strict env (phi phi' : formula cfg env) :=
  forall rho gamma, terminates gamma S ->
    phi rho gamma -> exists gamma', phi' rho gamma' /\ clos S strict gamma gamma'.

Lemma approx_holds env (phi phi' : formula cfg env) strict :
  (forall i, ExPathSemantics.holds strict phi phi' i) ->
  holds S strict phi phi'.
intro H. unfold holds.
intros.
specialize (H (exist _ gamma H0) _ _ H1 (clos_refl _ _)).
firstorder.
Qed.

Lemma holds_approx env (phi phi' : formula cfg env) strict :
  holds S strict phi phi' ->
  (forall i, ExPathSemantics.holds strict phi phi' i).
intros Hstrong i.
destruct i as [gamma term].
unfold ExPathSemantics.holds, ExReachability.holds.
intros rho gamma1 Hphi Hreach.
specialize (Hstrong _ gamma1 (terminates_fwd term Hreach) Hphi).
firstorder.
Qed.

Definition system_holds cfg S (A : system cfg) :=
  forall env phi1 phi2, @A env phi1 phi2 -> holds S true phi1 phi2.

Theorem soundness (A : system cfg) env (phi1 phi2 : formula cfg env) :
  IS cfg S None A env phi1 phi2 ->
  system_holds S A ->
  holds S false phi1 phi2.
Proof.
intros pf HA.
apply approx_holds.
intro i.
apply (ExPathSoundness.soundness pf);trivial.
clear -HA i.
pose proof holds_approx.
unfold ExPathSoundness.system_holds;intros.
eauto.
Qed.

(* Print Assumptions soundness. *)


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

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

From Undecidability.TM Require Import SBTM.
From Undecidability.MinskyMachines Require Import MMA.

From Undecidability.TM
  Require SBTM_HALT_to_PCTM_HALT.

From Undecidability.StackMachines
  Require PCTM_HALT_to_BSM_HALTING.

From Undecidability.MinskyMachines
  Require MMA BSM_to_MMA_HALTING MMA3_to_MMA2_HALTING.

Theorem reduction : SBTM_HALT ⪯ MMA2_HALTING.
Proof.
  eapply reduces_transitive. apply SBTM_HALT_to_PCTM_HALT.reduction.
  eapply reduces_transitive. apply PCTM_HALT_to_BSM_HALTING.reduction.
  eapply reduces_transitive. apply BSM_to_MMA_HALTING.reduction.
  apply MMA3_to_MMA2_HALTING.reduction.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj29synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (plus Zero (mult lv0 lv1)) (plus lv1 lv0))) (plus (mult lv0 lv2) lv2)).
Admitted.
QuickChick conj29synthconj2.


Set Implicit Arguments.

Require Import FPUtil.

Require Import Arith NArith NPeano Ascii String List Bool.
Import ListNotations.
Local Open Scope prog_scope.
Local Open Scope N_scope.
Local Open Scope nat_scope.
Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope bool_scope.
Require Import Bitvec.
Local Open Scope bitvec_scope.

Section GCM.

  Definition stateful_map S (upd : S -> S) (init : S) A (f : A -> S -> A) (ls : list A) : list A * S :=
    let step (p : list A * S) x :=
        let (acc, st) := p in
        let y := f x st in
        (y :: acc, upd st) in
    let (ls, final) := fold_left step ls ([], init) in
    (rev ls, final).

  Definition fold_left_i A B (f : nat -> A -> B -> A) (ls : list B) init init_i :=
    fst $ fold_left (fun (p : A * nat) x => let (a, i) := p in (f i a x, S i)) ls (init, init_i).

  Definition len A := @length A >> msb_of_nat 64.

  Infix "=?" := beq_nat : nat_scope.

  Definition gf128_mul := gf_mul 128 "11100001".

  Infix "*" := gf128_mul : bitvec_scope.
  Infix "+" := xor : bitvec_scope.

  Definition GHASH (H : b128) (A : bitvec) (C : bitvec) : b128 :=
    let As := slice 128 A in
    let Cs := slice 128 C in
    let m := length As in
    let n := length Cs in
    let step i (X Y : b128) :=
        let Y := if (i =? m - 1)%nat || (i =? m + n - 1)%nat then
                   right_trunc_pad_to 128 Y
                 else
                   Y in
        (X + Y) * H in
    let X := fold_left_i step (As ++ Cs) (zeros 128) 0 in
    (X + (len A ++ len C)) * H.

  Variable E : key_t -> b128 -> b128.
  Variable K : key_t.
  Definition IV_t := bitvec.
  Variable IV : IV_t.
  Variable P : bitvec.
  Definition A_t := bitvec.
  Variable A : A_t.
  Variable t : nat.

  Definition H := E K $ zeros 128.

  Definition msb_unsign_plus (a b : bitvec) : bitvec := msb_of_N (length a) ((msb_to_N a) + (msb_to_N b))%N.

  Definition incr v :=
    let F_len := length v - 32 in
    let F := firstn F_len v in
    let I := skipn F_len v in
    F ++ (msb_unsign_plus I (msb_of_nat 32 1)).

  Definition Y0 : b128 :=
    if (length IV =? 96)%nat then
      IV ++ zeros 31 ++ bin "1"
    else
      GHASH H [] IV.

  Definition Encrypt : bitvec :=
    match P with
      | nil => nil
      | _ =>
        let Ps := slice 128 P in
        let Pi := removelast Ps in
        let Pn := last Ps (zeros 128) in
        let (Ci, Yn) := stateful_map incr (incr Y0) (fun Pi Yi => Pi + E K Yi) Pi in
        let Cn := Pn + firstn (length Pn) (E K Yn) in
        flat Ci ++ Cn
    end.

  Definition Hash := fun C => firstn t $ GHASH H A C + E K Y0.

End GCM.

Definition encrypt E K IV P A k :=
  let C := Encrypt E K IV P in
  let T := Hash E K IV A k C in
  (C, T).

Definition decrypt E K IV C A (T : bitvec) :=
  let k := length T in
  let T' := Hash E K IV A k C in
  if T' =? T then
    let P := Encrypt E K IV C in
    Some P
  else
    None.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime Cprime : Universe, ((wd_ B Aprime /\ (wd_ B Cprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ B C /\ (wd_ B A /\ (col_ Aprime B Cprime /\ (col_ A B C /\ (col_ A C Cprime /\ col_ Aprime C Cprime)))))))))) -> col_ B Cprime C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import BasicMachineTypes.
Require Import ClasspoolIface.
Require Import ClassDatatypesIface.
Require Import List.

Require Import AnnotationIface.

Module Type ASSIGNABILITY
  (A_B : BASICS)
  (ANN : ANNOTATION A_B)
  (A_C : CLASSDATATYPES A_B ANN)
  (A_CP : CLASSPOOL A_B ANN A_C).

(* Assignability *)

Inductive sub_class (classes:A_CP.cert_classpool) : A_B.Classname.t -> A_B.Classname.t -> Prop :=
| sub_class_refl : forall nm cwitness,
   A_CP.class_loaded classes nm cwitness ->
   sub_class classes nm nm
| sub_class_step : forall nm nm_t s_nm c,
   A_CP.class_loaded classes nm c ->
   A_C.class_super_class c = Some s_nm ->
   sub_class classes s_nm nm_t ->
   sub_class classes nm nm_t.

Hypothesis sub_class_trans : forall classes a b c,
  sub_class classes a b ->
  sub_class classes b c ->
  sub_class classes a c.

Hypothesis preserve_subclass : forall classesA classesB A A_B,
  sub_class classesA A A_B ->
  A_CP.preserve_old_classes classesA classesB ->
  sub_class classesB A A_B.

Hypothesis preserve_subclass_rev : forall classesA classesB nm_s c_s nm_t,
  A_CP.class_loaded classesA nm_s c_s ->
  sub_class classesB nm_s nm_t ->
  A_CP.preserve_old_classes classesA classesB ->
  sub_class classesA nm_s nm_t.

Inductive direct_super_interface (classes:A_CP.cert_classpool) : list A_B.Classname.t -> A_B.Classname.t -> Prop :=
| d_inter_here : forall nmT interfaces,
   direct_super_interface classes (nmT::interfaces) nmT
| d_inter_step_up : forall interfaces nmX cX nmT,
   A_CP.class_loaded classes nmX cX ->
   A_C.class_interface cX = true ->
   direct_super_interface classes (A_C.class_interfaces cX) nmT ->
   direct_super_interface classes (nmX::interfaces) nmT
| d_inter_step_along : forall interfaces nmT nmX,
   direct_super_interface classes interfaces nmT ->
   direct_super_interface classes (nmX::interfaces) nmT.

Definition class_implements classes nmS nmT :=
 exists nmS', exists cS',
   A_CP.class_loaded classes nmS' cS' /\
   A_C.class_interface cS' = false /\
   sub_class classes nmS nmS' /\
   direct_super_interface classes (A_C.class_interfaces cS') nmT.

Hypothesis cl_impls_direct : forall classes nmS cS nmT,
  A_CP.class_loaded classes nmS cS ->
  A_C.class_interface cS = false ->
  direct_super_interface classes (A_C.class_interfaces cS) nmT ->
  class_implements classes nmS nmT.
Implicit Arguments cl_impls_direct [classes nmS cS nmT].

Hypothesis cl_impls_super: forall classes nmS cS nm_superS nmT,
  A_CP.class_loaded classes nmS cS ->
  A_C.class_super_class cS = Some nm_superS ->
  class_implements classes nm_superS nmT ->
  class_implements classes nmS nmT.
Implicit Arguments cl_impls_super [classes nmS cS nm_superS nmT].

Parameter assignable : A_CP.cert_classpool -> A_C.java_ref_type -> A_C.java_ref_type -> Prop.
Parameter is_assignable : forall classes S T, {assignable classes S T}+{~assignable classes S T}.

Hypothesis assignable_class_class : forall classes nmS nmT cS cT,
   A_CP.class_loaded classes nmS cS ->
   A_CP.class_loaded classes nmT cT ->
   A_C.class_interface cS = false ->
   A_C.class_interface cT = false ->
   sub_class classes nmS nmT ->
   assignable classes (A_C.ty_obj nmS) (A_C.ty_obj nmT).
Implicit Arguments assignable_class_class [classes nmS nmT cS cT].

Hypothesis assignable_class_interface : forall classes nmS nmT cS cT nmS' cS',
   A_CP.class_loaded  classes nmS cS ->
   A_CP.class_loaded  classes nmT cT ->
   A_CP.class_loaded  classes nmS' cS' ->
   A_C.class_interface cS = false ->
   A_C.class_interface cS' = false ->
   A_C.class_interface cT = true ->
   sub_class classes nmS nmS' ->
   direct_super_interface classes (A_C.class_interfaces cS') nmT ->
   assignable classes (A_C.ty_obj nmS) (A_C.ty_obj nmT).
Implicit Arguments assignable_class_interface [classes nmS nmT cS cT nmS' cS'].

Hypothesis assignable_class_interface2 : forall classes nmS nmT cS cT,
  A_CP.class_loaded classes nmS cS ->
  A_CP.class_loaded classes nmT cT ->
  A_C.class_interface cS = false ->
  A_C.class_interface cT = true ->
  class_implements classes nmS nmT ->
  assignable classes (A_C.ty_obj nmS) (A_C.ty_obj nmT).
Implicit Arguments assignable_class_interface2 [classes nmS nmT cS cT].

Hypothesis assignable_interface_class : forall classes nmS cS,
   A_CP.class_loaded  classes nmS cS ->
   A_C.class_interface cS = true ->
   assignable classes (A_C.ty_obj nmS) (A_C.ty_obj A_B.java_lang_Object).

Hypothesis assignable_interface_interface_refl : forall classes nmS cS,
   A_CP.class_loaded classes nmS cS ->
   A_C.class_interface cS = true ->
   assignable classes (A_C.ty_obj nmS) (A_C.ty_obj nmS).
Implicit Arguments assignable_interface_interface_refl [classes nmS cS].

Hypothesis assignable_interface_interface_strict : forall classes nmS nmT cS cT,
   A_CP.class_loaded  classes nmS cS ->
   A_CP.class_loaded  classes nmT cT ->
   A_C.class_interface cS = true ->
   A_C.class_interface cT = true ->
   direct_super_interface classes (A_C.class_interfaces cS) nmT ->
   assignable classes (A_C.ty_obj nmS) (A_C.ty_obj nmT).
Implicit Arguments assignable_interface_interface_strict [classes nmS nmT cS cT].

Hypothesis get_sub_class : forall classes A A_B cA cB,
  A_CP.class_loaded  classes A cA ->
  A_CP.class_loaded  classes A_B cB ->
  A_C.class_interface cA = false ->
  A_C.class_interface cB = false ->
  assignable classes (A_C.ty_obj A) (A_C.ty_obj A_B) ->
  sub_class classes A A_B.

Hypothesis get_class_implements : forall classes A A_B cA cB,
  A_CP.class_loaded  classes A cA ->
  A_CP.class_loaded  classes A_B cB ->
  A_C.class_interface cA = false ->
  A_C.class_interface cB = true ->
  assignable classes (A_C.ty_obj A) (A_C.ty_obj A_B) ->
  exists A', exists cA', A_CP.class_loaded  classes A' cA'
                         /\ A_C.class_interface cA' = false
                         /\ sub_class classes A A'
                         /\ direct_super_interface classes (A_C.class_interfaces cA') A_B.

Hypothesis preserve_assignable : forall classesA classesB nmS nmT,
  assignable classesA nmS nmT ->
  A_CP.preserve_old_classes classesA classesB ->
  assignable classesB nmS nmT.

Hypothesis preserve_assignable_rev : forall classesA classesB nmA cA nmB,
  assignable classesB (A_C.ty_obj nmA) (A_C.ty_obj nmB) ->
  A_CP.class_loaded classesA nmA cA ->
  A_C.class_interface cA = false ->
  A_CP.preserve_old_classes classesA classesB ->
  assignable classesA (A_C.ty_obj nmA) (A_C.ty_obj nmB).

Hypothesis assignable_refl : forall classes nmA cA,
  A_CP.class_loaded classes nmA cA ->
  assignable classes (A_C.ty_obj nmA) (A_C.ty_obj nmA).

Hypothesis assignable_trans : forall classes a b c,
  assignable classes a b ->
  assignable classes b c ->
  assignable classes a c.

Hypothesis assignable_shared_subclass : forall classes A A_B A_C cA cB cC,
  A_CP.class_loaded classes A cA ->
  A_CP.class_loaded classes A_B cB ->
  A_CP.class_loaded classes A_C cC ->
  A_C.class_interface cA = false ->
  A_C.class_interface cB = false ->
  A_C.class_interface cC = false ->
  assignable classes (A_C.ty_obj A) (A_C.ty_obj A_B) ->
  assignable classes (A_C.ty_obj A) (A_C.ty_obj A_C) ->
  assignable classes (A_C.ty_obj A_B) (A_C.ty_obj A_C) \/ assignable classes (A_C.ty_obj A_C) (A_C.ty_obj A_B).

Hypothesis assignable_shared_subclass_2 : forall classes A A_B A_C cA cB cC,
  A_CP.class_loaded classes A cA ->
  A_CP.class_loaded classes A_B cB ->
  A_CP.class_loaded classes A_C cC ->
  A_C.class_interface cA = false ->
  A_C.class_interface cB = false ->
  A_C.class_interface cC = true ->
  assignable classes (A_C.ty_obj A) (A_C.ty_obj A_B) ->
  assignable classes (A_C.ty_obj A) (A_C.ty_obj A_C) ->
     assignable classes (A_C.ty_obj A_B) (A_C.ty_obj A_C)
  \/ (exists B', exists cB', A_CP.class_loaded classes B' cB'
                             /\ A_C.class_interface cB' = false
                             /\ assignable classes (A_C.ty_obj B') (A_C.ty_obj A_B)
                             /\ assignable classes (A_C.ty_obj A) (A_C.ty_obj B')
                             /\ assignable classes (A_C.ty_obj B') (A_C.ty_obj A_C)).

Hypothesis subclass_distinct : forall classes nm c nm' nm_t,
  A_CP.class_loaded classes nm c ->
  A_C.class_super_class c = Some nm' ->
  A_C.class_interface c = false ->
  sub_class classes nm' nm_t ->
  nm <> nm_t.

Hypothesis superclass_loaded : forall classes nm_s c_s nm_t,
  A_CP.class_loaded classes nm_s c_s ->
  sub_class classes nm_s nm_t ->
  exists c, A_CP.class_loaded classes nm_t c.

Hypothesis assignable_loaded : forall classes nmA cA nmB,
  A_CP.class_loaded classes nmA cA ->
  assignable classes (A_C.ty_obj nmA) (A_C.ty_obj nmB) ->
  exists cB, A_CP.class_loaded classes nmB cB.

End ASSIGNABILITY.


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

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

Print Assumptions add.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (plus (Succ lv1) lv0)).
Admitted.
QuickChick conj13eqsynthconj5.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Equalities over the FormalSyntax.

*)
Require Import List.
Export ListNotations.
Require Export ZArith.
Require Import Init.Datatypes.

Require Import DynamicSemanticsTypeSubstitution.
Require Export CpdtTactics.
Require Export Case.
Require Import FormalSyntax.

Set Implicit Arguments.

(* Equalities *)

Fixpoint beq_evar_p(ep ep' : EVar * P) : bool :=
  match ep, ep' with
   | (e,p), (e',p') =>
     andb (beq_evar e e') (beq_path p p')
  end.

Fixpoint beq_phi (phi phi' : Phi) : bool :=
match phi, phi' with
   | witnesschanges, witnesschanges => true
   | aliases, aliases => true
   | _, _ => false
end.

Fixpoint beq_tau (t t' : Tau) : bool :=
 match t, t with
 | tv_t alpha, tv_t beta => beq_tvar alpha beta
 | cint, cint => true
 | (cross t0 t1), (cross t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | (arrow t0 t1), (arrow t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | (ptype t0), (ptype t0')        => beq_tau t0 t0'
 | (utype alpha k t1), (utype beta k' t1')
   => andb (beq_kappa k k') (beq_tau t1 (subst_Tau t1' (tv_t alpha) beta))
 | (etype phi alpha k t1), (etype phi' beta k' t1')
   =>
   (andb
      (andb (beq_phi phi phi') (beq_tvar alpha beta))
      (andb (beq_kappa k k') (beq_tau t1 t1')))
 | _ , _ => false
end.

Fixpoint beq_i (i i' : I) : bool :=
  match i, i' with
    | i_i i, i_i i' => Zeq_bool i i'
 end.

Fixpoint beq_ipe (ipe ipe' : IPE) : bool :=
 match ipe, ipe' with
  | zero_pe, zero_pe => true
  | one_pe, one_pe => true
  | _, _ => false
end.

Fixpoint beq_pe (pe pe': PE) : bool :=
 match pe, pe' with
  | i_pe ipe, i_pe ipe' => beq_ipe ipe ipe'
  | u_pe, u_pe          => true
  | _, _                => false
end.

Fixpoint beq_st (s s' : St) : bool :=
  match s, s' with
    | (e_s e), (e_s e') => beq_e e e'
    | retn e, retn e'   => beq_e e e'
    | seq s1 s2, seq s1' s2' => andb (beq_st s1 s1') (beq_st s2 s2')
    | if_s e s1 s2, if_s e' s1' s2' =>
      andb (andb (beq_e e e') (beq_st s1 s1'))
           (beq_st s2 s2')
    | while e s, while e' s' => andb (beq_e e e') (beq_st s s')
    | letx x e s, letx x' e' s' =>
       andb (andb (beq_evar x x') (beq_e e e')) (beq_st s s')
    | open e alpha x s, open e' beta x' s' =>
      andb (andb (beq_e e e')    (beq_tvar alpha beta))
           (andb (beq_evar x x') (beq_st s s'))
    | openstar e alpha x s, openstar e' beta x' s' =>
      andb (andb (beq_e e e')    (beq_tvar alpha beta))
           (andb (beq_evar x x') (beq_st s s'))
    | _, _ => false
  end
with beq_e (e e' : E) : bool :=
 match e, e' with
 | i_e i, i_e i'                 => beq_i i i'
 | p_e x p, p_e x' p'            => andb (beq_evar x x') (beq_path p p')
 | f_e f, f_e f'                 => beq_f f f'
 | amp e, amp e'                 => beq_e e e'
 | star e, star e'               => beq_e e e'
 | cpair e0 e1, cpair e0' e1'    => andb (beq_e e0 e0') (beq_e e1 e1')
 | dot e ipe, dot e' ipe'        => andb (beq_e e e') (beq_ipe ipe ipe')
 | assign e1 e2, assign e1' e2'  => andb (beq_e e1 e1') (beq_e e2 e2')
 | appl e1 e2, appl e1' e2'      => andb (beq_e e1 e1') (beq_e e2 e2')
 | call s, call s'               => beq_st s s'
 | inst e t, inst e' t'          => andb (beq_e e e') (beq_tau t t')
 | pack t0 e t1, pack t0' e' t1' => andb (andb (beq_tau t0 t0') (beq_e e e'))
                                         (beq_tau t1 t1')
 | _, _ => false
end
with beq_f (f f' : F) : bool :=
 match  f, f with
 | dfun t0 x t1 s, dfun t0' x' t1' s' =>
   (andb (andb (beq_tau t0 t0') (beq_evar x x'))
         (andb (beq_tau t1 t1') (beq_st s s')))
 | ufun a k f, ufun a' k' f'     => (andb (andb (beq_tvar a a') (beq_kappa k k'))
                                          (beq_f f f'))
 | _, _ => false
end.


From mathcomp Require Import all_ssreflect all_algebra finmap.
From Coq Require Import Uint63 PArray.
From Polyhedra Require Import extra_misc.
Require Import graph high_graph extra_array extra_int refinement.
Require Import NArith.BinNat NArith.BinNatDef.

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

Local Notation "a .[ i ]" := (PArray.get a i).

Import Order.Theory.

(* Module ImgGraphFormatComputation.

Definition length_morph_check (morph morph' : array int) (gl gr : graph.graph):=
  (length gl =? length morph)%uint63 && (length gr =? length morph')%uint63.

Definition length_edge_inv_check (edge_inv : array (array (int * int))) (gr : graph.graph):=
  (length gr =? length edge_inv)%uint63 &&
  (IFold.iall (fun i => ((length edge_inv.[i]) =? GraphUtils.nb_neighbours gr i)%uint63) (length edge_inv)).

Definition length_format_check morph morph' edge_inv gl gr:=
    length_morph_check morph morph' gl gr && length_edge_inv_check edge_inv gr.

(* Definition length_label_check {T1 T2 : Type} (gl gr : graph.graph) (lbll : array T1) (lblr : array T2):=
  (correct_label gl lbll) && (correct_label gr lblr). *)

(* Definition global_length_check
  {T1 T2 : Type} gl gr
  (lbll : array T1) (lblr : array T2)
  morph morph' edge_inv:=
  [&& length_morph_check gl gr morph morph',
      length_edge_inv_check gr edge_inv &
      length_label_check gl gr lbll lblr]. *)

Definition valid_nei_check gl:=
  IFold.iall (fun i=>
    PArrayUtils.all
      (fun j=> GraphUtils.mem_vertex gl j)
    (neighbours gl i))
  (length gl).

(* Definition is_sort_check {T2 : Type} (lblr : array T2)
  (r_sort : T2 -> T2 -> bool):=
  PArrayUtils.is_sorted_rel r_sort lblr. *)

Definition img_graph_format morph morph' edge_inv gl gr :=
  length_format_check morph morph' edge_inv gl gr &&
  valid_nei_check gl.

End ImgGraphFormatComputation.

Module IGFC := ImgGraphFormatComputation.

Section ImgGraphFormatEquiv.

Definition length_morph_check (morph morph' : array int) (gl gr : graph.graph) :=
  (length gl == length morph)%O && (length gr == length morph')%O.

Definition length_edge_inv_check (edge_inv : array (array (int * int))) (gr : graph.graph):=
  (length gr == length edge_inv) &&
  (iall (fun i => ((length edge_inv.[i]) == nb_neighbours gr i)%O) (length edge_inv)).

Definition length_format_check morph morph' edge_inv gl gr :=
    length_morph_check morph morph' gl gr && length_edge_inv_check edge_inv gr.

  (*
Definition length_label_check {T1 T2 : Type} (gl gr : graph.graph) (lbll : array T1) (lblr : array T2):=
  (correct_label gl lbll) && (correct_label gr lblr). *)

(* Definition global_length_check
  {T1 T2 : Type} gl gr
  (lbll : array T1) (lblr : array T2)
  morph morph' edge_inv:=
  [&& length_morph_check gl gr morph morph',
      length_edge_inv_check gr edge_inv &
      length_label_check gl gr lbll lblr]. *)

Definition valid_nei_check gl:=
  iall (fun i=>
    arr_all
      (fun j=> mem_vertex gl j)
    (neighbours gl i))
  (length gl).

(* Definition is_sort_check {T2 : Type} (lblr : array T2)
  (r_sort : T2 -> T2 -> bool):=
  is_sorted_rel r_sort lblr. *)

Definition img_graph_format morph morph' edge_inv gl gr :=
  length_format_check morph morph' edge_inv gl gr && valid_nei_check gl.

Section Proofs.

Lemma img_graph_formatE morph morph' edge_inv gl gr :
  IGFC.img_graph_format morph morph' edge_inv gl gr =
  img_graph_format morph morph' edge_inv gl gr.
Proof.
repeat congr andb; rewrite ?eqEint //.
- by rewrite iallE; apply/eq_all=> i; rewrite eqEint nb_neighboursE.
- by rewrite /IGFC.valid_nei_check iallE; apply/eq_all=> i; rewrite arr_allE.
Qed.

End Proofs.

End ImgGraphFormatEquiv.

Section ImgGraphFormatProofs.

Context (gl gr : graph.graph).
Context (morph morph' : array int) (edge_inv : array (array (int * int))).

Local Notation format_h := (img_graph_format morph morph' edge_inv gl gr).

Lemma img_graph_format_length: format_h ->
  (length gl = length morph) * (length gr = length morph') * (length gr = length edge_inv).
Proof. by case/andP=> /andP [/andP [/eqP <- /eqP <-] /andP [/eqP <-]]. Qed.

Lemma img_graph_format_edge_length: format_h ->
  forall i, mem_vertex gr i -> length edge_inv.[i] = nb_neighbours gr i.
Proof.
move=> /[dup] form_h.
case/andP=> /andP [_ /andP] [_ h] _ i i_gr.
move/allP: h=> /(_ i); rewrite mem_irangeE le0x /=.
by rewrite -(img_graph_format_length form_h)=> /(_ i_gr)/eqP.
Qed.

Lemma img_graph_format_valid_nei: format_h-> forall i,
  mem_vertex gl i -> forall k, (k < nb_neighbours gl i)%O->
  mem_vertex gl (neighbours gl i).[k].
Proof.
move=> /[dup] form_h.
case/andP=> _ /allP h i i_gl k k_nei.
move: (h i); rewrite mem_irangeE le0x /= => /(_ i_gl) /allP /(_ (neighbours gl i).[k]); apply.
by apply map_f; rewrite mem_irangeE le0x.
Qed.

End ImgGraphFormatProofs. *)

Module ImgGraphComputation.

Definition vertex_morph_check morph (gl gr : graph.graph):=
  (IFold.iall (fun k=> GraphUtils.mem_vertex gr morph.[k]) (length gl)).

Definition vertex_inv_check morph morph' (gl gr : graph.graph) :=
  IFold.iall
    (fun i=> (GraphUtils.mem_vertex gl morph'.[i]) &&
    (morph.[morph'.[i]] =? i)%uint63)
  (length gr).

(* Definition vertex_label_check {T1 T2 : Type} (f : T1 -> T2) (r_eq : rel T2)
  (lbll : array T1) (lblr : array T2)
  (morph : array int) :=
  IFold.iall (fun i => r_eq (f lbll.[i]) lblr.[morph.[i]]) (length morph). *)

Definition img_vertex morph morph' gl gr :=
    vertex_morph_check morph gl gr && vertex_inv_check morph morph' gl gr.

Definition nei_check morph gl gr:=
  IFold.iall (fun i=>
    GraphUtils.neighbour_all
      (fun j=>
        ~~ (morph.[i] =? morph.[j])%uint63 ==>
        GraphUtils.mem_vertex gr morph.[i] &&
        GraphUtils.mem_edge gr morph.[i] morph.[j])
    gl i)
  (length gl).

Definition no_loop_check morph (gl gr : graph.graph):=
  IFold.iall (fun i=>
    GraphUtils.mem_vertex gr morph.[i] &&
    ~~(GraphUtils.mem_edge gr morph.[i] morph.[i]))
  (length gl).

Definition edge_inv_check morph edge_inv gl gr :=
  IFold.iall (fun i=>
    IFold.iall (fun j=>
      let: (a,b) := edge_inv.[i].[j] in
      [&& (GraphUtils.mem_vertex gl a),
          (GraphUtils.mem_vertex gl b),
          (morph.[a] =? i)%uint63,
          (morph.[b] =? (GraphUtils.neighbours gr i).[j])%uint63 &
          GraphUtils.mem_edge gl a b]
    ) (length (GraphUtils.neighbours gr i))
  ) (length gr).

Definition img_edge morph edge_inv gl gr :=
  [&& nei_check morph gl gr, no_loop_check morph gl gr & edge_inv_check morph edge_inv gl gr].

Definition img_graph morph morph' edge_inv gl gr :=
  img_vertex morph morph' gl gr &&
  img_edge morph edge_inv gl gr.

End ImgGraphComputation.

Module IGC := ImgGraphComputation.

Section ImgGraphEquiv.

Definition vertex_morph_check morph (gl gr : graph.graph):=
  (iall (fun k=> mem_vertex gr morph.[k]) (length gl)).

Definition vertex_inv_check morph morph' (gl gr : graph.graph) :=
  iall
    (fun i=> (mem_vertex gl morph'.[i]) &&
    (morph.[morph'.[i]] == i)%O)
  (length gr).

(* Definition vertex_label_check {T1 T2 : Type} (f : T1 -> T2) (r_eq : rel T2)
  (lbll : array T1) (lblr : array T2)
  (morph : array int) :=
  iall (fun i => r_eq (f lbll.[i]) lblr.[morph.[i]]) (length morph). *)

Definition img_vertex morph morph' gl gr :=
  vertex_morph_check morph gl gr && vertex_inv_check morph morph' gl gr.

Definition nei_check morph gl gr:=
  iall (fun i=>
    neighbour_all
      (fun j=>
        ~~ (morph.[i] == morph.[j])%O ==>
        mem_vertex gr morph.[i] &&
        mem_edge gr morph.[i] morph.[j])
    gl i)
  (length gl).

Definition no_loop_check morph (gl gr : graph.graph):=
  iall (fun i=>
    mem_vertex gr morph.[i] &&
    ~~(mem_edge gr morph.[i] morph.[i]))
  (length gl).

Definition edge_inv_check morph edge_inv  gl gr:=
  iall (fun i=>
    iall (fun j=>
      let: (a,b) := edge_inv.[i].[j] in
      [&& (mem_vertex gl a),
          (mem_vertex gl b),
          (morph.[a] == i),
          (morph.[b] == (neighbours gr i).[j]) &
          mem_edge gl a b]
    ) (length (neighbours gr i))
  ) (length gr).

Definition img_edge morph edge_inv gl gr :=
  [&& nei_check morph gl gr, no_loop_check morph gl gr & edge_inv_check morph edge_inv gl gr].

Definition img_graph morph morph' edge_inv gl gr:=
    img_vertex morph morph' gl gr &&
    img_edge morph edge_inv gl gr.

Section Proofs.

Lemma img_vertexE morph morph' gl gr:
  IGC.img_vertex morph morph' gl gr =
  img_vertex morph morph' gl gr.
Proof.
congr andb.
- by rewrite /IGC.vertex_morph_check iallE; apply/eq_all=> i; rewrite mem_vertexE.
- by rewrite /IGC.vertex_inv_check iallE; apply/eq_all=> i; rewrite mem_vertexE eqEint.
Qed.

Lemma img_edgeE morph edge_inv gl gr:
  IGC.img_edge morph edge_inv gl gr = img_edge morph edge_inv gl gr.
Proof.
repeat congr andb.
- rewrite /IGC.nei_check iallE; apply/eq_all=> i.
  rewrite neighbour_allE; apply/eq_all=> j.
  by rewrite eqEint mem_edgeE.
- rewrite /IGC.no_loop_check iallE; apply/eq_all=> i.
  by rewrite mem_edgeE.
- rewrite /IGC.edge_inv_check iallE; apply/eq_all=> i.
  rewrite iallE; apply/eq_all=> j; case: (edge_inv.[i].[j])=> ??.
  by rewrite !mem_vertexE !eqEint !mem_edgeE.
Qed.

Lemma img_graphE morph morph' edge_inv gl gr:
  IGC.img_graph morph morph' edge_inv gl gr =
  img_graph morph morph' edge_inv gl gr.
Proof. by rewrite /IGC.img_graph img_vertexE img_edgeE. Qed.

End Proofs.
End ImgGraphEquiv.

Section ImageGraphStructure.

(* Local Definition format_h morph morph' edge_inv gl gr := img_graph_format morph morph' edge_inv gl gr. *)

Definition high_vtx_morph morph (Gl Gr : graph [choiceType of int]) := all (fun x=> morph.[x] \in vertices Gr) (vertices Gl).

Lemma vtx_morph_check_struct morph:
  (rel_structure =~> rel_structure =~> eq)
  (vertex_morph_check morph) (high_vtx_morph morph).
Proof.
move=> gl Gl glGl gr Gr grGr; rewrite /vertex_morph_check (@rel_struct_all _ _ _ glGl).
by apply/eq_all=> i; rewrite (rel_struct_vtx grGr).
Qed.

Definition high_vtx_inv morph morph' (Gl Gr : graph [choiceType of int]) :=
  all (fun x=> (morph'.[x] \in vertices Gl) && (morph.[morph'.[x]] == x)) (vertices Gr).

Lemma vtx_inv_check_struct morph morph':
  (rel_structure =~> rel_structure =~> eq)
  (vertex_inv_check morph morph') (high_vtx_inv morph morph').
Proof.
move=> gl Gl glGl gr Gr grGr; rewrite /vertex_inv_check (rel_struct_all _ grGr); apply/eq_all=> i.
by congr andb; rewrite (rel_struct_vtx glGl).
Qed.

Definition high_img_vtx morph morph' Gl Gr := high_vtx_morph morph Gl Gr && high_vtx_inv morph morph' Gl Gr.

Lemma vtx_check_struct morph morph':
  (rel_structure =~> rel_structure =~> eq)
  (img_vertex morph morph') (high_img_vtx morph morph').
Proof. move=> ??????; congr andb; [exact:vtx_morph_check_struct|exact:vtx_inv_check_struct]. Qed.

Lemma high_img_vtxP morph morph' Gl Gr: high_img_vtx morph morph' Gl Gr -> vertices Gr = (fun i=> morph.[i]) @` (vertices Gl).
Proof.
case/andP=> /allP morph_in /allP morph_surj; apply/fsetP=> z; apply/idP/idP.
- case/morph_surj/andP=> ? /eqP <-; exact/in_imfset.
- by case/imfsetP=> z' /= /morph_in ? ->.
Qed.

Definition high_nei (morph : array int) (Gl Gr : graph [choiceType of int]) :=
  all (fun x=>
    all (fun y=> (morph.[x] != morph.[y]) ==> (edges Gr morph.[x] morph.[y])) (successors Gl x))
  (vertices Gl).

Lemma nei_check_struct morph:
  (rel_structure =~> rel_structure =~> eq)
  (nei_check morph) (high_nei morph).
Proof.
move=> gl Gl glGl gr Gr grGr; rewrite /nei_check (rel_struct_all _ glGl).
apply/eq_in_all=> i; rewrite -(rel_struct_vtx glGl)=> igl.
rewrite (rel_struct_nei_all _ glGl igl); apply/eq_in_all=> j j_succ.
congr implb; apply/idP/idP.
- by case/andP=> moigr; rewrite (rel_struct_edge grGr).
- move=> /[dup] /edge_vtxl; rewrite -(rel_struct_vtx grGr)=> moigr.
  by rewrite -(rel_struct_edge grGr) // moigr.
Qed.

Definition high_no_loop (morph : array int) (Gl Gr : graph [choiceType of int]):=
  all (fun x=> (morph.[x] \in vertices Gr) &&
    ~~ (edges Gr morph.[x] morph.[x])) (vertices Gl).

Lemma no_loop_check_struct morph:
  (rel_structure =~> rel_structure =~> eq)
  (no_loop_check morph) (high_no_loop morph).
Proof.
move=> gl Gl glGl gr Gr grGr; rewrite /no_loop_check (rel_struct_all _ glGl).
apply/eq_all=> i; apply/idP/idP.
- case/andP=> moigr; rewrite (rel_struct_edge grGr) // -(rel_struct_vtx grGr).
  by move=> ->; rewrite moigr.
- case/andP; rewrite -(rel_struct_vtx grGr)=> moigr.
  by rewrite -(rel_struct_edge grGr) // moigr.
Qed.

Definition high_edge_inv morph edge_inv Gl gr Gr:=
  all (fun x=> all (fun y=> let: (a,b):= edge_inv.[x].[y] in
    [&& morph.[a] == x, morph.[b] == (neighbours gr x).[y] &
      edges Gl a b])
    (irange0 (length (neighbours gr x))))
  (vertices Gr).

Lemma edge_inv_check_struct morph edge_inv gl Gl gr Gr:
  rel_structure gl Gl -> rel_structure gr Gr ->
  (edge_inv_check morph edge_inv gl gr) =
  (high_edge_inv morph edge_inv Gl gr Gr).
Proof.
move=> glGl grGr.
rewrite /edge_inv_check (rel_struct_all _ grGr); apply/eq_in_all=> x.
rewrite -(rel_struct_vtx grGr)=> xgr.
apply/eq_in_all=> y y_succ.
case: (edge_inv.[x].[y])=> a b.
apply/idP/idP=> [/and5P [?? -> ->] //|/and3P [-> -> /=]].
- by rewrite (rel_struct_edge glGl).
- move=> /[dup] /edge_vtxlr [aGl bGl].
  by rewrite (rel_struct_edge glGl) !(rel_struct_vtx glGl) ?aGl ?bGl.
Qed.

Definition high_img_edge morph edge_inv Gl gr Gr:=
  [&& high_nei morph Gl Gr, high_no_loop morph Gl Gr & high_edge_inv morph edge_inv Gl gr Gr].

Lemma edge_check_struct morph edge_inv gl Gl gr Gr:
  rel_structure gl Gl -> rel_structure gr Gr ->
  img_edge morph edge_inv gl gr = high_img_edge morph edge_inv Gl gr Gr.
Proof.
move=> ??; repeat congr andb;
  [exact:nei_check_struct|exact:no_loop_check_struct|exact:edge_inv_check_struct].
Qed.

Definition high_img_graph morph morph' edge_inv Gl gr Gr:=
    high_img_vtx morph morph' Gl Gr && high_img_edge morph edge_inv Gl gr Gr.

Lemma img_graph_struct morph morph' edge_inv gl Gl gr Gr:
  rel_structure gl Gl -> rel_structure gr Gr ->
  (img_graph morph morph' edge_inv gl gr) =
  (high_img_graph morph morph' edge_inv Gl gr Gr).
Proof. by move=> glGl grGr; congr andb; [exact:vtx_check_struct|exact:edge_check_struct]. Qed.

Lemma high_img_graphP morph morph' edge_inv Gl gr Gr:
  rel_structure gr Gr ->
  high_img_graph morph morph' edge_inv Gl gr Gr ->
  Gr = (fun i=> morph.[i]) @/ Gl.
Proof.
move=> grGr.
case/andP=> vtx_h edge_h; apply/graphE.
rewrite vtx_quot_graph (high_img_vtxP vtx_h); split=> // i j.
apply/idP/idP.
- case/and3P: edge_h=> _ no_loop_h /allP/(_ i) h /[dup] /edge_vtxlr [iGr jGr] /[dup] ijGr.
  rewrite -(rel_struct_edge grGr) ?(rel_struct_vtx grGr) //.
  move/neighboursP; rewrite !(rel_struct_vtx grGr).
  move=> /(_ iGr jGr) [k k_nei j_eq].
  move/allP: (h iGr)=> /(_ k); rewrite mem_irangeE le0x /=.
  move/(_ k_nei); case: (edge_inv.[i].[k])=> a b /and3P [/eqP a_i /eqP b_k a_b].
  apply/edge_quot_graph; exists a, b; split=> //; rewrite -?j_eq //.
  rewrite -b_k -a_i; apply/negP=> /eqP morph_eq.
  move/allP: no_loop_h=> /(_ _ (edge_vtxl a_b)).
  by case/andP=> _; rewrite {2}morph_eq a_i b_k j_eq ijGr.
- case/edge_quot_graph=> a [b] [i_eq j_eq i_n_j abGl].
  case/and3P: edge_h=> /allP /(_ _ (edge_vtxl abGl)) /allP /(_ b).
  by rewrite in_succE => /(_ abGl); rewrite i_eq j_eq i_n_j.
Qed.

End ImageGraphStructure.

Module ImgLabelGraphComputation.

Definition img_label {T1 T2 : Type} (f : T1 -> T2) (r_eq : rel T2) morph
  lbll lblr :=
  IFold.iall (fun i=> r_eq (f lbll.[i]) lblr.[morph.[i]]) (length lbll).

(* Definition img_label_sort_check {T2 : Type} (r_sort : rel T2) lblr:=
  PArrayUtils.is_sorted_rel r_sort lblr. *)

Definition img_label_graph {T1 T2} (f : T1 -> T2) r_eq morph morph' edge_inv
  gll grl :=
  IGC.img_graph morph morph' edge_inv gll.1 grl.1 && img_label f r_eq morph gll.2 grl.2.

End ImgLabelGraphComputation.

Module ILGC := ImgLabelGraphComputation.

Section ImgLabelGraphEquiv.

Definition img_label {T1 T2 : Type} (f : T1 -> T2) (r_eq : rel T2) morph
  lbll lblr :=
  iall (fun i=> r_eq (f lbll.[i]) lblr.[morph.[i]]) (length lbll).

(* Definition img_label_sort_check {T2 : Type} (r_sort : rel T2) lblr:=
  rel_sorted r_sort lblr. *)

Definition img_label_graph {T1 T2} (f : T1 -> T2) r_eq morph morph' edge_inv
  gll grl :=
  img_graph morph morph' edge_inv gll.1 grl.1 && img_label f r_eq morph gll.2 grl.2.

Lemma img_labelE {T1 T2 : Type} (f : T1 -> T2) r_eq morph lbll lblr:
  ILGC.img_label f r_eq morph lbll lblr =
  img_label f r_eq morph lbll lblr.
Proof. by rewrite /ILGC.img_label iallE. Qed.

Lemma img_label_graphE {T1 T2 : Type} (f : T1 -> T2) r_eq morph morph' edge_inv gll grl:
  ILGC.img_label_graph f r_eq morph morph' edge_inv gll grl =
  img_label_graph f r_eq morph morph' edge_inv gll grl.
Proof. by congr andb; rewrite ?img_graphE ?img_labelE. Qed.

End ImgLabelGraphEquiv.

Section ImgLabelRel.
Section Def.

Context {T1 T2 : Type} (f : T1 -> T2) (r_eq: rel T2).
Context (morph morph' : array int) (edge_inv : array (array (int * int))).

Definition high_img_label Gl lbll lblr := all (fun x=> r_eq (f lbll.[x]) lblr.[morph.[x]]) (vertices Gl).
Definition high_img_label_graph Gll gr Grl :=
  high_img_graph morph morph' edge_inv Gll.1 gr Grl.1 && high_img_label Gll.1 Gll.2 Grl.2.
End Def.

Section RelLabelGraph.

Context {t1 t2 : Type} {T1 T2: choiceType} (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop) (f : t1 -> t2) (F : T1 -> T2).
Context (eq_t2 : rel t2) (eq_T2 : rel T2).
Context (morph morph' : array int) (edge_inv : array (array (int * int))).

Lemma rel_label_graph_img gl Gl gr Gr ll Ll lr Lr:
  (r1 =~> r2) f F->
  (r2 =~> r2 =~> eq) eq_t2 eq_T2->
  @rel_lbl_graph _ _ r1 (gl,ll) (Gl,Ll) ->
  @rel_lbl_graph _ _ r2 (gr,lr) (Gr,Lr) ->
  img_label_graph f eq_t2 morph morph' edge_inv (gl,ll) (gr,lr) =
  high_img_label_graph F eq_T2 morph morph' edge_inv (Gl,Ll) gr (Gr,Lr).
Proof.
move=> fF eq_tT2 [/= len_gll [ /=glGl llLl]] [/= len_grl [ /= grGr lrLr]].
rewrite /img_label_graph /high_img_label_graph /= (img_graph_struct _ _ _ glGl grGr).
apply/andb_id2l=> /andP [mor_vtx mor_edge]; rewrite /img_label /high_img_label.
rewrite -len_gll; rewrite (rel_struct_all _ glGl); apply/eq_in_all=> i iGl.
apply/eq_tT2.
- by apply/fF/(rel_array_r llLl); rewrite -len_gll; move: iGl; rewrite -(rel_struct_vtx glGl).
- apply/(rel_array_r lrLr); case/andP: mor_vtx=> /allP/(_ i iGl).
  by rewrite -(rel_struct_vtx grGr) -len_grl.
Qed.

End RelLabelGraph.

Section RelFinalGraph.

Context {T1 T2 : choiceType} (f : T1 -> T2).
Context (morph morph' : array int) (edge_inv : array (array (int * int))).

Lemma rel_final_graph_img gl (ll : array T1) Gl gr (lr : array T2) Gr g:
  rel_structure g gr->
  rel_final_graph (gl, ll) Gl -> rel_final_graph (gr,lr) Gr ->
  high_img_label_graph f (@eq_op _) morph morph' edge_inv (gl, ll) g (gr, lr) ->
  Gr = f @/ Gl.
Proof.
move=> ggr glGl grGr /andP [] /= /(high_img_graphP ggr)=> gr_eq.
move: grGr; rewrite gr_eq=> final_g /allP h.
apply/graphE; split.
- rewrite -(gisof_vtx final_g) !vtx_quot_graph /= -(gisof_vtx glGl) /=.
  apply/fsetP=> z; apply/idP/idP.
  + case/imfsetP=> ? /imfsetP [/= i igl -> ->].
    by move/eqP: (h _ igl)=> <-; apply/in_imfset/in_imfset.
  + case/imfsetP=> ? /imfsetP /= [i igl -> ->].
    move/eqP: (h _ igl)=> ->; apply/in_imfset=> /=.
    by apply/imfsetP; exists i.
- move=> x y; apply/idP/idP.
  + move=> /[dup] /edge_vtxlr [xGr yGr].
    move: (xGr) (yGr); rewrite -(gisof_vtx final_g) /=.
    case/imfsetP=> /= ? ++ /imfsetP [?] /=.
    rewrite vtx_quot_graph=> /imfsetP /= [i igl ->] ->.
    case/imfsetP=> j /= jgl -> ->.
    rewrite -(gisof_edge final_g) /= ?(vtx_quot_graph);
      [|by apply/imfsetP; exists i|by apply/imfsetP; exists j].
    case/edge_quot_graph=> i' [j'] [<- <- ij' /[dup]].
    case/edge_vtxlr=> i'gl j'gl ij'gl.
    move: (h _ i'gl) (h _ j'gl)=> /eqP <- /eqP <-.
    apply/edge_quot_graph; exists ll.[i'], ll.[j'].
    split=> //; last by rewrite -(gisof_edge glGl).
    apply/negP=> /eqP; rewrite (eqP (h _ i'gl)) (eqP (h _ j'gl)).
    move/(gisof_inj final_g)=> /=; rewrite vtx_quot_graph.
    rewrite (in_imfset _ _ i'gl) (in_imfset _ _ j'gl)=> /(_ isT isT).
    by move/eqP; rewrite (negPf ij').
  + case/edge_quot_graph=> x' [y'] [<- <- f_xy'] /[dup].
    case/edge_vtxlr; rewrite -(gisof_vtx glGl) /=.
    case/imfsetP=> /= i igl x'_eq /imfsetP [/= j jgl y'_eq].
    rewrite x'_eq y'_eq -(gisof_edge glGl) //= => ijgl.
    rewrite (eqP (h _ igl)) (eqP (h _ jgl)).
    rewrite -(gisof_edge final_g) ?vtx_quot_graph ?(in_imfset _ _ igl) ?(in_imfset _ _ jgl) //.
    apply/edge_quot_graph; exists i,j; split=> //.
    apply/negP=> /eqP /(congr1 (fun x=> lr.[x])).
    rewrite -(eqP (h _ igl)) -(eqP (h _ jgl)) -x'_eq -y'_eq.
    by move/eqP; rewrite (negPf f_xy').
Qed.

End RelFinalGraph.
Section RelGraphR.

Context {t1 t2 : Type} {T1 T2: choiceType} (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop).
Context (f : t1 -> t2) (F : T1 -> T2).
Context (eq_t2 : rel t2).
Context (morph morph' : array int) (edge_inv : array (array (int * int))).

Lemma rel_graph_r_img gl ll gr lr Gl Gr:
  (r1 =~> r2) f F->
  (r2 =~> r2 =~> eq) eq_t2 (@eq_op _)->
  @rel_graph_r _ _ r1 (gl,ll) Gl -> @rel_graph_r _ _ r2 (gr,lr) Gr ->
  img_label_graph f eq_t2 morph morph' edge_inv (gl,ll) (gr,lr) ->
  Gr = F @/ Gl.
Proof.
move=> fF eq_tT2 [[gl' ll'] glgl' gl'Gl] [[gr' lr'] grgr' gr'Gr].
rewrite (rel_label_graph_img _ _ _ fF eq_tT2 glgl' grgr').
apply/rel_final_graph_img=> //; by case: grgr'=> _ [].
Qed.

End RelGraphR.

End ImgLabelRel.

(* Section GraphStruct.

Definition to_graph_struct (g : graph.graph) : high_graph.graph [choiceType of int] :=
  mk_graph [fset i | i in irange0 (graph_length g)] (mem_edge g).

Lemma to_graph_vtx (g : graph.graph) x:
  x \in vertices (to_graph_struct g) = mem_vertex g x.
Proof. by rewrite vtx_mk_graph inE /= mem_irangeE le0x /= ltEint. Qed.

Lemma to_graph_edge (g : graph.graph) i j: mem_vertex g i ->
  mem_vertex g j -> edges (to_graph_struct g) i j = mem_edge g i j.
Proof.
move=> ig jg.
by rewrite edge_mk_graph ?inE /= ?mem_irangeE ?le0x ?ltEint.
Qed.

Lemma to_graph_succ (g : graph.graph) i:
  mem_vertex g i ->
  successors (to_graph_struct g) i = [fset j : int| (mem_vertex g j && mem_edge g i j)].
Proof.
move=> ig.
rewrite succ_mk_graph ?inE /= ?mem_irangeE ?le0x ?ltEint //.
by apply/fsetP=> y; rewrite !inE /= ?mem_irangeE le0x ltEint /=.
Qed.

Lemma to_graph_succ_nei (g : graph.graph) i:
  mem_vertex g i ->
  successors (to_graph_struct g) i = [fset j : int | (mem_vertex g j) && (j \in arr_to_seq (neighbours g i))].
Proof.
move=> ig; rewrite to_graph_succ //; apply/fsetP=> y.
rewrite !inE /=; apply/idP/idP.
- case/andP=> yg /neighboursP; rewrite yg ig.
  case/(_ isT isT)=> k k_nei <-.
  apply/(nthP (default (neighbours g i))).
  by exists (int_to_nat k); rewrite ?size_arr_to_seq ?nth_arr_to_seq -?ltEint_nat // int_to_natK.
- case/andP=> yg.
  case/(nthP (default (neighbours g i)))=> k; rewrite size_arr_to_seq=> k_len.
  rewrite nth_arr_to_seq // => y_eq; apply/andP; split=> //.
  apply/neighboursP; rewrite ?yg ?xg //; exists (nat_to_int k)=> //.
  rewrite ltEint_nat nat_to_intK // inE.
  exact/(ltn_trans k_len)/int_thresholdP.
Qed.

(* Section Quotient.

Context (gl gr : graph.graph) (morf morf' : array int) (t : array (array (int * int))).

Hypothesis quot_h : graph.quot_graph gl gr morf morf' t.

Lemma to_graph_quot :
  (to_graph_struct gr) = ((fun i => morf.[i]) @/ (to_graph_struct gl)).
Proof.
apply/gisof_idE/gisofE; split=> //.
- apply/fsetP=> x; rewrite vtx_quot_graph !inE /= to_graph_vtx.
  apply/idP/idP.
  + case/(quot_graph_morf_complete quot_h)=> x' x'gl ->.
    by apply/in_imfset=> /=; rewrite to_graph_vtx.
  + case/imfsetP=> /= x'; rewrite to_graph_vtx=> x'gl ->.
    exact/(quot_graph_morf_correct quot_h).
- move=> x y; rewrite !to_graph_vtx=> xgr ygr.
  rewrite to_graph_edge ?to_graph_vtx //.
  apply/idP/idP.
  + case/(quot_graph_edge_morf quot_h xgr ygr)=> /[swap].
    case=> x' [y'] [x'gl y'gl <- <- gl_xy'] ?.
    apply/edge_quot_graph; exists x'; exists y'; split=> //=.
    by rewrite to_graph_edge ?to_graph_vtx.
  + case/edge_quot_graph=> x' [y'] [x_eq y_eq ?].
    move=> /[dup] /[dup] /edge_vtxl + /edge_vtxr.
    rewrite !to_graph_vtx=> x'gl y'gl.
    rewrite to_graph_edge ?to_graph_vtx // => gl_xy'.
    apply/(quot_graph_edge_morf quot_h xgr ygr); split=> //.
    by exists x', y'; split.
Qed.

End Quotient. *)
End GraphStruct.

(* Section LabelEquiv.

Definition label_equiv {T T' : Type} (a : array T) (b : array T') (r : T -> T' -> bool):=
  length a = length b /\ forall i, (i < length a)%O -> r a.[i] b.[i].

Lemma label_equiv_get {T T' : Type} (a : array T) (b : array T') (r : T -> T' -> bool):
  label_equiv a b r -> forall i, (i < length a)%O -> r a.[i] b.[i].
Proof. by case. Qed.

Lemma label_equiv_length {T T' : Type} (a : array T) (b : array T') (r : T -> T' -> bool):
  label_equiv a b r -> length a = length b.
Proof. by case. Qed.

Lemma lbl_eq_arr_to_seq {T T' : Type} (a : array T) (b : array T') (r : T -> T' -> bool):
  label_equiv a b r <-> (length a = length b :> nat) /\ (forall i, (i < length a)%nat ->
    r (nth (default a) (arr_to_seq a) i) (nth (default b) (arr_to_seq b) i)).
Proof.
split.
- case=> eq_len h; split; rewrite eq_len //.
  move=> i i_len; rewrite !nth_arr_to_seq ?eq_len //.
  apply: h; rewrite eq_len ltEint_nat nat_to_intK //.
  apply/(ltn_trans i_len)/int_thresholdP.
- case=> /int_to_nat_inj eq_len h; split=> //= i.
  rewrite ltEint_nat=> /[dup] ? /h; rewrite !nth_arr_to_seq -?eq_len //.
  by rewrite int_to_natK.
Qed.

Lemma label_equiv_inj {T T' : Type} (a : array T) (b : array T') (r : T -> T' -> bool)
  (e : T -> T -> bool) (e' : T' -> T' -> bool):
  label_equiv a b r ->
  (forall i j, (i < length a)%O -> (j < length a)%O -> e a.[i] a.[j] -> i = j) ->
  (forall i j i' j', (i < length a)%O -> (i' < length b)%O -> (j < length a)%O -> (j' < length b)%O ->
    r a.[i] b.[i'] -> r a.[j] b.[j'] -> e a.[i] a.[j] <-> e' b.[i'] b.[j']) ->
  forall i j, (i < length b)%O -> (j < length b)%O -> e' b.[i] b.[j] -> i = j.
Proof.
case=> len_eq r_ab a_inj r_equiv i j ib jb.
move: (r_ab i) (r_ab j); rewrite len_eq ib jb => /(_ isT) + /(_ isT).
move/r_equiv=> /[apply] /[apply]; rewrite len_eq ib jb=> /(_ isT isT isT isT).
by apply/a_inj; rewrite len_eq.
Qed.

Lemma label_equiv_sort {T T' : Type} (a : array T) (b : array T')
  (r : T -> T' -> bool) (r_sort : rel T) (r_sort' : rel T'):
  label_equiv a b r ->
  (forall x y x' y', r x x' -> r y y' -> r_sort x y = r_sort' x' y') ->
  rel_sorted a r_sort = rel_sorted b r_sort'.
Proof.
case=> len_eq r_get r_sort_sort'; rewrite /rel_sorted.
apply/(sorted_rel_pair (r:=r) (x:=(default a)) (x':=(default b)))=> //.
- by rewrite !size_arr_to_seq len_eq.
- move=> k; rewrite size_arr_to_seq=> k_len; rewrite !nth_arr_to_seq -?len_eq //.
  apply/r_get; rewrite ltEint_nat nat_to_intK //.
  apply/(ltn_trans k_len)/int_thresholdP.
Qed.

Section Quotient.

Context {T1 T2 T1' T2': Type}.
Context (g1 g2 : graph.graph).
Context (lbl1 : array T1) (lbl2 : array T2) (lbl1' : array T1') (lbl2' : array T2').
Context (r_lbl : T1 -> T2 -> bool) (r_lbl' : T1' -> T2' -> bool).
Context (r_sort : rel T2) (r_sort' : rel T2').
Context (r1 : T1 -> T1' -> bool) (r2 : T2 -> T2' -> bool).
Context (morf morf': array int) (t : array (array (int * int))).

Hypothesis g1g2 : graph.lbl_quot g1 g2 morf morf' t lbl1 lbl2 r_lbl r_sort.
Hypothesis lbl_equiv1 : label_equiv lbl1 lbl1' r1.
Hypothesis lbl_equiv2 : label_equiv lbl2 lbl2' r2.
Hypothesis r2_h : forall x y x' y', r2 x x' -> r2 y y' -> r_sort x y = r_sort' x' y'.
Hypothesis r1212'_h : forall i j, (i < length lbl1)%O -> (j < length lbl2)%O -> r_lbl lbl1.[i] lbl2.[j] <-> r_lbl' lbl1'.[i] lbl2'.[j].

Lemma label_equiv_quot: graph.lbl_quot g1 g2 morf morf' t lbl1' lbl2' r_lbl' r_sort'.
Proof.
case: g1g2=> quot_g1g2 lbl12 vert_lbl12 sort_lbl2.
split=> //.
- rewrite /label_check !(lbl_quot_label g1g2) (label_equiv_length lbl_equiv1).
  by rewrite (label_equiv_length lbl_equiv2).
- rewrite /vert_check=> i ig1.
  apply/r1212'_h; try apply/vert_lbl12=> //.
  + by rewrite -lbl12 (quot_graph_length quot_g1g2).
  + move: (quot_graph_morf_correct quot_g1g2); rewrite -lbl12.
    by apply; rewrite /mem_vertex (quot_graph_length quot_g1g2).
- by rewrite /sort_check -(label_equiv_sort lbl_equiv2 r2_h).
Qed.

End Quotient.
End LabelEquiv. *)

Section GraphRepr.

Context (t : Type) (T : choiceType) (g : graph.graph) (lbl : array t) (G : high_graph.graph T).
Context (conv : int -> T) (rel_t : t -> T -> Prop).

Definition repr_graph := [/\
  correct_label g lbl,
  gisof (to_graph_struct g) G conv &
  forall i, mem_vertex g i -> rel_t lbl.[i] (conv i)].

Lemma repr_graph_correct : repr_graph -> correct_label g lbl.
Proof. by case. Qed.

Lemma repr_graph_conv_inj : repr_graph ->
  forall i j, mem_vertex g i -> mem_vertex g j -> conv i = conv j -> i = j.
Proof. by case=> _ /gisof_inj conv_inj _ i j ig jg /conv_inj; apply; rewrite to_graph_vtx. Qed.

Lemma repr_graph_vtx_low: repr_graph -> forall i,
  mem_vertex g i -> conv i \in vertices G.
Proof.
case=> _ gisof_repr _ i ig; rewrite -(gisof_vtx gisof_repr); apply/in_imfset=> /=.
by rewrite to_graph_vtx.
Qed.

Lemma repr_graph_vtx_high: repr_graph ->
  forall x : T, x \in vertices G -> exists2 i, mem_vertex g i & conv i = x.
Proof.
case=> _ gisof_repr _ x; rewrite -(gisof_vtx gisof_repr).
case/imfsetP=> /= i; rewrite to_graph_vtx => ig ->.
by exists i.
Qed.

Lemma repr_graph_edge_low: repr_graph -> forall i j,
  mem_vertex g i -> mem_vertex g j ->
  mem_edge g i j -> edges G (conv i) (conv j).
Proof.
case=> _ repr_gisof _ i j ig jg g_ij.
by rewrite -(gisof_edge repr_gisof) ?to_graph_vtx // to_graph_edge.
Qed.

Lemma repr_graph_edge_high: repr_graph ->
  {in vertices G&, forall x y, edges G x y ->
  exists i, (exists j,
    [/\ mem_vertex g i, mem_vertex g j,
    x = (conv i), y = (conv j) &
    mem_edge g i j])}.
Proof.
move=> /[dup] rep [_ repr_gisof _] x y.
case/(repr_graph_vtx_high rep)=> i ig <-.
case/(repr_graph_vtx_high rep)=> j jg <-.
rewrite -(gisof_edge repr_gisof) ?to_graph_vtx // to_graph_edge //.
by move=> g_ij; exists i,j; split.
Qed.

Lemma repr_graph_succ: repr_graph->
  forall i, mem_vertex g i->
  successors G (conv i) = conv @` [fset j : int | (mem_vertex g j) && (j \in arr_to_seq (neighbours g i))].
Proof.
case=> _ /gisof_succ + _ i ig.
move/(_ i); rewrite to_graph_vtx=> /(_ ig) ->.
by rewrite to_graph_succ_nei.
Qed.

Lemma repr_graph_card_succ: repr_graph->
  (forall i, mem_vertex g i -> lti_sorted (neighbours g i))->
  (forall i j, mem_vertex g i -> (j < nb_neighbours g i)%O -> mem_vertex g (neighbours g i).[j])->
  forall i, mem_vertex g i-> #|` successors G (conv i)| = nb_neighbours g i.
Proof.
move=> gG stt_h nei_h i ig.
rewrite (repr_graph_succ gG ig) card_in_imfset /=; last first.
  move=> x y; rewrite !inE /= => /andP [+ _] /andP [+ _]; exact: (repr_graph_conv_inj gG).
rewrite card_imfset //=.
set S := [seq _ <- _ | _ & _]; suff: perm_eq S (arr_to_seq (neighbours g i)) by
  move/perm_size=> ->; rewrite size_arr_to_seq.
apply/uniq_perm; [ exact/filter_uniq/enum_uniq | exact/lti_sorted_uniq/stt_h | ].
move=> x; rewrite mem_filter mem_enum inE andbT.
apply/andb_idl; case/mapP=> k; rewrite mem_irangeE le0x /=.
move=> k_nei ->; exact/(nei_h i k ig).
Qed.

Lemma repr_graph_rel: repr_graph->
  forall i, mem_vertex g i -> rel_t lbl.[i] (conv i).
Proof. by case. Qed.

End GraphRepr.

(* Section GraphRepr.

Context {T : choiceType} (g : graph.graph) (lbl : array T) (G : high_graph.graph T).

Definition repr_graph := correct_label g lbl /\ gisof (to_graph_struct g) G (fun i => lbl.[i]).

Lemma repr_lbl_inj:
  repr_graph ->
  {in vertices (to_graph_struct g) &, injective (fun i => lbl.[i])}.
Proof. by case=> ? []. Qed.

Lemma repr_vtx:
  repr_graph -> forall x,
  x \in vertices G = [exists i, mem_vertex g i && (lbl.[i] == x)].
Proof.
case=> _ /gisofE [_ <- _].
move=> x; apply/idP/idP.
- case/imfsetP=> x' /=; rewrite to_graph_vtx=> ? ->.
  by apply/existsP; exists x'; rewrite eqxx andbT.
- case/existsP=> x' /andP [? /eqP <-]; apply/in_imfset=> /=.
  by rewrite to_graph_vtx.
Qed.

Lemma repr_vtx_lbl:
  repr_graph -> forall i, mem_vertex g i -> lbl.[i] \in vertices G.
Proof. by move=> ? i gi; rewrite repr_vtx //; apply/existsP; exists i; rewrite gi eqxx. Qed.

Lemma repr_vtx_fset:
  repr_graph -> vertices G = [fset lbl.[i] | i : int & mem_vertex g i].
Proof.
move=> repr_g; apply/fsetP=> x; rewrite (repr_vtx repr_g).
apply/idP/idP.
- case/existsP=> x' /andP [x'g /eqP <-]; exact: in_imfset.
- case/imfsetP=> /= x'; rewrite inE=> x'g ->; apply/existsP; exists x'.
  by rewrite x'g eqxx.
Qed.

Lemma repr_vtx_card: repr_graph -> #|` vertices G| = length g.
Proof.
move=> /[dup] gG /repr_vtx_fset ->; rewrite card_in_imfset /=.
- rewrite (@perm_size _ _ (irange0 (length g))) ?size_irange0 //.
  apply/uniq_perm; rewrite ?filter_uniq -?enumT ?enum_uniq ?uniq_irange //.
  by move=> y; rewrite mem_filter mem_irangeE le0x mem_enum inE ltEint andbT.
- by move=> ????; apply/(repr_lbl_inj gG); rewrite to_graph_vtx.
Qed.

Lemma repr_edge:
  repr_graph -> forall x y,
    edges G x y = [exists i, [exists j,
    [&& mem_vertex g i, mem_vertex g j,
    lbl.[i] == x, lbl.[j] == y & mem_edge g i j]]].
Proof.
move=> gG x y.
case: (gG)=> /eqb_spec g_lbl gG_gisof.
apply/idP/idP.
- move=> /[dup] /[dup] /edge_vtxl + /edge_vtxr.
  rewrite !(repr_vtx gG)=> /existsP [i] /andP [ig /eqP <-].
  case/existsP=> j /andP [jg /eqP <-].
  rewrite -(gisof_morph gG_gisof) ?to_graph_edge ?to_graph_vtx //.
  move=> ?; apply/existsP; exists i; apply/existsP; exists j.
  by rewrite ig jg !eqxx.
- case/existsP=> i /existsP [j] /and5P [ig jg /eqP <- /eqP <- g_ij].
  by rewrite -(gisof_morph gG_gisof) ?to_graph_edge ?to_graph_vtx.
Qed.

Lemma repr_succ x:
  repr_graph -> mem_vertex g x ->
  successors G lbl.[x] =
  [fset lbl.[y] | y : int & ((mem_vertex g y) && (mem_edge g x y))].
Proof.
move=> gG xg; apply/fsetP=> z; apply/idP/idP.
- rewrite in_succE (repr_edge gG).
  case/existsP=> i /existsP [j] /and5P [ig jg].
  move/eqP/(repr_lbl_inj gG); rewrite !to_graph_vtx ig xg=> -> //.
  move/eqP=> <- xjg; apply/in_imfset; rewrite inE.
  by apply/and3P; split.
- case/imfsetP=> /= j; rewrite inE=> /andP [jg xjg] ->.
  rewrite in_succE (repr_edge gG).
  by apply/existsP; exists x; apply/existsP; exists j; apply/and5P; split.
Qed.

End GraphRepr.

Section Giso.

Context {T : choiceType} (g : graph.graph) (lbl : array T).

Lemma repr_graph_giso_id (G G' : high_graph.graph T):
  G = G' -> repr_graph g lbl G' -> repr_graph g lbl G.
Proof. by move=> ->. Qed.

(*TODO : need some lemmas on gisof*)
End Giso.

(* Section GraphRepr.

Context {T : Type} {T' : choiceType} (r : T -> T' -> Prop).
Context (g : graph.graph) (lbl: array T) (G : high_graph.graph T').

Definition repr_graph := exists2 lbl' : array T',
  label_equiv lbl lbl' r & repr_graph_base g lbl' G.

End GraphRepr. *)

Section Quotient.

Context {T1 T2 : choiceType}.
Context (g1 g2: graph.graph) (lbl1 : array T1) (lbl2 : array T2).
Context (G1 : high_graph.graph T1).

Hypothesis g1G1 : repr_graph g1 lbl1 G1.

Context (morf morf': PArray.array int) (t : array (array (int * int))) (F : T1 -> T2) (r_sort : rel T2).
Hypothesis g1g2 : lbl_quot g1 g2 morf morf' t lbl1 lbl2
  (fun t1 t2=> F t1 == t2) r_sort.
Hypothesis r_sort_irr : irreflexive r_sort.
Hypothesis r_sort_trans : transitive r_sort.

Lemma repr_quot_inj:
  {in vertices ([eta get morf] @/ to_graph_struct g1) &, injective (get lbl2)}.
Proof.
move=> i j; rewrite vtx_quot_graph.
case/imfsetP => /= [x'] + -> /imfsetP /= [y'] + ->.
rewrite !to_graph_vtx => x'g1 y'g1.
move: (lbl_quot_sort g1g2)=> /(sorted_rel_inj r_sort_irr r_sort_trans).
apply; rewrite ltEint -(lbl_quot_label g1g2);
  exact: (quot_graph_morf_correct (lbl_quot_quot g1g2)).
Qed.

Lemma repr_quot_vtx:
  get lbl2 @` vertices ([eta get morf] @/ to_graph_struct g1) =
  vertices (F @/ G1).
Proof.
apply/fsetP=> x; apply/idP/idP.
- case/imfsetP=> /= x'; rewrite vtx_quot_graph.
  case/imfsetP=> /= x''; rewrite to_graph_vtx.
  move=> x''g1 -> ->; rewrite vtx_quot_graph.
  apply/imfsetP=> /=; exists lbl1.[x'']; rewrite ?(lbl_quot_vert g1g2).
  + by rewrite (repr_vtx g1G1); apply/existsP; exists x''; rewrite eqxx x''g1.
  + case: g1g2=> quot_h _ vert_h _; apply/eqP; rewrite eq_sym.
    by apply: vert_h; rewrite -(quot_graph_length quot_h).
- rewrite !vtx_quot_graph; case/imfsetP=> /= x'.
  rewrite (repr_vtx g1G1); case/existsP=> x'' /andP [x''g1 /eqP <-] ->.
  move:(lbl_quot_vert g1g2)=> /(_ x'').
  rewrite -(quot_graph_length (lbl_quot_quot g1g2))=> /(_ x''g1)/eqP ->.
  apply/in_imfset=> /=.
  by apply/in_imfset=> /=; rewrite to_graph_vtx.
Qed.

Lemma repr_quot_edge:
  {in vertices ([eta get morf] @/ to_graph_struct g1) &,
  forall x y : int_choiceType,
  edges ([eta get morf] @/ to_graph_struct g1) x y =
  edges (F @/ G1) lbl2.[x] lbl2.[y]}.
Proof.
move=> x y xG1 yG1.
apply/idP/idP.
- case/edge_quot_graph=> /= x' [y'].
  case=> x_eq y_eq x_n_y /[dup] /[dup] /edge_vtxl + /edge_vtxr.
  rewrite !to_graph_vtx => x'g1 y'g1; rewrite to_graph_edge ?to_graph_vtx //.
  move=> g1_xy'; apply/edge_quot_graph; exists lbl1.[x'], lbl1.[y'].
  rewrite (repr_edge g1G1).
  move:(lbl_quot_vert g1g2)=> vert_g1g2.
  move: (vert_g1g2 x') (vert_g1g2 y').
  rewrite -(quot_graph_length (lbl_quot_quot g1g2))=> /(_ x'g1)/eqP ->.
  move/(_ y'g1)/eqP=> ->; rewrite x_eq y_eq.
  split=> //.
  + move: x_n_y; apply: contra_neq=> /repr_quot_inj.
    apply; rewrite vtx_quot_graph; apply/imfsetP=> /=.
    * by exists x'; rewrite ?to_graph_vtx ?x_eq.
    * by exists y'; rewrite ?to_graph_vtx ?y_eq.
  + by apply/existsP; exists x'; apply/existsP; exists y'; apply/and5P; split.
- case/edge_quot_graph=> x' [y'] [Fx' Fy' lbl2_xy].
  rewrite (repr_edge g1G1)=> /existsP [x''] /existsP [y''].
  case/and5P=> x''g1 y''g1 /eqP lbl1x'' /eqP lbl1y'' g1_xy''.
  apply/edge_quot_graph; exists x'', y''; split.
  + move: Fx'; rewrite -lbl1x''.
    move:(lbl_quot_vert g1g2)=> /(_ x'').
    rewrite -(quot_graph_length (lbl_quot_quot g1g2))=> /(_ x''g1)/eqP ->.
    move/(repr_quot_inj _ xG1); apply; rewrite vtx_quot_graph.
    by apply/in_imfset; rewrite to_graph_vtx.
  + move: Fy'; rewrite -lbl1y''.
    move:(lbl_quot_vert g1g2)=> /(_ y'').
    rewrite -(quot_graph_length (lbl_quot_quot g1g2))=> /(_ y''g1)/eqP ->.
    move/(repr_quot_inj _ yG1); apply; rewrite vtx_quot_graph.
    by apply/in_imfset; rewrite to_graph_vtx.
  + by move: lbl2_xy; apply/contra_neq=> ->.
  + by rewrite to_graph_edge ?to_graph_vtx.
Qed.

Lemma repr_graph_quot: repr_graph g2 lbl2 (F @/ G1).
Proof.
split.
- by rewrite /correct_label -(lbl_quot_label g1g2) eqb_refl.
- move: (lbl_quot_quot g1g2)=> /to_graph_quot/gisof_idE/gisof_trans; apply.
  apply/gisofE; split.
  + exact: repr_quot_inj.
  + exact: repr_quot_vtx.
  + exact: repr_quot_edge.
Qed.

End Quotient. *)

 *)