(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

(* ************* ************************************* *****)
(* ftl interface *)

Require Import LibEx.
Require Import ListEx.
Require Import Monad.
Require Import Data.

Require Import Params.
Require Import Nand.
Require Import NandLems.

Require Import Bast0.
Require Import FTLProp.

Lemma check_used_implies_check_data_log :
  forall bi,
    check_used_block bi = true
    -> check_data_block bi = true \/ check_log_block bi = true.
Proof.
  intros bi.
  destruct bi.
  simpl; intros.
  unfold check_used_block in H.
  simpl in H.
  unfold check_data_block, check_log_block.
  simpl.
  destruct (bi_state); try discriminate.
  left; trivial.
  right; trivial.
Qed.
Arguments check_used_implies_check_data_log [bi] _.

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

  Lemmas for block info table

*)

Lemma bit_update_same :
  forall bit pbn bi,
    bit_get bit pbn = Some bi
    -> bit_update bit pbn bi = Some bit.
Proof.
  unfold bit_get, bit_update.
  intros.
  rewrite (list_set_same H).
  trivial.
Qed.

Lemma bit_update_bit_get_neq :
  forall bit pbn bit' bi' pbn',
    bit_update bit pbn' bi' = Some bit'
    -> pbn <> pbn'
    -> bit_get bit' pbn = bit_get bit pbn.
Proof.
  unfold bit_update, bit_get.
  intros.
  rewrite (list_get_list_set_neq H (neq_sym H0)).
  trivial.
Qed.

Lemma bit_update_bit_get_eq :
  forall bit pbn bi bit',
    bit_update bit pbn bi = Some bit'
    -> bit_get bit' pbn = Some bi.
Proof.
  unfold bit_update, bit_get.
  intros.
  rewrite (list_get_list_set_eq H).
  trivial.
Qed.

Lemma bit_update_some :
  forall bit pbn bi bi',
    bit_get bit pbn = Some bi
    -> exists bit', bit_update bit pbn bi' = Some bit'.
