(** * PrettyBounds for Machines in TM/Code *)

From Undecidability Require Export TM.PrettyBounds.PrettyBounds.
From Undecidability Require Export TM.Code.ProgrammingTools.
From Undecidability Require Export TM.Code.ListTM TM.Code.CaseList TM.Code.CaseNat TM.Code.CaseSum.

(** We want to give proofs without building constants/the need to manually unfold "_ <=( _ ) _" *)
(** So every intermediate goal shall have the shape "x <=(?c) y", and we use lemmas to simplify this depending on the shape of x *)
(* Sadly, this approach works only for non-recursive functions*)

Section CaseList_nice.

  Implicit Types (sigX X : Type).

  Lemma CaseList_steps_nice :
    { c | forall sigX X (cX:codable sigX X) (xs:list X),
    CaseList_steps xs  <=(c) match xs with
                             | nil => 1
                             | x :: _ => size x + 1
                             end }.
  Proof. eexists. intros. unfold CaseList_steps, CaseList_steps_nil,CaseList_steps_cons. domWith_approx. Qed.

  Lemma CaseList_steps_nil_nice :
    { c | CaseList_steps_nil <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

  Lemma CaseList_steps_cons_nice :
    { c | forall  sigX X (cX:codable sigX X) (x : X), CaseList_steps_cons x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold CaseList_steps_cons. domWith_approx. Qed.

  Lemma Constr_nil_steps_nice :
    { c | Constr_nil_steps <=(c) 1 }.
  Proof. eexists. domWith_approx. Qed.

  Lemma Constr_cons_steps_nice :
    { c | forall  sigX X (cX:codable sigX X) (x : X), Constr_cons_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold Constr_cons_steps. domWith_approx. Qed.

End CaseList_nice.

Section CaseNat_steps_nice.

  Lemma CaseNat_steps_nice :
    { c | CaseNat_steps <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

  Lemma Constr_O_steps_nice :
    { c | Constr_O_steps <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

  Lemma Constr_S_steps_nice :
    { c | Constr_S_steps <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

End CaseNat_steps_nice.

(** Sadly, we need more ugly approach for recursive functions: *)

Section encodeList_size_eq.
  Variable X : Type.
  Variable sigX : Type.
  Context {cX : codable sigX X}.

  Lemma encodeList_size_app (l1 l2 : list X) :
    size (l1 ++ l2) <= size l1 + size l2.
  Proof.
    rewrite !Encode_list_hasSize in *.
    cbn. induction l1;cbn. eauto. cbn. cbn. autorewrite with list. lia.
  Qed.

  Lemma encodeList_size_app_eq (l1 l2 : list X) :
    size (l1 ++ l2) = size l1 + size l2 - 1.
  Proof.
    rewrite !Encode_list_hasSize in *.
    cbn. induction l1;cbn. lia. autorewrite with list. rewrite IHl1.
    assert ((Encode_list_size cX l2) > 0) by (induction l2;cbn;lia). lia.
  Qed.

  Lemma encodeList_size_cons  x (l : list X) :
    size (x::l) = 1 + size x + size l.
  Proof.
    rewrite !Encode_list_hasSize in *.
    cbn. unfold size. autorewrite with list. lia.
  Qed.

  Lemma encodeList_size_nil:
    size (@nil X) = 1.
  Proof.
    rewrite !Encode_list_hasSize in *.
    reflexivity.
  Qed.

End encodeList_size_eq.

Create HintDb size_eqs.
Hint Rewrite encodeList_size_app encodeList_size_cons encodeList_size_nil encodeList_size_app: size_eqs.

Ltac rewrite_sizes := rewrite_strat (innermost (hints size_eqs)).

(** ** Copy steps functions *)

(* Copy steps functions are very nice! *)
Section Copy_very_nice.
  Implicit Types (sigX X : Type).

  Lemma CopyValue_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x:X), CopyValue_steps x <=(c) size x + 1 }.
  Proof.
    eexists. intros ? ? ? x. unfold CopyValue_steps. domWith_approx.
    (*
    - apply dominatedWith_const; auto.
    - apply dominatedWith_refl. instantiate (1 := 1). lia.
*)
  Qed.

  Lemma Reset_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x:X), Reset_steps x <=(c) size x + 1 }.
  Proof.
    eexists. intros ? ? ? x. unfold Reset_steps. domWith_approx.
    (*
    - apply dominatedWith_const; auto.
    - apply dominatedWith_refl. instantiate (1 := 1). lia.
*)
  Qed.

  Lemma Translate_steps_nice :
    { c | forall  sigX X (cX : codable sigX X) (x:X), Translate_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold Translate_steps. domWith_approx. Qed.

  Lemma MoveValue_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (sigY Y : Type) (cY : codable sigY Y) (x : X) (y : Y),
        MoveValue_steps x y <=(c) size x + size y + 1 }.
  Proof.
    eexists. intros. unfold MoveValue_steps. domWith_approx.
  Qed.

  (* "Better" version *)
  Lemma MoveValue_steps_nice' :
    { c | forall sigX X (cX : codable sigX X) (sizeGt1 : forall (x : X), 1 <= size x)  (sigY Y : Type) (cY : codable sigY Y) (x : X) (y : Y) (sizeGt1' : forall (y : Y), 1 <= size y), MoveValue_steps x y <=(c) size x + size y }.
  Proof.
    eexists. intros ?  ? ? ? ? ? ? x y ?. unfold MoveValue_steps.
    rewrite <- Nat.add_assoc. eapply dominatedWith_add_l.
    - apply dominatedWith_add.
      + apply dominatedWith_mult_l. apply dominatedWith_solve.
        enough (1 <= size y) by lia. apply sizeGt1'.
      + apply dominatedWith_mult_l. apply dominatedWith_solve.
        enough (1 <= size x) by lia. apply sizeGt1.
    - enough (1 <= size x) by lia. apply sizeGt1.
  Qed.

End Copy_very_nice.

(** With this set-up, we can tackle recursive functions. *)

Arguments size {sig X cX} : simpl never.

Section Nth'_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  (*
  Lemma Nth'_Step_steps_nice :
    { c | forall (xs : list X) (n : nat), Nth'_Step_steps xs n <=(c) size _ xs }.
  Proof.
    evar (c:nat). exists c.
    intros. unfold Nth'_Step_steps.
    apply dominatedWith_match_nat.
    - intros ->. apply dominatedWith_match_list.
      + intros ->. cbn. unfold dominatedWith. unfold CaseList_steps_nil. do 11 instantiate (1 := S _). instantiate (1 := 0). lia.
      + intros x xs' ->. unfold CaseNat_steps, CaseList_steps_cons. hnf. rewrite Encode_list_hasSize. cbn [Encode_list_size].
        ring_simplify. instantiate (1 := 48). lia.
    - intros x ->. apply dominatedWith_match_list.
      + intros ->. ring_simplify. rewrite Encode_list_hasSize; cbn [Encode_list_size].
        apply dominatedWith_const. lia.
      + intros x' xs' ->. rewrite Encode_list_hasSize; cbn [Encode_list_size].
        unfold CaseList_steps_cons, Reset_steps, CaseNat_steps. ring_simplify. instantiate (1 := 100). hnf. ring_simplify. nia.
  Qed.
*)

  Lemma Nth'_Step_steps_nice_nil :
    { c | forall (n : nat), Nth'_Step_steps (X:=X) nil n <=(c) 1 }.
  Proof.
    evar (c:nat). exists c.
    intros. unfold Nth'_Step_steps. apply dominatedWith_match_nat.
    - intros ->. unfold CaseNat_steps, CaseList_steps_cons. ring_simplify. hnf. apply dominatedWith_const. lia.
    - intros n' ->. unfold CaseNat_steps, CaseList_steps_cons. ring_simplify. hnf. apply dominatedWith_const. lia.
  Qed.

  Lemma Nth'_Step_steps_nice_cons :
    { c | forall (x : X) (xs : list X) (n : nat), Nth'_Step_steps (x :: xs) n <=(c) size x+1 }.
  Proof.
    evar (c:nat). exists c.
    intros. unfold Nth'_Step_steps. apply dominatedWith_match_nat.
    - intros ->. unfold CaseNat_steps, CaseList_steps_cons. ring_simplify. hnf. instantiate (1 := 57). nia.
    - intros n' ->. unfold CaseNat_steps, CaseList_steps_cons, Reset_steps. ring_simplify. hnf. instantiate (1 := 57). ring_simplify. nia.
  Qed.

  Lemma max_plus_l a b c :
    max a (c + max b a) <= c + max b a.
  Proof.
    assert (a <= b \/ b <= a) as [H | H] by lia.
    - replace (max b a) with b.
      rewrite max_r by lia. lia.
      now rewrite max_l by lia.
    - replace (max b a) with a.
      rewrite max_r by lia. lia.
      now rewrite max_r by lia.
  Qed.

  Lemma Nth'_Loop_steps_nice :
    { c | forall (xs : list X) (n : nat), Nth'_Loop_steps xs n <=(c) size xs }.
  Proof.
    pose_nice Nth'_Step_steps_nice_nil  HStep_nil  c_nil.
    pose_nice Nth'_Step_steps_nice_cons HStep_cons c_cons.
    pose (c := 1 + max c_nil c_cons).
    exists c.
    intros xs. induction xs as [ | x xs' IH]; intros.
    - eapply dominatedWith_mono_c. cbn [Nth'_Loop_steps].
      destruct n; apply HStep_nil. constructor; apply Max.le_max_l || auto with arith. (* Why is [rewrite Max.le_max_l] not working? *)
    - cbn [Nth'_Loop_steps]. eapply dominatedWith_mono_c; [..|shelve]. eapply dominatedWith_match_nat.
      + intros ->. hnf.
        specialize (HStep_cons x xs' 0).
        instantiate (1 := c_cons). rewrite Encode_list_hasSize; cbn [Encode_list_size]. ring_simplify. lia.
      + intros n' ->. hnf.
        specialize (HStep_cons x xs' (S n')).
        instantiate (1 := c). rewrite Encode_list_hasSize; cbn [Encode_list_size].
        rewrite HStep_cons. specialize (IH n'). hnf in IH. rewrite IH. ring_simplify. rewrite Encode_list_hasSize; cbn [Encode_list_size].
        ring_simplify. subst c. nia.
    Unshelve.
    apply max_plus_l.
  Qed.

  (* Three different proofs! I consider only the third compositional, because we don't unfold any constants. *)
  Lemma Nth'_steps_nice :
    { c | forall (xs : list X) (n : nat), Nth'_steps xs n <=(c) size xs + n + 1 }.
  Proof.
  (*   pose_nice Nth'_Loop_steps_nice H c. *)
  (*   eexists. intros xs n. specialize (H xs n). *)
  (*   hnf. unfold Nth'_steps. ring_simplify. *)
  (*   (* At this point, ultimate domination would be better, because we would not have to look in the values of [CopyValue_steps] and [Reset_steps], because we already know that they are Θ(size _ xs). Below, [28] has been chosen in dependence of these constants. *) *)
  (*   unfold CopyValue_steps, Reset_steps. *)
  (*   instantiate (1 := 12 + c + 4 + 4 + _). *)
  (*   rewrite !Encode_list_hasSize. rewrite Encode_list_hasSize_skipn. *)
  (*   rewrite Encode_nat_hasSize. rewrite H, Encode_list_hasSize. *)
  (*   ring_simplify. *)
  (*   assert (n - (1 + |xs|) <= n) as H' by lia; rewrite H'; clear H'. *)
  (*   (* Encode_list_size cX xs * c + 16 * Encode_list_size cX xs + 4 * n + 48 <= *)
  (*      Encode_list_size cX xs * c + Encode_list_size cX xs * ?m + 20 * Encode_list_size cX xs + c * n + c + ?m * n + ?m + 20 * n + 20 *) *)
  (*   instantiate (1 := 28). *)
  (*   nia. *)
  (* Restart. *)
  (*   (* Another proof with more automation *) *)
  (*   pose_nice Nth'_Loop_steps_nice H c. *)
  (*   eexists. intros xs n. specialize (H xs n). *)
  (*   hnf. unfold Nth'_steps. *)
  (*   repeat eapply dominatedWith_add. *)
  (*   (* Compositional part is more or less automatic *) *)
  (*   all: ring_simplify. *)
  (*   (* The second tactic can solve more and is faster *) *)
  (*   all: domWith_approx. *)
  (*   all: try solve [ eauto | apply dominatedWith_const; lia | apply dominatedWith_solve; lia *)
  (*                  | eapply dominatedWith_trans; eauto; apply dominatedWith_solve; lia ]. *)
  (*   (* Specific part for [Nth'] *) *)
  (*   1-4: apply dominatedWith_solve; rewrite !Encode_list_hasSize; etransitivity; [ apply (Encode_list_hasSize_skipn _ xs (1+n)) | lia ]. *)
  (*   1-4: assert (1 <= size xs) by (rewrite Encode_list_hasSize; apply Encode_list_hasSize_ge1); *)
  (*     apply dominatedWith_solve; rewrite Encode_nat_hasSize; lia. *)
  (* Restart. *)
    (* Another proof with more automation *)
    pose_nice Nth'_Loop_steps_nice H c.
    eexists. intros xs n. specialize (H xs n).
    hnf. unfold Nth'_steps.
    (* Automated Compositionality! *)
    domWith_approx.
    - eapply dominatedWith_trans.
      apply (proj2_sig CopyValue_steps_nice).
      domWith_approx.
    - eapply dominatedWith_trans.
      eauto. domWith_approx.
    - eapply dominatedWith_trans.
      apply (proj2_sig Reset_steps_nice).
      apply dominatedWith_S''.
      2:lia.
      2:{ apply dominatedWith_solve. rewrite !Encode_list_hasSize.
           hnf. rewrite Encode_list_hasSize_skipn. lia. }
      pose proof (Encode_list_hasSize_ge1 _ xs). rewrite Encode_list_hasSize. lia.
    - eapply dominatedWith_trans.
      apply (proj2_sig Reset_steps_nice).
      (* This is the [Nth']-specific complication *)
      apply dominatedWith_S''.
      2: lia.
      2: { apply dominatedWith_solve. rewrite !Encode_list_hasSize. rewrite Encode_nat_hasSize.
           pose proof (Encode_list_hasSize_ge1 _ xs). lia. }
      pose proof (Encode_list_hasSize_ge1 _ xs). rewrite Encode_list_hasSize. lia.
  Qed.

End Nth'_nice.

(* Print Assumptions Nth'_steps_nice. *)

Section Length_steps_nice.

  Variable (sigX X : Type) (cX : codable sigX X).

  (* Print Length_Step_steps. *)

  Lemma Length_Step_steps_nice_nil :
    {c | Length_Step_steps (X:=X)nil <=(c) 1 }.
  Proof. eexists. cbn. intros. apply dominatedWith_const. lia. Qed.

  Lemma Length_Step_steps_nice_cons :
    {c | forall (xs : list X) (x : X), Length_Step_steps (x :: xs) <=(c) size x + 1 }.
  Proof.
    pose_nice CaseList_steps_nice Hc_CaseList c_CaseList.
    pose_nice Reset_steps_nice Hc_Reset c_Reset.
    eexists. intros. cbn.
    ring_simplify. domWith_approx.
    - apply (Hc_CaseList _ _ _ [x]).
    - apply Hc_Reset.
  Qed.

  Lemma Length_Loop_steps_nice :
    { c | forall (xs : list X), Length_Loop_steps xs <=(c) size xs }.
  Proof.
    pose_nice Length_Step_steps_nice_nil Hc_nil c_nil.
    pose_nice Length_Step_steps_nice_cons Hc_cons c_cons.
    pose (c := 1 + max c_nil c_cons). exists c.
    setoid_rewrite Encode_list_hasSize; cbn [Encode_list_size].
    induction xs as [ | x xs' IH].
    - eapply dominatedWith_mono_c. apply Hc_nil. subst c. lia.
    - specialize Hc_cons with (xs := xs').
      (* eapply dominatedWith_mono_c; [..|shelve]. *)
      hnf. cbn [Length_Loop_steps]. rewrite (Hc_cons x). ring_simplify.
      (* instantiate (1 := c). *) subst c. ring_simplify.
      hnf in IH. cbn. rewrite IH. ring_simplify.
      enough (c_cons * size x + c_cons <=
              size x * Init.Nat.max c_nil c_cons + size x +
              Init.Nat.max c_nil c_cons) by lia.
      enough (c_cons * size x <=
              size x * Init.Nat.max c_nil c_cons + size x) by lia.
      enough (c_cons * size x <= size x * max c_nil c_cons) by lia.
      Fail enough (c_cons <= max c_nil c_cons) by lia.
      rewrite Nat.mul_comm.
      apply Nat.mul_le_mono_l.
      auto with arith.
      (* TODO: This needs to be more automated! *)
  Qed.

  Lemma Length_steps_nice :
    { c | forall (xs : list X), Length_steps xs <=(c) size xs }.
  Proof.
    pose_nice Length_Loop_steps_nice Hc_loop c_loop.
    eexists. intros.
    unfold Length_steps. (* ring_simplify. *)
    (* This OUGHT to be easy! https://xkcd.com/1349/ *)
    (* 36 + 12 * size (Encode_list cX) xs + Length_Loop_steps xs <=(?c)
       size (Encode_list cX) xs *)
    rewrite <- Nat.add_assoc. eapply dominatedWith_add_l.
    2:{ rewrite Encode_list_hasSize. apply Encode_list_hasSize_ge1. }
    domWith_approx.
    - hnf. apply Hc_loop.
  Qed.

End Length_steps_nice.

Section App_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  Lemma App'_steps_nice :
    { c | forall (xs : list X), App'_steps xs <=(c) size xs }.
  Proof.
    eexists. intros xs. unfold App'_steps.
    eapply dominatedWith_add_l.
    - domWith_approx.
    - rewrite Encode_list_hasSize. apply Encode_list_hasSize_ge1.
  Qed.

  (* [App] is not used *)
End App_nice.

Lemma Encode_pair_hasSize_ge1 (sigX sigY X Y : Type) (cX : codable sigX X) (cY : codable sigY Y) (p : X * Y) :
  1 <= size (fst p) \/ 1 <= size (snd p) ->
  1 <= Encode_pair_size _ _ p.
Proof. destruct p as (x,y). cbn in *. intros [H|H]; cbn; rewrite H; lia. Qed.

Lemma Encode_nat_hasSize_ge1 (n : nat) :
  1 <= size n.
Proof. rewrite Encode_nat_hasSize. lia. Qed.

Lemma Encode_option_hasSize_ge1 (sigX X : Type) (cX : codable sigX X) (o : option X) :
  1 <= Encode_option_size _ o.
Proof. destruct o; cbn; lia. Qed.

(** *** CasePair *)

From Undecidability Require Import CasePair.

Section CasePair_steps_nice.
  Implicit Types (sigX X : Type).

  Lemma CasePair_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x : X), CasePair_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold CasePair_steps. domWith_approx. Qed.

  Lemma Constr_pair_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x : X), Constr_pair_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold Constr_pair_steps. domWith_approx. Qed.

End CasePair_steps_nice.

(** *** CaseSum and CaseOption *)

From Undecidability Require Import CaseSum.

Section CaseSum_steps_nice.

  Lemma CaseSum_steps_nice :
    { c | CaseSum_steps <=(c) 1 }.
  Proof. eexists. unfold CaseSum_steps. domWith_approx. Qed.

  Lemma Constr_inl_steps_nice :
    { c | Constr_inl_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_inl_steps. domWith_approx. Qed.

  Lemma Constr_inr_steps_nice :
    { c | Constr_inr_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_inr_steps. domWith_approx. Qed.

  Lemma CaseOption_steps_nice :
    { c | CaseOption_steps <=(c) 1 }.
  Proof. eexists. unfold CaseOption_steps. domWith_approx. Qed.

  Lemma Constr_Some_steps_nice :
    { c | Constr_Some_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_Some_steps. domWith_approx. Qed.

  Lemma Constr_None_steps_nice :
    { c | Constr_None_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_None_steps. domWith_approx. Qed.

End CaseSum_steps_nice.

Lemma Encode_list_hasSize_el (sigX X : Type) (cX : codable sigX X) (xs : list X) (x : X) :
  In x xs ->
  size x < Encode_list_size _ xs.
Proof.
  induction xs as [ | x' xs' IH].
  - intros [].
  - intros [<- | H].
    + cbn. lia.
    + specialize IH with (1 := H). cbn. lia.
Qed.

(** *** CompareValue(s) *)
From Undecidability Require Import Code.CompareValue.

Section CompareValues_nice.

  Lemma CompareValues_steps_nice :
    { c | forall (sigX X : Type) (cX : codable sigX X) (x1 x2 : X), CompareValues_steps x1 x2 <=(c) size x1 + size x2 + 1 }.
  Proof. eexists. intros. unfold CompareValues_steps. domWith_approx. Qed.

End CompareValues_nice.


(** Interpretation of a hypersequent as a term in NNF *)
Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.hseq.
Require Import RL.hr.semantic.

Require Import List.
Require Import Lra.

Require Import RL.OLlibs.Permutation_Type_more.

Local Open Scope R_scope.

(** ** Interpretation of a sequent *)
Fixpoint sem_seq (T1 : sequent) :=
  match T1 with
  | nil => RS_zero
  | ((r , A) :: T1) => (r *S A) +S (sem_seq T1)
  end.

(** *** Properties of this interpretation *)
Lemma sem_seq_plus : forall T1 T2, sem_seq (T1 ++ T2) === sem_seq T1 +S sem_seq T2.
Proof.
  induction T1; intros T2.
  - etransitivity ; [ | apply commu_plus]; symmetry; apply neutral_plus.
  - specialize (IHT1 T2).
    destruct a as (r , A).
    simpl.
    etransitivity ; [ | apply asso_plus].
    apply (@ctxt (RS_plusC (RS_TC (r *S A)) RS_hole)).
    apply IHT1.
Qed.

Lemma sem_seq_mul : forall T r, sem_seq (seq_mul r T) === r *S sem_seq T.
Proof.
  induction T; intros r.
  - symmetry; apply mul_0.
  - destruct a as [a Ha]; simpl.
    etransitivity ; [ apply (@ctxt (RS_plusC (RS_TC (time_pos r a *S Ha)) RS_hole)); apply IHT | ]; simpl.
    etransitivity ; [ apply (@ctxt (RS_plusC RS_hole (RS_TC (r *S sem_seq T)))) | ].
    { symmetry ; apply mul_assoc. }
    simpl; auto with MGA_solver.
Qed.

Lemma sem_seq_vec : forall r A (Hnnil : r <> nil), sem_seq (vec r A) === (existT _ (sum_vec r) (sum_vec_non_nil _ Hnnil)) *S A.
Proof.
  induction r; intros A Hnnil.
  { exfalso; auto. }
  destruct r as [ | b r].
  - simpl in *.
    replace (existT (fun r : R => (0 <? r) = true) (projT1 a + 0) (sum_vec_non_nil _ Hnnil)) with a by (apply Rpos_eq; simpl; nra).
    auto.
  - assert (b :: r <> nil) as H by now auto.
    specialize (IHr A H).
    change (sem_seq (vec (a :: b :: r) A)) with (a *S A +S (sem_seq (vec (b :: r) A))).
    replace (existT (fun r0 : R => (0 <? r0) = true) (sum_vec (a :: b :: r)) (sum_vec_non_nil _ Hnnil)) with (plus_pos a (existT _ (sum_vec (b :: r)) (sum_vec_non_nil _ H))) by (destruct a; destruct  b; apply Rpos_eq; simpl; nra).
    etransitivity ; [ | symmetry; apply mul_distri_coeff].
    auto with MGA_solver.
Qed.

Lemma sem_seq_permutation : forall T1 T2, Permutation_Type T1 T2 -> sem_seq T1 === sem_seq T2.
Proof.
  intros T1 T2 Hperm; induction Hperm; try destruct x; try destruct y; simpl; try auto with MGA_solver.
  - etransitivity ; [ apply asso_plus | ].
    etransitivity; [ apply plus_left; apply commu_plus | ].
    auto.
  - transitivity (sem_seq l'); assumption.
Qed.

Lemma mul_vec_eq : forall A l r, sem_seq (vec (mul_vec r l) A) === r *S sem_seq (vec l A).
Proof.
  intros A.
  induction l; intros r.
  - simpl; symmetry; apply mul_0.
  - simpl.
    etransitivity; [ apply plus_right; apply IHl | ].
    etransitivity; [ apply plus_left; symmetry; apply mul_assoc | ].
    auto with MGA_solver.
Qed.

(** ** Interpretation of a hypersequent *)
Fixpoint sem_hseq G :=
  match G with
  | nil => RS_zero (* should not happen *)
  | T1 :: nil => sem_seq T1
  | T1 :: G => (sem_seq T1) \/S (sem_hseq G)
  end.

(** *** Properties of this interpretation *)
Lemma sem_hseq_permutation : forall G1 G2, Permutation_Type G1 G2 -> sem_hseq G1 === sem_hseq G2.
Proof.
  intros G1 G2 Hperm; induction Hperm.
  - reflexivity.
  - destruct l; destruct l'.
    + reflexivity.
    + exfalso; apply (Permutation_Type_nil_cons Hperm).
    + apply Permutation_Type_sym in Hperm.
      exfalso; apply (Permutation_Type_nil_cons Hperm).
    + unfold sem_hseq; fold (sem_hseq (s :: l)); fold (sem_hseq (s0 :: l')).
      auto with MGA_solver.
  - destruct l.
    + simpl; apply commu_max.
    + unfold sem_hseq; fold (sem_hseq (s :: l)).
      etransitivity; [ apply asso_max | ].
      etransitivity; [ | symmetry; apply asso_max ].
      apply max_left; apply commu_max.
  - transitivity (sem_hseq l'); assumption.
Qed.


Require Import ZArith.

Definition outside_interval (a b : Z) := (Z.sgn a + Z.sgn b)%Z.

Definition inside_interval_1 (o1 o2 : Z) :=
  (0 < o1)%Z /\ (0 < o2)%Z \/ (o1 < 0)%Z /\ (o2 < 0)%Z.

Definition inside_interval_2 (o1 o2 : Z) :=
  (0 < o1)%Z /\ (o2 < 0)%Z \/ (o1 < 0)%Z /\ (0 < o2)%Z.

Lemma inside_interval_1_dec_inf :
 forall o1 o2 : Z, {inside_interval_1 o1 o2} + {~ inside_interval_1 o1 o2}.
Proof.
 intros.
 abstract (case (Z_lt_dec 0 o1); intro Ho1;
            [ case (Z_lt_dec 0 o2); intro Ho2;
               [ left; left; split
               | right; intro H;
                  match goal with
                  | id1:(~ ?X1) |- ?X2 =>
                      apply id1; case H; intros (H1, H2);
                       [ idtac
                       | apply False_ind; apply Z.lt_irrefl with o1;
                          apply Z.lt_trans with 0%Z ]
                  end ]
            | case (Z_lt_dec o1 0); intro Ho1';
               [ case (Z_lt_dec o2 0); intro Ho2;
                  [ left; right; split
                  | right; intro H; case H; intros (H1, H2);
                     [ apply Ho1 | apply Ho2 ] ]
               | right; intro H; apply Ho1; case H; intros (H1, H2);
                  [ idtac | apply False_ind; apply Ho1' ] ] ];
            try assumption).
Defined.

Lemma inside_interval_2_dec_inf :
 forall o1 o2 : Z, {inside_interval_2 o1 o2} + {~ inside_interval_2 o1 o2}.
Proof.
 intros.
 abstract (case (Z_lt_dec 0 o1); intro Ho1;
            [ case (Z_lt_dec o2 0); intro Ho2;
               [ left; left; split
               | right; intro H;
                  match goal with
                  | id1:(~ ?X1) |- ?X2 =>
                      apply id1; case H; intros (H1, H2);
                       [ idtac
                       | apply False_ind; apply Z.lt_irrefl with o1;
                          apply Z.lt_trans with 0%Z ]
                  end ]
            | case (Z_lt_dec o1 0); intro Ho1';
               [ case (Z_lt_dec 0 o2); intro Ho2;
                  [ left; right; split
                  | right; intro H; case H; intros (H1, H2);
                     [ apply Ho1 | apply Ho2 ] ]
               | right; intro H; apply Ho1; case H; intros (H1, H2);
                  [ idtac | apply False_ind; apply Ho1' ] ] ];
            try assumption).
Defined.

Inductive Qpositive : Set :=
  | nR : Qpositive -> Qpositive
  | dL : Qpositive -> Qpositive
  | One : Qpositive.

Inductive Qhomographic_sg_denom_nonzero : Z -> Z -> Qpositive -> Prop :=
  | Qhomographic_signok0 :
      forall (c d : Z) (p : Qpositive),
      p = One -> (c + d)%Z <> 0%Z -> Qhomographic_sg_denom_nonzero c d p
  | Qhomographic_signok1 :
      forall (c d : Z) (xs : Qpositive),
      Qhomographic_sg_denom_nonzero c (c + d)%Z xs ->
      Qhomographic_sg_denom_nonzero c d (nR xs)
  | Qhomographic_signok2 :
      forall (c d : Z) (xs : Qpositive),
      Qhomographic_sg_denom_nonzero (c + d)%Z d xs ->
      Qhomographic_sg_denom_nonzero c d (dL xs).

Lemma Qhomographic_signok_1 :
 forall c d : Z, Qhomographic_sg_denom_nonzero c d One -> (c + d)%Z <> 0%Z.
Proof.
 intros.
 inversion H.
 assumption.
Defined.

Lemma Qhomographic_signok_2 :
 forall (c d : Z) (xs : Qpositive),
 Qhomographic_sg_denom_nonzero c d (nR xs) ->
 Qhomographic_sg_denom_nonzero c (c + d) xs.
Proof.
 intros.
 inversion H.
 discriminate H0.
 assumption.
Defined.

Lemma Qhomographic_signok_3 :
 forall (c d : Z) (xs : Qpositive),
 Qhomographic_sg_denom_nonzero c d (dL xs) ->
 Qhomographic_sg_denom_nonzero (c + d) d xs.
Proof.
 intros.
 inversion H.
 discriminate H0.
 assumption.
Defined.

Fixpoint Qhomographic_sign (a b c d : Z) (p : Qpositive) {struct p} :
  forall (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
  Z * (Z * (Z * (Z * Z)) * Qpositive).
set (o1 := outside_interval a b) in *.
set (o2 := outside_interval c d) in *.
destruct p as [q| q| ]; intros H_Qhomographic_sg_denom_nonzero.
 (* p=(nR xs) *)
  case (Z_zerop b).
   (* b=0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    exact ((Z.sgn a * Z.sgn c)%Z, (a, (b, (c, d)), nR q)).
    (* d<>0 *)
    intro Hd'.
    case (Z_lt_dec 0 o2).
     (*  `0 < o2` *)
     intro Ho2.
     exact (Z.sgn a, (a, (b, (c, d)), nR q)).
     (* ~( 0<o2 ) *)
     intro Ho2'.
     case (Z_lt_dec o2 0).
      (* o2 < 0  *)
      intro Ho2.
      exact ((- Z.sgn a)%Z, (a, (b, (c, d)), nR q)).
      (* ~`0 < o2` /\ ~ `0 < o2` /\ d<>0  *)
      intro Ho2''.
      exact
       (Qhomographic_sign a (a + b)%Z c (c + d)%Z q
          (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)).
   (* b<>0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    case (Z_lt_dec 0 o1).
     (*  `0 < o1` *)
     intro Ho1.
     exact (Z.sgn c, (a, (b, (c, d)), nR q)).
     (* ~( 0<o1 ) *)
     intro Ho1'.
     case (Z_lt_dec o1 0).
      (* o1 < 0  *)
      intro Ho1.
      exact ((- Z.sgn c)%Z, (a, (b, (c, d)), nR q)).
      (* ~`0 < o1` /\ ~ `0 < o1` /\ b<>0  *)
      intro Ho1''.
      exact
       (Qhomographic_sign a (a + b)%Z c (c + d)%Z q
          (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)).
    (* d<>0 *)
    intro Hd'.
    case (inside_interval_1_dec_inf o1 o2).
     (* (inside_interval_1 o1 o2) *)
     intro H_inside_1.
     exact (1%Z, (a, (b, (c, d)), nR q)).
     (* ~(inside_interval_1 o1 o2) *)
     intro H_inside_1'.
     case (inside_interval_2_dec_inf o1 o2).
      (* (inside_interval_2 o1 o2) *)
      intro H_inside_2.
      exact ((-1)%Z, (a, (b, (c, d)), nR q)).
      (*  ~(inside_interval_1 o1 o2)/\~(inside_interval_2 o1 o2) *)
      intros H_inside_2'.
      exact
       (Qhomographic_sign a (a + b)%Z c (c + d)%Z q
          (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)).
  (* p=(dL xs) *)
  case (Z_zerop b).
   (* b=0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    exact ((Z.sgn a * Z.sgn c)%Z, (a, (b, (c, d)), dL q)).
    (* d<>0 *)
    intro Hd'.
    case (Z_lt_dec 0 o2).
     (*  `0 < o2` *)
     intro Ho2.
     exact (Z.sgn a, (a, (b, (c, d)), dL q)).
     (* ~( 0<o2 ) *)
     intro Ho2'.
     case (Z_lt_dec o2 0).
      (* o2 < 0  *)
      intro Ho2.
      exact ((- Z.sgn a)%Z, (a, (b, (c, d)), dL q)).
      (* ~`0 < o2` /\ ~ `0 < o2` /\ d<>0  *)
      intro Ho2''.
      exact
       (Qhomographic_sign (a + b)%Z b (c + d)%Z d q
          (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)).
   (* b<>0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    case (Z_lt_dec 0 o1).
     (*  `0 < o1` *)
     intro Ho1.
     exact (Z.sgn c, (a, (b, (c, d)), dL q)).
     (* ~( 0<o1 ) *)
     intro Ho1'.
     case (Z_lt_dec o1 0).
      (* o1 < 0  *)
      intro Ho1.
      exact ((- Z.sgn c)%Z, (a, (b, (c, d)), dL q)).
      (* ~`0 < o1` /\ ~ `0 < o1` /\ b<>0  *)
      intro Ho1''.
      exact
       (Qhomographic_sign (a + b)%Z b (c + d)%Z d q
          (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)).
    (* d<>0 *)
    intro Hd'.
    case (inside_interval_1_dec_inf o1 o2).
     (* (inside_interval_1 o1 o2) *)
     intro H_inside_1.
     exact (1%Z, (a, (b, (c, d)), dL q)).
     (* ~(inside_interval_1 o1 o2) *)
     intro H_inside_1'.
     case (inside_interval_2_dec_inf o1 o2).
      (* (inside_interval_2 o1 o2) *)
      intro H_inside_2.
      exact ((-1)%Z, (a, (b, (c, d)), dL q)).
      (*  ~(inside_interval_1 o1 o2)/\~(inside_interval_2 o1 o2) *)
      intros H_inside_2'.
      exact
       (Qhomographic_sign (a + b)%Z b (c + d)%Z d q
          (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)).

 (* p = One *)
  set (soorat := Z.sgn (a + b)) in *.
  set (makhraj := Z.sgn (c + d)) in *.

  case (Z.eq_dec soorat 0).
   (*  `soorat = 0` *)
   intro eq_numerator0.
   exact (0%Z, (a, (b, (c, d)), One)).
   (*  `soorat <> 0` *)
   intro.
   case (Z.eq_dec soorat makhraj).
    (* soorat = makhraj *)
    intro.
    exact (1%Z, (a, (b, (c, d)), One)).
    (* soorat <> makhraj *)
    intro.
    exact ((-1)%Z, (a, (b, (c, d)), One)).
Defined.

Scheme Qhomographic_sg_denom_nonzero_inv_dep :=
  Induction for Qhomographic_sg_denom_nonzero Sort Prop.

Lemma Qhomographic_sign_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H1 H2 : Qhomographic_sg_denom_nonzero c d p),
 Qhomographic_sign a b c d p H1 = Qhomographic_sign a b c d p H2.
Proof.
 intros.
 generalize H2 H1 a b.
 intro.
 abstract let T_local := (intros; simpl in |- *; rewrite H; reflexivity) in
          (elim H0 using Qhomographic_sg_denom_nonzero_inv_dep; intros;
            [ destruct p0 as [q| q| ];
               [ discriminate e
               | discriminate e
               | simpl in |- *; case (Z.eq_dec (Z.sgn (a0 + b0)) 0);
                  case (Z.eq_dec (Z.sgn (a0 + b0)) (Z.sgn (c0 + d0)));
                  intros; reflexivity ]
            | T_local
            | T_local ]).
Defined.


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

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils godel_coding pos vec subcode sss compiler_correction.

From Undecidability.MinskyMachines.MMA
  Require Import mma_defs mma_utils.

Set Implicit Arguments.
Set Default Goal Selector "!".

#[local] Notation "e #> x" := (vec_pos e x).
#[local] Notation "e [ v / x ]" := (vec_change e x v).

Section mma_k_mma_2_compiler.

  Variable (k : nat) (gc : godel_coding k) (n : nat).

  (* s and r are the first two registers in pos (2+n) *)

  Notation s := (pos0 : pos (2+n)).  (* spare register *)
  Notation r := (pos1 : pos (2+n)).  (* register storing ⦉a,b,c⦊ *)

  Let simul (v : vec nat (k+n)) (w : vec nat (2+n)) : Prop :=
        let (v1,v2) := vec_split _ _ v in
        let (w1,w2) := vec_split _ _ w in
        w1 = 0##(gc_enc gc v1)##vec_nil /\ w2 = v2.

  Infix "⋈" := simul (at level 70, no associativity).

  Notation "⟨ x ⟩" := (gc_pr gc x) (at level 1, format "⟨ x ⟩").

  Local Fact pr_not_zero x : 0 < ⟨x⟩.
  Proof. apply gc_pr_nz. Qed.

  Hint Resolve pr_not_zero : core.

  Section the_instruction_compiler.

    (* The length of compiled code does not depend on the linker *)

    Local Definition ilen : mm_instr (pos (k+n)) -> nat.
    Proof using gc.
      intros [ x | x j ]; apply pos_both in x as [ x | x ].
      + exact (8+⟨x⟩).
      + exact 1.
      + exact (16+7*⟨x⟩).
      + exact 1.
    Defined.

    (* The instruction compiler is parameterized by a linker *)

    Variable lnk : nat -> nat.

    Local Definition icomp : nat -> mm_instr (pos (k+n)) -> list (mm_instr (pos (2+n))).
    Proof using gc lnk.
      intros i [ x | x j ].
      + apply pos_both in x as [ x | x ].
        * exact (mma_mult_cst_with_zero r s ⟨x⟩ (lnk i)).
        * exact (INCₐ (pos_nxt (pos_nxt x)) :: nil).
      + apply pos_both in x as [ x | x ].
        * exact (mma_div_branch r s ⟨x⟩ (lnk i) (lnk j)).
        * exact (DECₐ (pos_nxt (pos_nxt x)) (lnk j) :: nil).
    Defined.

    Local Fact icomp_length_eq i ρ : length (icomp i ρ) = ilen ρ.
    Proof.
      unfold icomp, ilen.
      destruct ρ as [ x | x j ]; destruct (pos_both _ _ x); auto.
      + now rewrite mma_mult_cst_with_zero_length.
      + now rewrite mma_div_branch_length.
    Qed.

    Local Fact icomp_eq_1 i (x : pos k) :
           icomp i (INCₐ (pos_left _ x)) = mma_mult_cst_with_zero r s ⟨x⟩ (lnk i).
    Proof. unfold icomp; now rewrite pos_both_left. Qed.

    Local Fact icomp_eq_2 i (x : pos n) :
           icomp i (INCₐ (pos_right _ x)) = INCₐ (pos_nxt (pos_nxt x)) :: nil.
    Proof. unfold icomp; now rewrite pos_both_right. Qed.

    Local Fact icomp_eq_3 i (x : pos k) j :
           icomp i (DECₐ (pos_left _ x) j) = mma_div_branch r s ⟨x⟩ (lnk i) (lnk j).
    Proof. unfold icomp; now rewrite pos_both_left. Qed.

    Local Fact icomp_eq_4 i (x : pos n) j :
           icomp i (DECₐ (pos_right _ x) j) = DECₐ (pos_nxt (pos_nxt x)) (lnk j) :: nil.
    Proof. unfold icomp; now rewrite pos_both_right. Qed.

  End the_instruction_compiler.

  Hint Resolve subcode_refl : core.

  (* The critical lemma is the soundness of the instruction compiler:
       every source instruction is simulated by its compiled image
       (at list of target instructions) in at least one step of
       computation *)

  Local Lemma icomp_sound :
         instruction_compiler_sound icomp (@mma_sss (k+n)) (@mma_sss (2+n)) simul.
  Proof.
    intros lnk [ x | x j ] i1 v1 i2 v2 w1 H.
    + apply mma_sss_INC_inv in H as (-> & ->).
      revert w1 i1 v1.
      pattern x; revert x; apply pos_left_right_rect; intros x w1 i v.
      * rewrite icomp_eq_1, mma_mult_cst_with_zero_length.
        intros H1 (H2 & H3).
        exists (w1[(⟨x⟩*(w1#>r))/r]); msplit 2; rew vec.
        - apply mma_mult_cst_with_zero_progress; try easy.
          2: f_equal; auto.
          apply f_equal with (f := fun v => v#>pos0) in H2; revert H2; rew vec.
        - apply vec_pos_ext; intros p; repeat invert pos p; rew vec.
          ++ apply f_equal with (f := fun v => v#>pos0) in H2; revert H2; rew vec.
          ++ apply f_equal with (f := fun v => v#>pos1) in H2; revert H2; rew vec; simpl; intros ->.
             rewrite gc_succ; f_equal.
             apply vec_pos_ext; intros p; rewrite !vec_pos_set.
             destruct (pos_eq_dec p x) as [ -> | D ]; rew vec; rewrite !vec_pos_set.
             rewrite vec_change_neq; auto.
             now contradict D; apply pos_left_inj in D.
        - apply vec_pos_ext; intros p; rew vec.
          rewrite vec_change_neq.
          2: apply pos_left_right_neq.
          generalize (f_equal (fun v => v#>p) H3); rew vec.
      * rewrite icomp_eq_2; simpl.
        intros H1 (H2 & H3).
        exists (w1[(S (w1#>(pos_right 2 x)))/pos_right 2 x]); msplit 2.
        - mma sss INC with (pos_right 2 x); simpl pos_right.
          mma sss stop.
          now f_equal; rewrite H1.
        - apply vec_pos_ext; intros p; repeat invert pos p; rew vec.
          ++ generalize (f_equal (fun v => v#>pos0) H2); rew vec.
          ++ generalize (f_equal (fun v => v#>pos1) H2); rew vec; simpl.
             intros ->; f_equal.
             apply vec_pos_ext; intros p; rew vec.
             rewrite vec_change_neq; auto.
             intros E; symmetry in E; revert E.
             apply pos_left_right_neq.
        - apply vec_pos_ext; intros p; rew vec; rewrite vec_pos_set.
          destruct (pos_eq_dec x p) as [ -> | D ]; rew vec.
          ++ f_equal; generalize (f_equal (fun v => v#>p) H3); rew vec.
          ++ rewrite !vec_change_neq.
             2,3: now contradict D; apply pos_right_inj in D.
             generalize (f_equal (fun v => v#>p) H3); rew vec.
    + case_eq (v1#>x).
      * intros Hv1.
        apply mma_sss_DEC0_inv in H as (-> & ->); auto.
        revert v1 w1 Hv1.
        pattern x; revert x; apply pos_left_right_rect; intros x v1 w1 Hv1.
        - rewrite icomp_eq_3, mma_div_branch_length.
          intros H1 H2.
          exists w1; split; auto.
          destruct H2 as (H2 & H3).
          apply mma_div_branch_1_progress; try easy.
          ++ generalize (f_equal (fun v => v#>pos0) H2); rew vec.
          ++ generalize (f_equal (fun v => v#>pos1) H2); rew vec; simpl.
             intros ->; apply gc_not_div; rew vec.
          ++ f_equal; auto.
        - rewrite icomp_eq_4; simpl.
          intros H1 H2.
          exists w1; split; auto.
          rewrite H1.
          destruct H2 as (H2 & H3).
          mma sss DEC zero with (pos_right 2 x) (lnk j).
          ++ now generalize (f_equal (fun v => v#>x) H3); rew vec; intros ->.
          ++ mma sss stop.
      * intros a Ha.
        apply mma_sss_DEC1_inv with (u := a) in H; auto.
        destruct H as (-> & ->).
        revert v1 w1 a Ha.
        pattern x; revert x; apply pos_left_right_rect; intros x v1 w1 a Ha.
        - rewrite icomp_eq_3, mma_div_branch_length.
          intros H1 (H2 & H3).
          set (v' := let (v,_) := vec_split _ _ v1 in v); simpl in v'.
          exists (w1[(gc_enc gc (v'[a/x]))/pos1]); msplit 2; rew vec.
          ++ apply mma_div_branch_0_progress with (gc_enc gc (v'[a/x])); try easy.
             ** generalize (f_equal (fun v => v#>pos0) H2); rew vec.
             ** generalize (f_equal (fun v => v#>pos1) H2); rew vec; simpl; intros ->.
                rewrite Nat.mul_comm, gc_succ; f_equal; rew vec.
                unfold v'; rewrite <- Ha.
                apply vec_pos_ext; intros p; rewrite !vec_pos_set.
                destruct (pos_eq_dec p x) as [ -> | D ]; rew vec.
          ++ apply vec_pos_ext; intros p; repeat invert pos p; simpl; rew vec.
             ** generalize (f_equal (fun v => v#>pos0) H2); rew vec.
             ** f_equal; unfold v'.
                apply vec_pos_ext; intros p; rew vec; rewrite !vec_pos_set.
                destruct (pos_eq_dec p x) as [ -> | D ]; rew vec; rewrite vec_pos_set.
                rewrite vec_change_neq; auto.
                now contradict D; apply pos_left_inj in D.
          ++ apply vec_pos_ext; intros p; rew vec.
             generalize (f_equal (fun v => v#> p) H3); rew vec; rewrite ! vec_pos_set.
             simpl; intros ->; rewrite vec_change_neq; auto.
             apply pos_left_right_neq.
        - rewrite icomp_eq_4; simpl.
          intros H1 (H2 & H3).
          exists (w1[a/pos_right 2 x]); msplit 2; simpl pos_right; rew vec.
          ++ mma sss DEC S with (pos_right 2 x) (lnk j) a.
             ** now generalize (f_equal (fun v => v#>x) H3); rew vec; intros ->.
             ** mma sss stop.
          ++ apply vec_pos_ext; intros p; repeat invert pos p; rew vec.
             ** generalize (f_equal (fun v => v#>pos0) H2); rew vec.
             ** generalize (f_equal (fun v => v#>pos1) H2); rew vec; simpl; intros ->.
                f_equal; apply vec_pos_ext; intros p; rew vec.
                rewrite vec_change_neq; auto.
                intros E; symmetry in E; revert E; apply pos_left_right_neq.
          ++ apply vec_pos_ext; intros p; rewrite !vec_pos_set.
             destruct (pos_eq_dec x p) as [ -> | D ]; rew vec.
             rewrite !vec_change_neq; auto.
             2,3: contradict D.
             2: now apply pos_right_inj in D.
             2: now repeat apply pos_nxt_inj in D.
             generalize (f_equal (fun v => v#>p) H3);rew vec.
  Qed.

  (* From the soundness of the (individual) instruction compiler, using our
     generic compiler we immediately obtain a linker/compiler for programs
     of source instructions into programs of target instructions *)

  Theorem mma_k_mma_2_compiler : compiler_t (@mma_sss (k+n)) (@mma_sss (2+n)) simul.
  Proof.
    apply generic_compiler with icomp ilen.
    + intros; now rewrite icomp_length_eq.  (* ilen computes length icomp *)
    + apply mma_sss_total_ni.               (* source semantics is total *)
    + apply mma_sss_fun.                    (* target semantics is functional *)
    + apply icomp_sound.                    (* compiled individual instructions is sound *)
  Qed.

End mma_k_mma_2_compiler.

Arguments mma_k_mma_2_compiler {_}.


Require Import SecOrder.
Require Import Modal.
Require Import my_arith__my_leb_nat.
Require Import is_pos_neg.
Require Import occ_in_phi.
Require Import Arith.EqNat.
Require Import occ_in_phi.
Require Import my_bool.

(* is_pos lemmas *)

Lemma is_pos_occ : forall (phi : Modal) (i : nat),
  is_pos phi i = true -> occ_in_phi phi i = true.
Proof.
  intros phi i Hpos.
  unfold is_pos in *.
  case_eq (occ_in_phi phi i);
  intros Hocc; induction phi;
  rewrite Hocc in *; try discriminate; try reflexivity.
Qed.

Lemma is_pos_notin : forall (phi : Modal) (i : nat),
  is_pos phi i = true -> Nat.leb i (length (pv_in phi)) = true.
Proof.
  intros phi i H.
  induction phi.
    unfold is_pos in H.
    case_eq (Nat.leb i (length (pv_in (atom p))));
    try reflexivity; intros H_eq; try discriminate.
      unfold occ_in_phi in *; rewrite H_eq in *.
      case_eq (beq_nat i 0); intros H_beq;
        rewrite H_beq in *; try discriminate.

    simpl in *.
    case_eq (Nat.leb i (length (pv_in phi)));
    try reflexivity; intros H_eq; rewrite H_eq in *;
    try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.

    simpl in *.
    rewrite List.app_length.
    case_eq (Nat.leb i (length (pv_in phi1)));
    intros H_eq; rewrite H_eq in *.
      pose proof (leb_plus_r i (length (pv_in phi1))
                 (length (pv_in phi2)) H_eq) as H_leb.
      exact H_leb.

      rewrite List.app_length in H.
      case_eq (Nat.leb i (length (pv_in phi1) + length (pv_in phi2)));
      intros H_leb; try reflexivity; rewrite H_leb in *;
      try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.

    simpl in *.
    rewrite List.app_length.
    case_eq (Nat.leb i (length (pv_in phi1)));
    intros H_eq; rewrite H_eq in *.
      pose proof (leb_plus_r i (length (pv_in phi1))
                 (length (pv_in phi2)) H_eq) as H_leb.
      exact H_leb.

      rewrite List.app_length in H.
      case_eq (Nat.leb i (length (pv_in phi1) + length (pv_in phi2)));
      intros H_leb; try reflexivity; rewrite H_leb in *;
      try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.

    simpl in *.
    rewrite List.app_length.
    case_eq (Nat.leb i (length (pv_in phi1)));
    intros H_eq; rewrite H_eq in *.
      pose proof (leb_plus_r i (length (pv_in phi1))
                 (length (pv_in phi2)) H_eq) as H_leb.
      exact H_leb.

      rewrite List.app_length in H.
      case_eq (Nat.leb i (length (pv_in phi1) + length (pv_in phi2)));
      intros H_leb; try reflexivity; rewrite H_leb in *;
      try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.

    simpl in *.
    case_eq (Nat.leb i (length (pv_in phi)));
    intros H_eq; rewrite H_eq in *; try reflexivity;
    try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.

    simpl in *.
    case_eq (Nat.leb i (length (pv_in phi)));
    intros H_eq; rewrite H_eq in *; try reflexivity;
    try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.
Qed.

Lemma is_pos_atom : forall (q : propvar) (i : nat),
  is_pos (atom q) i = true -> (EqNat.beq_nat 1 i = true).
Proof.
  intros q i H.
  simpl in *.
  case_eq i.
    intros H_eq; try rewrite H_eq in *.
    assert (Nat.leb 0 1 = true) as H_leb.
      unfold Nat.leb; reflexivity.
    rewrite H_leb in *; discriminate.

    intros n H_eq.
    case_eq n.
      reflexivity.

      intros m H_eq2; rewrite H_eq2 in *.
      rewrite H_eq in *.
      assert (Nat.leb (S (S m)) 1 = false) as H_f.
        simpl; reflexivity.
      rewrite H_f in *; discriminate.
Qed.

Lemma is_pos_mneg : forall (psi : Modal) (i : nat),
  is_pos (mneg psi) i = true -> (is_pos psi i) = false.
Proof.
  intros psi i H.
  simpl is_pos in H.
  case_eq (Nat.leb i (length (pv_in psi)));
  intros H_eq; rewrite H_eq in *.
    case_eq (is_pos psi i); intros H_pos;
    rewrite H_pos in *; try discriminate;
    try reflexivity.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.

      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      discriminate.
Qed.

Lemma is_pos_mneg2 : forall (psi : Modal) (i : nat),
  is_pos psi i = false ->
    occ_in_phi psi i = true ->
      is_pos (mneg psi) i = true.
Proof.
  intros phi i Hpos Hocc.
  simpl.
  destruct (occ_in_phi_leb2 phi i Hocc) as [l r].
  rewrite l.
  rewrite r.
  rewrite Hpos.
  reflexivity.
Qed.

Lemma is_pos_mconj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_pos phi1 i = true)).
Proof.
  intros phi1 phi2 i Hpos Hocc.
  assert (beq_nat i 0 = false) as Hbeq.
    apply occ_in_phi_0 with (phi := phi1) ; exact Hocc.
  assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
    apply occ_in_phi_leb; exact Hocc.
  simpl in Hpos.
  rewrite Hbeq in *.
  rewrite List.app_length in Hpos.
  rewrite leb_plus_r in Hpos.
  rewrite Hleb in Hpos.
    exact Hpos.

    exact Hleb.
Qed.

Lemma is_pos_mconj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i = true ->
    (Nat.leb (length (pv_in phi1) + 1) i = true) ->
      is_pos phi2 (i - (length (pv_in phi1))) = true.
Proof.
  intros phi1 phi2 i Hpos12 Hleb.
  rewrite is_pos_defn_mconj in *.
  case_eq (occ_in_phi (mconj phi1 phi2) i); intros Hocc;
  rewrite Hocc in *.
    case_eq (Nat.leb i (length (pv_in phi1))); intros Hleb2;
    rewrite Hleb2 in *.
      apply leb_notswitch in Hleb2.
      rewrite Hleb in *.
      discriminate.

      exact Hpos12.

      discriminate.
Qed.

Lemma is_pos_mdisj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_pos phi1 i = true)).
Proof.
  intros phi1 phi2 i Hpos Hocc.
  assert (beq_nat i 0 = false) as Hbeq.
    apply occ_in_phi_0 with (phi := phi1) ; exact Hocc.
  assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
    apply occ_in_phi_leb; exact Hocc.
  simpl in Hpos.
  rewrite Hbeq in *.
  rewrite List.app_length in Hpos.
  rewrite leb_plus_r in Hpos.
  rewrite Hleb in Hpos.
    exact Hpos.

    exact Hleb.
Qed.

Lemma is_pos_mdisj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i = true ->
    (Nat.leb (length (pv_in phi1) + 1) i = true) ->
      is_pos phi2 (i - (length (pv_in phi1))) = true.
Proof.
  intros phi1 phi2 i Hpos12 Hleb.
  rewrite is_pos_defn_mdisj in *.
  case_eq (occ_in_phi (mdisj phi1 phi2) i); intros Hocc;
  rewrite Hocc in *.
    case_eq (Nat.leb i (length (pv_in phi1))); intros Hleb2;
    rewrite Hleb2 in *.
      apply leb_notswitch in Hleb2.
      rewrite Hleb in *.
      discriminate.

      exact Hpos12.

      discriminate.
Qed.

Lemma is_pos_mconj : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_pos phi1 i = true)) /\
    ((Nat.leb (length (pv_in phi1) + 1) i = true) ->
       is_pos phi2 (i - (length (pv_in phi1))) = true).
Proof.
  intros phi1 phi2 i Hpos.
  apply conj.
    apply is_pos_mconj_l with (phi2 := phi2); exact Hpos.

    apply is_pos_mconj_r with (phi1 := phi1); exact Hpos.
Qed.

Lemma is_pos_mdisj : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_pos phi1 i = true)) /\
    ((Nat.leb (length (pv_in phi1) + 1) i = true) ->
       is_pos phi2 (i - (length (pv_in phi1))) = true).
Proof.
  intros phi1 phi2 i Hpos.
  apply conj.
    apply is_pos_mdisj_l with (phi2 := phi2); exact Hpos.

    apply is_pos_mdisj_r with (phi1 := phi1); exact Hpos.
Qed.

Lemma is_pos_box : forall (phi : Modal) (i : nat),
  is_pos (box phi) i = true <-> is_pos phi i = true.
Proof.
  split; intros H.
  simpl in H.
  case_eq (Nat.leb i (length (pv_in phi)));
  intros H_eq; rewrite H_eq in *; try exact H;
  try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      try discriminate; try exact H.

      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      try discriminate; try exact H.

  pose proof (is_pos_occ phi i H) as H1.
  simpl.
  rewrite H.
  rewrite occ_in_phi_defn in H1.
  case_eq (beq_nat i 0); intros Hbeq; rewrite Hbeq in *;
  try discriminate.
  case_eq (Nat.leb i (length (pv_in phi))); intros Hleb;
  rewrite Hleb in *; try discriminate; try reflexivity.
Qed.

Lemma is_pos_box2 : forall (phi : Modal) (i : nat),
  is_pos (box phi) i = is_pos phi i.
Proof.
  intros phi i.
  case_eq (is_pos (box phi) i); intros Hpos.
    pose proof (is_pos_occ _ _ Hpos) as Hocc.
    pose proof Hocc as Hocc2.
    apply occ_in_phi_box with (phi := phi) in Hocc2.
    induction phi; simpl in *; rewrite Hocc2 in *;
    symmetry; assumption.

    case_eq (is_pos phi i); intros Hpos2.
      simpl in Hpos.
      rewrite Hpos2 in Hpos.
      apply if_then_else_true_false in Hpos.
      case_eq (beq_nat i 0); intros Hbeq; rewrite Hbeq in *.
        rewrite (beq_nat_true _ _ Hbeq) in Hpos2.
        apply is_pos_occ in Hpos2.
        apply occ_in_phi_0 in Hpos2.
        simpl in *; discriminate.

        case_eq (Nat.leb i (length (pv_in phi))); intros Hleb.
          rewrite Hleb in *.
          discriminate.

          induction phi; simpl in *;
          rewrite Hleb in *; rewrite Hbeq in *;
          discriminate.

        reflexivity.
Qed.

Lemma is_pos_diam : forall (phi : Modal) (i : nat),
  is_pos (diam phi) i = true <-> is_pos phi i = true.
Proof.
  split; intros H.
  simpl in H.
  case_eq (Nat.leb i (length (pv_in phi)));
  intros H_eq; rewrite H_eq in *; try exact H;
  try discriminate.
      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      try discriminate; try exact H.

      case_eq (beq_nat i 0); intros H_beq; rewrite H_beq in *;
      try discriminate; try exact H.

  pose proof (is_pos_occ phi i H) as H1.
  simpl.
  rewrite H.
  rewrite occ_in_phi_defn in H1.
  case_eq (beq_nat i 0); intros Hbeq; rewrite Hbeq in *;
  try discriminate.
  case_eq (Nat.leb i (length (pv_in phi))); intros Hleb;
  rewrite Hleb in *; try discriminate; try reflexivity.
Qed.

Lemma is_pos_diam2 : forall (phi : Modal) (i : nat),
  is_pos (diam phi) i = is_pos phi i.
Proof.
  intros phi i.
  case_eq (is_pos (diam phi) i); intros Hpos.
    pose proof (is_pos_occ _ _ Hpos) as Hocc.
    pose proof Hocc as Hocc2.
    apply occ_in_phi_box with (phi := phi) in Hocc2.
    induction phi; simpl in *; rewrite Hocc2 in *;
    symmetry; assumption.

    case_eq (is_pos phi i); intros Hpos2.
      simpl in Hpos.
      rewrite Hpos2 in Hpos.
      apply if_then_else_true_false in Hpos.
      case_eq (beq_nat i 0); intros Hbeq; rewrite Hbeq in *.
        rewrite (beq_nat_true _ _ Hbeq) in Hpos2.
        apply is_pos_occ in Hpos2.
        apply occ_in_phi_0 in Hpos2.
        simpl in *; discriminate.

        case_eq (Nat.leb i (length (pv_in phi))); intros Hleb.
          rewrite Hleb in *.
          discriminate.

          induction phi; simpl in *;
          rewrite Hleb in *; rewrite Hbeq in *;
          discriminate.

        reflexivity.
Qed.

(* ------------------------------------------------------------ *)

(* is_neg lemmas *)

Lemma is_neg_occ : forall (phi : Modal) (i : nat),
  is_neg phi i = true -> occ_in_phi phi i = true.
Proof.
  intros phi i H.
  case_eq (occ_in_phi phi i); intros Hocc;
  try reflexivity;
  induction phi; unfold is_neg in H; rewrite Hocc in *;
  discriminate.
Qed.

Lemma is_neg_mneg : forall (psi : Modal) (i : nat),
  is_neg (mneg psi) i = true -> (is_neg psi i) = false.
Proof.
  intros phi i Hneg.
  pose proof Hneg as Hocc.
  apply is_neg_occ in Hocc.
  simpl in *.
  rewrite Hocc in Hneg.
  case_eq (is_neg phi i); intros H.
    rewrite H in *; discriminate.

    reflexivity.
Qed.

Lemma is_neg_box : forall (phi : Modal) (i : nat),
  is_neg (box phi) i = true -> is_neg phi i = true.
Proof.
  intros phi i Hneg.
  pose proof (is_neg_occ (box phi) i Hneg) as Hocc.
  simpl in *.
  rewrite Hocc in Hneg.
  assumption.
Qed.

Lemma is_neg_diam : forall (phi : Modal) (i : nat),
  is_neg (diam phi) i = true -> is_neg phi i = true.
Proof.
  intros phi i Hneg.
  pose proof (is_neg_occ (box phi) i Hneg) as Hocc.
  simpl in *.
  rewrite Hocc in Hneg.
  assumption.
Qed.

Lemma is_neg_0 : forall (phi : Modal),
  is_neg phi 0 = false.
Proof.
  induction phi; simpl; reflexivity.
Qed.

Lemma is_neg_box2 : forall (phi : Modal) (i : nat),
  is_neg (box phi) i = is_neg phi i.
Proof.
  intros phi i.
  case_eq (beq_nat i 0); intros Hbeq.
    rewrite (beq_nat_true _ _ Hbeq).
    simpl.
    rewrite is_neg_0.
    reflexivity.

    case_eq (Nat.leb i (length (pv_in phi))); intros Hleb;
      simpl;
      rewrite Hbeq;
      rewrite Hleb.
      reflexivity.

      induction phi; simpl in *; rewrite Hbeq; rewrite Hleb;
      reflexivity.
Qed.

Lemma is_neg_diam2 : forall (phi : Modal) (i : nat),
  is_neg (diam phi) i = is_neg phi i.
Proof.
  intros phi i.
  case_eq (beq_nat i 0); intros Hbeq.
    rewrite (beq_nat_true _ _ Hbeq).
    simpl.
    rewrite is_neg_0.
    reflexivity.

    case_eq (Nat.leb i (length (pv_in phi))); intros Hleb;
      simpl;
      rewrite Hbeq;
      rewrite Hleb.
      reflexivity.

      induction phi; simpl in *; rewrite Hbeq; rewrite Hleb;
      reflexivity.
Qed.

(* --------------------------------------------------------------- *)
Lemma is_pos_neg_f_t_mconj : forall (phi1 phi2 : Modal) (i : nat),
    (forall i : nat,
         occ_in_phi phi1 i = true ->
         (is_pos phi1 i = false -> is_neg phi1 i = true) /\
         (is_pos phi1 i = true -> is_neg phi1 i = false)) ->
    (forall i : nat,
         occ_in_phi phi2 i = true ->
         (is_pos phi2 i = false -> is_neg phi2 i = true) /\
         (is_pos phi2 i = true -> is_neg phi2 i = false)) ->
     occ_in_phi (mconj phi1 phi2) i = true ->
 (is_pos (mconj phi1 phi2) i = false -> is_neg (mconj phi1 phi2) i = true) /\
 (is_pos (mconj phi1 phi2) i = true -> is_neg (mconj phi1 phi2) i = false).
Proof.
  intros phi1 phi2 i IHphi1 IHphi2 Hocc.
  apply conj; intros H.
    case_eq (occ_in_phi phi1 i); intros Hocc1.
      simpl.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc1) as [Ha Hb].
      rewrite Hb.
      destruct (IHphi1 i Hocc1) as [H1 H2].
      simpl in H.
      rewrite Hocc in H.
      rewrite Hb in H.
      apply H1; assumption.

      pose proof (occ_in_phi_mconj _ _ _ Hocc Hocc1) as Hocc2.
      simpl. simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_f _ _ Hocc1) as [Hbeq | Hleb].
        rewrite (beq_nat_true _ _ Hbeq) in Hocc2.
        simpl in *.
        apply occ_in_phi_0 in Hocc2.
        simpl in *; discriminate.

        rewrite Hleb.
        destruct (IHphi2 (i - length (pv_in phi1)) Hocc2) as [Ha Hb].
        apply Ha.
        simpl in H.
        rewrite Hocc in H.
        rewrite Hleb in H.
        assumption.

    case_eq (occ_in_phi phi1 i); intros Hocc1.
      simpl.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc1) as [Ha Hb].
      rewrite Hb.
      destruct (IHphi1 i Hocc1) as [H1 H2].
      simpl in H.
      rewrite Hocc in H.
      rewrite Hb in H.
      apply H2; assumption.

      pose proof (occ_in_phi_mconj _ _ _ Hocc Hocc1) as Hocc2.
      simpl. simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_f _ _ Hocc1) as [Hbeq | Hleb].
        rewrite (beq_nat_true _ _ Hbeq) in Hocc2.
        simpl in *.
        apply occ_in_phi_0 in Hocc2.
        simpl in *; discriminate.

        rewrite Hleb.
        destruct (IHphi2 (i - length (pv_in phi1)) Hocc2) as [Ha Hb].
        apply Hb.
        simpl in H.
        rewrite Hocc in H.
        rewrite Hleb in H.
        assumption.
Qed.

Lemma is_pos_neg_f_t_mimpl : forall (phi1 phi2 : Modal) (i : nat),
    (forall i : nat,
         occ_in_phi phi1 i = true ->
         (is_pos phi1 i = false -> is_neg phi1 i = true) /\
         (is_pos phi1 i = true -> is_neg phi1 i = false)) ->
    (forall i : nat,
         occ_in_phi phi2 i = true ->
         (is_pos phi2 i = false -> is_neg phi2 i = true) /\
         (is_pos phi2 i = true -> is_neg phi2 i = false)) ->
     occ_in_phi (mconj phi1 phi2) i = true ->
 (is_pos (mimpl phi1 phi2) i = false -> is_neg (mimpl phi1 phi2) i = true) /\
 (is_pos (mimpl phi1 phi2) i = true -> is_neg (mimpl phi1 phi2) i = false).
Proof.
  intros phi1 phi2 i IHphi1 IHphi2 Hocc.
  apply conj; intros H.
    case_eq (occ_in_phi phi1 i); intros Hocc1.
      simpl.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc1) as [Ha Hb].
      rewrite Hb.
      destruct (IHphi1 i Hocc1) as [H1 H2].
      simpl in H.
      rewrite Hocc in H.
      rewrite Hb in H.
      case_eq (is_pos phi1 i); intros Hpos;
        rewrite Hpos in *.
        rewrite H2;
        reflexivity.

        discriminate.

      pose proof (occ_in_phi_mconj _ _ _ Hocc Hocc1) as Hocc2.
      simpl. simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_f _ _ Hocc1) as [Hbeq | Hleb].
        rewrite (beq_nat_true _ _ Hbeq) in Hocc2.
        simpl in *.
        apply occ_in_phi_0 in Hocc2.
        simpl in *; discriminate.

        rewrite Hleb.
        destruct (IHphi2 (i - length (pv_in phi1)) Hocc2) as [Ha Hb].
        apply Ha.
        simpl in H.
        rewrite Hocc in H.
        rewrite Hleb in H.
        assumption.

    case_eq (occ_in_phi phi1 i); intros Hocc1.
      simpl.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc1) as [Ha Hb].
      rewrite Hb.
      destruct (IHphi1 i Hocc1) as [H1 H2].
      simpl in H.
      rewrite Hocc in H.
      rewrite Hb in H.
      case_eq (is_pos phi1 i); intros Hpos;
        rewrite Hpos in *.
        discriminate.

        rewrite H1; reflexivity.

      pose proof (occ_in_phi_mconj _ _ _ Hocc Hocc1) as Hocc2.
      simpl. simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_f _ _ Hocc1) as [Hbeq | Hleb].
        rewrite (beq_nat_true _ _ Hbeq) in Hocc2.
        simpl in *.
        apply occ_in_phi_0 in Hocc2.
        simpl in *; discriminate.

        rewrite Hleb.
        destruct (IHphi2 (i - length (pv_in phi1)) Hocc2) as [Ha Hb].
        apply Hb.
        simpl in H.
        rewrite Hocc in H.
        rewrite Hleb in H.
        assumption.
Qed.

Lemma is_pos_neg_f_t_box : forall (phi : Modal) (i : nat),
    (forall i : nat,
        occ_in_phi phi i = true ->
        (is_pos phi i = false -> is_neg phi i = true) /\
        (is_pos phi i = true -> is_neg phi i = false)) ->
     occ_in_phi (box phi) i = true ->
  (is_pos (box phi) i = false -> is_neg (box phi) i = true) /\
  (is_pos (box phi) i = true -> is_neg (box phi) i = false).
Proof.
  intros phi i IHphi Hocc.
  rewrite is_pos_box2.
  rewrite is_neg_box2.
  apply IHphi.
  rewrite occ_in_phi_box in Hocc.
  assumption.
Qed.

Lemma is_pos_neg_f_t : forall (phi : Modal) (i : nat),
  occ_in_phi phi i = true ->
  (is_pos phi i = false -> is_neg phi i = true) /\
  (is_pos phi i = true -> is_neg phi i = false).
Proof.
  induction phi; intros i Hocc.
    apply occ_in_phi_atom in Hocc.
    rewrite Hocc.
    simpl.
    apply conj.
      intros; discriminate.

      reflexivity.

    pose proof Hocc as Hocc2.
    apply occ_in_phi_mneg with (phi := phi) in Hocc2.
    destruct (IHphi i Hocc2) as [Ha Hb].
    apply conj; intros H; simpl;
      simpl in Hocc; rewrite Hocc.
      case_eq (is_pos phi i); intros Hpos.
        specialize (Hb Hpos).
        rewrite Hb.
        reflexivity.

        specialize (Ha Hpos).
        simpl in H.
        rewrite Hocc in H.
        rewrite Hpos in *.
        discriminate.

      case_eq (is_pos phi i); intros Hpos.
        specialize (Hb Hpos).
        simpl in H.
        rewrite Hocc in H.
        rewrite Hpos in *.
        discriminate.

        specialize (Ha Hpos).
        rewrite Ha.
        reflexivity.

    apply is_pos_neg_f_t_mconj; assumption.
    apply is_pos_neg_f_t_mconj; assumption.
    apply is_pos_neg_f_t_mimpl; assumption.
    apply is_pos_neg_f_t_box; assumption.
    apply is_pos_neg_f_t_box; assumption.
Qed.

Lemma is_pos_neg_f : forall (phi : Modal) (i : nat),
  occ_in_phi phi i = true ->
  (is_pos phi i = false -> is_neg phi i = true).
Proof.
  intros phi i Hocc Hpos.
  apply is_pos_neg_f_t; assumption.
Qed.

Lemma is_pos_neg_t : forall (phi : Modal) (i : nat),
  (is_pos phi i = true -> is_neg phi i = false).
Proof.
  intros phi i Hpos.
  pose proof (is_pos_occ _ _ Hpos) as Hocc.
  apply is_pos_neg_f_t; assumption.
Qed.

Lemma is_neg_pos_f : forall (phi : Modal) (i : nat),
  occ_in_phi phi i = true ->
  (is_neg phi i = false -> is_pos phi i = true).
Proof.
  intros phi i Hocc Hpos.
  pose proof (is_pos_neg_f _ _ Hocc) as H.
  apply contrapos_bool_ft in H; assumption.
Qed.

Lemma is_neg_pos_t : forall (phi : Modal) (i : nat),
  (is_neg phi i = true -> is_pos phi i = false).
Proof.
  intros phi i Hpos.
  pose proof (is_neg_occ _ _ Hpos) as Hocc.
  pose proof (is_pos_neg_t phi i) as H.
  apply contrapos_bool_tf in H; assumption.
Qed.

Lemma is_pos_neg_not_and : forall (phi : Modal) (i : nat),
  ~(is_pos phi i = true /\ is_neg phi i = true).
Proof.
  unfold not; intros phi i H.
  destruct H as [Hpos Hneg].
  apply is_pos_neg_t in Hpos.
  rewrite Hpos in Hneg.
  discriminate.
Qed.

(* ------------------------------------------------------- *)

Lemma is_pos_neg_or_mconj : forall (phi1 phi2 : Modal) (i : nat),
  (forall i : nat,
      occ_in_phi phi1 i = true ->
      is_pos phi1 i = true \/ is_neg phi1 i = true) ->
  (forall i : nat,
      occ_in_phi phi2 i = true ->
      is_pos phi2 i = true \/ is_neg phi2 i = true) ->
   occ_in_phi (mconj phi1 phi2) i = true ->
   is_pos (mconj phi1 phi2) i = true \/ is_neg (mconj phi1 phi2) i = true.
Proof.
  intros phi1 phi2 i IHphi1 IHphi2 Hocc.
  case_eq (occ_in_phi phi1 i); intros Hocc2.
    destruct (IHphi1 i Hocc2) as [Hpos1 | Hneg1].
      simpl is_pos at 1.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
      rewrite Hb.
      left; assumption.

      simpl is_neg at 1.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
      rewrite Hb.
      right; assumption.

    pose proof (occ_in_phi_mconj _ _ _ Hocc Hocc2) as Hocc3.
    destruct (occ_in_phi_f _ _ Hocc2) as [Hbeq | Hleb].
      simpl in *; rewrite Hbeq in *; discriminate.
      simpl in Hocc.
      destruct (IHphi2 (i - length (pv_in phi1)) Hocc3) as [Hpos2 | Hneg2].
        simpl is_pos.
        rewrite Hocc.
        rewrite Hleb.
        left; assumption.

        simpl is_neg.
        rewrite Hocc.
        rewrite Hleb.
        right; assumption.
Qed.

Lemma is_pos_neg_or_mneg : forall (phi : Modal) (i : nat),
 (forall i : nat,
    occ_in_phi phi i = true -> is_pos phi i = true \/ is_neg phi i = true) ->
  occ_in_phi (mneg phi) i = true ->
  is_pos (mneg phi) i = true \/ is_neg (mneg phi) i = true.
Proof.
  intros phi i IHphi Hocc.
  pose proof Hocc as Hocc2.
  rewrite occ_in_phi_mneg in Hocc.
  destruct (IHphi i Hocc) as [Hpos | Hneg].
    simpl in *.
    rewrite Hocc2.
    apply is_pos_neg_t in Hpos.
    rewrite Hpos.
    right; reflexivity.

    simpl in *.
    rewrite Hocc2.
    apply is_neg_pos_t in Hneg.
    rewrite Hneg.
    left; reflexivity.
Qed.

Lemma is_pos_neg_or_mimpl : forall (phi1 phi2 : Modal) (i : nat),
   (forall i : nat, occ_in_phi phi1 i = true ->
        is_pos phi1 i = true \/ is_neg phi1 i = true) ->
   (forall i : nat, occ_in_phi phi2 i = true ->
        is_pos phi2 i = true \/ is_neg phi2 i = true) ->
    occ_in_phi (mimpl phi1 phi2) i = true ->
    is_pos (mimpl phi1 phi2) i = true \/ is_neg (mimpl phi1 phi2) i = true.
Proof.
  intros phi1 phi2 i IHphi1 IHphi2 Hocc.
  case_eq (occ_in_phi phi1 i); intros Hocc2.
    destruct (IHphi1 i Hocc2) as [Hpos1 | Hneg1].
      simpl is_neg.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
      rewrite Hb.
      apply is_pos_neg_t in Hpos1.
      rewrite Hpos1.
      right; reflexivity.

      simpl is_pos.
      simpl in Hocc.
      rewrite Hocc.
      destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
      rewrite Hb.
      apply is_neg_pos_t in Hneg1.
      rewrite Hneg1.
      left; reflexivity.

    pose proof (occ_in_phi_mconj _ _ _ Hocc Hocc2) as Hocc3.
    destruct (occ_in_phi_f _ _ Hocc2) as [Hbeq | Hleb].
      simpl in *; rewrite Hbeq in *; discriminate.
      simpl in Hocc.
      destruct (IHphi2 (i - length (pv_in phi1)) Hocc3) as [Hpos2 | Hneg2].
        simpl is_pos.
        rewrite Hocc.
        rewrite Hleb.
        left; assumption.

        simpl is_neg.
        rewrite Hocc.
        rewrite Hleb.
        right; assumption.
Qed.

Lemma is_pos_neg_or : forall (phi : Modal) (i : nat),
  occ_in_phi phi i = true ->
  is_pos phi i = true \/ is_neg phi i = true.
Proof.
  intros phi.
  induction phi; intros  i Hocc;
    try (apply is_pos_neg_or_mconj; assumption).

    apply occ_in_phi_atom in Hocc.
    rewrite Hocc.
    left; reflexivity.

    apply is_pos_neg_or_mneg; assumption.
    apply is_pos_neg_or_mimpl; assumption.

    rewrite is_pos_box2.
    rewrite is_neg_box2.
    apply IHphi.
    apply occ_in_phi_box.
    assumption.

    rewrite is_pos_diam2.
    rewrite is_neg_diam2.
    apply IHphi.
    apply occ_in_phi_box.
    assumption.
Qed.

Lemma is_pos_neg_mimpl_l : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mimpl phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = true)).
Proof.
  intros phi1 phi2 i Hpos Hocc.
  assert (beq_nat i 0 = false) as Hbeq.
    apply occ_in_phi_0 with (phi := phi1) ; exact Hocc.
  assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
    apply occ_in_phi_leb; exact Hocc.
  simpl in Hpos.
  rewrite Hbeq in *.
  rewrite List.app_length in Hpos.
  rewrite leb_plus_r in Hpos.
  rewrite Hleb in Hpos.
  case_eq (is_pos phi1 i); intros Hpos'; rewrite Hpos' in *.
    discriminate.

    apply is_pos_neg_f in Hpos'; assumption.

    apply occ_in_phi_leb2; assumption.
Qed.

Lemma is_pos_neg_mimpl_r : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mimpl phi1 phi2) i = true ->
    (Nat.leb (length (pv_in phi1) + 1) i = true) ->
      is_pos phi2 (i - (length (pv_in phi1))) = true.
Proof.
  intros phi1 phi2 i Hpos12 Hleb.
  rewrite is_pos_defn_mimpl in *.
  case_eq (occ_in_phi (mimpl phi1 phi2) i); intros Hocc;
  rewrite Hocc in *.
    case_eq (Nat.leb i (length (pv_in phi1))); intros Hleb2;
    rewrite Hleb2 in *.
      apply leb_notswitch in Hleb2.
      rewrite Hleb in *.
      discriminate.

      exact Hpos12.

      discriminate.
Qed.

Lemma is_pos_neg_mimpl : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mimpl phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = true)) /\
    ((Nat.leb (length (pv_in phi1) + 1) i = true) ->
       is_pos phi2 (i - (length (pv_in phi1))) = true).
Proof.
  intros phi1 phi2 i Hpos.
  apply conj.
    apply is_pos_neg_mimpl_l with (phi2 := phi2); exact Hpos.

    apply is_pos_neg_mimpl_r with (phi1 := phi1); exact Hpos.
Qed.

(* ---------------------------------------------------------------------------- *)
(* is_neg lemmas *)

Lemma is_neg_mconj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mconj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = true)).
Proof.
  intros phi1 phi2 i Hneg Hocc.
  assert (beq_nat i 0 = false) as Hbeq.
    apply occ_in_phi_0 with (phi := phi1); assumption.
  assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
    apply occ_in_phi_leb; assumption.
  pose proof (is_neg_occ _ _ Hneg) as Hocc2.
  simpl in *.
  rewrite Hocc2 in *.
  rewrite Hleb in Hneg.
  assumption.
Qed.

Lemma is_neg_mconj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mconj phi1 phi2) i = true ->
    occ_in_phi phi1 i = false ->
       is_neg phi2 (i - (length (pv_in phi1))) = true.
Proof.
  intros phi1 phi2 i Hneg Hocc.
  pose proof (is_neg_occ _ _ Hneg) as Hocc2.
  simpl in *.
  rewrite Hocc2 in Hneg.
  apply occ_in_phi_f in Hocc.
  destruct Hocc as [Hbeq | Hleb].
    rewrite (beq_nat_true _ _ Hbeq) in *.
    simpl in *.
    discriminate.

    rewrite Hleb in *.
    assumption.
Qed.

Lemma is_neg_mconj : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mconj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = true)) /\
    (occ_in_phi phi1 i = false ->
       is_neg phi2 (i - (length (pv_in phi1))) = true).
Proof.
  intros phi1 phi2 i Hneg.
  apply conj.
    apply is_neg_mconj_l with (phi2 := phi2); exact Hneg.
    apply is_neg_mconj_r with (phi1 := phi1); exact Hneg.
Qed.

Lemma is_neg_mdisj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mdisj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = true)).
Proof.
  intros phi1 phi2 i Hneg Hocc.
  assert (beq_nat i 0 = false) as Hbeq.
    apply occ_in_phi_0 with (phi := phi1); assumption.
  assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
    apply occ_in_phi_leb; assumption.
  pose proof (is_neg_occ _ _ Hneg) as Hocc2.
  simpl in *.
  rewrite Hocc2 in *.
  rewrite Hleb in Hneg.
  assumption.
Qed.

Lemma is_neg_mdisj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mdisj phi1 phi2) i = true ->
    occ_in_phi phi1 i = false ->
       is_neg phi2 (i - (length (pv_in phi1))) = true.
Proof.
  intros phi1 phi2 i Hneg Hocc.
  pose proof (is_neg_occ _ _ Hneg) as Hocc2.
  simpl in *.
  rewrite Hocc2 in Hneg.
  apply occ_in_phi_f in Hocc.
  destruct Hocc as [Hbeq | Hleb].
    rewrite (beq_nat_true _ _ Hbeq) in *.
    simpl in *.
    discriminate.

    rewrite Hleb in *.
    assumption.
Qed.

Lemma is_neg_mdisj : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mdisj phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = true)) /\
    (occ_in_phi phi1 i = false ->
       is_neg phi2 (i - (length (pv_in phi1))) = true).
Proof.
  intros phi1 phi2 i Hneg.
  apply conj.
    apply is_neg_mdisj_l with (phi2 := phi2); exact Hneg.
    apply is_neg_mdisj_r with (phi1 := phi1); exact Hneg.
Qed.

Lemma is_neg_mimpl_l : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mimpl phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = false)).
Proof.
  intros phi1 phi2 i Hneg Hocc.
  assert (beq_nat i 0 = false) as Hbeq.
    apply occ_in_phi_0 with (phi := phi1); assumption.
  assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
    apply occ_in_phi_leb; assumption.
  pose proof (is_neg_occ _ _ Hneg) as Hocc2.
  simpl in *.
  rewrite Hocc2 in *.
  rewrite Hleb in Hneg.
  case_eq (is_neg phi1 i); intros H; rewrite H in *.
    discriminate. reflexivity.
Qed.

Lemma is_neg_mimpl_r : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mimpl phi1 phi2) i = true ->
    occ_in_phi phi1 i = false ->
       is_neg phi2 (i - (length (pv_in phi1))) = true.
Proof.
  intros phi1 phi2 i Hneg Hocc.
  pose proof (is_neg_occ _ _ Hneg) as Hocc2.
  simpl in *.
  rewrite Hocc2 in Hneg.
  apply occ_in_phi_f in Hocc.
  destruct Hocc as [Hbeq | Hleb].
    rewrite (beq_nat_true _ _ Hbeq) in *.
    simpl in *.
    discriminate.

    rewrite Hleb in *.
    assumption.
Qed.

Lemma is_neg_mimpl : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mimpl phi1 phi2) i = true ->
    ( occ_in_phi phi1 i = true ->  (is_neg phi1 i = false)) /\
    (occ_in_phi phi1 i = false ->
       is_neg phi2 (i - (length (pv_in phi1))) = true).
Proof.
  intros phi1 phi2 i Hneg.
  apply conj.
    apply is_neg_mimpl_l with (phi2 := phi2); exact Hneg.
    apply is_neg_mimpl_r with (phi1 := phi1); exact Hneg.
Qed.


Check 3.
Check nat.
Check Set.
Check Type.

Definition aproof : (2 + 1 = 3) := refl_equal 3.
Print aproof.


Require Export Types.

(* Programs *)

(* Can also use sequence and parallel in place of nats, ala QBricks *)
Inductive prog :=
| H' (n : nat)
| S' (n : nat)
| T' (n : nat)
| CNOT (n1 n2 : nat)
| seq (p1 p2 : prog).

Infix ";" := seq (at level 51, right associativity).

(** Basic Typing judgements *)

Parameter has_type : prog -> GType -> Prop.

Notation "p :: T" := (has_type p T).

Axiom HTypes : H' 0 :: (X → Z) ∩ (Z → X).
Axiom STypes : S' 0 :: (X → Y) ∩ (Z → Z).
Axiom CNOTTypes : CNOT 0 1 :: (X ⊗ I → X ⊗ X) ∩ (I ⊗ X → I ⊗ X) ∩
                             (Z ⊗ I → Z ⊗ I) ∩ (I ⊗ Z → Z ⊗ Z).

(* T only takes Z → Z *)
Axiom TTypes : T' 0 :: (Z → Z).

Axiom SeqTypes : forall g1 g2 A B C,
    g1 :: A → B ->
    g2 :: B → C ->
    g1 ; g2 :: A → C.

Axiom seq_assoc : forall p1 p2 p3 A,
    p1 ; (p2 ; p3) :: A <-> (p1 ; p2) ; p3 :: A.

(* Note that this doesn't restrict # of qubits referenced by p. *)
Axiom TypesI : forall p, p :: I → I.
Axiom TypesI2 : forall p, p :: I ⊗ I → I ⊗ I.
Hint Resolve TypesI TypesI2 : base_types_db.

(** Structural rules *)

(* Subtyping rules *)
Axiom cap_elim_l : forall g A B, g :: A ∩ B -> g :: A.
Axiom cap_elim_r : forall g A B, g :: A ∩ B -> g :: B.
Axiom cap_intro : forall g A B, g :: A -> g :: B -> g :: A ∩ B.
Axiom cap_arrow : forall g A B C,
  g :: (A → B) ∩ (A → C) ->
  g :: A → (B ∩ C).

Axiom arrow_sub : forall g A A' B B',
  (forall l, l :: A' -> l :: A) ->
  (forall r, r :: B -> r :: B') ->
  g :: A → B ->
  g :: A' → B'.

Hint Resolve cap_elim_l cap_elim_r cap_intro cap_arrow arrow_sub : subtype_db.

Lemma cap_elim : forall g A B, g :: A ∩ B -> g :: A /\ g :: B.
Proof. eauto with subtype_db. Qed.

Lemma cap_arrow_distributes : forall g A A' B B',
  g :: (A → A') ∩ (B → B') ->
  g :: (A ∩ B) → (A' ∩ B').
Proof.
  intros; apply cap_arrow.
  apply cap_intro; eauto with subtype_db.
Qed.

Lemma cap_arrow_distributes' : forall g A A' B B',
  g :: (A → A') ∩ (B → B') ->
  g :: (A ∩ B) → (A' ∩ B').
intros.
  apply cap_elim in H as [TA TB].
  apply cap_arrow.
  apply cap_intro.
  - apply arrow_sub with (A := A) (B := A'); trivial. intros l. apply cap_elim_l.
  - apply arrow_sub with (A := B) (B := B'); trivial. intros l. apply cap_elim_r.
Qed.

(* Full explicit proof *)
Lemma cap_arrow_distributes'' : forall g A A' B B',
  g :: (A → A') ∩ (B → B') ->
  g :: (A ∩ B) → (A' ∩ B').
Proof.
  intros.
  apply cap_arrow.
  apply cap_intro.
  - eapply arrow_sub; intros.
    + eapply cap_elim_l. apply H0.
    + apply H0.
    + eapply cap_elim_l. apply H.
  - eapply arrow_sub; intros.
    + eapply cap_elim_r. apply H0.
    + apply H0.
    + eapply cap_elim_r. apply H.
Qed.

(** Typing Rules for Tensors *)

Notation s := Datatypes.S.

Axiom tensor_base : forall g E A A',
    Singleton A ->
    g 0 :: (A → A') ->
    g 0 ::  A ⊗ E → A' ⊗ E.

Axiom tensor_inc : forall g n E A A',
    Singleton E ->
    g n :: (A → A') ->
    g (s n) ::  E ⊗ A → E ⊗ A'.

Axiom tensor_base2 : forall g E A A' B B',
    Singleton A ->
    Singleton B ->
    g 0 1 :: (A ⊗ B → A' ⊗ B') ->
    g 0 1 :: (A ⊗ B ⊗ E → A' ⊗ B' ⊗ E).

Axiom tensor_base2_inv : forall g E A A' B B',
    Singleton A ->
    Singleton B ->
    g 0 1 :: (B ⊗ A → B' ⊗ A') ->
    g 1 0 :: (A ⊗ B ⊗ E → A' ⊗ B' ⊗ E).

Axiom tensor_inc2 : forall (g : nat -> nat -> prog) m n E A A' B B',
    Singleton E ->
    g m n :: (A ⊗ B → A' ⊗ B') ->
    g (s m) (s n) ::  E ⊗ A ⊗ B → E ⊗ A' ⊗ B'.

Axiom tensor_inc_l : forall (g : nat -> nat -> prog) m E A A' B B',
    Singleton A ->
    Singleton E ->
    g m 0 :: (A ⊗ B → A' ⊗ B') ->
    g (s m) 0 ::  A ⊗ E ⊗ B → A' ⊗ E ⊗ B'.

Axiom tensor_inc_r : forall (g : nat -> nat -> prog) n E A A' B B',
    Singleton A ->
    Singleton E ->
    g 0 n :: (A ⊗ B → A' ⊗ B') ->
    g 0 (s n) ::  A ⊗ E ⊗ B → A' ⊗ E ⊗ B'.

(* For flipping CNOTs. Could have CNOT specific rule. *)
Axiom tensor2_comm : forall (g : nat -> nat -> prog) A A' B B',
    Singleton A ->
    Singleton B ->
    g 0 1 :: A ⊗ B → A' ⊗ B' ->
    g 1 0 :: B ⊗ A → B' ⊗ A'.

(** Arrow rules *)

(* Does this need restrictions?
   If we had g :: X → iX then we could get
   g :: I → -I which makes negation meaningless
   (and leads to a contradiction if I ∩ -I = ⊥.
*)

Axiom arrow_mul : forall p A A' B B',
    p :: A → A' ->
    p :: B → B' ->
    p :: A * B → A' * B'.

Axiom arrow_i : forall p A A',
    p :: A → A' ->
    p :: i A → i A'.

Axiom arrow_neg : forall p A A',
    p :: A → A' ->
    p :: -A → -A'.

Hint Resolve HTypes STypes TTypes CNOTTypes : base_types_db.
Hint Resolve cap_elim_l cap_elim_r : base_types_db.

Hint Resolve HTypes STypes TTypes CNOTTypes : typing_db.
Hint Resolve cap_intro cap_elim_l cap_elim_r : typing_db.
Hint Resolve SeqTypes : typing_db.

Lemma eq_arrow_r : forall g A B B',
    g :: A → B ->
    B = B' ->
    g :: A → B'.
Proof. intros; subst; easy. Qed.

(* Tactics *)

Ltac is_I A :=
  match A with
  | I => idtac
  end.

Ltac is_prog1 A :=
  match A with
  | H' => idtac
  | S' => idtac
  | T' => idtac
  end.

Ltac is_prog2 A :=
  match A with
  | CNOT => idtac
  end.

(* Reduces to sequence of H, S and CNOT *)
Ltac type_check_base :=
  repeat apply cap_intro;
  repeat eapply SeqTypes; (* will automatically unfold compound progs *)
  repeat match goal with
         | |- Singleton _       => auto 50 with sing_db
         | |- ?g :: ?A → ?B      => tryif is_evar B then fail else eapply eq_arrow_r
         | |- ?g :: - ?A → ?B    => apply arrow_neg
         | |- ?g :: i ?A → ?B    => apply arrow_i
         | |- context[?A ⊗ ?B]  => progress (autorewrite with tensor_db)
         | |- ?g :: ?A * ?B → _ => apply arrow_mul
         | |- ?g :: (?A * ?B) ⊗ I → _ => rewrite decompose_tensor_mult_l
         | |- ?g :: I ⊗ (?A * ?B) → _ => rewrite decompose_tensor_mult_r
         | |- ?g (S _) (S _) :: ?T => apply tensor_inc2
         | |- ?g 0 (S (S _)) :: ?T => apply tensor_inc_r
         | |- ?g (S (S _)) 0 :: ?T => apply tensor_inc_l
         | |- ?g 1 0 :: ?T       => apply tensor_base2_inv
         | |- ?g 0 1 :: ?T       => apply tensor_base2
         | |- ?g 1 0 :: ?T       => apply tensor2_comm
         | |- ?g (S _) :: ?T     => is_prog1 g; apply tensor_inc
         | |- ?g 0 :: ?T         => is_prog1 g; apply tensor_base
         | |- ?g :: ?A ⊗ ?B → _  => tryif (is_I A + is_I B) then fail else
             rewrite (decompose_tensor A B) by (auto 50 with sing_db)
         | |- ?g :: ?A → ?B      => tryif is_evar A then fail else
             solve [eauto with base_types_db]
         | |- ?B = ?B'          => tryif has_evar B then fail else
            (repeat rewrite mul_tensor_dist);
            (repeat normalize_mul);
            (repeat rewrite <- i_tensor_dist_l);
            (repeat rewrite <- neg_tensor_dist_l);
            autorewrite with mul_db;
            try reflexivity
         end.


Require Export Coq.Unicode.Utf8.
Require Export Fexists.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _    => True
    | tabs _     => True
    | pack _ t _ => Value t
    | _          => False
  end.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | tapptabs {T2 t11} :
      red (tapp (tabs t11) T2) (tsubstTm X0 T2 t11)
  | E_UnpackPack {T11 v12 T1 t2} :
      Value v12 →
      red (unpack (pack T11 v12 (texist T1)) t2)
          (tsubstTm X0 T11 (substTm X0 (tshiftTm C0 v12) t2))
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tapp t1 T2) (tapp t1' T2)
  | E_pack {T11 t12 t12' T1} :
      red t12 t12' → red (pack T11 t12 T1) (pack T11 t12' T1)
  | E_unpack {t1 t1' t2} :
      red t1 t1' → red (unpack t1 t2) (unpack t1' t2).


From mathcomp Require Import all_ssreflect.
From hanoi Require Import gdist ghanoi.

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

Section sHanoi.

(*****************************************************************************)
(*  The pegs are the elements of 'I_n.+3                                     *)
(*****************************************************************************)

Variable m : nat.
Implicit Type p : peg m.+3.

Local Notation "c1 `--> c2" := (smove c1 c2)
    (format "c1  `-->  c2", at level 60).
Local Notation "c1 `-->* c2" := (connect smove c1 c2)
    (format "c1  `-->*  c2", at level 60).

Let p0 : peg m.+3 := ord0.

Definition so1 p : (peg m.+3) := if (p == inord 1) then inord 2 else inord 1.

Lemma so1_cor p : so1 p != p0 /\ so1 p != p.
Proof.
rewrite /so1; case: (p =P _) => [->|/eqP pD1]; split.
- by apply/eqP/val_eqP; rewrite /= !inordK.
- by apply/eqP/val_eqP; rewrite /= !inordK.
- by apply/eqP/val_eqP; rewrite /= !inordK.
by rewrite eq_sym.
Qed.

Definition so2 p1 p2 : (peg m.+3) :=
if (p1 == inord 1) then
  if (p2 == inord 2) then inord 3 else inord 2
else
  if (p2 == inord 1) then
    if (p1 == inord 2) then inord 3 else inord 2
  else inord 1.

Lemma so2_cor p1 p2 :
  0 < m ->
  [/\ so2 p1 p2 != p0, so2 p1 p2 != p1 & so2 p1 p2 != p2].
Proof.
move=> m_gt0.
rewrite /so2; case: (p1 =P _) => [->|/eqP p1D1];
  rewrite /so2; case: (p2 =P _) => [->|/eqP p2D].
- by split; apply/eqP/val_eqP; rewrite /= !inordK.
- by split; try (by rewrite eq_sym); apply/eqP/val_eqP; rewrite /= !inordK.
- case: (p1 =P _) => [->|/eqP p1D2].
    by split; apply/eqP/val_eqP; rewrite /= !inordK.
  by split; try (by rewrite eq_sym); apply/eqP/val_eqP; rewrite /= !inordK.
by split; try (by rewrite eq_sym); apply/eqP/val_eqP; rewrite /= !inordK.
Qed.

Lemma shanoi_connect_perfect n (c : configuration _ n) p : c `-->* `c[p].
Proof.
have sirr := @sirr m.+3.
elim: n c p => [c p | n IH c p]; first by apply/eq_connect0/ffunP=> [] [[]].
pose p1 := c ldisk.
rewrite -[c]cunliftrK -/p1 -[perfect p]cunliftrK perfect_unliftr ffunE.
have [<-|/eqP pDp1] := p =P p1; first by apply/connect_liftr/IH.
have [p1Ep0|/eqP p1Dp0] := p1 =P p0.
  rewrite p1Ep0.
  case: (so1_cor p) => sDp0 sDp.
  apply: connect_trans (_ : connect _ ↑[`c[so1 p]]_p _); last first.
    by apply/connect_liftr/IH.
  apply: connect_trans (_ : connect _ ↑[`c[so1 p]]_p0 _).
    by apply/connect_liftr/IH.
  apply/connect1/move_liftr_perfect; try by rewrite eq_sym.
  by rewrite /srel /= eq_sym -p1Ep0 pDp1.
have [pEp0|/eqP pDp0] := p =P p0.
  case: (so1_cor p1) => sDp0 sDp1.
  apply: connect_trans (_ : connect _ ↑[`c[so1 p1]]_p1 _).
    by apply/connect_liftr/IH.
  apply: connect_trans (_ : connect _ ↑[`c[so1 p1]]_p _).
    apply/connect1/move_liftr_perfect; try by rewrite eq_sym.
      by rewrite /srel /= eq_sym pDp1 pEp0 muln0.
    by rewrite eq_sym pEp0.
  by apply/connect_liftr/IH.
apply: connect_trans (_ : connect _ ↑[`c[p]]_p1 _).
  by apply/connect_liftr/IH.
apply: connect_trans (_ : connect _ ↑[`c[p]]_p0 _).
  apply/connect1/move_liftr_perfect; try by rewrite eq_sym.
  by rewrite /srel /= p1Dp0 muln0.
apply: connect_trans (_ : connect _ ↑[`c[p1]]_p0 _).
  by apply/connect_liftr/IH.
apply: connect_trans (_ : connect _ ↑[`c[p1]]_p _).
  apply/connect1/move_liftr_perfect; try by rewrite // eq_sym.
  by rewrite /srel /= eq_sym pDp0.
by apply/connect_liftr/IH.
Qed.

Lemma shanoi_connect n (c1 c2 : configuration m.+3 n) : c1 `-->* c2.
Proof.
apply: connect_trans (shanoi_connect_perfect _ p0) _.
rewrite (connect_sym (@ssym m.+3)).
apply: shanoi_connect_perfect.
Qed.

End sHanoi.