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.


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.


(*
 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. *)

 *)