Proof.
  unfold bit_get, bit_update.
  intros.
  destruct (list_get_list_set bi' H) as [bit' Hbit'].
  exists bit'.
  trivial.
Qed.

(* Lemma bit_get_update_neq :  *)
(*   forall bit pbn bi bit' bi' pbn', *)
(*     bit_get bit pbn = Some bi *)
(*     -> pbn <> pbn' *)
(*     -> bit_update bit pbn' bi' = Some bit' *)
(*     -> bit_get bit' pbn = Some bi. *)
(* Proof. *)
(* Qed. *)

Lemma bit_update_spec :
  forall bit pbn bi bi',
    bit_get bit pbn = Some bi
    -> exists bit',bit_update bit pbn bi' = Some bit'
                  /\ bit_get bit' pbn = Some bi'
                  /\ (forall pbn', pbn <> pbn'
                                   -> bit_get bit' pbn' = bit_get bit pbn').
Proof.
  unfold bit_update, bit_get.
  intros.
  destruct (list_get_list_set bi' H) as [bit' Hbit'].
  exists bit'.
  split; trivial.
  rewrite (list_get_list_set_eq Hbit').
  split; trivial.
  intros.
  rewrite (list_get_list_set_neq Hbit' H0).
  trivial.
Qed.

Lemma bit_update_spec_rev :
  forall bit pbn bi bit',
    bit_update bit pbn bi = Some bit'
    -> exists bi', bit_get bit pbn = Some bi'.
Proof.
  unfold bit_update, bit_get.
  intros bit pbn bi bit' Hset.
  destruct (list_set_list_get_rev Hset) as [bi' Hget].
  exists bi'.
  trivial.
Qed.

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

  Lemmas for free_block_queue

*)

(* Old name: Lemma pbn_not_in_fbq_presev_fbq_enq :  *)
Lemma fbq_not_in_presev_fbq_enq :
  forall fbq pbn fbq' pbn',
    fbq_in fbq pbn = false
    -> fbq_enq fbq pbn' = Some fbq'
    -> pbn <> pbn'
    -> fbq_in fbq' pbn = false.
Proof.
  induction fbq.
    unfold fbq_in, fbq_enq.
    intros pbn fbq' pbn' Hin Henq Hneq.
    injection Henq.
    intro H.
    subst fbq'.
    simpl.
    simplbnat.
    trivial.

  unfold fbq_in.
  simpl.
  intros pbn fbq' pbn' Hin Henq Hneq.
  destruct fbq'.
    unfold fbq_enq in Henq.
    simpl in Henq.
    discriminate.
  inversion Henq.
  subst b.
  simpl.
  destruct (beq_nat pbn a) eqn:Hb.
    trivial.
  eapply IHfbq; eauto.
  unfold fbq_enq.
  trivial.
Qed.

(* Old name: Lemma fbq_in_fbq_enq_fbq_in :  *)
Lemma fbq_in_preserv_fbq_enq :
  forall pbn fbq pbn' fbq',
    pbn <> pbn'
    -> fbq_enq fbq pbn' = Some fbq'
    -> fbq_in fbq' pbn = fbq_in fbq pbn.
Proof.
  induction fbq.
    intros.
    unfold fbq_enq, fbq_in in * .
    simpl in H0.
    inversion H0.
    subst fbq'.
    simpl.
    simplbnat.
    trivial.
  destruct fbq'.
    intros.
    unfold fbq_enq in H0.
    discriminate.
  intros.
  unfold fbq_enq in * .
  simpl in * .
  inversion H0.
  subst b fbq'.
  simpl.
  unfold fbq_in in * .
  simpl.
  clear H0.
  destruct (beq_nat pbn a) eqn:Hb.
    trivial.
  eapply IHfbq; eauto.
Qed.

Lemma fbq_enq_fbq_in :
  forall pbn fbq fbq',
    fbq_enq fbq pbn = Some fbq'
    -> fbq_in fbq' pbn = true.
Proof.
  unfold fbq_enq, fbq_in.
  induction fbq.
    intros.
    injection H.
    intro; subst fbq'.
    simpl.
    simplbnat.
    trivial.
  intros.
  injection H.
  intro; subst fbq'.
  simpl.
  destruct (beq_nat pbn a) eqn:Hb.
    trivial.
  eapply IHfbq.
  trivial.
Qed.

Lemma fbq_enq_fbq_length_addone :
  forall fbq pbn fbq',
    fbq_enq fbq pbn = Some fbq'
    -> length fbq' = 1 + length fbq.
Proof.
  induction fbq.
    intros.
    unfold fbq_enq in H.
    injection H.
    intro; subst fbq'.
    simpl.
    trivial.
  intros.
  unfold fbq_enq in H.
  injection H.
  intro; subst fbq'.
  simpl.
  rewrite (IHfbq pbn (list_append fbq pbn)); eauto.
Qed.

Lemma fbq_deq_fbq_length_subone :
  forall fbq pbn fbq',
    fbq_deq fbq = Some (pbn, fbq')
    -> length fbq = S (length fbq').
Proof.
  unfold fbq_deq.
  induction fbq; simpl; intros; auto.
    discriminate.
  injection H; intros; subst a fbq'.
  trivial.
Qed.

Lemma fbq_not_in_preserv_fbq_deq :
  forall fbq pbn fbq' pbn',
    fbq_in fbq pbn = false
    -> fbq_deq fbq = Some (pbn', fbq')
    -> fbq_in fbq' pbn = false.
Proof.
  induction fbq; unfold fbq_in, fbq_deq; simpl; intros; auto.
    discriminate.
  injection H0; intros; subst a fbq'.
  destruct (beq_nat pbn pbn') eqn:Hpbn; trivial.
  discriminate.
Qed.

Lemma fbq_not_in_preserv_fbq_enq :
  forall fbq pbn fbq' pbn',
    pbn <> pbn'
    -> fbq_in fbq pbn = false
    -> fbq_enq fbq pbn' = Some fbq'
    -> fbq_in fbq' pbn = false.
Proof.
  unfold fbq_in, fbq_enq.
  induction fbq; simpl; intros; auto.
    injection H1; intros; subst fbq'.
    simpl.
    simplbnat.
    trivial.
  injection H1; intros; subst fbq'.
  simpl.
  destruct (beq_nat pbn a) eqn: Ha.
    discriminate.
  eauto.
Qed.

Lemma fbq_in_fbq_get:
  forall fbq pbn,
    fbq_in fbq pbn = true
    -> exists i, fbq_get fbq i = Some pbn.
Proof.
  induction fbq.
    unfold fbq_in, fbq_get.
    simpl.
    intros; discriminate.
  unfold fbq_in, fbq_get.
  simpl.
  intros.
  destruct (beq_nat pbn a) eqn:Ha.
    exists 0.
    rewbnat Ha.
    trivial.
  assert (pbn <> a).
    intro HF.
    subst a.
    simplbnat.
  destruct (IHfbq pbn H) as [i IH].
  exists (S i).
  trivial.
Qed.

Lemma fbq_get_fbq_deq_fbq_get:
  forall fbq i pbn pbn' fbq',
    fbq_get fbq (S i) = Some pbn
    -> fbq_deq fbq = Some (pbn', fbq')
    -> fbq_get fbq' i = Some pbn.
Proof.
  induction fbq.
    intros.
    unfold fbq_get, fbq_deq in * .
    discriminate.
  intros.
  unfold fbq_get in H.
  unfold fbq_deq in H0.
  injection H0.
  intros; subst fbq' a.
  simpl in H.
  trivial.
Qed.

Lemma fbq_get_fbq_rdeq_fbq_get:
  forall fbq i pbn pbn' fbq',
    fbq_get fbq i = Some pbn
    -> fbq_deq fbq' = Some (pbn', fbq)
    -> fbq_get fbq' (S i) = Some pbn.
Proof.
  induction fbq.
    intros.
    unfold fbq_get in H .
    unfold list_get in H.
    destruct i; discriminate.
  intros.
  unfold fbq_get in H.
  destruct fbq'.
    simpl in H0.
    discriminate.
  simpl in H0.
  injection H0.
  intros; subst fbq' b.
  unfold fbq_get.
  simpl.
  apply H.
Qed.

Lemma fbq_deq_fbq_get :
  forall fbq pbn fbq',
    fbq_deq fbq = Some (pbn, fbq')
    -> fbq_get fbq 0 = Some pbn.
Proof.
  induction fbq.
    intros.
    simpl in * .
    discriminate.
  intros pbn fbq' H.
  unfold fbq_deq in H.
  injection H.
  intros; subst fbq' a.
  unfold fbq_get.
  simpl.
  trivial.
Qed.

Lemma fbq_deq_fbq_in :
  forall fbq pbn fbq',
    fbq_deq fbq = Some (pbn, fbq')
    -> fbq_in fbq pbn = true.
Proof.
  unfold fbq_deq, fbq_in.
  induction fbq; simpl; intros; auto.
    discriminate.
  injection H; intros; subst a fbq'.
  simplbnat.
  trivial.
Qed.

Lemma fbq_in_preserv_fbq_deq :
  forall fbq pbn fbq' pbn',
    fbq_in fbq pbn = true
    -> pbn' <> pbn
    -> fbq_deq fbq = Some (pbn', fbq')
    -> fbq_in fbq' pbn = true.
Proof.
  unfold fbq_in, fbq_deq.
  induction fbq; simpl; intros; auto.
    discriminate.
  injection H1; intros; subst a fbq'.
  simplbnat.
  trivial.
Qed.

Lemma fbq_enq_spec :
  forall fbq pbn,
    exists fbq', fbq_enq fbq pbn = Some fbq'.
Proof.
  intros.
  unfold fbq_enq.
  exists (list_append fbq pbn).
  trivial.
Qed.

Lemma fbq_get_fbq_enq_fbq_get_rev:
  forall fbq fbq' i pbn pbn',
    fbq_enq fbq pbn' = Some fbq'
    -> fbq_get fbq' i = Some pbn
    -> pbn = pbn' /\ i = length fbq \/ fbq_get fbq i = Some pbn .
Proof.
  induction fbq; simpl; intros; trivial.
    unfold fbq_enq in H.
    injection H; intro; subst fbq'; clear H.
    unfold fbq_get in H0.
    simpl in H0.
    destruct i.
      injection H0; intro; subst pbn'; trivial.
      left; split; trivial.
    destruct i; discriminate.
  destruct i.
    unfold fbq_enq in H.
    injection H; intro; subst fbq'; auto.
  destruct fbq'.
    unfold fbq_enq in H.
    discriminate H.
  assert (fbq_enq fbq pbn' = Some fbq').
    clear - H.
    unfold fbq_enq in * .
    simpl in H.
    injection H; intros; subst.
    trivial.
  assert (fbq_get fbq' i = Some pbn).
    clear - H0.
    unfold fbq_get in * .
    simpl in H0.
    trivial.
  destruct (IHfbq fbq' i pbn pbn' H1 H2).
    destruct H3.
    left; subst; split; trivial.
  right.
  clear - H3.
  unfold fbq_get in * .
  simpl.
  trivial.
Qed.

Lemma fbq_not_in_fbq_get_some_implies_false:
  forall fbq pbn,
    fbq_in fbq pbn = false
    -> forall i, fbq_get fbq i = Some pbn
                 -> False.
Proof.
  unfold fbq_get.
  induction fbq; simpl; intros; auto.
    destruct i; discriminate.
  assert (fbq_in fbq pbn = false).
    unfold fbq_in in * .
    simpl in * .
    destruct (beq_nat pbn a).
      discriminate.
    trivial.
  destruct i.
    injection H0; intro; subst a; auto.
    unfold fbq_in in H.
    simpl in H.
    simplbnat.
  apply IHfbq with pbn i ; auto.
Qed.

Lemma fbq_get_fbq_deq_fbq_get_rev:
  forall fbq i pbn pbn' fbq',
    fbq_deq fbq = Some (pbn', fbq')
    -> fbq_get fbq' i = Some pbn
    -> fbq_get fbq (S i) = Some pbn.
Proof.
  induction fbq.
    intros.
    unfold fbq_get, fbq_deq in * .
    discriminate.
  intros.
  destruct i.
    simpl in *.
    unfold fbq_get.
    simpl.
    injection H; intros; subst fbq'; trivial.
  unfold fbq_deq in H.
  injection H; intros; subst a fbq'; auto.
Qed.

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

  Lemmas for block mapping table

*)

Lemma pbn_in_bmt_lbn_bmt_get :
  forall bmt lbn pbn,
    pbn_in_bmt_lbn bmt lbn pbn
    -> exists bmr, bmt_get bmt lbn = Some bmr
       /\ pbn_in_bmr pbn bmr.
Proof.
  intros bmt lbn pbn Hin.
  unfold pbn_in_bmt_lbn in Hin.
  destruct Hin.
    destruct H as [bmr Hget].
    exists (Some pbn, bmr).
    split; trivial.
    simpl.
    destruct bmr.
      left; trivial.
    trivial.
  destruct H as [bmr Hget].
  exists (bmr, Some pbn).
  split; trivial.
  unfold pbn_in_bmr.
  destruct bmr; trivial.
  right; trivial.
Qed.

Lemma bmt_get_bmt_update_some :
  forall bmt lbn mbr mbr',
    bmt_get bmt lbn = Some mbr
    -> exists bmt', bmt_update bmt lbn mbr' = Some bmt'.
Proof.
  unfold bmt_get, bmt_update.
  intros.
  destruct (list_get_list_set mbr' H) as [bmt' Hbmt'].
  exists bmt'.
  destruct mbr'; trivial.
Qed.

Lemma bmt_update_bmt_get_eq :
  forall bmt lbn bmr bmt',
    bmt_update bmt lbn bmr = Some bmt'
    -> bmt_get bmt' lbn = Some bmr.
Proof.
  unfold bmt_update, bmt_get.
  intros.
  destruct bmr.
  rewrite (list_get_list_set_eq H).
  trivial.
Qed.

Lemma bmt_update_bmt_get_neq :
  forall bmt lbn bmr bmt' lbn',
    bmt_update bmt lbn bmr = Some bmt'
    -> lbn <> lbn'
    -> bmt_get bmt' lbn' = bmt_get bmt lbn'.
Proof.
  unfold bmt_update, bmt_get.
  intros.
  destruct bmr.
  rewrite (list_get_list_set_neq H H0).
  trivial.
Qed.

Lemma bmt_update_bmt_get_eq_rev :
  forall bmt lbn bmr bmt',
    bmt_update bmt lbn bmr = Some bmt'
    -> exists bmr', bmt_get bmt lbn = Some bmr'.
Proof.
  unfold bmt_get, bmt_update.
  intros.
  destruct bmr as [bmrd bmrl].
  destruct (list_set_list_get_rev H) as [bmr' H'].
  exists bmr'; trivial.
Qed.

Lemma bmt_update_spec :
  forall bmt lbn mbr mbr',
    bmt_get bmt lbn = Some mbr
    -> exists bmt', bmt_update bmt lbn mbr' = Some bmt'
                    /\ bmt_get bmt' lbn = Some mbr'
                    /\ forall lbn', lbn' <> lbn
                                    -> bmt_get bmt' lbn' = bmt_get bmt lbn'.
Proof.
  unfold bmt_get, bmt_update.
  intros.
  destruct (list_get_list_set mbr' H) as [bmt' Hbmt'].
  exists bmt'.
  destruct mbr'.
  split; trivial.
  rewrite (list_get_list_set_eq Hbmt').
  split; trivial.
  intros.
  rewrite (list_get_list_set_neq Hbmt' (neq_sym H0)).
  trivial.
Qed.

Lemma bmt_update_pbn_in_bmt_lbn_neq :
  forall bmt lbn bmr bmt' lbn' pbn,
    bmt_update bmt lbn bmr = Some bmt'
    -> lbn' <> lbn
    -> pbn_in_bmt_lbn bmt lbn' pbn
    -> pbn_in_bmt_lbn bmt' lbn' pbn.
Proof.
  unfold pbn_in_bmt_lbn.
  intros bmt lbn bmr bmt' lbn' pbn Hu Hneq H.
  destruct H.
    left.
    unfold pbn_in_bmt_data in * .
    destruct H as [x H].
    rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hu (neq_sym Hneq)).
    exists x; trivial.
  right.
  unfold pbn_in_bmt_log in * .
  destruct H as [x H].
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hu (neq_sym Hneq)).
  exists x; trivial.
Qed.

Lemma bmt_update_pbn_in_bmt_lbn_eq :
  forall bmt lbn pbn bmr bmt',
    bmt_update bmt lbn bmr = Some bmt'
    -> pbn_in_bmr pbn bmr
    -> pbn_in_bmt_lbn bmt' lbn pbn.
Proof.
  unfold pbn_in_bmr, pbn_in_bmt_lbn.
  intros.
  destruct bmr as [bd bl].
  destruct bd; destruct bl.
    destruct H0.
    left.
    exists (Some b0).
    rewrite (bmt_update_bmt_get_eq _ _ _ _ H).
    subst; trivial.
    right.
    exists (Some b).
    subst b0.
    rewrite (bmt_update_bmt_get_eq _ _ _ _ H).
    trivial.

    left.
    exists None.
    rewrite (bmt_update_bmt_get_eq _ _ _ _ H).
    subst; trivial.

    right.
    exists None.
    rewrite (bmt_update_bmt_get_eq _ _ _ _ H).
    subst; trivial.

    contradiction.
Qed.

Lemma bmt_update_pbn_in_bmt_lbn_neq_rev :
(* Lemma bmt_update_pbn_in_bmt_neq :  *)
  forall bmt bmt' lbn lbn' pbn bmr,
    bmt_update bmt lbn bmr = Some bmt'
    -> lbn <> lbn'
    -> pbn_in_bmt_lbn bmt' lbn' pbn
    -> pbn_in_bmt_lbn bmt lbn' pbn.
Proof.
  unfold pbn_in_bmt_lbn.
  intros.
  destruct H1.
    left.
    unfold pbn_in_bmt_data in * .
    destruct H1.
    exists x.
    rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ H H0).
    trivial.
  right.
  destruct H1.
  exists x.
  rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ H H0).
  trivial.
Qed.

Lemma bmt_update_log_bmt_get_neq :
  forall bmt lbn pbn bmt' lbn',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> lbn <> lbn'
    -> bmt_get bmt' lbn' = bmt_get bmt lbn'.
Proof.
  unfold bmt_update_log.
  intros.
  destruct (bmt_get bmt lbn) eqn:Hget; try discriminate.
  destruct b.
  destruct (bmt_update bmt lbn (o, Some pbn)) eqn:Hup; try discriminate.
  injection H; intros; subst b.
  erewrite bmt_update_bmt_get_neq; eauto.
Qed.

Lemma bmt_update_log_spec :
  forall bmt lbn pbn bmr,
    bmt_get bmt lbn = Some bmr
    -> exists bmt', bmt_update_log bmt lbn pbn = Some bmt'
                    /\ bmt_get bmt' lbn = Some (fst bmr, Some pbn)
                    /\ (forall lbn',
                         lbn' <> lbn
                         -> bmt_get bmt' lbn' = bmt_get bmt lbn').
Proof.
  unfold bmt_update_log.
  intros.
  rewrite H.
  destruct bmr.
  destruct (bmt_update_spec bmt lbn _ (o, Some pbn) H) as [bmt' [Hup [Hget Hget']]].
  exists bmt'.
  rewrite Hup.
  split; trivial.
  simpl.
  split; trivial.
Qed.

Lemma bmt_update_log_pbn_in_bmt_log_eq :
  forall bmt lbn pbn bmt',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> pbn_in_bmt_log bmt' lbn pbn.
Proof.
  unfold pbn_in_bmt_log.
  unfold bmt_update_log.
  intros.
  destruct (bmt_get bmt lbn) eqn:Hget; try discriminate.
  destruct b as [bmrd bmrl].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) eqn:Hup; try discriminate.
  injection H; intros; subst b.
  rewrite (bmt_update_bmt_get_eq _ _ _ _ Hup).
  exists bmrd; trivial.
Qed.

Lemma bmt_update_log_pbn_in_bmt_data_preserv :
  forall bmt lbn pbn bmt' lbn' pbn',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> pbn_in_bmt_data bmt lbn' pbn'
    -> pbn_in_bmt_data bmt' lbn' pbn'.
Proof.
  unfold pbn_in_bmt_data.
  unfold bmt_update_log.
  intros.
  destruct (bmt_get bmt lbn) eqn:Hget; try discriminate.
  destruct b as [bmrd bmrl].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) eqn:Hup; try discriminate.
  injection H; intros; subst b.
  destruct (pbn_eq_dec lbn lbn') as [Heq | Hneq].
    subst lbn'.
    destruct H0 as [x H0].
    exists (Some pbn).
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hup).
    rewrite Hget in H0.
    injection H0; intros; subst bmrd x.
    trivial.
  destruct H0 as [x H0].
  clear H.
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hup Hneq).
  rewrite H0.
  exists x; trivial.
Qed.

Lemma bmt_update_log_pbn_in_bmt_data_preserv_rev :
  forall bmt lbn pbn bmt' lbn' pbn',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> pbn_in_bmt_data bmt' lbn' pbn'
    -> pbn_in_bmt_data bmt lbn' pbn'.
Proof.
  unfold pbn_in_bmt_data.
  unfold bmt_update_log.
  intros.
  destruct (bmt_get bmt lbn) eqn:Hget; try discriminate.
  destruct b as [bmrd bmrl].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) eqn:Hup; try discriminate.
  injection H; intros; subst b.
  destruct (pbn_eq_dec lbn lbn') as [Heq | Hneq].
    subst lbn'.
    destruct H0 as [x H0].
    exists bmrl.
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hup) in H0.
    injection H0; intros; subst bmrd x.
    trivial.
  destruct H0 as [x H0].
  clear H.
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hup Hneq) in H0.
  exists x; trivial.
Qed.

Lemma bmt_update_log_pbn_in_bmt_log_preserv_rev :
  forall bmt lbn pbn bmt' lbn' pbn',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> lbn <> lbn'
    -> pbn_in_bmt_log bmt' lbn' pbn'
    -> pbn_in_bmt_log bmt lbn' pbn'.
Proof.
  unfold pbn_in_bmt_log.
  unfold bmt_update_log.
  intros.
  destruct (bmt_get bmt lbn) eqn:Hget; try discriminate.
  destruct b as [bmrd bmrl].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) eqn:Hup; try discriminate.
  injection H; intros; subst b; clear H.
  destruct H1 as [x H1].
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hup H0) in H1.
  exists x; trivial.
Qed.

Lemma bmt_update_log_pbn_in_bmt_lbn_neq :
  forall bmt lbn pbn bmt' lbn' pbn',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> lbn <> lbn'
    -> pbn_in_bmt_lbn bmt lbn' pbn'
    -> pbn_in_bmt_lbn bmt' lbn' pbn'.
Proof.
  unfold pbn_in_bmt_lbn.
  unfold bmt_update_log.
  unfold pbn_in_bmt_data, pbn_in_bmt_log.
  intros.
  destruct (bmt_get bmt lbn) eqn:Hget; try discriminate.
  destruct b as [bmrd bmrl].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) eqn:Hup; try discriminate.
  injection H; intros; subst b; clear H.
  destruct H1 as [[x H1] | [x H1]].
    left.
    rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hup H0) in H1.
    exists x; trivial.
  right.
  rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hup H0) in H1.
  exists x; trivial.
Qed.

Lemma bmt_update_log_pbn_in_bmt_lbn_neq_rev :
  forall bmt lbn pbn bmt' lbn' pbn',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> lbn <> lbn'
    -> pbn_in_bmt_lbn bmt' lbn' pbn'
    -> pbn_in_bmt_lbn bmt lbn' pbn'.
Proof.
  unfold pbn_in_bmt_lbn.
  intros.
  destruct H1 as [H1 | H1].
  left.
  apply (bmt_update_log_pbn_in_bmt_data_preserv_rev _ _ _ _ _ _ H); trivial.
  right.
  apply (bmt_update_log_pbn_in_bmt_log_preserv_rev _ _ _ _ _ _ H); trivial.
Qed.

Lemma bmt_update_log_bmt_get_eq_rev :
  forall bmt lbn pbn bmt',
    bmt_update_log bmt lbn pbn = Some bmt'
    -> exists bmr, bmt_get bmt lbn = Some bmr.
Proof.
  unfold bmt_update_log.
  intros.
  destruct (bmt_get bmt lbn) as [ bmr | ] eqn:Hget.
    destruct bmr as [bmrd bmrl].
    destruct (bmt_update bmt lbn(bmrd, Some pbn)) as [ bmt'' | ] eqn:Hu.
      injection H; intro; subst bmt''; clear H.
      exists (bmrd, bmrl); trivial.
    discriminate.
  discriminate.
Qed.

Lemma bmt_get_pbn_in_bmt_r :
  forall bmt lbn x pbn2,
    bmt_get bmt lbn = Some (x, Some pbn2)
    -> pbn_in_bmt bmt pbn2.
Proof.
  intros bmt lbn x pbn2 Hget.
  exists lbn; right.
  exists x; trivial.
Qed.

Lemma bmt_get_pbn_in_bmt_l :
  forall bmt lbn pbn1 x,
    bmt_get bmt lbn = Some (Some pbn1, x)
    -> pbn_in_bmt bmt pbn1.
Proof.
  intros bmt lbn pbn1 x Hget.
  exists lbn; left.
  exists x; trivial.
Qed.

(************** *)

Lemma pmt_update_pmt_len :
  forall pmt loc off pmt',
    pmt_update pmt loc off = Some pmt'
    -> pmt_len pmt' = pmt_len pmt.
Proof.
  unfold pmt_update, pmt_len.
  intros.
  erewrite list_set_length_preserv; eauto.
Qed.

Lemma pmt_update_pmt_get_eq :
  forall pmt loc off pmt',
    pmt_update pmt loc off = Some pmt'
    -> pmt_get pmt' loc = Some (pmte_log off).
Proof.
  unfold pmt_update, pmt_get.
  intros.
  rewrite (list_get_list_set_eq H).
  trivial.
Qed.

Lemma pmt_update_pmt_get_neq :
  forall pmt loc off pmt' loc',
    pmt_update pmt loc off = Some pmt'
    -> loc' <> loc
    -> pmt_get pmt' loc' = pmt_get pmt loc'.
Proof.
  unfold pmt_update, pmt_get.
  intros.
  rewrite (list_get_list_set_neq H (neq_sym H0)).
  trivial.
Qed.

Lemma beq_pmt_entry_true_eq :
  forall a1 a2 : pmt_entry, beq_pmt_entry a1 a2 = true -> a1 = a2.
Proof.
  intros a1 a2 H.
  destruct a1; destruct a2; simpl in H; simpl; try discriminate; trivial.
  rewbnat H.
  trivial.
Qed.

Lemma beq_pmt_entry_eq_true :
  forall a1 a2 : pmt_entry, a1 = a2 -> beq_pmt_entry a1 a2 = true.
Proof.
  intros a1 a2 H.
  destruct a1; destruct a2; simpl in H; simpl; try discriminate; trivial.
  injection H; intro; subst; trivial.
  simplbnat.
  trivial.
Qed.

Lemma beq_pmt_entry_false_neq :
  forall a1 a2 : pmt_entry, beq_pmt_entry a1 a2 = false -> a1 <> a2.
Proof.
  intros a1 a2 H.
  destruct a1; destruct a2; simpl in H; simpl; try discriminate; trivial.
  intro HF.
  injection HF; intro; subst off0.
  simplbnat.
Qed.

Lemma beq_pmt_entry_neq_false :
  forall a1 a2 : pmt_entry, a1 <> a2 -> beq_pmt_entry a1 a2 = false.
Proof.
  intros a1 a2 H.
  destruct a1; destruct a2; simpl in H; simpl; try discriminate; trivial.
    destruct (H (refl_equal _)).
  destruct (beq_nat off off0) eqn: Hbeq.
    apply False_ind.
    apply H.
    rewbnat Hbeq.
    trivial.
  trivial.
Qed.

Lemma pmt_find_rev_pmt_get :
  forall pmt off loc,
    pmt_find_rev pmt (pmte_log off) = Some loc
    -> pmt_get pmt loc = Some (pmte_log off).
Proof.
  unfold pmt_find_rev, pmt_get.
  intros pmt off loc Hfind.
  rewrite (list_find_rev_list_get Hfind); trivial.
  apply beq_pmt_entry_true_eq; trivial.
Qed.

Lemma pmt_len_pmt_get:
  forall pmt len,
    pmt_len pmt = len
    -> forall loc,
         (blt_nat loc len = true -> exists pmte, pmt_get pmt loc = Some pmte)
         /\ (blt_nat loc len = false -> pmt_get pmt loc = None).
Proof.
  intros.
  unfold pmt_len, pmt_get in * .
  destruct (length_elim H loc) as [H1 H2].
  split; trivial.
Qed.

Lemma pmt_update_pmt_find_rev_neq :
  forall pmt loc off pmt' off',
    pmt_get pmt loc = Some pmte_empty
    -> pmt_update pmt loc off = Some pmt'
    -> off' <> off
    -> pmt_find_rev pmt' (pmte_log off') = pmt_find_rev pmt (pmte_log off').
Proof.
  unfold pmt_get, pmt_update, pmt_find_rev.
  intros.
  apply list_set_list_find_rev_neq with loc pmte_empty (pmte_log off); trivial.
  intro HF.
  apply H1.
  injection HF; auto.
  intro HF; discriminate.
  apply beq_pmt_entry_neq_false; trivial.
  apply beq_pmt_entry_false_neq; trivial.
Qed.

Lemma pmt_update_spec:
  forall pmt loc off,
    bvalid_page_off loc = true
    -> pmt_get pmt loc = Some pmte_empty
    -> exists pmt', pmt_update pmt loc off = Some pmt'
                    /\ pmt_get pmt' loc = Some (pmte_log off)
                    /\ (forall loc',
                          loc' <> loc
                          -> pmt_get pmt' loc' = pmt_get pmt loc').
Proof.
  intros pmt loc off Hloc Hget.
  assert (exists pmt', pmt_update pmt loc off = Some pmt').
    unfold pmt_update, pmt_get in * .
    destruct (@list_get_list_set _ pmt loc pmte_empty (pmte_log off) Hget) as [pmt' Hx].
    exists pmt'; trivial.
  destruct H as [pmt' H].
  rewrite H.
  exists pmt'.
  split; trivial.
  split.
    rewrite (pmt_update_pmt_get_eq _ _ _ _ H).
    trivial.
  intros loc' Hneq.
  rewrite (pmt_update_pmt_get_neq _ _ _ _ _ H Hneq).
  trivial.
Qed.

(************** *)

Lemma pbn_in_bmt_data_inj :
  forall bmt lbn pbn pbn',
    pbn_in_bmt_data bmt lbn pbn
    -> pbn_in_bmt_data bmt lbn pbn'
    -> pbn = pbn'.
Proof.
  unfold pbn_in_bmt_data.
  intros bmt lbn pbn pbn' Hpbn Hpbn'.
  destruct Hpbn as [x1 Hpbn].
  destruct Hpbn' as [x2 Hpbn'].
  rewrite Hpbn in Hpbn'.
  injection Hpbn'; intros; auto.
Qed.

Lemma pbn_in_bmt_log_inj :
  forall bmt lbn pbn pbn',
    pbn_in_bmt_log bmt lbn pbn
    -> pbn_in_bmt_log bmt lbn pbn'
    -> pbn = pbn'.
Proof.
  unfold pbn_in_bmt_log.
  intros bmt lbn pbn pbn' [x1 Hpbn] [x2 Hpbn'].
  rewrite Hpbn in Hpbn'.
  injection Hpbn'; intros; auto.
Qed.

(************** *)

Lemma invalid_off_implies_read_data_block_none :
  forall c pbn loc,
    ~ valid_page_off loc
    -> read_data_block c pbn loc = None.
Proof.
  intros c pbn loc H.
  unfold read_data_block.
  assert (bvalid_page_off loc = false).
    unfold valid_page_off in H.
    destruct (bvalid_page_off loc).
    destruct (H (refl_equal _)).
    trivial.
  rewrite (invalid_off_implies_nand_read_page_none _ _ _ H0); eauto.
Qed.

Lemma read_data_block_unchanged :
  forall c pbn off c',
    chip_get_block c pbn = chip_get_block c' pbn
    -> read_data_block c pbn off = read_data_block c' pbn off.
Proof.
  intros c pbn off c' Hg.
  unfold read_data_block.
  erewrite nand_read_page_eq_in_same_block; eauto.
Qed.

Lemma read_log_block_unchanged :
  forall c pbn off bi c',
    chip_get_block c pbn = chip_get_block c' pbn
    -> read_log_block c bi pbn off = read_log_block c' bi pbn off.
Proof.
  intros c pbn off bi c' Hg.
  unfold read_log_block.
  destruct (find_page_in_log_block bi off) as [loc | ].
  erewrite nand_read_page_eq_in_same_block; eauto.
  trivial.
Qed.

Lemma abundant_elim :
  forall fbq,
    check_freebq_count fbq = fbqs_abundant
    -> exists b fbq', fbq_deq fbq = Some (b, fbq')
                      /\ fbq_in fbq b = true.
Proof.
  unfold check_freebq_count.
  intros fbq H.
  destruct (ble_nat MIN_FREE_BLOCKS (length fbq)) eqn:Hfbq; try discriminate.
  clear H.
  destruct fbq as [ | b fbq' ].
    simpl in Hfbq.
    unfold ble_nat in Hfbq.
    unfold MIN_FREE_BLOCKS in Hfbq.
    simpl in Hfbq.
    discriminate.
  exists b, fbq'.
  simpl.
  split; trivial.
  unfold fbq_in.
  unfold list_inb.
  simplbnat.
  trivial.
Qed.


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

Require Import List Permutation Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils pos vec.

From Undecidability.ILL
  Require Import ILL.

Set Implicit Arguments.

Section obvious_links_between_fragments.

  Notation "P ⇒ Q" := (forall Γ A, P Γ A -> Q Γ A) (at level 70).

  Fact S_ill_restr_restr_wc : S_ill_restr ⇒ S_ill_restr_wc.
  Proof.
    induction 1.
    all: try now constructor.
    now constructor 3 with (Γ := Γ).
  Qed.

  Fact S_ill_full_wc : S_ill ⇒ S_ill_wc.
  Proof.
    induction 1.
    all: try now constructor.
    now constructor 3 with (Γ := Γ).
  Qed.

  Fact S_ill_restr_full : S_ill_restr ⇒ S_ill.
  Proof.
    induction 1.
    all: try now constructor.
    now constructor 2 with (Γ := Γ).
  Qed.

  Fact S_ill_restr_full_wc : S_ill_restr_wc ⇒ S_ill_wc.
  Proof.
    induction 1.
    all: try now constructor.
    + now constructor 2 with A.
    + now constructor 3 with (Γ := Γ).
  Qed.

End obvious_links_between_fragments.

Local Notation "Γ '⊢r' A" := (S_ill_restr Γ A) (at level 70, no associativity).
Local Notation "Γ '⊢' A" := (S_ill_wc Γ A) (at level 70, no associativity).

Fact S_ill_restr_weak Γ Δ B : Δ ⊢r B -> ‼Γ++Δ ⊢r B.
Proof. intro; induction Γ; simpl; auto; apply in_ill1_weak; auto. Qed.

Fact S_ill_wc_weak Γ Δ B : Δ ⊢ B -> ‼Γ++Δ ⊢ B.
Proof. intro; induction Γ; simpl; auto; apply in_ill4_weak; auto. Qed.

Fact S_ill_restr_cntr Γ Δ B : ‼Γ++‼Γ++Δ ⊢r B -> ‼Γ++ Δ ⊢r B.
Proof.
  revert Γ Δ; intros Ga.
  induction Ga as [ | A Ga IH ]; simpl; auto; intros De.
  intros H.
  apply in_ill1_cntr.
  apply in_ill1_perm with (‼Ga ++ (!A::!A::De)).
  + apply Permutation_sym.
    do 2 apply Permutation_cons_app; auto.
  + apply IH.
    revert H; apply in_ill1_perm.
    rewrite app_assoc.
    apply Permutation_cons_app.
    rewrite <- app_assoc.
    apply Permutation_app; auto.
    apply Permutation_cons_app; auto.
Qed.

Fact S_ill_wc_cntr Γ Δ B : ‼Γ++‼Γ++Δ ⊢ B -> ‼Γ++ Δ ⊢ B.
Proof.
  revert Γ Δ; intros Ga.
  induction Ga as [ | A Ga IH ]; simpl; auto; intros De.
  intros H.
  apply in_ill4_cntr.
  apply in_ill4_perm with (‼Ga ++ (!A::!A::De)).
  + apply Permutation_sym.
    do 2 apply Permutation_cons_app; auto.
  + apply IH.
    revert H; apply in_ill4_perm.
    rewrite app_assoc.
    apply Permutation_cons_app.
    rewrite <- app_assoc.
    apply Permutation_app; auto.
    apply Permutation_cons_app; auto.
Qed.

Theorem S_ill_restr_weak_cntr Σ Γ A B : In A Σ -> ‼Σ++Γ ⊢r B <-> !A::‼Σ++Γ ⊢r B.
Proof.
  revert Σ Γ; intros Si Ga.
  intros H.
  apply In_perm in H.
  destruct H as (Si' & H).
  split.
  + apply in_ill1_weak.
  + intros H1.
    apply in_ill1_perm with (‼(A :: Si') ++ Ga).
    * apply Permutation_app; auto.
      apply Permutation_map; auto.
    * simpl; apply in_ill1_cntr.
      revert H1; apply in_ill1_perm.
      simpl; apply Permutation_cons; auto.
      change (!A::‼Si'++Ga) with (‼(A::Si')++Ga).
      apply Permutation_app; auto.
      apply Permutation_map, Permutation_sym; auto.
Qed.

Theorem S_ill_wc_weak_cntr Σ Γ A B : In A Σ -> ‼Σ++Γ ⊢ B <-> !A::‼Σ++Γ ⊢ B.
Proof.
  revert Σ Γ; intros Si Ga.
  intros H.
  apply In_perm in H.
  destruct H as (Si' & H).
  split.
  + apply in_ill4_weak.
  + intros H1.
    apply in_ill4_perm with (‼(A :: Si') ++ Ga).
    * apply Permutation_app; auto.
      apply Permutation_map; auto.
    * simpl; apply in_ill4_cntr.
      revert H1; apply in_ill4_perm.
      simpl; apply Permutation_cons; auto.
      change (!A::‼Si'++Ga) with (‼(A::Si')++Ga).
      apply Permutation_app; auto.
      apply Permutation_map, Permutation_sym; auto.
Qed.

(* We prove soundness for the stronger system *)

Section trivial_phase_semantics.

  Variables (n : nat) (s : ill_vars -> vec nat n -> Prop).

  Reserved Notation "'⟦' A '⟧'" (at level 65).

  Definition ill_tps_imp (X Y : _ -> Prop) (v : vec _ n) := forall x, X x -> Y (vec_plus x v).
  Definition ill_tps_mult (X Y : _ -> Prop) (x : vec _ n) := exists a b, x = vec_plus a b /\ X a /\ Y b.

  Infix "**" := ill_tps_mult (at level 65, right associativity).
  Infix "-*" := ill_tps_imp (at level 65, right associativity).

  Fact ll_tps_mult_mono (X1 X2 Y1 Y2 : _ -> Prop) :
             (forall x, X1 x -> X2 x)
          -> (forall x, Y1 x -> Y2 x)
          -> (forall x, (X1**Y1) x -> (X2**Y2) x).
  Proof.
    intros H1 H2 x (a & b & H3 & H4 & H5); subst.
    exists a, b; auto.
  Qed.

  Fixpoint ill_tps A x : Prop :=
    match A with
      | £ X     => s X x
      | A & B   => ⟦A⟧ x /\ ⟦B⟧ x
      | !A      => ⟦A⟧ x /\ x = vec_zero
      | A ⊸ B   => (⟦A⟧ -* ⟦B⟧) x
      | A ⊗ B   => (⟦A⟧ ** ⟦B⟧) x
      | A ⊕ B   => ⟦A⟧ x \/ ⟦B⟧ x
      | ⟘              => False
      | ⟙              => True
      | _               => x = vec_zero
    end
  where "⟦ A ⟧" := (ill_tps A).

  Reserved Notation "'[[' Γ ']]'" (at level 0).

  Fixpoint ill_tps_list Γ :=
    match Γ with
      | ∅    => eq vec_zero
      | A::Γ => ⟦A⟧ ** [[Γ]]
    end
  where "[[ Γ ]]" := (ill_tps_list Γ).

  Fact ill_tps_app Γ Δ x : [[Γ++Δ]] x <-> ([[Γ]]**[[Δ]]) x.
  Proof.
    revert Γ Δ x; intros Ga De.
    induction Ga as [ | A Ga IH ]; intros x; simpl; split; intros Hx.
    + exists vec_zero, x; simpl; rew vec.
    + destruct Hx as (a & b & H1 & H2 & H3); subst; auto; rewrite vec_zero_plus; auto.
    + destruct Hx as (a & b & H1 & H2 & H3).
      apply IH in H3.
      destruct H3 as (c & d & H4 & H5 & H6).
      exists (vec_plus a c), d; split.
      * subst; apply vec_add_assoc.
      * split; auto.
        exists a, c; auto.
    + destruct Hx as (y & d & H1 & H2 & H3).
      destruct H2 as (a & g & H2 & H4 & H5).
      exists a, (vec_plus g d); split.
      * subst; symmetry; apply vec_add_assoc.
      * split; auto.
        apply IH.
        exists g, d; auto.
  Qed.

  Fact ill_tps_lbang Γ x : [[‼Γ]] x <-> [[Γ]] x /\ x = vec_zero.
  Proof.
    revert Γ x; intros Ga.
    induction Ga as [ | A Ga IH ]; intros x.
    + simpl; split; auto; tauto.
    + split.
      * intros (a & g & H1 & H2 & H3).
        split.
        - exists a, g; repeat split; auto.
          ** apply H2.
          ** apply IH; auto.
        - apply IH, proj2 in H3.
          apply proj2 in H2; subst; auto.
          apply vec_zero_plus.
      * intros ((a & g & H1 & H2 & H3) & H4).
        exists x, x.
        assert (a = vec_zero /\ g = vec_zero) as E.
        { apply vec_plus_is_zero; subst; auto. }
        destruct E; subst; repeat split; auto; rew vec.
        apply IH; auto.
  Qed.

  Fact ill_tps_list_bang_zero Γ : [[‼Γ]] vec_zero <-> forall A, In A Γ -> ⟦A⟧ vec_zero.
  Proof.
    induction Γ as [ | A Ga IH ].
    + split.
      * simpl; tauto.
      * intros _; simpl; auto.
    + split.
      * intros (u & v & H1 & H2 & H3).
        destruct H2 as [ H2 H4 ]; subst; auto.
        rewrite vec_zero_plus in H1; subst.
        rewrite IH in H3.
        intros B [ E | HB ]; subst; auto.
      * intros H.
        exists vec_zero, vec_zero.
        rewrite vec_zero_plus; repeat split; auto.
        - apply H; left; auto.
        - rewrite IH.
          intros; apply H; right; auto.
  Qed.

  (* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ ⟦ ⟧ Γ Δ Σ*)

  Fact ill_tps_perm Γ Δ : Γ ~p Δ -> forall x, [[Γ]] x -> [[Δ]] x.
  Proof.
    induction 1 as [ | A Ga De H IH | A B Ga | ]; simpl; auto.
    + intros x (a & b & H1 & H2 & H3).
      exists a, b; repeat split; auto.
    + intros x (a & b & H1 & H2 & c & d & H3 & H4 & H5).
      exists c, (vec_plus a d); split.
      * subst; rewrite (vec_add_comm c), vec_add_assoc, (vec_add_comm c); auto.
      * split; auto.
        exists a, d; auto.
  Qed.

  Definition ill_sequent_tps Γ A := [[Γ]] -* ⟦A⟧.

  Notation "'[<' Γ '|-' A '>]'" := (ill_sequent_tps Γ A).

  Fact ill_sequent_tps_mono Γ A B :
     (forall x, ⟦A⟧ x -> ⟦B⟧ x) -> forall x, [< Γ |- A >] x -> [< Γ |- B >] x.
  Proof.
    intros H x; simpl; unfold ill_sequent_tps.
    intros H1 a H2.
    apply H, H1; auto.
  Qed.

  Fact ill_perm_tps Γ Δ : Γ ~p Δ -> forall x A, [< Γ |- A >] x -> [< Δ |- A >] x.
  Proof.
    intros H1 x B; unfold ill_sequent_tps.
    intros H2 a H3.
    apply H2; revert H3.
    apply ill_tps_perm, Permutation_sym; auto.
  Qed.

  Fact ill_sequent_tps_eq  Γ A : [< Γ |- A >] vec_zero <-> forall x, [[Γ]] x -> ⟦A⟧ x.
  Proof.
    split.
    * intros H x Hx.
      rewrite <- vec_zero_plus, vec_add_comm.
      apply (H x); trivial.
    * intros H x Hx.
      rewrite vec_add_comm, vec_zero_plus; auto.
  Qed.

  Theorem ill_tps_sound Γ A : Γ ⊢ A -> [< Γ |- A >] vec_zero.
  Proof.
    induction 1 as [ A
                   | Γ Δ A B H1 IH1 H2 IH2
                   | Γ Δ A H1 H2 IH2
                   | Γ Δ A B C H1 IH1 H2 IH2
                   | Γ A B H1 IH1
                   | Γ A B C H1 IH1
                   | Γ A B C H1 IH1
                   | Γ A B H1 IH1 H2 IH2
                   | Γ A B H1 IH1
                   | Γ A H1 IH1
                   | Γ A B H1 IH1
                   | Γ A B H1 IH1
                   | Γ A B C H1 IH1
                   | Γ Δ A B H1 IH1 H2 IH2
                   | Γ A B C H1 IH1 H2 IH2
                   | Γ A B H1 IH1
                   | Γ A B H1 IH1
                   | Γ A
                   | Γ
                   | Γ A H1 IH1
                   |
                   ]; unfold ill_sequent_tps in * |- *.

    + intros x; simpl; intros (a & b & H1 & H2 & H3); subst; eq goal H2.
      f_equal; do 2 rewrite vec_add_comm, vec_zero_plus; auto.

    (* Cut Rule *)

    + intros x Hx.
      rewrite ill_tps_app in Hx.
      apply IH2.
      destruct Hx as (a & b & G1 & G2 & G3); subst.
      exists a, b; split; auto.
      split; auto.
      rewrite <- vec_zero_plus, vec_add_comm.
      apply IH1; auto.

    + revert IH2; apply ill_perm_tps; auto.

    + intros x (y & z & H3 & H4 & H5); simpl.
      apply IH2.
      apply ill_tps_app in H5.
      destruct H5 as (g & d & H5 & H6 & H7).
      simpl in H4.
      apply IH1, H4 in H6.
      exists (vec_plus y g), d; repeat split; auto.
      * subst; apply vec_add_assoc.
      * eq goal H6; f_equal; rew vec.

    + simpl; intros y Hy a Ha.
      rewrite vec_add_assoc.
      apply IH1.
      exists a, y; repeat split; auto; lia.

    + intros x (a & b & H2 & H3 & H4); apply IH1.
      exists a, b; repeat split; auto; apply H3.

    + intros x (a & b & H2 & H3 & H4); apply IH1.
      exists a, b; repeat split; auto; apply H3.

    + intros x Hx; split.
      * apply IH1; auto.
      * apply IH2; auto.

    + intros x (a & g & H2 & H3 & H4).
      apply IH1; exists a, g; repeat split; auto.
      apply H3.

    + intros x Hx; split.
      apply IH1; auto.
      rew vec.
      apply ill_tps_lbang in Hx; tauto.

    + intros x (a & g & H2 & H3 & H4).
      apply IH1.
      apply proj2 in H3; subst; auto.
      rew vec; auto.

    + intros x (a & g & H2 & H3 & H4).
      apply IH1.
      exists a, g.
      repeat (split; auto).
      exists a, g.
      repeat (split; auto).
      apply proj2 in H3.
      subst; rew vec; auto.

    (* ⊗ left *)

    + intros x Hx.
      apply IH1.
      destruct Hx as (c & g & ? & (a & b & ? & H2 & H3) & H4); subst.
      exists a, (vec_plus b g); split; auto.
      * rewrite vec_add_assoc; trivial.
      * split; auto; exists b, g; auto.

    (* ⊗ right *)

    + intros x Hx.
      apply ill_tps_app in Hx.
      destruct Hx as (a & b & ? & H3 & H4); subst.
      exists a, b; split.
      * rewrite vec_add_comm, vec_zero_plus; auto.
      * split; rewrite <- vec_zero_plus, vec_add_comm.
        - apply IH1; auto.
        - apply IH2; auto.

    (* ⊕ left & ⊕ right 1 & 2 *)

    + intros x Hx.
      destruct Hx as (u & g & ? & [ G1 | G1 ] & G2); subst.
      * apply IH1; exists u, g; auto.
      * apply IH2; exists u, g; auto.
    + intros x Hx; left; apply IH1; auto.
    + intros x Hx; right; apply IH1; auto.

    (* ⟘ left, ⟙ right *)

    + intros ? (? & _ & _ & [] & _).
    + intros x _; red; trivial.

    (* 𝝐 unit left & right *)

    + intros x (i & g & ? & H2 & H3); subst.
      red in H2; subst.
      rewrite vec_zero_plus.
      apply IH1; auto.
    + intros x Hx; red in Hx; subst.
      rewrite vec_zero_plus; red; trivial.
  Qed.

  (* This semantics is NOT complete for ILL
     or even the (!,&,-o) fragment but it is
     complete for the EILL fragment *)

End trivial_phase_semantics.


(* * Addendum for Vectors ([Vector.t]) *)
(* Author: Maximilian Wuttke *)

From Undecidability.Shared.Libs.PSL Require Import Prelim Tactics.Tactics EqDec.
From Coq.Vectors Require Import Fin Vector.
From Undecidability.Shared.Libs.PSL Require Import Vectors.FinNotation.
From Undecidability.Shared.Libs.PSL Require Export Vectors.Fin.

(* Vector.nth should not reduce with simpl, except the index is given with a constructor *)
Arguments Vector.nth {A} {m} (v') !p.
Arguments Vector.map {A B} f {n} !v.
Arguments Vector.map2 {A B C} g {n} !v1 !v2.

Tactic Notation "dependent" "destruct" constr(V) :=
  match type of V with
  | Vector.t ?Z (S ?n) =>
    revert all except V;
    pattern V; revert n V;
    eapply caseS; intros
  | Vector.t ?Z 0 =>
    revert all except V;
    pattern V; revert V;
    eapply case0; intros
  | Fin.t 0 => inv V
  | Fin.t (S ?n) =>
    let pos := V in
    revert all except pos;
    pattern pos; revert n pos;
    eapply Fin.caseS; intros
  | _ => fail "Wrong type"
  end.

Delimit Scope vector_scope with vector.
Local Open Scope vector.

Module VectorNotations2.

Notation "[ | | ]" := (nil _) (format "[ |  | ]"): vector_scope.
Notation "h ':::' t" := (cons _ h _ t) (at level 60, right associativity) : vector_scope.

Notation "[ | x | ]" := (x ::: [| |]) : vector_scope.
Notation "[ | x ; y ; .. ; z | ] " := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..))
   (format "[ | x ;  y ;  .. ;  z | ] ") : vector_scope.
Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope.

End VectorNotations2.

Import VectorNotations2.

Ltac existT_eq :=
  match goal with
  | [ H: existT ?X1 ?Y1 ?Z1 = existT ?X2 ?Y2 ?Z2 |- _] =>
    apply EqdepFacts.eq_sigT_iff_eq_dep in H; inv H
  end.

Ltac existT_eq' :=
  match goal with
  | [ H: existT ?X1 ?Y1 ?Z1 = existT ?X2 ?Y2 ?Z2 |- _] =>
    apply EqdepFacts.eq_sigT_iff_eq_dep in H; induction H
  end.

Lemma vect_map_injective X Y n (f : X -> Y) (v1 v2 : Vector.t X n) :
  (forall x y, f x = f y -> x = y) ->
  map f v1 = map f v2 -> v1 = v2.
Proof.
  intros Inj Eq.
  induction n; cbn in *.
  - dependent destruct v1. dependent destruct v2; reflexivity.
  - dependent destruct v1. dependent destruct v2. cbn in *.
    eapply cons_inj in Eq as (-> % Inj &?). f_equal. now apply IHn.
Qed.

Lemma replace_nth X n (v : Vector.t X n) i (x : X) :
  (Vector.replace v i x) [@i] = x.
Proof.
  induction i; dependent destruct v; cbn; auto.
Qed.

Lemma replace_nth2 X n (v : Vector.t X n) i j (x : X) :
  i <> j -> (Vector.replace v i x) [@j] = v[@j].
Proof.
  revert v. pattern i, j. revert n i j.
  eapply Fin.rect2; intros; try congruence.
  - revert f H. pattern v. revert n v.
    eapply Vector.caseS.
    cbn. reflexivity.
  - revert f H. pattern v. revert n v.
    eapply Vector.caseS.
    cbn. reflexivity.
  - revert g f H H0. pattern v. revert n v.
    eapply Vector.caseS. firstorder congruence.
Qed.

Lemma destruct_vector_nil (X : Type) :
  forall v : Vector.t X 0, v = [| |].
Proof.
  now apply case0.
Qed.

Lemma destruct_vector_cons (X : Type) (n : nat) :
  forall v : Vector.t X (S n), { h : X & { v' : Vector.t X n | v = h ::: v' }}.
Proof.
  revert n. apply caseS. eauto.
Qed.

Lemma In_nil (X : Type) (x : X) :
  ~ In x [| |].
Proof. intros H. inv H. Qed.

Lemma In_cons (X : Type) (n : nat) (x y : X) (xs : Vector.t X n) :
  In y (x ::: xs) -> x = y \/ In y xs.
Proof.
  intros H. inv H; existT_eq'; tauto.
Qed.

Ltac destruct_vector_in :=
  lazymatch goal with
  | [ H: Vector.In _ [| |] |- _ ] => solve [exfalso;simple apply In_nil in H;exact H]
  | [ H: Vector.In _ (?x ::: _) |- _ ] => simple apply In_cons in H as [H| H] ; try (is_var x;move H at bottom;subst x)
  end.

(*
Goal ~ Vector.In 10 [|1;2;4|].
Proof.
  intros H. repeat destruct_vector_in; congruence.
Qed.
*)

Section In_Dec.
  Variable X : Type.
  Hypothesis X_dec : eq_dec X.

  Fixpoint in_dec (n : nat) (x : X) (xs : Vector.t X n) { struct xs } : bool :=
    match xs with
    | [| |] => false
    | y ::: xs' => if Dec (x = y) then true else in_dec x xs'
    end.

  Lemma in_dec_correct (n : nat) (x : X) (xs : Vector.t X n) :
    in_dec x xs = true <-> In x xs.
  Proof.
    split; intros.
    {
      induction xs; cbn in *.
      - congruence.
      - decide (x = h) as [ -> | D].
        + constructor.
        + constructor. now apply IHxs.
    }
    {
      induction H; cbn.
      - have (x = x).
      - decide (x = x0).
        + reflexivity.
        + apply IHIn.
    }
  Qed.

  Global Instance In_dec (n : nat) (x : X) (xs : Vector.t X n) : dec (In x xs).
  Proof. eapply dec_transfer. eapply in_dec_correct. auto. Defined.

End In_Dec.

(* Destruct a vector of known size *)
Ltac destruct_vector :=
  repeat match goal with
         | [ v : Vector.t ?X 0 |- _ ] =>
           let H  := fresh "Hvect" in
           pose proof (@destruct_vector_nil X v) as H;
           subst v
         | [ v : Vector.t ?X (S ?n) |- _ ] =>
           let h  := fresh "h" in
           let v' := fresh "v'" in
           let H  := fresh "Hvect" in
           pose proof (@destruct_vector_cons X n v) as (h&v'&H);
           subst v; rename v' into v
         end.

Section In_nth.
  Variable (A : Type) (n : nat).

  Lemma vect_nth_In (v : Vector.t A n) (i : Fin.t n) (x : A) :
    Vector.nth v i = x -> Vector.In x v.
  Proof.
    induction n; cbn in *.
    - inv i.
    - dependent destruct v. dependent destruct i; cbn in *; subst; econstructor; eauto.
  Qed.

  Lemma vect_nth_In' (v : Vector.t A n) (x : A) :
    Vector.In x v -> exists i : Fin.t n, Vector.nth v i = x.
  Proof.
    induction n; cbn in *.
    - inversion 1.
    - dependent destruct v. destruct_vector_in.
      + exists Fin.F1. auto.
      + specialize (IHn0 _ H) as (i&<-). exists (Fin.FS i). auto.
  Qed.

End In_nth.

Section tabulate_vec.
  Variable X : Type.

  Fixpoint tabulate (n : nat) (f : Fin.t n -> X) {struct n} : Vector.t X n.
  Proof.
    destruct n.
    - apply Vector.nil.
    - apply Vector.cons.
      + apply f, Fin.F1.
      + apply tabulate. intros m. apply f, Fin.FS, m.
  Defined.

  Lemma nth_tabulate n (f : Fin.t n -> X) (m : Fin.t n) :
    Vector.nth (tabulate f) m = f m.
  Proof.
    induction m.
    - cbn. reflexivity.
    - cbn. rewrite IHm. reflexivity.
  Qed.

  Lemma in_tabulate n (f : Fin.t n -> X) (x : X) :
    In x (tabulate (n := n) f) <-> exists i : Fin.t n, x = f i.
  Proof.
    split.
    {
      revert f x. induction n; intros f x H.
      - cbn in *. inv H.
      - cbn in *. apply In_cons in H as [ <- | H ].
        + eauto.
        + specialize (IHn (fun m => f (Fin.FS m)) _ H) as (i&IH). eauto.
    }
    {
      intros (i&Hi). induction i; cbn in *; subst; econstructor; eauto.
    }
  Qed.

  Lemma Vector_tabulate_const {n} (c : X) f :
  (forall n, f n = c) ->
  tabulate f = Vector.const c n.
  Proof.
  induction n; cbn.
  - reflexivity.
  - intros. rewrite H. f_equal. eapply IHn. intros. eapply H.
  Qed.

End tabulate_vec.

Lemma Vector_map_tabulate {X Y n} (f : X -> Y) g :
  Vector.map (n:=n) f (tabulate g) = tabulate (fun x => f (g x)).
Proof.
induction n; cbn.
- reflexivity.
- f_equal. eapply IHn.
Qed.

Lemma const_at n X (c : X) i :
  (Vector.const c n)[@i] = c.
Proof.
  induction i; cbn; eauto.
Qed.

(*
Lemma vec_replace_nth X x n (t : Vector.t X n) (i : Fin.t n) :
  x = Vector.nth (Vector.replace t i x) i.
Proof.
  induction i; dependent destruct t; simpl; auto.
Qed.

Lemma vec_replace_nth_nochange X x n (t : Vector.t X n) (i j : Fin.t n) :
  Fin.to_nat i <> Fin.to_nat j -> Vector.nth t i = Vector.nth (Vector.replace t j x) i.
Proof.
  revert j. induction i; dependent destruct t; dependent destruct j; simpl; try tauto.
  apply IHi. contradict H. cbn. now rewrite !H.
Qed.
 *)

#[global]
Instance Vector_eq_dec n A: eq_dec A -> eq_dec (Vector.t A n).
Proof.
  intros H x y. eapply VectorEq.eq_dec with (A_beq := fun x y => proj1_sig (Sumbool.bool_of_sumbool (H x y))).
  intros ? ?. destruct (Sumbool.bool_of_sumbool).
  cbn.  destruct x1;intuition.
Defined.

#[global]
Instance Fin_eq_dec n : eq_dec (Fin.t n).
Proof.
  intros; hnf.
  destruct (Fin.eqb x y) eqn:E.
  - left. now eapply Fin.eqb_eq.
  - right. intros H. eapply Fin.eqb_eq in H. congruence.
Defined.

Import VectorNotations.
Lemma Vector_map_app {X Y k1 k2} (v1 : Vector.t X k1) (v2 : Vector.t X k2) (f : X -> Y) :
  Vector.map f (v1 ++ v2)%vector = Vector.map f v1 ++ Vector.map f v2.
Proof.
  induction v1; cbn; congruence.
Qed.

Lemma Vector_in_app {X n1 n2} (x : X) (v1 : Vector.t X n1) (v2 : Vector.t X n2):
  Vector.In x (v1 ++ v2) <-> Vector.In x v1 \/ Vector.In x v2.
Proof.
  induction v1; cbn.
  - firstorder. inversion H.
  - split.
    + intros [-> | H] % In_cons.
      * left. econstructor.
      * eapply IHv1 in H as [ | ]; eauto. left. now econstructor.
    + intros [ [ -> | ] % In_cons | ]; econstructor; intuition.
Qed.

Lemma vect_in_map (X Y : Type) (n : nat) (f : X -> Y) (V : Vector.t X n) (x : X) :
  In x V -> In (f x) (map f V).
Proof. induction 1; cbn; constructor; auto. Qed.

Lemma vect_in_map_iff (X Y : Type) (n : nat) (f : X -> Y) (V : Vector.t X n) (y : Y) :
  In y (map f V) <-> (exists x : X, f x = y /\ In x V).
Proof.
  split.
  - intros H. induction V; cbn in *.
    + inv H.
    + apply In_cons in H as [ <- | H].
      * exists h. split; auto. now constructor 1.
      * specialize (IHV H) as (x&Hx1&Hx2). exists x. split; auto. now constructor 2.
  - intros (x&<-&H). now apply vect_in_map.
Qed.

Lemma In_replace (X : Type) (n : nat) (xs : Vector.t X n) (i : Fin.t n) (x y : X) :
  In y (replace xs i x) -> (x = y \/ In y xs).
Proof.
  revert i x y. induction xs; intros; cbn in *.
  - inv i.
  - dependent destruct i; cbn in *; apply In_cons in H as [-> | H]; auto; try now (right; constructor).
    specialize (IHxs _ _ _ H) as [-> | IH]; [ now left | right; now constructor ].
Qed.

Lemma In_replace' (X : Type) (n : nat) (xs : Vector.t X n) (i : Fin.t n) (x y : X) :
  In y (replace xs i x) -> x = y \/ exists j, i <> j /\ xs[@j] = y.
Proof.
  revert i x y. induction xs; intros; cbn -[nth] in *.
  - inv i.
  - dependent destruct i; cbn -[nth] in *.
    + apply In_cons in H as [->|H].
      * tauto.
      * apply vect_nth_In' in H as (j&H). right. exists (Fin.FS j). split. discriminate. cbn. assumption.
    + apply In_cons in H as [->|H].
      * right. exists Fin.F1. split. discriminate. cbn. reflexivity.
      * specialize (IHxs _ _ _ H) as [-> | (j&IH1&IH2)]; [ tauto | ].
        right. exists (Fin.FS j). split. now intros -> % Fin.FS_inj. cbn. assumption.
Qed.

(* Tactic for simplifying a hypothesis of the form [In x v] *)

Ltac simpl_vector_inv :=
  repeat match goal with
         | [ H : [| |] = (_ ::: _) |- _ ] => solve [discriminate H]
         | [ H : (_ ::: _) = [| |]  |- _ ] => solve [discriminate H]
         | [ H : Fin.F1 = Fin.FS _ |- _] => solve [discriminate H]
         | [ H : Fin.FS _ = Fin.F1 |- _] => solve [discriminate H]
         | [ H : Fin.FS ?i = Fin.FS ?j |- _] =>
           simple apply Fin.FS_inj in H;
           first [is_var i;move H at bottom;subst i | is_var j;move H at bottom;subst j | idtac]
         end.

Ltac simpl_vector_in :=
  repeat
    match goal with
    | _ => first
            [ progress destruct_vector_in
            | progress simpl_vector_inv
            | progress auto
            | congruence
            ]
    | [ H : Vector.In _ (Vector.map _ _) |- _] =>
      let x := fresh "x" in
      eapply vect_in_map_iff in H as (x&<-&H)
    | [ H : Vector.In _ (Vector.map _ _) |- _] =>
      let x := fresh "x" in
      let H' := fresh H in
      eapply vect_in_map_iff in H as (x&H&H')
    | [ H : Vector.In _ (tabulate _) |- _ ] =>
      let i := fresh "i" in
      apply in_tabulate in H as (i&->)
    | [ H : Vector.In _ (tabulate _) |- _ ] =>
      let i := fresh "i" in
      let H := fresh "H" in
      apply in_tabulate in H as (i&H)
    end.

Ltac vector_not_in :=
  let H := fresh "H" in
  intros H; simpl_vector_in.

Goal Vector.In (Fin.F1 (n := 10)) [|Fin1; Fin2; Fin3 |] -> False.
Proof. intros H. simpl_vector_in. Qed.

Goal Vector.In (Fin.F1 (n := 10)) (map (Fin.FS) [|Fin0; Fin1; Fin2|]) -> False.
Proof. intros H. simpl_vector_in. Qed.

Inductive Vector_In2 {A : Type} (a : A) : forall {n}, t A n -> Type :=
| vec_inB {n} (v : t A n) : Vector_In2 a (cons A a n v)
| vec_inS a' {n} (v : t A n) : Vector_In2 a v -> Vector_In2 a (cons A a' n v).
#[global] Hint Constructors Vector_In2 : core.

(* Conversion between vectors and lists *)
Module VecToListCoercion.
  Coercion Vector.to_list : Vector.t >-> list.
End VecToListCoercion.

Import VecToListCoercion.

Lemma tolist_In (X : Type) (n : nat) (xs : Vector.t X n) (x : X) :
  Vector.In x xs <-> List.In x xs.
Proof.
  split; intros H.
  - induction H; cbn; auto.
  - induction xs; cbn in *; auto. destruct H as [-> | H]; econstructor; eauto.
Qed.

Arguments Vector.eqb {_}  _ {_ _}.

Lemma vector_eqb_spec X n eqb:
  (forall (x1 x2 : X) , reflect (x1 = x2) (eqb x1 x2))
  -> forall x y , reflect (x=y) (Vector.eqb (n:=n) eqb x y).
Proof with try (constructor;congruence).
  intros Hf x y.
  apply iff_reflect. symmetry. apply Vector.eqb_eq. symmetry. apply reflect_iff. eauto.
Qed.

Lemma vector_to_list_inj (X : Type) (n : nat) (xs ys : Vector.t X n) :
  Vector.to_list xs = Vector.to_list ys -> xs = ys.
Proof.
  revert ys. induction xs as [ | x n xs IH]; intros; cbn in *.
  - destruct_vector. reflexivity.
  - destruct_vector. cbn in *. inv H. f_equal. auto.
Qed.

Lemma vector_to_list_length (X : Type) (n : nat) (xs : Vector.t X n) :
  length(Vector.to_list xs) = n.
Proof.
  induction xs as [ | x n xs IH].
  - now cbn.
  - change (S (length xs) = S n). congruence.
Qed.

Lemma vector_rev_append_tail_to_list A (n m: nat) (v : Vector.t A n) (w : Vector.t A m):
Vector.to_list (Vector.rev_append_tail v w) = (List.rev (Vector.to_list v) ++ Vector.to_list w)%list.
Proof.
  unfold Vector.to_list. revert v m w. induction n;intros v;dependent destruct v;cbn. reflexivity.
  intros. specialize IHn with (w:=h:::w). cbn in *. rewrite IHn. autorewrite with list. easy.
Qed.

Lemma vector_rev_to_list A (n : nat) (v : Vector.t A n):
  Vector.to_list (Vector.rev v) = List.rev (Vector.to_list v).
Proof.
  unfold Vector.rev,Vector.rev_append.
  specialize (vector_rev_append_tail_to_list v [| |]) as H'. cbn in H'.
  autorewrite with list in H'. rewrite <- H'. generalize (Vector.rev_append_tail v [| |]).
  generalize (Plus.plus_tail_plus n 0). generalize (Plus.tail_plus n 0). generalize (plus_n_O n).
  intros -> ? <-. rewrite <- plus_n_O. reflexivity.
Qed.

Lemma vector_map_to_list A B (f : A -> B)(n : nat) (v : Vector.t A n):
  Vector.to_list (Vector.map f v) = List.map f (Vector.to_list v).
Proof.
  unfold Vector.map, Vector.to_list. revert v;induction n;intros v;dependent destruct v;cbn. easy. now rewrite IHn.
Qed.

Lemma eq_nth_iff' X n (v w : Vector.t X n):
  (forall i : Fin.t n, v[@i] = w[@i]) -> v = w.
Proof. intros. eapply Vector.eq_nth_iff. now intros ? ? ->. Qed.

Lemma vector_fold_right_to_list (A B : Type) (f : A -> B -> B) (n : nat) (v : Vector.t A n) (a : B):
      Vector.fold_right f v a = List.fold_right f a (Vector.to_list v).
Proof.
  unfold Vector.to_list. induction n. all:destruct_vector. all:cbn;congruence.
Qed.
Lemma vector_fold_left_to_list (A B : Type) (f : A -> B -> A) (n : nat) (v : VectorDef.t B n) (a : A):
  VectorDef.fold_left f a v = List.fold_left f (Vector.to_list v) a.
Proof.
  unfold Vector.to_list. induction n in v,a|-*. all:destruct_vector. all:cbn;congruence.
Qed.

Lemma vector_fold_left_right (A B : Type) (f : A -> B -> A) (n : nat) (v : VectorDef.t B n) (a : A):
  Vector.fold_left f a v = Vector.fold_right (fun x y => f y x) (Vector.rev v) a.
Proof.
  rewrite vector_fold_right_to_list, vector_fold_left_to_list.
  setoid_rewrite <- List.rev_involutive at 2. rewrite List.fold_left_rev_right. f_equal.
  rewrite vector_rev_to_list,List.rev_involutive. easy.
Qed.

Local Arguments Fin.of_nat_lt _ {_} _.

Lemma vector_nth_rev_append_tail_r' X n n' (v : Vector.t X n) (v' : Vector.t X n') i (i':=proj1_sig (Fin.to_nat i))
  j (H: i' = n + j) H':
  (Vector.rev_append_tail v v') [@ i] = v'[@ Fin.of_nat_lt j H'].
Proof.
  revert dependent n'. revert j.
  induction v; cbn; intros.
  {f_equal. subst j. erewrite Fin.of_nat_ext, Fin.of_nat_to_nat_inv. easy. }
  cbn. intros.
  erewrite IHv with (v':=h::v') (j:=S j). 2:nia. cbn.
  f_equal. eapply Fin.of_nat_ext.
  Unshelve. nia.
Qed.

Lemma vector_nth_rev_append_tail_r X n n' (v : Vector.t X n) (v' : Vector.t X n') i (i':=proj1_sig (Fin.to_nat i))
  (H : n <= i') H':
  (Vector.rev_append_tail v v') [@ i] = v'[@ Fin.of_nat_lt (i' - n) H'].
Proof.
  revert dependent n'.
  induction v;cbn;intros.
  {f_equal. revert H'. rewrite Nat.sub_0_r. intro. erewrite Fin.of_nat_ext, Fin.of_nat_to_nat_inv. easy. }
  unshelve erewrite IHv with (v':=h::v'). 3:nia. 1:abstract (clear - H'; nia).
  generalize (vector_nth_rev_append_tail_r_subproof n n' i H').
  destruct (proj1_sig (Fin.to_nat i) - n) eqn:H''. nia.
  cbn. intros. f_equal. revert H'. replace (proj1_sig (Fin.to_nat i) - S n) with n0 by nia.
  intros. apply Fin.of_nat_ext.
Qed.

Lemma vector_nth_rev_append_tail_l X n n' (v : Vector.t X n) (v' : Vector.t X n') i (i':=proj1_sig (Fin.to_nat i))
  (H: i' < n) H':
  (Vector.rev_append_tail v v') [@ i] = v[@ Fin.of_nat_lt (n-1-i') H'].
Proof.
  revert dependent n'.
  induction v;cbn;intros. nia.
  revert H'. destruct (n - 0 - proj1_sig (Fin.to_nat i)) eqn:H';cbn.
  - unshelve erewrite vector_nth_rev_append_tail_r. 3:nia. 1:abstract nia.
    generalize (vector_nth_rev_append_tail_l_subproof n n' i H H').
    destruct (proj1_sig (Fin.to_nat i) - n) eqn:H''. 2:nia.
    reflexivity.
  - unshelve erewrite IHv. 3:nia. 1:abstract nia. intros. f_equal.
    generalize (vector_nth_rev_append_tail_l_subproof0 n n' i H n0 H').
    replace (n - 1 - proj1_sig (Fin.to_nat i)) with n0. 2:nia.
    intros. eapply Fin.of_nat_ext.
Qed.

Lemma vector_nth_rev X n (v : Vector.t X n) i H':
  (Vector.rev v) [@ i] = v[@ Fin.of_nat_lt (n -1-proj1_sig (Fin.to_nat i)) H'].
Proof.
  unfold Vector.rev, Vector.rev_append.
  specialize (vector_nth_rev_append_tail_l v []). cbn zeta.
  generalize (Vector.rev_append_tail v []). generalize (Plus.plus_tail_plus n 0).
  generalize (Plus.tail_plus n 0). generalize (plus_n_O n). generalize (n+0).
  intros ? -> ? <- ? H. apply H. now destruct Fin.to_nat.
Qed.

Lemma Vector_nth_L {X k1 k2} (v1 : Vector.t X k1) (v2 : Vector.t X k2) i :
  (v1 ++ v2)[@ Fin.L k2 i] = v1[@i].
Proof.
  revert k2 v2 i.
  induction v1; intros.
  - pattern i. apply Fin.case0.
  - apply (Fin.caseS' i).
    + reflexivity.
    + cbn. eapply IHv1.
Qed.

Lemma Vector_nth_R {X k1 k2} (v1 : Vector.t X k1) (v2 : Vector.t X k2) i :
  (v1 ++ v2)[@ Fin.R k1 i] = v2[@i].
Proof.
  revert k2 v2 i.
  induction v1; intros.
  - reflexivity.
  - cbn. eapply IHv1.
Qed.


Require Import Verdi.Verdi.
Require Import Verdi.NameOverlay.

Require Import StructTact.Fin.

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrfun.
Require Import mathcomp.ssreflect.fintype.

Require Import mathcomp.fingroup.fingroup.

Require Import mathcomp.algebra.zmodp.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.
Require Import ExtrOcamlString.

Require Import Verdi.ExtrOcamlBasicExt.
Require Import Verdi.ExtrOcamlNatIntExt.

Require Import Verdi.ExtrOcamlBool.
Require Import Verdi.ExtrOcamlList.
Require Import Verdi.ExtrOcamlFinInt.

Require Import ExtractTreeAggregationStaticDeps.

Module NumNames : NatValue. Definition n := 3. End NumNames.
Module Names := FinName NumNames.
Module NamesOT := FinNameOrderedType NumNames Names.
Module NamesOTCompat := FinNameOrderedTypeCompat NumNames Names.
Module RootNames := FinRootNameType NumNames Names.
Module AdjacentNames := FinCompleteAdjacentNameType NumNames Names.

Require Import MSetList.
Module NamesSet <: MSetInterface.S := MSetList.Make NamesOT.

Require Import FMapList.
Module NamesMap <: FMapInterface.S := FMapList.Make NamesOTCompat.

Module AdjacencyNames := FinAdjacency NumNames Names NamesOT NamesSet AdjacentNames.

Module TAuxNames := NameTypeTAux Names NamesOT NamesSet NamesOTCompat NamesMap.

Module ADefNames := NameTypeADefs Names NamesOT NamesSet NamesOTCompat NamesMap AggregationGroup.

Module TreeAggregationNames :=
  TreeAggregation Names NamesOT NamesSet NamesOTCompat NamesMap RootNames AggregationGroup AdjacentNames AdjacencyNames TAuxNames ADefNames.
Import TreeAggregationNames.

Extraction "extraction/aggregation/ocaml/TreeAggregation.ml" List.seq TreeAggregation_BaseParams TreeAggregation_MultiParams.


From SMTCoq Require Import SMTCoq.
From SMTCoq Require Import PArray Int63.
Require Import GCHQ.

Definition finterp h1 h9 h2 h3 h4 h5 h6 h7 h8 :=
  hinterp h2 h3 h4 h5 h6 h7 h8 h9 h1.

Definition tr (z : Z) : bool.
exact true.
Qed.

Definition tt (i : int) := tr (to_Z i).

Definition pb := pb1.

Time Definition tt1 :=
   Eval vm_compute in  finterp (gen_all pb) tt.

Time Definition tt2 :=
  Eval lazy delta[tt1 mk_andb mk_orb
     seq.head seq.foldl seq.behead] iota beta in
  tt1 true false
  Bool.eqb mk_andb mk_implb mk_orb Datatypes.negb.

Ltac end_tac v :=
  let w := eval compute in v in
idtac w;
(timeout 30 (
    try (
     assert (Datatypes.implb tt2 ((tr w))); [
                          unfold tt2; verit | idtac];
                                  idtac "ho"; fail 1);
      idtac "false"; exact false)) ||
idtac "true"; exact true.

Ltac col i j n :=
  let u := constr:(Zeq_bool j n) in
  let v := eval compute in u in
     match v with true => exact nil
                 |false => apply cons;
                           [end_tac (i * n + j)%Z|
                            col i (j + 1)%Z n]
     end.

Ltac row i n :=
  let u := constr:(Zeq_bool i n) in
  let v := eval compute in u in
     match v with true => exact nil
                 |false => apply cons;
                           [col i 0%Z n|
                            row (i + 1)%Z n]
     end.

Definition s0 : list bool.
col 0 0 (Z.of_nat (p_size pb)).
Defined.