(** * Notations and utilities for Decidability.

Except for some comments and minor additins at the end, this material
is taken from Gert Smolka's Base Library for ICL

   - Version: 30 June 2014 Author: Gert Smolka, Saarland University
   - Acknowlegments: Sigurd Schneider, Dominik Kirst *)

(*

This file defines some abbreviations and notation:
 dec
 eq_dec
 decision
 decide

(1) (dec P)  is a Type     for P: Prop
     it abbreviates {P}+{~P}

(2) (eq_dec T) is a Type   for T:Type
    Notation for (forall x y : T, dec (x=y))
              ie (forall x y : T, {(x=y)} + {~(x=y)}

for various T, can construct (below) inhabitants of eq_dec_T.
For example
  nat_eq_dec   : (eq_dec nat)
  bool_eq_dec  : (eq_dec bool)

So, eg, nat_eq_dec takes two arguments, returns a sumbool

(nat_eq_dec 3 7) is an element of {3=7}+{~ 3 =7}
(nat_eq_dec 3 7) : {3=7}+{~ 3 =7}

(3)   (decision P D)  is a value    for P:Prop and D: dec P
    specifically, (decision P D) has type (dec P)

  indeed, (decision P D) is precisely D.
  but with implit arguments, ie
  Arguments decision P {D}
  the effect is that, eg,
  (decision (x=y)) has type {x=y}+{~x=y}

  explictly would have [for x y : nat, say]
  (@decision (x=y) (nat_eq_dec x y)) : {x=y}+{~ x=y}
  since (x=y): Prop and (nat_eq_dec x y): (eq_dec nat)

  The value that (decision P D) names is either
  a proof of P or a proof of ~P.

  So in programming we can match on it, ie do things like
     [ if (decision (x=y) then ... else ... ]

Definition dumb' (n m: nat) : nat :=
  if decision (x=y) then x else y.

Definition dumb (n m: nat) : nat :=
  if @decision (x=y) (@nat_eq_dec x y) then x else y.

(4)  decide P is a tactic
     means (destruct (decision P))

  another form
  decide p as i
  means (destruct (decision P)) as I
*)
Require Export Bool.
Require Export Omega.
Require Export List.
Require Export Morphisms.

(* This is unset at the end of this file *)
Global Set Implicit Arguments.
Global Unset Strict Implicit.

(** *** General decidability abstraction over any Prop *)

Definition dec (P : Prop) : Type := {P} + {~ P}.

(** *** When the dec Pop is equality *)

Notation "'eq_dec' T" := (forall x y : T, dec (x=y)) (at level 70).

(** Register dec as a type class *)

Existing Class dec.

(** *** A trick using implicit arguments *)

Definition decision (P : Prop) (D : dec P) : dec P := D.
Arguments decision P {D}.

(** ** A tactic for using decidable Props*)

Tactic Notation "decide" constr(p) :=
  destruct (decision p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (decision p) as i.

(** ** Hints for auto concerning dec *)

Hint Extern 4 =>
match goal with
  | [  |- dec ?p ] => exact (decision p)
end.

(** *** Improves type class inference *)

Hint Extern 4 =>
match goal with
  | [  |- dec ((fun _ => _) _) ] => simpl
end : typeclass_instances.

(** ** Register instance rules for dec *)

Instance True_dec :  dec True :=
  left I.

Instance False_dec :  dec False :=
  right (fun A => A).

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec. tauto.
Defined.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Defined.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Defined.

(* Coq standard modules make "not" and "iff" opaque for type class
inference, can be seen with Print HintDb typeclass_instances. *)

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. auto.
Defined.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. auto.
Qed.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  intros x y. hnf. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  intros x y. hnf. decide equality.
Defined.

Instance nat_le_dec (x y : nat) : dec (x <= y) :=
  le_dec x y.

(** ** Propositional connectives *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_prop_iff (X Y : Prop) :
  (X <-> Y) -> dec X -> dec Y.
Proof.
  unfold dec; tauto.
Defined.

(** * Decidability laws for lists *)

Export ListNotations.
Notation "| A |" := (length A) (at level 65).
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
(* Notation "A === B" := (equi A B) (at level 70). *)

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  intros D. apply list_eq_dec. exact D.
Defined.

Instance list_in_dec (X : Type) (x : X) (A : list X) :
  eq_dec X -> dec (x el A).
Proof.
  intros D. apply in_dec. exact D.
Defined.

Lemma list_sigma_forall X A (p : X -> Prop) (p_dec : forall x, dec (p x)) :
  {x | x el A /\ p x} + {forall x, x el A -> ~ p x}.
Proof.
  induction A as [|x A]; simpl.
  - tauto.
  - destruct IHA as [[y [D E]]|D].
    + eauto.
    + destruct (p_dec x) as [E|E].
      * eauto.
      * right. intros y [[]|F]; auto.
Defined.

Arguments list_sigma_forall {X} A p {p_dec}.

Instance list_forall_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (forall x, x el A -> p x).
Proof.
  intros p_dec.
  destruct (list_sigma_forall A (fun x => ~ p x)) as [[x [D E]]|D].
  - right. auto.
  - left. intros x E. apply dec_DN; auto.
Defined.

Instance list_exists_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (exists x, x el A /\ p x).
Proof.
  intros p_dec.
  destruct (list_sigma_forall A p) as [[x [D E]]|D].
  - unfold dec. eauto.
  - right. intros [x [E F]]. exact (D x E F).
Defined.

Lemma list_exists_DM X A  (p : X -> Prop) :
  (forall x, dec (p x)) ->
  ~ (forall x, x el A -> ~ p x) -> exists x, x el A /\ p x.
Proof.
  intros D E.
  destruct (list_sigma_forall A p) as [F|F].
  + destruct F as [x F]. eauto.
  + contradiction (E F).
Qed.

Lemma list_exists_not_incl X (A B : list X) :
  eq_dec X ->
  ~ A <<= B -> exists x, x el A /\ ~ x el B.
Proof.
  intros D E.
  apply list_exists_DM; auto.
  intros F. apply E. intros x G.
  apply dec_DN; auto.
Qed.

Lemma list_cc X (p : X -> Prop) A :
  (forall x, dec (p x)) ->
  (exists x, x el A /\ p x) -> {x | x el A /\ p x}.
Proof.
  intros D E.
  destruct (list_sigma_forall A p) as [[x [F G]]|F].
  - eauto.
  - exfalso. destruct E as [x [G H]]. apply (F x); auto.
Defined.

Global Unset Implicit Arguments.

(** * Connecting sumbool decision function with booleans *)

(** *** dd additions *)

Definition sumbool_to_bool :
  forall P Q : Prop, {P} + {Q} -> bool :=
  fun P Q sb => if sb then true else false.

Arguments sumbool_to_bool {P} {Q} _.

Lemma sumbool_to_bool_correct_left P Q  sb :
  (@sumbool_to_bool P Q sb) = true -> P.
Proof.
 intros H.
    unfold sumbool_to_bool in H.
    destruct sb as [y | n]; easy.
Qed.

Lemma sumbool_to_bool_correct_right P Q sb :
  (@sumbool_to_bool P Q sb) = false -> Q.
Proof.
  intros H.
  unfold sumbool_to_bool in H.
  destruct sb as [y | n]; easy.
Qed.

(** NB: don't expect iff in the above.
Suppose P = Q !

But in the case Q is ~P we do get iff:
*)

Definition dec_to_bool :
  forall P : Prop, {P} + {~ P} -> bool :=
  fun P sb => @sumbool_to_bool P (~P) sb.

Arguments dec_to_bool {P} _.

Lemma dec_to_bool_correct P sb :
  (@dec_to_bool P sb) = true <-> P.
Proof.
  split.
  - unfold dec_to_bool.
    apply sumbool_to_bool_correct_left.
  - intros H.
    apply not_false_is_true; intros H1.
    assert (H2:= sumbool_to_bool_correct_right P (~P) sb H1).
    easy.
Qed.

Lemma dec_to_bool_correct' P sb :
  (@dec_to_bool P sb) = false <-> (P -> False).
Proof.
  assert (H1:= dec_to_bool_correct P sb).
  assert (H2:= not_true_iff_false (dec_to_bool sb)).
  firstorder.
Qed.


Require Export Iron.Language.SystemF2Effect.Type.

(********************************************************************)
(* Constants *)
Inductive const : Type :=
  | CUnit   : const
  | CNat    : nat   -> const
  | CBool   : bool  -> const.
Hint Constructors const.

Fixpoint typeOfConst (c : const) : ty :=
  match c with
  | CUnit     => TUnit
  | CNat  _   => TNat
  | CBool _   => TBool
  end.

(* Primitive Operators *)
Inductive op1 : Type :=
  | OSucc   : op1
  | OIsZero : op1.
Hint Constructors op1.

(* Values *)
Inductive val : Type :=
  | VVar     : nat   -> val
  | VLoc     : nat   -> val
  | VLam     : ty    -> exp -> val
  | VLAM     : ki    -> exp -> val
  | VConst   : const -> val

(* Expressions *)
with     exp : Type :=
  | XVal     : val -> exp
  | XLet     : ty  -> exp -> exp -> exp
  | XApp     : val -> val -> exp
  | XAPP     : val -> ty  -> exp

  (* Pure operators *)
  | XOp1     : op1 -> val -> exp

  (* Store operators *)
  | XPrivate : exp -> exp
  | XExtend  : ty  -> exp -> exp

  | XAlloc   : ty  -> val -> exp
  | XRead    : ty  -> val -> exp
  | XWrite   : ty  -> val -> val -> exp.

Hint Constructors val.
Hint Constructors exp.

(********************************************************************)
(* Induction principle for expressions. *)
Lemma exp_mutind : forall
    (PX : exp -> Prop)
    (PV : val -> Prop)
 ,  (forall n,                                     PV (VVar   n))
 -> (forall l,                                     PV (VLoc   l))
 -> (forall t x,        PX x                    -> PV (VLam   t x))
 -> (forall k x,        PX x                    -> PV (VLAM   k x))
 -> (forall c,                                     PV (VConst c))
 -> (forall v,          PV v                    -> PX (XVal   v))
 -> (forall t x1 x2,    PX x1 -> PX x2          -> PX (XLet   t x1 x2))
 -> (forall v1 v2,      PV v1 -> PV v2          -> PX (XApp   v1 v2))
 -> (forall v t,        PV v                    -> PX (XAPP   v  t))
 -> (forall o v,        PV v                    -> PX (XOp1 o   v))
 -> (forall x,          PX x                    -> PX (XPrivate x))
 -> (forall t x,        PX x                    -> PX (XExtend  t x))
 -> (forall r v,        PV v                    -> PX (XAlloc r v))
 -> (forall r v,        PV v                    -> PX (XRead  r v))
 -> (forall r v1 v2,    PV v1 -> PV v2          -> PX (XWrite r v1 v2))
 ->  forall x, PX x.
Proof.
 intros PX PV.
 intros hVar hLoc hLam hLAM hConst
        hVal hLet hApp hAPP hOp1
        hPrivate hExtend
        hAlloc hRead hWrite.
 refine (fix  IHX x : PX x := _
         with IHV v : PV v := _
         for  IHX).

 (* expressions *)
 case x; intros.
 apply hVal.     apply IHV.
 apply hLet.     apply IHX. apply IHX.
 apply hApp.     apply IHV. apply IHV.
 apply hAPP.     apply IHV.
 apply hOp1.     apply IHV.
 apply hPrivate. apply IHX.
 apply hExtend.  apply IHX.
 apply hAlloc.   apply IHV.
 apply hRead.    apply IHV.
 apply hWrite.   apply IHV. apply IHV.

 (* values *)
 case v; intros.
 apply hVar.
 apply hLoc.
 apply hLam. apply IHX.
 apply hLAM. apply IHX.
 apply hConst.
Qed.


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