(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Compare_dec.
Require Export Peano_dec.
Require Import Sumbool.

Local Open Scope nat_scope.

Implicit Types m n x y : nat.

(** The decidability of equality and order relations over
    type [nat] give some boolean functions with the adequate specification. *)

Definition notzerop n := sumbool_not _ _ (zerop n).
Definition lt_ge_dec : forall x y, {x < y} + {x >= y} :=
  fun n m => sumbool_not _ _ (le_lt_dec m n).

Definition nat_lt_ge_bool x y := bool_of_sumbool (lt_ge_dec x y).
Definition nat_ge_lt_bool x y :=
  bool_of_sumbool (sumbool_not _ _ (lt_ge_dec x y)).

Definition nat_le_gt_bool x y := bool_of_sumbool (le_gt_dec x y).
Definition nat_gt_le_bool x y :=
  bool_of_sumbool (sumbool_not _ _ (le_gt_dec x y)).

Definition nat_eq_bool x y := bool_of_sumbool (eq_nat_dec x y).
Definition nat_noteq_bool x y :=
  bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)).

Definition zerop_bool x := bool_of_sumbool (zerop x).
Definition notzerop_bool x := bool_of_sumbool (notzerop x).


Import Nat.
Require Import List.
Require Import PeanoNat.

Require Import Logic.Axiom.LEM.
Require Import Logic.Rel.Prop.
Require Import Logic.Nat.Fresh.

Require Import Logic.Fol.Valid.
Require Import Logic.Fol.Syntax.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.
Require Import Logic.Set.Empty.
Require Import Logic.Set.ElemIncl.
Require Import Logic.Set.Foundation.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Environment.

Fixpoint eval (e:Env) (p:Formula) : Prop :=
    match p with
    | Bot           => False
    | Elem n m      => (e n) :: (e m)
    | Imp p1 p2     => eval e p1 -> eval e p2
    | All n p1      => forall (x:set), eval (bind e n x) p1
    end.

Lemma evalCompat : forall (e e':Env) (p:Formula),
    envEqual e e' -> eval e p <-> eval e' p.
Proof.
    intros e e' p. revert p e e'.
    induction p as [ |n m|p1 IH1 p2 IH2|n p1 IH1]; intros e e' H1; simpl.
    - split; auto.
    - split; apply elemCompatLR; try (apply H1);
      apply envEqualSym in H1; apply H1.
    - apply implyCompatLR.
        + apply IH1. assumption.
        + apply IH2. assumption.
    - apply allCompat. intros x. apply IH1, bindEnvEqual; try assumption.
      apply equalRefl.
Qed.

(* Given an environement e, a formula p and a variable n, we can define a       *)
(* predicate P: set -> Prop by defining P x as the proposition obtained by      *)
(* evaluating the formula p in an environment where n is bound to x.            *)
Definition eval1 (e:Env) (p:Formula) (n:nat) (x:set) : Prop :=
    eval (bind e n x) p.

(* Given an environement e, a formula p and two variables n m, we can define a  *)
(* two variables predicate P: set -> set -> Prop by defining P x y as the pro-  *)
(* position obtained by evaluating the formula p in an environment where n is   *)
(* bound to x and m is bound to y. This predicate makes sense if n <> m.        *)
Definition eval2 (e:Env) (p:Formula) (n m:nat) (x y:set) : Prop :=
    eval (bind (bind e n x) m y) p.

Definition eval3 (e:Env) (p:Formula) (n m k:nat) (x y z:set) : Prop :=
    eval (bind (bind (bind e n x) m y) k z) p.

Lemma eval3ToEval2 : forall (e:Env) (p:Formula) (n m k:nat) (x y z:set),
    eval3 e p n m k x y z <-> eval2 (bind e n x) p m k y z.
Proof.
    intros e p n m k x y z. unfold eval3, eval2. split; auto.
Qed.

Lemma evalBot : forall (e:Env), eval e Bot <-> False.
Proof. intros e. unfold eval. split; intros H; assumption. Qed.

Lemma evalElem : forall (e:Env) (n m:nat),
    eval e (Elem n m) <-> (e n) :: (e m).
Proof. intros e n m. unfold eval. split; intros H; assumption. Qed.

Lemma evalImp : forall (e:Env) (p q:Formula),
    eval e (Imp p q) <-> (eval e p -> eval e q).
Proof.
    intros e p q. unfold eval. fold (eval e p). fold (eval e q).
    split; intros H; assumption.
Qed.

Lemma evalAll : forall (e:Env) (p:Formula) (n:nat),
    eval e (All n p) <-> forall (x:set), eval (bind e n x) p.
Proof.
    intros e p n. unfold eval. split; intros H; assumption.
Qed.

Lemma evalNot : forall (e:Env) (p:Formula),
    eval e (Not p) <-> ~ eval e p.
Proof.
    intros e p. unfold Not, eval. fold (eval e p).
    split; intros H; assumption.
Qed.

Lemma evalOr : LEM -> forall (e:Env) (p q:Formula),
    eval e (Or p q) <-> eval e p \/ eval e q.
Proof.
    intros L e p q. unfold Or, eval. simpl.
    apply LEMOr. assumption.
Qed.

Lemma evalAnd : LEM -> forall (e:Env) (p q:Formula),
    eval e (And p q) <-> eval e p /\ eval e q.
Proof.
    intros L e p q. unfold And, eval. simpl.
    apply LEMAnd. assumption.
Qed.

Lemma evalExi : LEM -> forall (e:Env) (p:Formula) (n:nat),
    eval e (Exi n p) <-> exists (x:set), eval (bind e n x) p.
Proof.
    intros L e p n. unfold Exi, eval, bind. simpl.
    apply LEMExist. assumption.
Qed.

Lemma evalIff : LEM -> forall (e:Env) (p q:Formula),
    eval e (Iff p q) <-> (eval e p <-> eval e q).
Proof.
    intros L e p q. unfold Iff. apply evalAnd. assumption.
Qed.

(* LEM is not needed for this one.                                              *)
Lemma evalSub : forall (e:Env) (n m:nat),
    eval e (Sub n m) <-> (e n) <= (e m).
Proof.
    intros e n m. unfold Sub. rewrite elemIncl.
    rewrite evalAll. simpl. split; intros H z.
    - remember (H z) as H' eqn:E. clear E.
      rewrite bindSame in H'.
      rewrite bindDiff in H'.
      rewrite bindDiff in H'.
        + assumption.
        + apply freshNot_m.
        + apply freshNot_n.
    - rewrite bindSame.
      rewrite bindDiff.
      rewrite bindDiff.
        + apply H.
        + apply freshNot_m.
        + apply freshNot_n.
Qed.

Lemma evalEqu : LEM -> forall (e:Env) (n m:nat),
    eval e (Equ n m) <-> (e n) == (e m).
Proof.
    intros L e n m. unfold Equ, equal.
    rewrite evalAnd, evalAll, evalAll. split; intros [H1 H2].
    - split; intros z.
        + remember (H1 z) as H1' eqn:E. clear E.
          rewrite evalIff in H1'.
          rewrite evalElem in H1'.
          rewrite evalElem in H1'.
          rewrite bindSame in H1'.
          rewrite bindDiff in H1'.
          rewrite bindDiff in H1'.
            { assumption. }
            { apply freshNot_m. }
            { apply freshNot_n. }
            { assumption. }
        + remember (H2 z) as H2' eqn:E. clear E.
          rewrite evalIff in H2'.
          rewrite evalElem in H2'.
          rewrite evalElem in H2'.
          rewrite bindSame in H2'.
          rewrite bindDiff in H2'.
          rewrite bindDiff in H2'.
            { assumption. }
            { apply freshNot_m. }
            { apply freshNot_n. }
            { assumption. }
    - split; intros z;
      rewrite evalIff, evalElem, evalElem, bindSame, bindDiff, bindDiff.
        + apply H1.
        + apply freshNot_m.
        + apply freshNot_n.
        + assumption.
        + apply H2.
        + apply freshNot_m.
        + apply freshNot_n.
        + assumption.
    - assumption.
Qed.

Lemma evalEmpty : forall (e:Env) (n:nat),
    eval e (Empty n) <-> (e n) == Nil.
Proof.
    intros e n. unfold Empty. rewrite evalAll. split; intros H.
    - apply emptyUnique. intros x. remember (H x) as H' eqn:E. clear E. clear H.
      rewrite evalNot in H'. rewrite evalElem in H'.
      rewrite bindSame in H'. rewrite bindDiff in H'.
        + assumption.
        + apply freshNot_n.
    - intro x. rewrite evalNot, evalElem, bindSame, bindDiff.
      rewrite emptyIsNil in H. rewrite H.
        + apply emptyCharac.
        + apply freshNot_n.
Qed.

Lemma evalMin : LEM -> forall (e:Env) (n m:nat),
    eval e (Min n m) <-> minimal (e n) (e m).
Proof.
    intros L e n m. unfold Min. rewrite evalAnd, evalElem, evalNot, evalExi.
    unfold minimal. split; intros [H1 H2].
    - split.
        + assumption.
        + intros [y H]. apply H2. exists y. rewrite evalAnd, evalElem, evalElem.
          rewrite bindSame, bindDiff, bindDiff.
            { assumption. }
            { apply freshNot_n. }
            { apply freshNot_m. }
            { assumption. }
    - split.
        + assumption.
        + intros [y H]. apply H2. exists y. rewrite evalAnd in H.
          rewrite evalElem in H. rewrite evalElem in H. rewrite bindSame in H.
          rewrite bindDiff in H. rewrite bindDiff in H.
            { assumption. }
            { apply freshNot_n. }
            { apply freshNot_m. }
            { assumption. }
    - assumption.
    - assumption.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Export ZArith.
Require Import Lia.
Local Open Scope Z_scope.

Coercion Zpos : positive >-> Z.
Coercion Z_of_N : N >-> Z.

Lemma Zpos_plus : forall p q, Zpos (p + q) = p + q.
Proof. intros;trivial. Qed.

Lemma Zpos_mult : forall p q, Zpos (p * q) = p * q.
Proof. intros;trivial. Qed.

Lemma Zpos_xI_add : forall p, Zpos (xI p) = Zpos p + Zpos p + Zpos 1.
Proof. intros p;rewrite Zpos_xI;ring. Qed.

Lemma Zpos_xO_add : forall p, Zpos (xO p) = Zpos p + Zpos p.
Proof. intros p;rewrite Zpos_xO;ring. Qed.

Lemma Psucc_Zplus : forall p, Zpos (Pos.succ p) = p + 1.
Proof. intros p;rewrite Zpos_succ_morphism; unfold Z.succ; trivial. Qed.

Hint Rewrite Zpos_xI_add Zpos_xO_add Pplus_carry_spec
 Psucc_Zplus Zpos_plus : zmisc.

Lemma Zlt_0_pos : forall p, 0 < Zpos p.
Proof. unfold Z.lt; trivial. Qed.

Lemma Pminus_mask_carry_spec : forall p q,
  Pminus_mask_carry p q = Pminus_mask p (Pos.succ q).
Proof.
 intros p q;generalize q p;clear q p.
 induction q;destruct p;simpl;try rewrite IHq;trivial.
 destruct p;trivial.  destruct p;trivial.
Qed.

Hint Rewrite Pminus_mask_carry_spec : zmisc.

Ltac zsimpl := autorewrite with zmisc.
Ltac CaseEq t := generalize (refl_equal t);pattern t at -1;case t.
Ltac generalizeclear H := generalize H;clear H.

Lemma Pminus_mask_spec :
   forall p q,
    match Pminus_mask p q with
    | IsNul    => Zpos p =  Zpos q
    | IsPos k => Zpos p = q + k
    | IsNeq   => p < q
    end.
Proof.
  intros p q;
  case (Pos.sub_mask_spec p q).
  lia.
  all: intros r <-; lia.
Qed.

Definition PminusN x y :=
  match Pminus_mask x y with
  | IsPos k => Npos k
  | _ => N0
  end.

Lemma PminusN_le : forall x y:positive, x <= y -> Z_of_N (PminusN y x) = y - x.
Proof.
 intros x y Hle;unfold PminusN.
 assert (H := Pminus_mask_spec y x);destruct (Pminus_mask y x).
 rewrite H;unfold Z_of_N;auto with zarith.
 rewrite H;unfold Z_of_N;auto with zarith.
 elimtype False;lia.
Qed.

Lemma Ppred_Zminus : forall p, 1< Zpos p ->  (p-1)%Z = Pos.pred p.
Proof. destruct p;simpl;trivial. intros;elimtype False;lia. Qed.

Local Open Scope positive_scope.

Declare Scope P_scope.
Delimit Scope P_scope with P.
Local Open Scope P_scope.

Definition is_lt (n m : positive) :=
  match (n ?= m) with
  | Lt => true
  | _ => false
  end.
Infix "?<" := is_lt (at level 70, no associativity) : P_scope.

Lemma is_lt_spec : forall n m, if n ?< m then (n < m)%Z else (m <= n)%Z.
Proof.
intros n m; unfold is_lt, Z.lt , Z.le, Z.compare.
rewrite Pos.compare_antisym.
case (m ?= n); simpl; auto; intros HH; discriminate HH.
Qed.

Definition is_eq a b :=
  match (a ?= b) with
  | Eq => true
  | _ => false
  end.
Infix "?=" := is_eq (at level 70, no associativity) : P_scope.

Lemma is_eq_refl : forall n, n ?= n = true.
Proof. intros n;unfold is_eq;rewrite Pos.compare_refl;trivial. Qed.

Lemma is_eq_eq : forall n m, n ?= m = true -> n = m.
Proof.
 unfold is_eq;intros n m H; apply Pos.compare_eq.
destruct (n ?= m)%positive;trivial;try discriminate.
Qed.

Lemma is_eq_spec_pos : forall n m, if n ?= m then  n = m else  m <> n.
Proof.
 intros n m; CaseEq (n ?= m);intro H.
 rewrite (is_eq_eq _ _ H);trivial.
 intro H1;rewrite H1 in H;rewrite is_eq_refl in H;discriminate H.
Qed.

Lemma is_eq_spec : forall n m, if n ?= m then Zpos n = m else Zpos m <> n.
Proof.
 intros n m; CaseEq (n ?= m);intro H.
 rewrite (is_eq_eq _ _ H);trivial.
 intro H1;inversion H1.
 rewrite H2 in H;rewrite is_eq_refl in H;discriminate H.
Qed.

Definition is_Eq a b :=
  match a, b with
  | N0, N0 => true
  | Npos a', Npos b' => a' ?= b'
  | _, _ => false
  end.

Lemma is_Eq_spec :
 forall n m, if is_Eq n m then Z_of_N n = m else Z_of_N m <> n.
Proof.
 destruct n;destruct m;simpl;trivial;try (intro;discriminate).
 apply is_eq_spec.
Qed.

(* [times x y] return [x * y], a litle bit more efficiant *)
Fixpoint times (x y : positive) {struct y} : positive :=
  match x, y with
  | xH, _ => y
  | _, xH => x
  | xO x', xO y' => xO (xO (times x' y'))
  | xO x', xI y' => xO (x' + xO (times x' y'))
  | xI x', xO y' => xO (y' + xO (times x' y'))
  | xI x', xI y' => xI (x' + y' + xO (times x' y'))
  end.

Infix "*" := times : P_scope.

Lemma times_Zmult : forall p q, Zpos (p * q)%P = (p * q)%Z.
Proof.
 intros p q;generalize q p;clear p q.
 induction q;destruct p; unfold times; try fold (times p q);
   autorewrite with zmisc; try rewrite IHq; ring.
Qed.

Fixpoint square (x:positive) : positive :=
 match x with
 | xH => xH
 | xO x => xO (xO (square x))
 | xI x => xI (xO (square x + x))
 end.

Lemma square_Zmult : forall x, Zpos (square x) = (x * x) %Z.
Proof.
 induction x as [x IHx|x IHx |];unfold square;try (fold (square x));
   autorewrite with zmisc; try rewrite IHx; ring.
Qed.


Require Import Coq.Classes.EquivDec.
Require Import Decidable List.

  Ltac decide' X :=
    let e := fresh "e" in
    let c := fresh "c" in
    lazymatch X with
    | equiv_dec _ _ => destruct X as [e|c]; [destruct e|]
    | _ => lazymatch type of X with
          | equiv_dec _ _ => destruct X as [e|c]; [destruct e|]
          | {_ === _} + {_ =/= _} => destruct X as [e|c]; [destruct e|]
          end
    end.

  Lemma In_dec (A : Type) `{EqDec A eq} a (l : list A) : decidable (In a l).
  Proof.
    unfold decidable.
    induction l.
    - right. tauto.
    - destruct IHl.
      + left; econstructor 2; eauto.
      + destruct (a == a0).
        * destruct e. left; econstructor. reflexivity.
        * right. contradict H0. inversion H0; eauto. subst a0. exfalso. apply c. reflexivity.
  Qed.


Require Import List.

Require Import String.

Inductive bolType := bolInt|bolFloat|bolBool|bolString.
Inductive bolID := fromString: string -> bolID.
Inductive bolInd := fromID: bolID -> bolInd.

Inductive bolConcept :=
    | bolAtomicCon: bolID -> bolConcept
    | bolConUnion: bolConcept -> bolConcept -> bolConcept
    | bolConIntersect: bolConcept -> bolConcept -> bolConcept
    | bolRelDom: bolRelation -> bolConcept
    | bolRelCod: bolRelation -> bolConcept
    | bolConForall: bolRelation -> bolConcept -> bolConcept
    | bolConExists: bolRelation -> bolConcept -> bolConcept
  with bolRelation :=
    | bolAtomicRel: bolID -> bolRelation
    | bolRelUnion: bolRelation -> bolRelation -> bolRelation
    | bolRelComp: bolRelation -> bolRelation -> bolRelation
    | bolRelInv: bolRelation -> bolRelation
    | bolRelTrans: bolRelation -> bolRelation
    | bolRelDiag: bolConcept -> bolRelation.

Inductive bolProp :=
    | bolAtomicProp: bolID -> bolProp.

Inductive bolValue :=
    | bolNaturalNumberValue: nat -> bolValue
    | bolBoolValue: bool -> bolValue.

Inductive bolDecl :=
    | bolIndDecl: bolID -> bolDecl
    | bolConDecl: bolID -> bolDecl
    | bolRelDecl: bolID -> bolDecl
    | bolPropDecl: bolID -> bolType -> bolDecl.

Inductive bolFormula :=
    | bolEq: bolConcept -> bolConcept -> bolFormula
    | bolSub: bolConcept -> bolConcept -> bolFormula
    | bolIsA: bolInd -> bolConcept -> bolFormula
    | bolInRel: bolInd -> bolRelation -> bolInd -> bolFormula
    | bolHasPropValue: bolInd -> bolProp -> bolValue -> bolFormula.

Definition string_to_bolID := fun str => fromString str.
Definition bolID_to_ind := fun id => fromID id.
Definition bolID_to_rel := fun id => bolAtomicRel id.
Definition bolID_to_con := fun id => bolAtomicCon id.
Definition bolID_to_prop := fun id => bolAtomicProp id.

Coercion string_to_bolID: string >-> bolID.
Coercion bolID_to_ind:    bolID  >-> bolInd.
Coercion bolID_to_rel:    bolID  >-> bolRelation.
Coercion bolID_to_con:    bolID  >-> bolConcept.
Coercion bolID_to_prop:   bolID  >-> bolProp.

Definition nat_to_value := fun n => bolNaturalNumberValue n.
Coercion nat_to_value: nat >-> bolValue.

Definition bolSignature := list bolDecl.
Definition bolTheory := list bolFormula.
Definition bolOntology := (bolSignature * bolTheory)%type.
Definition bolQuery := (bolOntology * bolFormula)%type.

Notation "'CON' i"  := (bolConDecl i) (at level 60).
Notation "'IND' i"  := (bolIndDecl i) (at level 60).
Notation "'REL' i"  := (bolRelDecl i) (at level 60).
Notation "'PROP' i 'TYPE' t" := (bolPropDecl i t) (at level 60).

Notation "c1 '==' c2" := (bolEq c1 c2) (at level 60).
Notation "c1 '<<=' c2" := (bolSub c1 c2) (at level 60).
Notation "i 'IS-A' c" := (bolIsA i c) (at level 60).
Notation "i '<.' R '.>' j" := (bolInRel i R j) (at level 60).
Notation "i 'HAS' v 'OF' P" := (bolHasPropValue i P v) (at level 60).
Notation "i 'IS' P" := (bolHasPropValue i P (bolBoolValue true)) (at level 60).
Notation "i 'IS-NOT' P" := (bolHasPropValue i P (bolBoolValue false)) (at level 60).

Notation "c1 'U' c2" := (bolConUnion c1 c2) (at level 60).
Notation "c1 'C' c2" := (bolConIntersect c1 c2) (at level 60).
Notation "'dom' R" := (bolRelDom R) (at level 60).
Notation "'cod' R" := (bolRelCod R) (at level 60).
Notation "c 'forall' R" := (bolConForall R c) (at level 60).
Notation "c 'exists' R" := (bolConExists R c) (at level 60).

Notation "R1 'u' R2" := (bolRelUnion R1 R2) (at level 60).
Notation "R1 ';' R2" := (bolRelComp R1 R2) (at level 60).
Notation "R '*'" := (bolRelTrans R) (at level 60).
Notation "'inv' R" := (bolRelInv R) (at level 60).

Notation "d1 ';;' d2" :=  (cons d1 d2) (at level 80, right associativity, only parsing). (* ended by notation END below *)
Notation "'SIGNATURE' decls 'THEORY' formulae" := (decls, formulae) (at level 80, right associativity, only parsing).
Notation "'END'" := nil (at level 60, only parsing).

Definition bolDeclId (decl: bolDecl): bolID := match decl with
| bolIndDecl id => id
| bolConDecl id => id
| bolRelDecl id => id
| bolPropDecl id _ => id
end.

Definition bolIdEq (id id': bolID): bool := match id with
| fromString s => match id' with
  | fromString s' => eqb s s'
  end
end.


(* -------------------------------------------------------------------- *)
Require Import ssreflect ssrbool List.

Set Implicit Arguments.

Axiom todo : forall {A}, A.
Ltac todo := by apply: todo.

(* ==================================================================== *)
(* This template contains incomplete definitions that you have to       *)
(* fill. We always used the keyword `Definition` for all of them but    *)
(* you are free to change for a `Fixpoint` or an `Inductive`.           *)
(*                                                                      *)
(* If needed, it is perfectly fine to add intermediate definitions and  *)
(* local lemmas.                                                        *)

(* ==================================================================== *)
(* In this project, we are going to develop and prove correct an        *)
(* algorithm for deciding the membership of a word w.r.t. a given       *)
(* regular language - all these terms are going to be defined below     *)

(* This project lies in the domain of *formal languages*. The study     *)
(* of formal languages is a branch of theoretical computer science and  *)
(* is about that is interested in the purely syntactical aspects of     *)
(* of languages and as applications in different domains, ranging from  *)
(* the definition of  the grammar of programming languages to the field *)
(* of automated translation.                                            *)

(* As with natural languages, we first need to fix an alphabet. In our  *)
(* case, we are simply going to declare a type `A : Type` - i.e. we     *)
(* will use the same alphabet for all the formal languages we are going *)
(* to study. Inhabitants of `A` are called `letters`.                   *)

Parameter (A : Type).

(* -------------------------------------------------------------------- *)
(* A `word` is then simply a finite sequence of letters of `A`. We      *)
(* denote by A* the set of words over `A`. In Coq, we are going to      *)
(* represent words as lists whose elements are inhabitants of `A`. This *)
(* naturally leads to the following definition:                         *)

Notation word := (list A).

(* -------------------------------------------------------------------- *)
(* You can get an overview of the List library at the following URL:    *)
(* https://coq.inria.fr/distrib/current/stdlib/Coq.Lists.List.html      *)

(* -------------------------------------------------------------------- *)
(* In this setting, a `language` is simply a subset of A*. Assuming     *)
(* that `x` & `y` are letters of A, we can define the following         *)
(* languages:                                                           *)
(*                                                                      *)
(*  - the empty language: `L = ∅`;                                      *)
(*                                                                      *)
(*  - the language that contains only the empty word ε (i.e. the only   *)
(*    (word of length 0): L = {ε}`;                                     *)
(*                                                                      *)
(*  - the language that contains all the words solely composed of the   *)
(*    letter `x`: L = { ε, x, xx, xxx, ... } = { xⁿ | n ∈ ℕ } (here,    *)
(*    xⁿ stands for the word x…x, where x is repeated n times);         *)
(*                                                                      *)
(*  - the language that contains all the words of the form xⁿyⁿ:        *)
(*    L = { xⁿyⁿ | n ∈ ℕ };                                             *)
(*                                                                      *)
(*  - if we assume that A contains the letter '[' & ']', we can         *)
(*    define the language of well-balanced words for '[' & ']':         *)
(*    L = { w ∈ { [, ] }* | s.t. P(w) && Q(w) }, where                  *)
(*      - P(w) = any prefix of w contain no more ]'s then ['s           *)
(*      - Q(w) = the number of ['s and ]'s of w are equal.              *)

(* --------------------------------------------------------------------      *)
(* We can also combine languages to form other languages. For example,       *)
(* if L and G are languages, we can define:                                  *)
(*                                                                           *)
(*  - the union of L & G            L ∪ G                                    *)
(*  - the concatenation of L & G    { w1 · w2 | w1 ∈ L, w2 ∈ G }             *)
(*  - the intersection of L & G     L ∩ G                                    *)
(*  - the complement of L           A* \ L                                   *)
(*  - the Kleene closure of L       L* = { w_1 ... w_n | n \in ℕ, w_i ∈ L }  *)
(*  - the mirror of L               rev(L) = { rev(w) | w ∈ L }              *)

(* -------------------------------------------------------------------- *)
(* To define languages in Coq, we need a way to represent subsets       *)
(* of A*, i.e. subsets of the set of `word`'s. To that end, we are      *)
(* going to represent a set using its indicator function. (We remind    *)
(* that, given a subset F of an ambient set E, the indicator function   *)
(* of F is the function f_E from E to { ⊤, ⊥ } s.t.                     *)
(*                                                                      *)
(*                     f_E(x) = ⊤ iff x ∈ E                             *)

(* In Coq, the codomain of its indicator function is going to be a      *)
(* proposition: given a function `F : E -> Prop`, we say that x belongs *)
(* to `x` iff `f x` holds.                                              *)

Notation language := (word -> Prop).

(* -------------------------------------------------------------------- *)
(* From now use, we assume that L, G, H denote languages, x, y denote   *)
(* letters and that and w denotes a word.                               *)

Implicit Types (L G H : language) (x y : A) (w : word).

(* -------------------------------------------------------------------- *)
(* From there, we can define the following languages                    *)

(* The empty language: no words belong to it.                           *)
(* (its indicator function always return `False`)                       *)
Definition lang0 : language :=
  fun w => False.

(* The language that only contains the empty word.                      *)
Definition lang1 : language :=
  fun w => w = nil.

(* Q1. We now ask you to define the following languages                 *)

(*  Given a word `w0`, the language that only contains the word `w0`.   *)
(* EXPL: you check if the input word is exactly w0 *)
Definition langW w0 : language :=
  fun w => w = w0.

(* Given a sequence `ws` of words, the language that contains all the   *)
(* the words `ws` and only these words.                                 *)

(* EXPL: for all the words you check if they are in the desired ws list *)
Definition langF (ws : list word) : language :=
  fun w => In w ws.

(* Given a letter `x`, the language that only contains the letter `x`   *)
(* seen as a word of length 1.                                          *)

(* EXPL: since x is an input letter, you check if the word w is equal to
x in word form. But x is not in word form yet, so you append it to an
empty list (nil) and check*)
Definition langA x : language :=
  fun w => w = (cons x nil).

(* The union of the two languages `L` and `G`.                          *)
(* EXPL: if w is in L or in G then it is in their union *)
Definition langU L G : language :=
  fun w => L w \/ G w.

(* The intersection of the two languages `L` and `G`.                   *)
(* EXPL: if w is in L and G then it is in their intersection *)
Definition langI L G : language :=
  fun w => L w /\ G w.

(* The concatenation of the two languages `L` and `G`.                  *)
(* the concatenation of L & G    { w1 · w2 | w1 ∈ L, w2 ∈ G }           *)
(* EXPL: check if w = w1 + w2 and check the condition on the right (shown above) *)
Definition langS L G : language :=
  fun w => exists w1 w2, (app w1 w2) = w /\ L w1 /\ G w2.

(* The Kleene closure of the language `L`                               *)
(* the Kleene closure of L       L* = { w_1 ... w_n | n \in ℕ, w_i ∈ L }  *)
(* EXPL: the nicest way to do this is with an inductive def. Conceptually,
 the closure is all possible concatenations, so for instance if I have
 L = {a} then L* = nil, a, aa, aaa, aaaa, etc, for all n. Then the stuff
 below can be deduced intuitively. Another example, if L = {a,b} then
 a is clearly in the closure, b is clearly in the closure, then ab is also
 clearly in the closure (as it is a concatenation of two words in l, of
 total length 2. *)
Inductive langK L : language :=
  | langK_nil : langK L nil (* the empty word is in the closure *)
  | langK_one : forall w, L w -> langK L w (* if w is in L then it is in the closure *)
(* if w1 is in the closure then [ if w2 is in the closure, then the concatenation of them
  is in the closure] *)
  | langK_two : forall w1 w2, langK L w1 -> langK L w2 -> langK L (w1 ++ w2).

(* The mirror of the language `L` (You can use the `rev`, that reversed *)
(* a list, from the standard library. *)
(*  - the mirror of L               rev(L) = { rev(w) | w ∈ L } *)
(* EXPL: to check if a word is in the reverse language, we can check if its reverse
(kinda like the reverse of the reverse) is in the "original" language. Eg: if
L = {"apple"} and M (the reverse) = {"elppa"}, to check if "elppa" is in M we
check if "apple" is in L *)
Definition langM L : language :=
  fun w => L (rev w).

(* -------------------------------------------------------------------- *)
(* Given two languages, we will consider `L` & `G` equal iff they       *)
(* contain the same words:                                              *)

Definition eqL L G := forall w, L w <-> G w.

Infix "=L" := eqL (at level 90).

(* Q2. Prove the following equivalances:                                *)

Lemma concat0L L : langS lang0 L =L lang0.
(* concatenation, empty lang, L = L, empty lang *)
Proof.
split.
unfold lang0. unfold langS. (* write according to definition *)
move => [w1 [w2 h]]. (*says that (_:word) and w2 are words, and sets False /\ L w2 as the hyp *)
apply h. (* false is not provable alone, so we use h1. this works because false -> false and false -> true *)
(* i.e. prop starting w false is always true *)
unfold lang0. done. (* done tries to solve by trivial means, which works because we have false -> false *)
Qed.

Lemma concatL0 L : langS L lang0 =L lang0.
Proof.
(* follows the same logic as the one above.*)
split.
unfold lang0. unfold langS.
move => [w1 [w2 h]]. apply h.
(*h is now the other way around but we will either get true /\ false or false /\ false which are both false*)
(* so we can still use h*)
unfold lang0. done.
Qed.

Lemma concat1L L : langS lang1 L =L L.
Proof.
split.
unfold lang1. unfold langS.
move => [w1 [w2 [h1 [h2 h3]]]].
rewrite h2 in h1. simpl in h1. rewrite h1 in h3.
apply h3.
unfold lang1. unfold langS.
move => h.
exists nil. exists w.
done.
Qed.

Lemma concatL1 L : langS L lang1 =L L.
Proof.
split.
unfold lang1. unfold langS.
move => [w1 [w2 [h1 [h2 h3]]]].
rewrite h3 in h1. rewrite app_nil_r in h1. rewrite h1 in h2.   (* app_nil_r says that l ++ [] = l *)
apply h2.
unfold lang1. unfold langS.
move => h.
exists w. exists nil.
rewrite app_nil_r.
done. (* you can also split 3 times and see that the rest is trivial *)
Qed.

(************************* TO DO ****************************)
Lemma concatA L G H : langS (langS L G) H =L langS L (langS G H).
Proof.
split.
(* TO DO *)
Admitted.
(* ---------------------------------------------------------- *)

Lemma unionC L G : langU L G =L langU G L.
Proof.
split. unfold langU.
case. (* because of the "or" *)
move => h1. right. apply h1.
move => h2. left. apply h2.
unfold langU.
case.
move => h3. right. apply h3.
move => h4. left. apply h4.
Qed.

Lemma interC L G : langI L G =L langI G L.
Proof.
split.
unfold langI.
split. (* because of the "and" *)
apply H. apply H.
unfold langI.
split.
apply H. apply H.
Qed.

Lemma langKK L : langK (langK L) =L langK L.
Proof.
split.
move => h. induction h. (* so we can use the inductive def from earlier!! *)
apply langK_nil. apply H.
apply langK_two. apply IHh1. apply IHh2. (* both apply and assumption would work here *)
apply langK_one.
Qed.

(* Note that, since languages are represented as indicator functions    *)
(* over `Prop`, we cannot assess that `L =L G` implies `L = G`.         *)

(* ==================================================================== *)
(*                          REGULAR LANGUAGES                           *)

(* We are now interested in a subclass of languages called "regular     *)
(* languages": a language `L` is said to be regular iff one of the      *)
(* following holds:                                                     *)
(*                                                                      *)
(*  - L = ∅ or L = {ε} or L = {x} for some x ∈ A ;                      *)
(*  - L = L1 ∪ L2 for L1, L2 regular languages ;                        *)
(*  - L = L1 · L2 for L1, L2 regular languages ;                        *)
(*  - L = G* for G a regular language.                                  *)

(* This kind of inductive definitions can be encoded in Coq using       *)
(* an inductive predicate `regular : language -> Prop` s.t.             *)
(*                                                                      *)
(*             L is regular iff `regular L` holds                       *)

(* Q3. complete the following definition of the predicate `regular`:    *)

Inductive regular : language -> Prop :=
  (* Any language equivalent to a regular language is regular *)
| REq L G of regular L & G =L L : regular G

  (* The empty language is regular *)
| REmpty : regular lang0
| RVoid : regular lang1
| RAtom x: regular (langA x)
| RUnion L G of regular L & regular G: regular (langU L G)
| RConcat L G of regular L & regular G: regular (langS L G)
| RKleene G of regular G: regular (langK G)

(* TODO: to be completed *)
.

(* -------------------------------------------------------------------- *)
(* Q4. prove that `langW w` is regular.                                 *)
Lemma regularW w : regular (langW w).
Proof.
induction w.
move: REq => REq.
move: RVoid => RVoid.
apply REq with lang1.
done. done.
(**if (langS (langA a) (langW w)) and langW (a::w)
are equivalent then langW (a::w) is regular which is what we want**)
apply REq with (langS (langA a) (langW w)). (*this is easier*)
apply RConcat. (*splits things up*)
apply RAtom. apply IHw. (*deals with subgoals according to their form*)
split. (*splits equality into implications*)
move => lhs.
unfold langS. (*gives sth more explicit that we can work with*)
unfold langW in lhs. (*does the same but in the lhs*)
(*We need two words which when concatenated give a::w
such that the first word is in langA a and the second is in langW w*)
exists (a::nil). exists w.
split. simpl. rewrite lhs. trivial.
split. done. done.

unfold langS.
move => [w1 [w2]].
move => [sum [la lw]]. (*moves the ands separately*)
unfold langW.
unfold langA in la.
unfold langW in lw.
rewrite la in sum. (*rewrite to make something useful*)
rewrite lw in sum.
simpl in sum.
rewrite sum. trivial.
Qed.

(* -------------------------------------------------------------------- *)
(* Q5. prove that `langM L` is regular, given that L is regular.        *)
Lemma regularM L : regular L -> regular (langM L).
Proof.
move => rhs.
unfold langM.
Admitted.

(****************** CAROLINA WILL DO THE SECTION ABOVE ******************************)
(* I figured it was better if we split in half so we don't end up redoing the same
things twice or accidentally overwriting each other's code*)

(* ==================================================================== *)
(*                        REGULAR EXPRESSIONS                           *)

(* Related to regular languages is the notion of regular expressions.   *)
(* A regular expression is a formal, syntactic expression that can      *)
(* latter be interpreted as a regular language. Regular expressions are *)
(* pervasive in computer science, e.g. for searching for some text in   *)
(* a file, as it is possible with the `grep` command line tool.         *)
(*                                                                      *)
(* For instance, the command:                                           *)
(*                                                                      *)
(*    grep -E 'ab*a' foo.txt                                            *)
(*                                                                      *)
(* is going to print all the lines of `foo.txt` that contains a word    *)
(* of the form ab⋯ba (where the letter b can be repeated 0, 1 or more   *)
(* time. I.e., grep is going to find all the lines of `foo.txt` that    *)
(* contains a word that belongs in the formal language:                 *)
(*                                                                      *)
(*    L = { abⁿa | n ∈ ℕ }                                              *)
(*                                                                      *)
(* If you need to convince yourself that L is regular, note that:       *)
(*                                                                      *)
(*    L = { a } ∪ { b }* ∪ { a }                                        *)
(*                                                                      *)
(* In some sense, a regular expression is just a compact way to         *)
(* represent a regular language, and its definition is going to be      *)
(* close to the one of regular languages.                               *)
(*                                                                      *)
(* A regular expression is either:                                      *)
(*                                                                      *)
(*  - the constant ∅ or the constant ε or one letter from A             *)
(*  - the disjunction r1 | r2 of two regular expressions                *)
(*  - the concatenation r1 · r2 of two regular expressions              *)
(*  - the Kleene r* of some regular expression                          *)

(* We can represent regular expressions as a inductive type in Coq.     *)

(* Q6. complete the following definition:                               *)

Inductive regexp : Type :=
| RE_Empty : regexp
| RE_Void  : regexp
| RE_Atom  : A -> regexp
| RE_Disjunction : regexp -> regexp -> regexp
| RE_Concat  : regexp -> regexp -> regexp
| RE_Kleene  : regexp -> regexp
.

Implicit Types (r : regexp).

(* We now have to formally related regular expressions to regular       *)
(* languages. For that purpose, we are going to interpret a regular     *)
(* expression as a languages. If r is a regular expression, then we     *)
(* denote by language [r] as follows:                                   *)
(*                                                                      *)
(*   - [∅]       = ∅                                                    *)
(*   - [ε]       = ε                                                    *)
(*   - [a]       = { a } for a ∈ A                                      *)
(*   - [r₁ ∪ r₂] = [r₁] ∪ [r₂]                                          *)
(*   - [r₁ · r₂] = [r₁] · [r₂]                                          *)
(*   - [r*]      = [r]*                                                 *)

(* Q7. implement the Coq counterpart of the above definition:           *)

Fixpoint interp (r : regexp) {struct r} : language :=
  match r with
  | RE_Empty => lang0
  | RE_Void => lang1
  | RE_Atom A => langA A
  | RE_Disjunction r1 r2 => langU (interp r1) (interp r2)
  | RE_Concat r1 r2 => langS (interp r1) (interp r2)
  | RE_Kleene regexp => langK (interp regexp)
  end.

(* Q8. show that the interpretation of a regular expression is a        *)
(*     regular language:                                                *)

Lemma regular_regexp r : regular (interp r).
Proof. case r. simpl. apply REmpty. simpl. apply RVoid. todo. todo. todo. todo. Qed.

(* Q9. show that any regular language can be interpreted as a           *)
(*     regular expression:                                              *)

Lemma regexp_regular L : regular L -> exists r, L =L interp r.
Proof. todo. Qed.

(* Of course, it may happen that two regular expressions represent      *)
(* the same language: r1 ~ r2 iff [r1] = [r2].                          *)

(* Q10. write a binary predicate eqR : regexp -> regexp -> Prop s.t.    *)
(*      eqR r1 r2 iff r1 and r2 are equivalent regexp.                  *)

Definition eqR (r1 r2 : regexp) : Prop :=
  forall w, (interp r1) w <-> (interp r2) w.

Infix "~" := eqR (at level 90).

(* Q11. state and prove the following regexp equivalence:               *)
(*           (a|b)* ~ ( a*b* )*                                         *)
Lemma Q11 (a b : regexp): todo.
Proof. todo. Qed.

(* ==================================================================== *)
(*                          REGEXP MATCHING                             *)

(* We now want to write a algorithm for deciding if a given word `w`    *)
(* matches a regular expression `r`, i.e. for deciding wether `w ∈ [r]` *)
(*                                                                      *)
(* For that purpose, we are going to use Brzozowski's derivatives.      *)
(*                                                                      *)
(* The idea of the algorithm is the following:                          *)
(*                                                                      *)
(* Given a letter `x` and an regular expression `r`, the Brzozowski's   *)
(* derivatives of `x` w.r.t. `r` is a regular expression x⁻¹·r s.t.     *)
(*                                                                      *)
(*    x · w ∈ [r] ⇔ w ∈ [x⁻¹·r]                                         *)
(*                                                                      *)
(* Assuming that we can compute a Brzozowski's derivative for any       *)
(* letter `x` and regular expression `r`, one can check that a word `w` *)
(* matches a regexp `r` as follows:                                     *)
(*                                                                      *)
(*   - if w = x · w' for some letter x and word w', we recursively      *)
(*     check that `w` matches `x⁻¹·r`; otherwise                        *)
(*   - if w = ε, then we directly check that [r] contains the empty     *)
(*     word - a property that is deciable.                              *)

(* Q12. write a nullity test `contains0` : regexp -> bool s.t.          *)
(*                                                                      *)
(*      ∀ r, contains0 r ⇔ ε ∈ [e]                                      *)

Definition contains0 (r : regexp) : bool := todo.
  match r with
  | RE_Void => true
  | RE_Empty => false
  | _ => contains0 r
  end.

(* Q13. prove that your definition of `contains0` is correct:           *)

Lemma contains0_ok r : contains0 r <-> interp r nil.
Proof. todo. Qed.

(* We give below the definition of the Brzozowski's derivative:         *)
(*                                                                      *)
(*   - x⁻¹ · x         = ε                                              *)
(*   - x⁻¹ · y         = ∅ if x ≠ y                                     *)
(*   - x⁻¹ · ε         = ∅                                              *)
(*   - x⁻¹ · ∅         = ∅                                              *)
(*   - x⁻¹ · (r₁ | r₂) = (x⁻¹ · r₁) | (x⁻¹ · r₂)                        *)
(*   - x⁻¹ · (r₁ · r₂) = (x⁻¹ · r₁) · r₂ | E(r₁) · (x⁻¹ · r₂)           *)
(*   - x⁻¹ · r*        = (x⁻¹ · r) · r*                                 *)
(*                                                                      *)
(* where E(r) = ε if ε ∈ [r] & E(r) = ∅ otherwise.                      *)

(* Q14. write a function `Brzozowski` that computes a Brzozowski's      *)
(*      derivative as defined above.                                    *)
(*                                                                      *)
(* For that purpose, you may need to have a decidable equality over     *)
(* `A`. The parameter `Aeq` along with the axioms `Aeq_dec` give        *)
(* you such a decidable equality.                                       *)

Parameter Aeq : A -> A -> bool.

(* Here, `Aeq x y` has to be read as `Aeq x y = true`                   *)
Axiom Aeq_dec : forall (x y : A), Aeq x y <-> x = y.

Definition Brzozowski (x : A) (r : regexp) : regexp := todo.

(* Q15. write a function `rmatch` s.t. `rmatch r w` checks wether a     *)
(*      word `w` matches a given regular expression `r`.                *)

Definition rmatch (r : regexp) (w : word) : bool := todo.

(* Q16. show that the `Brzozowski` function is correct.                 *)

Lemma Brzozowski_correct (x : A) (w : word) (r : regexp) :
  interp (Brzozowski x r) w -> interp r (x :: w).
Proof. todo. Qed.

(* Q17. show that `rmatch` is correct.                                  *)

Lemma rmatch_correct (r : regexp) (w : word):
  rmatch r w -> interp r w.
Proof. todo. Qed.

(* Q18. (HARD - OPTIONAL) show that `rmatch` is complete.               *)

Lemma rmatch_complete (r : regexp) (w : word):
  interp r w -> rmatch r w.
Proof. todo. Qed.


Require Import Coq.omega.Omega.
Require Import Examples.AutoSep Examples.Malloc.

Definition bag := W * W -> nat.

Theorem W_W_dec : forall x y : W * W, {x = y} + {x <> y}.
  decide equality; apply weq.
Qed.

Definition mem (p : W * W) (b : bag) := (b p > 0)%nat.
Infix "%in" := mem (at level 70, no associativity).

Definition empty : bag := fun _ => O.

Definition equiv (b1 b2 : bag) := forall p, b1 p = b2 p.
Infix "%=" := equiv (at level 70, no associativity).

Definition add (b : bag) (p : W * W) : bag := fun p' => if W_W_dec p' p then S (b p') else b p'.
Infix "%+" := add (at level 50, left associativity).

Definition del (b : bag) (p : W * W) : bag := fun p' => if W_W_dec p' p then pred (b p') else b p'.
Infix "%-" := del (at level 50, left associativity).

Ltac bags := subst;
  repeat match goal with
           | [ H : _ %= _ |- _ ] => generalize dependent H
           | [ H : _ %in _ |- _ ] => generalize dependent H
           | [ H : ~ _ %in _ |- _ ] => generalize dependent H
           | [ H : _ \is _ |- _ ] => generalize dependent H
           | [ H : @eq W _ _ |- _ ] => generalize dependent H
           | [ H : ~(@eq W _ _) |- _ ] => generalize dependent H
         end; clear;
  unfold equiv, empty, mem, add, del, propToWord, IF_then_else; intuition idtac;
    repeat (match goal with
              | [ H : (_, _) = (_, _) |- _ ] => injection H; clear H; intros; subst
              | [ |- context[if ?E then _ else _] ] => destruct E; subst
              | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; subst
              | [ H : forall p : W * W, _ |- _ ] => rewrite H in *
            end; intuition idtac);
    try match goal with
          | [ |- _ \/ _ ] => right; intuition idtac
        end;
    repeat match goal with
             | [ H : forall p : W * W, _ |- _ ] => rewrite H in *
           end; auto; try (discriminate || omega).

Hint Extern 5 (_ %= _) => bags.
Hint Extern 5 (_ %in _) => bags.
Hint Extern 5 (~ _ %in _) => bags.
Hint Extern 5 (_ \is _) => bags.

Section adt.
  Variable P : bag -> W -> HProp.
  (* Abstract predicate for the data structure *)

  Variable res : nat.
  (* How many reserved stack slots? *)

  Definition initS : spec := SPEC reserving res
    PRE[_] mallocHeap
    POST[R] P empty R * mallocHeap.

  Definition isEmptyS : spec := SPEC("b") reserving res
    Al b,
    PRE[V] P b (V "b") * mallocHeap
    POST[R] [| (b %= empty) \is R |] * P b (V "b") * mallocHeap.

  Definition enqueueS : spec := SPEC("b", "v1", "v2") reserving res
    Al b,
    PRE[V] P b (V "b") * mallocHeap
    POST[_] P (b %+ (V "v1", V "v2")) (V "b") * mallocHeap.

  Definition dequeueS : spec := SPEC("b", "r") reserving res
    Al b,
    PRE[V] [| ~(b %= empty) |] * P b (V "b") * V "r" =?> 2 * mallocHeap
    POST[_] Ex v1, Ex v2, P (b %- (v1, v2)) (V "b") * (V "r" ==*> v1, v2) * mallocHeap.
End adt.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Sizing terms for induction. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax LibVarPathEnv.

Fixpoint size_t (tau : Tau) {struct tau} : nat :=
  match tau with
    | btvar i      => 1
    | ftvar x      => 1
    | cint         => 1
    | cross t0 t1  => (size_t t0) + (size_t t1)
    | arrow t0 t1  => (size_t t0) + (size_t t1)
    | ptype t0     => (size_t t0)
    | utype k t0   => (size_t t0)
    | etype p k t0 => (size_t t0)
  end.

Function size_tm_v (v : V) : nat :=  1.

Fixpoint size_tm_st (t : St) {struct t} : nat :=
  match t with
    | e_s  e       => 1 + size_tm_e e
    | retn e       => 1 + size_tm_e e
    | seq s0 s1    => 1 + (size_tm_st s0) + (size_tm_st s1)
    | if_s e s0 s1 => 1 + (size_tm_e e) + (size_tm_st s0) + (size_tm_st s1)
    | while e s0   => 1 + (size_tm_e e) + (size_tm_st s0)
    | letx e s     => 1 + (size_tm_e e) + (size_tm_st s)
    | open e s     => 1 + (size_tm_e e) + (size_tm_st s)
    | openstar e s => 1 + (size_tm_e e) + (size_tm_st s)
  end
with  size_tm_e (e : E) {struct e} : nat :=
  match e with
    | v_e v         => 1 + size_tm_v v
    | i_e  i        => 1
    | p_e x p       => 1
    | f_e f         => 1 + size_tm_f f
    | amp e         => 1 + size_tm_e e
    | star e        => 1 + size_tm_e e
    | cpair e0 e1   => 1 + (size_tm_e e0) + (size_tm_e e1)
    | dot e ipe     => 1 + size_tm_e e
    | assign e1 e2  => 1 + (size_tm_e e1) + (size_tm_e e2)
    | appl e1 e2    => 1 + (size_tm_e e1) + (size_tm_e e2)
    | call s        => 1 + size_tm_st s
    | inst e t      => 1 + (size_tm_e e) + (size_t t)
    | pack t0 e t1  => 1 + (size_t t0) + (size_tm_e e) + (size_t t1)
  end
with  size_tm_f (f : F) {struct f} : nat :=
  match f with
  | dfun t1 t2 s    => 1 + (size_t t1) + (size_t t2) + (size_tm_st s)
  | ufun k f        => 1 + size_tm_f f
end.

Function size_tm (t : Term) {struct t} : nat :=
  match t with
    | term_st s    => 1 + size_tm_st s
    | term_e  e    => 1 + size_tm_e e
    | term_f  f    => 1 + size_tm_f f
 end.


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

Require Import Undecidability.Synthetic.Undecidability.

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

From Undecidability.StackMachines.BSM
  Require Import tiles_solvable bsm_defs bsm_utils bsm_pcp.

From Undecidability.PCP
  Require Import PCP PCP_facts.

Set Default Proof Using "Type".

Fact tile_concat_itau ln lt : tile_concat ln lt = (itau1 lt (rev ln), itau2 lt (rev ln)).
Proof.
  induction ln as [ | i ln IH ]; simpl; auto.
  rewrite itau1_app, itau2_app; simpl.
  unfold card, string; generalize (nth i lt ([], [])); intros (a,b); rewrite IH.
  repeat rewrite <- app_nil_end; auto.
Qed.

(* tiles_solvable & iBPCP is the same predicate except that the existentially
   quantified list is reversed *)

Theorem tiles_solvable_iBPCP lt : tiles_solvable lt <-> iPCPb lt.
Proof.
  split.
  + intros (ln & H1 & H2 & H3).
    rewrite tile_concat_itau in H3.
    exists (rev ln).
    rewrite <- Forall_forall.
    repeat split; auto.
    * apply Forall_rev; auto.
    * contradict H1; rewrite <- (rev_involutive ln), H1; auto.
  + intros (ln & H1 & H2 & H3).
    exists (rev ln).
    rewrite tile_concat_itau, rev_involutive.
    repeat split; auto.
    * contradict H2; rewrite <- (rev_involutive ln), H2; auto.
    * apply Forall_rev, Forall_forall; auto.
Qed.

Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).
Local Notation "P // s ~~> t" := (sss_output (@bsm_sss _) P s t).
Local Notation "P // s ↓" := (sss_terminates (@bsm_sss _) P s).

Section iPCPb_to_BSM_HALTING.

  Let f (lt : list (card bool)) : BSM_PROBLEM.
  Proof.
    exists 4, 1, (pcp_bsm lt).
    exact (vec_set_pos (fun _ => nil)).
  Defined.

  Goal forall x, length(pcp_bsm x) >= 80.
  Proof.
    intros; rewrite pcp_bsm_size; lia.
  Qed.

  Theorem iPCPb_to_BSM_HALTING : iPCPb ⪯ BSM_HALTING.
  Proof.
    exists f.
    intros lt.
    rewrite <- tiles_solvable_iBPCP.
    unfold BSM_HALTING; split.
    * intros H.
      apply pcp_bsm_sound with (v := vec_set_pos (fun _ => nil)) in H.
      match type of H with  _ // _ ->> (?q,?w) => exists (q, w) end.
      split; auto.
      simpl; lia.
    * intros ((q & w) & H).
      apply pcp_bsm_complete in H; tauto.
  Qed.

End iPCPb_to_BSM_HALTING.


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime329719147332060395689499: prime 329719147332060395689499.
Proof.
 apply (Pocklington_refl
(Ell_certif
329719147332060395689499
8209062
((40165264598163841,1)::nil)
329719147332060395595419
9834496
0
3136)
((SPock_certif
40165264598163841
2
((303179835433, 1)::nil))
::
         (Pock_certif 303179835433 5 ((7951, 1)::(2,3)::nil) 59386) ::
         (Proof_certif 7951 prime7951) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Time Qed.


Section Witness.
  Variable f : nat -> bool.

  Inductive G (n: nat) : Prop :=
  | GI : (f n = false -> G (S n)) -> G n.

  Definition elim_G
    : forall p: nat -> Type, (forall n, (f n = false -> p (S n)) -> p n) -> forall n, G n -> p n
    := fun p g => fix F n a := let (h) := a in g n (fun e => F (S n) (h e)).

  Definition elim_GZ
    : forall Z, (forall n, (f n = false -> Z) -> Z) -> forall n, G n -> Z
    := fun Z p => fix F n a := let (h) := a in p n (fun e => F (S n) (h e)).


Require Import GLS_PSGLS_calcs.
Require Import List.
Export ListNotations.

Require Import genT.
Require Import ddT.
Require Import gen_tacs.
Require Import existsT.
Require Import univ_gen_ext.
Require Import dd_fc.
Require Import PeanoNat.
Require Import Lia.
Require Import GLS_PSGLS_remove_list.
Require Import GLS_PSGLS_list_lems.
Require Import List_lemmasT.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Hypothesis eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Lemma eq_dec_nat : forall (n m : nat), (n = m) + (n <> m).
Proof.
induction n.
- destruct m.
  * auto.
  * auto.
- intro m. destruct m.
  * auto.
  * destruct IHn with (m:=m).
    + left. lia.
    + right. lia.
Qed.

Lemma NoDup_incl_lengthT : forall (l l' : list MPropF), NoDup l -> incl l l' ->
          ((length l < length l') + (length l = length l')).
Proof.
induction l.
- intros. destruct l'.
  * right. auto.
  * left. simpl. lia.
- induction l' ; intros.
  * exfalso. assert (In a (a :: l)). apply in_eq. pose (H0 a H1). inversion i.
  * simpl. destruct (eq_dec_form a a0).
    + subst. assert (NoDup l). inversion H. assumption. assert (incl l l').
      unfold incl. intros. assert (In a (a0 :: l)). apply in_cons. assumption.
      apply H0 in H3. inversion H3. subst. exfalso. inversion H. apply H6. assumption. assumption.
      pose (IHl _ H1 H2). destruct s. left. lia. right. lia.
    + destruct (In_dec l a0).
      { destruct (In_dec l' a0).
        - assert (NoDup l). inversion H. assumption. assert (incl l l'). unfold incl.
          intros. assert (In a1 (a :: l)). apply in_cons. assumption. apply H0 in H3.
          inversion H3. subst. assumption. assumption. pose (IHl _ H1 H2). destruct s.
          left. lia. right. lia.
        - assert (NoDup l). inversion H. assumption. assert (incl l (a0 :: l')).
          unfold incl. intros. assert (In a1 (a :: l)). apply in_cons. assumption.
          apply H0 in H3. assumption. assert (In a l'). assert (In a (a :: l)).
          apply in_eq. apply H0 in H3. inversion H3. subst. exfalso. apply n. reflexivity.
          assumption. apply in_split in H3. destruct (eq_dec_nat (length l) (length l')).
          * subst. right. auto.
          * left. destruct H3. destruct H3. subst.
            rewrite app_length. simpl. assert (incl l (a0 :: x ++ x0)). unfold incl.
            intros. assert (In a1 (a :: l)). apply in_cons. assumption. apply H0 in H4.
            inversion H4. subst. apply in_eq. apply in_app_or in H5. destruct H5.
            apply in_cons. apply in_or_app. auto. inversion H5. subst. exfalso. inversion H.
            apply H8. assumption. apply in_cons. apply in_or_app. auto.
            rewrite app_length in n0. simpl in n0.
            pose (IHl _ H1 H3). destruct s.
            + simpl in l0. rewrite app_length in l0. lia.
            + exfalso. apply n0. simpl in e. rewrite app_length in e. lia.  }
      { assert (incl l l'). unfold incl. intros. assert (In a1 (a :: l)). apply in_cons. assumption.
        apply H0 in H2. inversion H2. subst. exfalso. apply f. assumption. assumption.
        assert (NoDup l). inversion H. assumption. pose (IHl _ H2 H1). destruct s.
        - left. lia.
        - right. lia. }
Qed.

(* First, let us define a the second part of our measure. This number is simply
   the number of implication symbols in a sequent.

   To define it, we need to define the number of implications in a formula. *)

Fixpoint n_imp_subformF (A : MPropF) : nat :=
match A with
 | # P => 0
 | ⊥ => 0
 | Imp B C => 1 + (n_imp_subformF B) + (n_imp_subformF C)
 | Box B => (n_imp_subformF B)
end.

(* With this definition in hand, we can then straightforwardly define the number
   of implications in a list of formulae. *)

Fixpoint n_imp_subformLF (l : list MPropF) : nat :=
match l with
  | [] => 0
  | h :: t => (n_imp_subformF h) + (n_imp_subformLF t)
end.

(* The the definition we were initially looking for can be reached: *)

Definition n_imp_subformS (s : Seq) : nat :=
    (n_imp_subformLF (fst s)) + (n_imp_subformLF (snd s)).

(* It is clear that n_imp_subformS counts the occurrences of implications in a
   sequent s. As a consequence, if that number is 0 we know for sure that the
   rules for implication on the left or right cannot be applied upwards on s.
   This is the meaning of the lemma n_imp_subformS_is_0.

   But first we need a preliminary lemma which claims that if an implication is
   in a list, then n_imp_subformLF of that list is higher than one.*)

Lemma In_n_imp_subformLF_is_non_0 (l : list MPropF) :
    forall A B, (In (Imp A B) l) -> (le 1 (n_imp_subformLF l)).
Proof.
intros A B Hin. induction l.
- inversion Hin.
- inversion Hin.
  * subst. simpl. apply Le.le_n_S. apply le_0_n.
  * pose (IHl H). simpl. destruct l0.
    + rewrite Nat.add_1_r. apply Le.le_n_S. apply le_0_n.
    + rewrite <- plus_n_Sm. apply Le.le_n_S. apply le_0_n.
Qed.

Theorem n_imp_subformS_is_0 (s : Seq) :
    (n_imp_subformS s) = 0 -> (existsT2 ps, (ImpRRule ps s) + (ImpLRule ps s)) -> False.
Proof.
intros is0 RA. destruct RA. destruct s0.
- inversion i. subst. unfold n_imp_subformS in is0. simpl in is0.
  assert (n_imp_subformLF (Δ0 ++ A → B :: Δ1) = 0). lia.
  assert (In (A → B) (Δ0 ++ A → B :: Δ1)). apply in_or_app. right. apply in_eq.
  pose (In_n_imp_subformLF_is_non_0 (Δ0 ++ A → B :: Δ1) A B H0). lia.
- inversion i. subst.
  assert (In (A → B) (Γ0 ++ A → B :: Γ1)). apply in_or_app. right. apply in_eq.
  pose (In_n_imp_subformLF_is_non_0 (Γ0 ++ A → B :: Γ1) A B H). unfold n_imp_subformS in is0.
  simpl in is0. assert (n_imp_subformLF (Δ0 ++ Δ1) = 0). lia. lia.
Qed.

Lemma n_imp_subformLF_dist_app : forall l1 l2, n_imp_subformLF (l1 ++ l2) =
                                               plus (n_imp_subformLF l1) (n_imp_subformLF l2).
Proof.
induction l1.
- intros. auto.
- intros. simpl. rewrite IHl1. lia.
Qed.

(* Second, we intend to define the notion of usable boxed formulae in a sequent. We also
   prove that if this measure is 0 then no GLR rule can be applied to this sequent.

   In the next definitions our aim is to define the list of all boxed subformulae (not
   occurrences) of all the formulae in a sequent. *)

Fixpoint subform_boxesF (A : MPropF) : list MPropF :=
match A with
 | # P => nil
 | ⊥ => nil
 | Imp B C => (subform_boxesF B) ++ (remove_list (subform_boxesF B) (subform_boxesF C))
 | Box B => (Box B) :: (subform_boxesF B)
end.

Fixpoint subform_boxesLF (l : list MPropF) : list MPropF :=
match l with
  | nil => nil
  | h :: t => (subform_boxesF h) ++ (remove_list (subform_boxesF h) (subform_boxesLF t))
end.

Definition subform_boxesS (s : Seq) : list MPropF :=
  (subform_boxesLF (fst s)) ++ (remove_list (subform_boxesLF (fst s)) (subform_boxesLF (snd s))).

Lemma In_subform_boxesF_box : forall (A B : MPropF), In A (subform_boxesF B) -> is_boxedT A.
Proof.
unfold is_boxedT. intros A B. generalize dependent A. induction B ; intros.
- simpl in H. destruct H.
- simpl in H. destruct H.
- simpl in H. apply in_app_or in H. destruct H.
  * apply IHB1 in H. assumption.
  * assert (In A (subform_boxesF B2)). apply In_remove_list_In_list in H. assumption.
    apply IHB2 in H0. assumption.
- simpl in H. destruct H. exists B. auto. apply IHB in H. assumption.
Qed.

Lemma In_subform_boxesLF_box : forall (A : MPropF) l, In A (subform_boxesLF l) -> is_boxedT A.
Proof.
unfold is_boxedT. intros A l. generalize dependent A. induction l ; intros.
- simpl in H. destruct H.
- simpl in H. apply in_app_or in H. destruct H. apply In_subform_boxesF_box in H. assumption.
  apply In_remove_list_In_list in H. apply IHl. assumption.
Qed.

(* Then next lemmas help us reach our goal. *)

Fixpoint length_form (a: MPropF) : nat :=
match a with
  | # v => 1
  | ⊥ => 1
  | Imp a0 a1 => S (length_form a0 + length_form a1)
  | Box a0 => S (length_form a0)
end.

Lemma S_le_False : forall (n : nat), S n <= n -> False.
Proof.
induction n.
- intro. inversion H.
- intro. apply Le.le_S_n in H. apply IHn. assumption.
Qed.

Lemma in_subform_boxesF_smaller_length_form : forall (A B : MPropF), In A (subform_boxesF B) ->
                (length_form A <= length_form B).
Proof.
intros A B. generalize dependent A. induction B; intros .
- simpl. inversion H.
- simpl. inversion H.
- simpl. simpl in H. apply in_app_or in H. destruct H.
  * apply IHB1 in H. lia.
  * assert (In A (subform_boxesF B2)). apply In_remove_list_In_list in H. assumption.
    apply IHB2 in H0. lia.
- simpl in H. destruct H. subst. auto. apply IHB in H. simpl. apply le_S. assumption.
Qed.

Lemma contradic_subform_boxesF: forall A l, (l = (subform_boxesF A)) -> (In (Box A) l)  -> False.
Proof.
intros. subst. pose (in_subform_boxesF_smaller_length_form (Box A) A H0).
inversion l.
- apply eq_S_F in H1. assumption.
- simpl in l. apply S_le_False in l. assumption.
Qed.

Lemma NoDup_subform_boxesF : forall A, NoDup (subform_boxesF A).
Proof.
induction A.
- simpl. apply NoDup_nil.
- simpl. apply NoDup_nil.
- simpl. apply add_remove_list_preserve_NoDup. apply IHA1. apply IHA2.
- simpl. apply NoDup_cons. intro. apply contradic_subform_boxesF in H. assumption.
  reflexivity. apply IHA.
Qed.

Lemma subform_boxesLF_dist_app : forall l1 l2,
        (subform_boxesLF (l1 ++ l2)) =
        (subform_boxesLF l1) ++ (remove_list (subform_boxesLF l1) (subform_boxesLF l2)).
Proof.
induction l1.
- intros l2. simpl. reflexivity.
- intros l2. simpl. rewrite IHl1. repeat rewrite <- app_assoc.
  assert (E: remove_list (subform_boxesF a) (subform_boxesLF l1 ++
             remove_list (subform_boxesLF l1) (subform_boxesLF l2)) =
             remove_list (subform_boxesF a) (subform_boxesLF l1) ++
             remove_list (subform_boxesF a ++ remove_list (subform_boxesF a)
             (subform_boxesLF l1)) (subform_boxesLF l2)).
  { rewrite app_remove_list. rewrite redund_remove_list. rewrite <- remove_list_dist_app. reflexivity. }
  rewrite E. reflexivity.
Qed.

Lemma NoDup_subform_boxesLF : forall l, NoDup (subform_boxesLF l).
Proof.
induction l.
- intros. simpl. apply NoDup_nil.
- intros. simpl. apply add_remove_list_preserve_NoDup. apply NoDup_subform_boxesF.
  apply IHl.
Qed.

Lemma NoDup_subform_boxesS : forall s, NoDup (subform_boxesS s).
Proof.
intro s. unfold subform_boxesS. apply add_remove_list_preserve_NoDup ;
apply NoDup_subform_boxesLF.
Qed.

Lemma univ_gen_ext_incl_subform_boxes : forall l1 l2 P, (univ_gen_ext P l1 l2) ->
                                          incl (subform_boxesLF l1) (subform_boxesLF l2).
Proof.
intros. induction X.
- unfold incl. intros. auto.
- unfold incl. intros. simpl in H. simpl. apply in_app_or in H. destruct H.
  * apply in_or_app. left. assumption.
  * apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
    apply in_or_app. right. apply not_removed_remove_list. apply IHX. assumption.
    assumption.
- unfold incl. intros. simpl. destruct (In_dec (subform_boxesF x) a).
  * apply in_or_app. left. assumption.
  * apply in_or_app. right. apply not_removed_remove_list. apply IHX. assumption.
    assumption.
Qed.

Lemma XBoxed_list_same_subform_boxes : forall l,
          incl (subform_boxesLF (XBoxed_list l)) (subform_boxesLF l) /\
          incl (subform_boxesLF l) (subform_boxesLF (XBoxed_list l)).
Proof.
induction l.
- split.
  * unfold incl. intros. simpl in H. inversion H.
  * unfold incl. intros. simpl in H. inversion H.
- split.
  * unfold incl. intros. simpl. simpl in H. apply in_app_or in H. destruct H.
    apply in_or_app. left. destruct a ; simpl in H ; try contradiction.
    simpl. assumption. simpl. right. assumption. apply In_remove_list_In_list in H.
    apply in_app_or in H. destruct H. apply in_or_app. left. assumption. apply in_or_app.
    right. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. destruct IHl.
    apply H1 in H. apply not_removed_remove_list ; assumption.
  * destruct IHl. unfold incl. intros. simpl in H1. apply in_app_or in H1. destruct H1.
    destruct a ; simpl in H1 ; try contradiction. apply in_app_or in H1. destruct H1.
    simpl. apply in_or_app. left. apply in_or_app. left. assumption. apply
    In_remove_list_In_list_not_In_remove_list in H1. destruct H1. simpl. apply in_or_app.
    left. apply in_or_app. right. apply not_removed_remove_list ; assumption. destruct H1.
    subst. simpl. apply in_or_app. right. apply not_removed_remove_list. apply in_eq.
    intros. apply contradic_subform_boxesF in H1. assumption. auto. simpl. apply in_or_app.
    left. assumption. simpl. apply in_or_app. right. rewrite remove_list_dist_app.
    apply in_or_app. right. apply not_removed_remove_list. apply
    In_remove_list_In_list_not_In_remove_list in H1. destruct H1. apply H0 in H1.
    apply not_removed_remove_list ; assumption. intro. apply
    In_remove_list_In_list_not_In_remove_list in H1. destruct H1. destruct a ; simpl ; try assumption.
    simpl (unBox_formula (a1 → a2)) in H2. firstorder. simpl (unBox_formula (Box a)) in H2.
    apply H3. simpl. right. assumption.
Qed.

Lemma In_incl_subform_boxes : forall l A, In A l ->
                  (forall B, In B (subform_boxesF A) -> In B (subform_boxesLF l)).
Proof.
induction l.
- intros. inversion H.
- intros. simpl. inversion H.
  * subst. apply in_or_app. left. assumption.
  * pose (IHl A H1). destruct (In_dec (subform_boxesF a) B).
    + apply in_or_app. left. assumption.
    + apply in_or_app. right. apply not_removed_remove_list. apply i. assumption.
      assumption.
Qed.

(* Now we can define the notion of usable boxed formulae: it is a one such that
   it does not appear as a top formula in the LHS of the sequent. To do so, we need to
   define the list of such formulae: *)

Fixpoint top_boxes (l : list MPropF) : list MPropF :=
match l with
  | nil => nil
  | h :: t => match h with
                | Box A => (Box A) :: top_boxes t
                | _ => top_boxes t
              end
end.

Lemma top_boxes_distr_app : forall (l1 l2 : list MPropF),
      top_boxes (l1 ++ l2) = (top_boxes l1) ++ (top_boxes l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct a ; try apply IHl1.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma top_boxes_incl_list : forall l, incl (top_boxes l) l.
Proof.
induction l.
- simpl. unfold incl. intros. inversion H.
- unfold incl. intros. destruct a.
  * simpl in H. apply in_cons. apply IHl. assumption.
  * simpl in H. apply in_cons. apply IHl. assumption.
  * simpl in H. apply in_cons. apply IHl. assumption.
  * simpl in H. destruct H.
    + subst. apply in_eq.
    + apply in_cons. apply IHl. assumption.
Qed.

Lemma in_top_boxes : forall l A, (In A (top_boxes l)) -> (existsT2 B l1 l2, (A = Box B) * (l = l1 ++ A :: l2)).
Proof.
induction l.
- intros. simpl in H. inversion H.
- intros. destruct a.
  * simpl in H. apply IHl in H. destruct H. destruct s. destruct s. destruct p. subst.
    exists x. exists ([# v] ++ x0). exists x1. auto.
  * simpl in H. apply IHl in H. destruct H. destruct s. destruct s. destruct p. subst.
    exists x. exists ([⊥] ++ x0). exists x1. auto.
  * simpl in H. apply IHl in H. destruct H. destruct s. destruct s. destruct p. subst.
    exists x. exists ([a1 → a2] ++ x0). exists x1. auto.
  * simpl (top_boxes (Box a :: l)) in H. destruct (eq_dec_form (Box a) A).
    + subst. exists a. exists []. exists l. auto.
    + subst. assert (H0 : In A (top_boxes l)). inversion H. exfalso. apply n. assumption.
      assumption. apply IHl in H0. destruct H0. destruct s. destruct s. destruct p.
      subst. exists x. exists ([Box a] ++ x0). exists x1. auto.
Qed.

Lemma box_in_top_boxes : forall l1 l2 A, existsT2 l3 l4, top_boxes (l1 ++ Box A :: l2) = l3 ++ Box A :: l4.
Proof.
intros. exists (top_boxes l1). exists (top_boxes l2). rewrite top_boxes_distr_app. auto.
Qed.

Lemma box_preserv_top_boxes : forall l1 l2 l3 A, top_boxes l1 = l2 ++ Box A :: l3 ->
                                existsT2 l4 l5, l1 = l4 ++ Box A :: l5.
Proof.
induction l1.
- intros. simpl in H. destruct l2 ; inversion H.
- induction l2.
  * intros. rewrite app_nil_l in H. destruct a.
    + pose (IHl1 [] l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([# v] ++ x).
      exists x0. subst. auto.
    + pose (IHl1 [] l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([⊥] ++ x).
      exists x0. subst. auto.
    + pose (IHl1 [] l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([a1 → a2] ++ x).
      exists x0. subst. auto.
    + inversion H. exists []. exists l1. auto.
  * intros. destruct a.
    + simpl in H. pose (IHl1 (a0 :: l2) l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([# v] ++ x).
      exists x0. subst. auto.
    + simpl in H. pose (IHl1 (a0 :: l2) l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([⊥] ++ x).
      exists x0. subst. auto.
    + simpl in H. pose (IHl1 (a0 :: l2) l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([a1 → a2] ++ x).
      exists x0. subst. auto.
    + inversion H. apply IHl1 in H2. destruct H2. destruct s. subst. exists (Box a :: x). exists x0. auto.
Qed.

Lemma removed_box_exists : forall l1 l2 l3 A,
    (remove_list (top_boxes l1) (top_boxes (l2 ++ Box A :: l3))) = nil ->
    (existsT2 l4 l5, l1 = l4 ++ Box A :: l5).
Proof.
intros. pose (box_in_top_boxes l2 l3 A). repeat destruct s. rewrite e in H.
remember (top_boxes l1) as l. apply remove_list_in_nil in H. destruct H.
destruct s. subst. apply box_preserv_top_boxes in e0. assumption.
Qed.

Lemma is_box_in_top_boxes : forall l A, In A l -> is_boxedT A -> In A (top_boxes l).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  * subst. inversion X. subst. simpl. left. reflexivity.
  * pose (IHl A H0 X). destruct a ; simpl ; try assumption.
    right. assumption.
Qed.

(* Some more 'macro' lemmas dealing with subform_boxes and top_boxes. *)

Lemma RHS_top_box_is_subformLF : forall (s : Seq) (A : MPropF),
        (In A (top_boxes (snd s))) -> (In A (subform_boxesLF (snd s))).
Proof.
intros s A H. apply in_top_boxes in H. destruct H. repeat destruct s0. destruct p. subst. rewrite e0.
rewrite subform_boxesLF_dist_app. apply in_or_app. pose (In_dec (subform_boxesLF x0) (Box x)).
destruct s0.
- left. assumption.
- right. apply not_removed_remove_list.
  * simpl. left. reflexivity.
  * assumption.
Qed.

Lemma RHS_top_box_is_subform : forall s A, (In A (top_boxes (snd s))) -> (In A (subform_boxesS s)).
Proof.
intros s A H. unfold subform_boxesS. apply RHS_top_box_is_subformLF in H.
apply remove_list_is_in with (l2:=subform_boxesLF (fst s)) in H. assumption.
Qed.

(* Finally, we can define the list of usable boxed formulae. The length of that list is
   the first component of our measure. *)

Definition usable_boxes (s : Seq) : list MPropF :=
   remove_list (top_boxes (fst s)) (subform_boxesS s).

(* We can show that our notion of usable box effectively captures what it is intended to:
   an upper bound on how many GLR rules can be applied to a sequent. To check this, we can
   show that if the number of usable boxes is effectively 0 then no GLR is applicable. This
   is the content of the lemma length_usable_boxes_is_0. *)

Lemma no_RHS_box_no_GLR (s : Seq) :
    (top_boxes (snd s)) = nil -> (existsT2 ps, GLRRule ps s) -> False.
Proof.
intros isnil RA. destruct RA. inversion g. subst. simpl in isnil.
rewrite top_boxes_distr_app in isnil. apply app_eq_nil in isnil. destruct isnil.
simpl in H1. inversion H1.
Qed.

Lemma all_RHS_boxes_are_LHS_boxes_no_GLR (s : Seq) :
    (IdBRule [] s -> False) ->  (* This line makes sure that we do PS: no IdB can happen. *)
    (remove_list (top_boxes (fst s)) (top_boxes (snd s))) = nil ->
    (existsT2 ps, GLRRule ps s) -> False.
Proof.
intros noId isnil RA. destruct RA. inversion g. subst. simpl in isnil.
apply noId. apply removed_box_exists in isnil. destruct isnil. destruct s.
subst. apply IdBRule_I.
Qed.

Lemma no_usable_boxes_all_RHS_are_LHS (s : Seq) :
    length (usable_boxes s) = 0 -> (remove_list (top_boxes (fst s)) (top_boxes (snd s))) = nil.
Proof.
intro is0. remember (usable_boxes s) as l. destruct l.
- unfold usable_boxes in Heql. symmetry in Heql. rewrite remove_list_is_nil in Heql.
  rewrite remove_list_is_nil. intros. apply RHS_top_box_is_subform in H. apply Heql. assumption.
- inversion is0.
Qed.

Theorem length_usable_boxes_is_0 (s : Seq) :
    length (usable_boxes s) = 0 ->
    (IdBRule [] s -> False) ->
    (existsT2 ps, GLRRule ps s) -> False.
Proof.
intros H0 H1. pose (no_usable_boxes_all_RHS_are_LHS s H0).
pose (all_RHS_boxes_are_LHS_boxes_no_GLR H1 e). assumption.
Qed.

Lemma NoDup_usable_boxes : forall s, NoDup (usable_boxes s).
Proof.
intro s. unfold usable_boxes. destruct s. simpl. unfold subform_boxesS.
simpl. pose (NoDup_subform_boxesLF l0). pose (NoDup_subform_boxesLF l).
pose (add_remove_list_preserve_NoDup n0 n). apply remove_list_preserv_NoDup.
assumption.
Qed.

(* We can consequently define our measure on sequents: *)

Definition term_meas (s : Seq) : nat * nat :=
  pair (length (usable_boxes s)) (n_imp_subformS s).

(* Third, we need to prove that if no PSGLS rule is applicable to a sequent s,
   then its derivations have a height equal to 0. *)

Theorem no_PSGLS_rule_applic : forall s, (forall ps, (PSGLS_rules ps s) -> False) ->
                                 forall (D : PSGLS_drv s), derrec_height D = 0.
Proof.
intros s noRA D. induction D.
- auto.
- exfalso. apply noRA with (ps:=ps). assumption.
Qed.

(* Fourth, we show that the number of usable boxes decreases upwards in the application
   of a GLR rule. To do so we need to prove some lemmas beforehand. *)

Lemma GLR_applic_more_top_boxes : forall prem concl, GLRRule [prem] concl ->
                                                     (IdBRule [] concl -> False) ->
                                    incl (top_boxes (fst concl)) (top_boxes (fst prem)).
Proof.
intros prem concl RA noIdB. inversion RA. subst. simpl. rewrite top_boxes_distr_app.
simpl. unfold incl. intros. apply in_or_app. left. assert (In a Γ0). apply in_top_boxes in H.
destruct H. repeat destruct s. destruct p. subst. apply in_or_app. right. apply in_eq.
assert (InT a Γ0). apply in_splitT in H1. destruct H1. destruct s. rewrite e.
apply InT_or_app. right. apply InT_eq. pose (InT_univ_gen_ext H2 X). destruct s.
exfalso. apply f. apply in_top_boxes in H. destruct H. repeat destruct s.
destruct p. exists x. assumption. apply top_boxes_incl_list in H.
pose (list_preserv_XBoxed_list BΓ). pose (InT_In i). apply i0 in i1.
apply is_box_in_top_boxes. apply i0. apply InT_In. assumption.
apply H0. apply InT_In. assumption.
Qed.

Lemma GLR_applic_le_subform_boxes : forall prem concl, GLRRule [prem] concl ->
                                                        (IdBRule [] concl -> False) ->
                        (length (subform_boxesS prem) <= length (subform_boxesS concl) /\
                         forall B, (In B (subform_boxesS prem)) -> (In B (subform_boxesS concl))).
Proof.
intros prem concl RA noIdB. inversion RA. subst. split.
- apply NoDup_incl_length.
  * apply NoDup_subform_boxesS.
  * intro. intros. unfold subform_boxesS in H. unfold subform_boxesS. simpl. simpl in H.
    repeat rewrite app_length.  repeat rewrite app_length in H. repeat rewrite remove_list_of_nil.
    repeat rewrite remove_list_of_nil in H. rewrite app_nil_r in H. apply in_app_or in H.
    destruct H. rewrite subform_boxesLF_dist_app in H. apply in_app_or in H. destruct H.
    apply in_or_app. left. apply univ_gen_ext_incl_subform_boxes in X. apply X. pose (XBoxed_list_same_subform_boxes BΓ).
    destruct a0. apply H1. assumption. apply In_remove_list_In_list in H.
    apply remove_list_is_in. rewrite subform_boxesLF_dist_app. apply remove_list_is_in.
    simpl. simpl in H. destruct H. left. assumption. right. repeat rewrite remove_list_of_nil in H.
    apply in_app_or in H. destruct H. apply in_or_app. auto. simpl in H. destruct H.
    apply remove_list_is_in. apply In_remove_list_In_list in H. rewrite subform_boxesLF_dist_app.
    apply remove_list_is_in. simpl. right. apply in_or_app. auto.
- intro. intros. unfold subform_boxesS in H. unfold subform_boxesS. simpl. simpl in H.
  repeat rewrite app_length.  repeat rewrite app_length in H. repeat rewrite remove_list_of_nil.
  repeat rewrite remove_list_of_nil in H. rewrite app_nil_r in H. apply in_app_or in H.
  destruct H. rewrite subform_boxesLF_dist_app in H. apply in_app_or in H. destruct H.
  apply in_or_app. left. apply univ_gen_ext_incl_subform_boxes in X. apply X. pose (XBoxed_list_same_subform_boxes BΓ).
  destruct a. apply H1. assumption. apply In_remove_list_In_list in H.
  apply remove_list_is_in. rewrite subform_boxesLF_dist_app. apply remove_list_is_in.
  simpl. simpl in H. destruct H. left. assumption. right. repeat rewrite remove_list_of_nil in H.
  apply in_app_or in H. destruct H. apply in_or_app. auto. simpl in H. destruct H.
  apply remove_list_is_in. apply In_remove_list_In_list in H. rewrite subform_boxesLF_dist_app.
  apply remove_list_is_in. simpl. right. apply in_or_app. auto.
Qed.

Theorem GLR_applic_less_usable_boxes : forall prem concl, GLRRule [prem] concl ->
                                                          (IdBRule [] concl -> False) ->
                                         length (usable_boxes prem) < length (usable_boxes concl).
Proof.
intros prem concl RA noIdB. inversion RA. unfold usable_boxes. simpl.
apply remove_list_incr_decr.
- apply NoDup_subform_boxesS.
- apply NoDup_subform_boxesS.
- exists (Box A). repeat split. simpl. rewrite top_boxes_distr_app. apply in_or_app. right. simpl.
  left. reflexivity. unfold subform_boxesS. simpl.
  destruct (In_dec (subform_boxesLF Γ0) (Box A)). apply in_or_app. left. assumption.
  apply in_or_app. right. apply not_removed_remove_list. rewrite subform_boxesLF_dist_app.
  destruct (In_dec (subform_boxesLF Δ0) (Box A)). apply in_or_app. left. assumption.
  apply in_or_app. right. apply not_removed_remove_list. simpl. auto. assumption. assumption.
  intro. simpl in H2. apply noIdB. subst. pose (in_top_boxes Γ0 (Box A) H2). repeat destruct s.
  destruct p. subst. apply IdBRule_I.
- intro A0. pose (@GLR_applic_more_top_boxes prem concl). subst. pose (i RA). pose (i0 noIdB).
  apply i1.
- intro A0. subst. pose (GLR_applic_le_subform_boxes RA noIdB). destruct a. apply H1.
Qed.

Theorem ImpR_applic_less_Imp_same_usable_boxes : forall prem concl, ImpRRule [prem] concl ->
                   prod (sum (length (usable_boxes prem) < length(usable_boxes concl))
                    (length (usable_boxes prem) = length(usable_boxes concl)))
                   (n_imp_subformS (prem) < n_imp_subformS (concl)).
Proof.
intros prem concl RA. inversion RA. subst. split.
- pose (NoDup_usable_boxes (Γ0 ++ A :: Γ1, Δ0 ++ B :: Δ1)).
  pose (NoDup_usable_boxes (Γ0 ++ Γ1, Δ0 ++ A → B :: Δ1)).
  apply NoDup_incl_lengthT. assumption. unfold incl. intros. unfold usable_boxes in H. simpl in H.
  unfold usable_boxes. simpl. apply In_remove_list_In_list_not_In_remove_list in H.
  destruct H. apply not_removed_remove_list. unfold subform_boxesS. unfold subform_boxesS in H.
  simpl. simpl in H. apply in_app_or in H. destruct H. rewrite subform_boxesLF_dist_app in H.
  apply in_app_or in H. destruct H. apply in_or_app. left. rewrite subform_boxesLF_dist_app.
  apply in_or_app. left. assumption. apply In_remove_list_In_list_not_In_remove_list in H.
  destruct H. simpl in H. apply in_app_or in H. destruct H. destruct (In_dec (subform_boxesLF (Γ0 ++ Γ1)) a).
  apply in_or_app. left. assumption. apply in_or_app. right. apply not_removed_remove_list.
  2: assumption. apply In_incl_subform_boxes with (A:=A → B). apply in_or_app. right. apply in_eq.
  simpl. apply in_or_app. left.
  assumption. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. apply in_or_app. left.
  rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list. assumption.
  assumption. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. rewrite subform_boxesLF_dist_app in H.
  apply in_app_or in H. destruct H. apply in_or_app. right. apply not_removed_remove_list.
  rewrite subform_boxesLF_dist_app. apply in_or_app. left. assumption. intro.
  apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app.
  rewrite subform_boxesLF_dist_app in H2. apply in_app_or in H2.
  destruct H2. auto. apply In_remove_list_In_list_not_In_remove_list in H2. destruct H2.
  right. apply not_removed_remove_list. simpl. apply in_or_app. right. apply not_removed_remove_list.
  assumption. intro. apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app. right.
  apply not_removed_remove_list. simpl. apply in_or_app. left. assumption. assumption. assumption.
  apply in_or_app. right. apply not_removed_remove_list. apply In_remove_list_In_list_not_In_remove_list in H.
  destruct H. simpl in H. apply in_app_or in H. destruct H. apply In_incl_subform_boxes with (A:=A → B).
  apply in_or_app. right. apply in_eq. simpl. apply in_or_app. right. apply not_removed_remove_list. assumption.
  intro. apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list.
  simpl. apply in_or_app. left. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app.
  auto. apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
  rewrite subform_boxesLF_dist_app.
  apply in_or_app. right. apply not_removed_remove_list. simpl. apply in_or_app. right.
  apply not_removed_remove_list. assumption. intro. apply in_app_or in H4. destruct H4.
  apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list.
  simpl. apply in_or_app. left. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app.
  apply in_or_app. auto. apply H3. apply In_remove_list_In_list_not_In_remove_list in H4. destruct H4.
  assumption. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app.
  apply in_or_app. rewrite subform_boxesLF_dist_app in H2. apply in_app_or in H2.
  destruct H2. auto. apply In_remove_list_In_list_not_In_remove_list in H2.
  destruct H2. right. apply not_removed_remove_list. simpl. apply in_or_app. right.
  apply not_removed_remove_list. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app.
  apply in_or_app. right. apply not_removed_remove_list. simpl. apply in_or_app. auto.
  assumption. assumption. intro. apply H0. rewrite top_boxes_distr_app. rewrite top_boxes_distr_app in H1.
  apply in_app_or in H1. destruct H1. apply in_or_app. auto. apply in_or_app. right.
  assert (A :: Γ1 = [A] ++ Γ1). auto. rewrite H2. rewrite top_boxes_distr_app. apply in_or_app. right.
  auto.
- unfold n_imp_subformS. simpl. repeat rewrite n_imp_subformLF_dist_app. simpl. lia.
Qed.

Theorem ImpL_applic_less_Imp_same_usable_boxes : forall prem1 prem2 concl, ImpLRule [prem1 ; prem2] concl ->
                   prod (prod (sum (length (usable_boxes prem1) < length(usable_boxes concl))
                    (length (usable_boxes prem1) = length(usable_boxes concl)))
                   (n_imp_subformS (prem1) < n_imp_subformS (concl)))
                   (prod (sum (length (usable_boxes prem2) < length(usable_boxes concl))
                    (length (usable_boxes prem2) = length(usable_boxes concl)))
                   (n_imp_subformS (prem2) < n_imp_subformS (concl))).
Proof.
intros prem1 prem2 concl RA. inversion RA. subst. split.
- split.
  * pose (NoDup_usable_boxes (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)).
    pose (NoDup_usable_boxes (Γ0 ++ A → B :: Γ1, Δ0 ++ Δ1)).
    apply NoDup_incl_lengthT. assumption. unfold incl. intros. unfold usable_boxes in H. simpl in H.
    unfold usable_boxes. simpl. apply In_remove_list_In_list_not_In_remove_list in H.
    destruct H. apply not_removed_remove_list. unfold subform_boxesS. unfold subform_boxesS in H.
    simpl. simpl in H. apply in_app_or in H. destruct H. rewrite subform_boxesLF_dist_app in H.
    apply in_app_or in H. destruct H. apply in_or_app. left. rewrite subform_boxesLF_dist_app.
    apply in_or_app. auto. apply in_or_app.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H. left.
    rewrite subform_boxesLF_dist_app. apply in_or_app. right.
    apply not_removed_remove_list. simpl. apply in_or_app.
    destruct (In_dec (subform_boxesF A ++ remove_list (subform_boxesF A) (subform_boxesF B)) a).
    auto. right. apply not_removed_remove_list.
    assumption. assumption. assumption. apply In_remove_list_In_list_not_In_remove_list in H.
    destruct H. rewrite subform_boxesLF_dist_app in H. apply in_app_or in H. destruct H. apply in_or_app.
    destruct (In_dec (subform_boxesLF (Γ0 ++ A → B :: Γ1)) a). auto. right. apply not_removed_remove_list.
    2: assumption. rewrite subform_boxesLF_dist_app. apply in_or_app. auto.
    apply in_or_app. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. simpl in H. apply in_app_or in H.
    destruct H. left. assert (In a (subform_boxesF (A → B))). simpl. apply in_or_app. auto.
    apply In_incl_subform_boxes with (A:=A → B). apply in_or_app. right. apply in_eq. assumption.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
    destruct (In_dec (subform_boxesLF (Γ0 ++ A → B :: Γ1)) a). auto. right.
    apply not_removed_remove_list. rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list.
    assumption. assumption. assumption. intro. apply H0. rewrite top_boxes_distr_app in H1. rewrite top_boxes_distr_app.
    apply in_or_app. apply in_app_or in H1. destruct H1. auto. simpl in H1. auto.
  * unfold n_imp_subformS. simpl. repeat rewrite n_imp_subformLF_dist_app. simpl. lia.
- split.
  * pose (NoDup_usable_boxes (Γ0 ++ B :: Γ1, Δ0 ++ Δ1)).
    pose (NoDup_usable_boxes (Γ0 ++ A → B :: Γ1, Δ0 ++ Δ1)).
    apply NoDup_incl_lengthT. assumption. unfold incl. intros. unfold usable_boxes in H. simpl in H.
    unfold usable_boxes. simpl. apply In_remove_list_In_list_not_In_remove_list in H.
    destruct H. apply not_removed_remove_list. unfold subform_boxesS. unfold subform_boxesS in H.
    simpl. simpl in H. apply in_app_or in H. destruct H.
    apply in_or_app. left. rewrite subform_boxesLF_dist_app in H.
    apply in_app_or in H. destruct H. rewrite subform_boxesLF_dist_app. apply in_or_app. auto.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H. simpl in H. apply in_app_or in H.
    destruct H. simpl. rewrite subform_boxesLF_dist_app. apply in_or_app. right.
    apply not_removed_remove_list. simpl. apply in_or_app. destruct (In_dec (subform_boxesF A) a).
    left. apply in_or_app. auto. left.
    apply in_or_app. right. apply not_removed_remove_list. assumption. assumption. assumption.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H. rewrite subform_boxesLF_dist_app.
    apply in_or_app. right. apply not_removed_remove_list. simpl. destruct (In_dec (subform_boxesF A) a).
    apply in_or_app. left. apply in_or_app. auto. apply in_or_app. right.
    apply not_removed_remove_list. assumption. intro. apply in_app_or in H3. destruct H3.
    apply f. auto. apply In_remove_list_In_list_not_In_remove_list in H3. destruct H3. auto.
    assumption. apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
    destruct (In_dec (subform_boxesLF (Γ0 ++ A → B :: Γ1)) a). apply in_or_app. auto.
    apply in_or_app. right. apply not_removed_remove_list. assumption. assumption.
    intro. apply H0. rewrite top_boxes_distr_app. rewrite top_boxes_distr_app in H1.
    apply in_app_or in H1. destruct H1. apply in_or_app. auto. simpl in H1.
    apply in_or_app. right. assert (B :: Γ1 = [B] ++ Γ1). reflexivity. rewrite H2.
    rewrite top_boxes_distr_app. apply in_or_app. auto.
  * unfold n_imp_subformS. simpl. repeat rewrite n_imp_subformLF_dist_app. simpl. lia.
Qed.

Theorem GLR_applic_reduces_measure : forall prem concl,
                GLRRule [prem] concl ->
                (IdBRule [] concl -> False) ->
                (length (usable_boxes prem) < length (usable_boxes concl)).
Proof.
apply GLR_applic_less_usable_boxes.
Qed.

Theorem ImpR_applic_reduces_measure : forall prem concl,
                ImpRRule [prem] concl ->
                ((length (usable_boxes prem) < length (usable_boxes concl)) +
                ((length (usable_boxes prem) = length (usable_boxes concl)) *
                (n_imp_subformS prem < n_imp_subformS concl))).
Proof.
intros.
pose (ImpR_applic_less_Imp_same_usable_boxes H). destruct p ; auto.
destruct s ; auto.
Qed.

Theorem ImpL_applic_reduces_measure : forall prem1 prem2 concl,
                ImpLRule [prem1; prem2] concl ->
                ((length (usable_boxes prem1) < length (usable_boxes concl)) +
                ((length (usable_boxes prem1) = length (usable_boxes concl)) *
                (n_imp_subformS prem1 < n_imp_subformS concl))) *
                ((length (usable_boxes prem2) < length (usable_boxes concl)) +
                ((length (usable_boxes prem2) = length (usable_boxes concl)) *
                (n_imp_subformS prem2 < n_imp_subformS concl))).
Proof.
intros.
pose (ImpL_applic_less_Imp_same_usable_boxes H). destruct p ; auto. destruct p ; auto.
destruct p0 ; auto. destruct s ; auto. destruct s0 ; auto. destruct s0 ; auto.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Utility.Utility.
Require Import compiler.mod4_0.

Local Open Scope Z_scope.

Lemma divisibleBy4Signed{width}{BW: Bitwidth width}{word: word.word width}{ok: word.ok word}:
  forall (w: word),
    (word.unsigned w) mod 4 = 0 ->
    (word.signed w) mod 4 = 0.
Proof.
  intros.
  rewrite word.signed_eq_swrap_unsigned.
  unfold word.swrap.
  pose proof (word.unsigned_range w).
  remember (word.unsigned w) as x. clear Heqx.
  destruct width_cases as [E | E]; simpl in *; rewrite E;
    Z.div_mod_to_equations; blia.
Qed.

Definition divisibleBy4{width}{word: word.word width}(x: word): Prop := (word.unsigned x) mod 4 = 0.

Ltac divisibleBy4_pre :=
  lazymatch goal with
  | |- ?G => assert_fails (has_evar G)
  end;
  unfold divisibleBy4 in *;
  lazymatch goal with
  | |- _ mod 4 = 0 => idtac
  | |- _ => fail "not a divisibleBy4 goal"
  end;
  repeat match goal with
         | H: _ mod 4 = 0 |- _ => revert H
         end;
  repeat match goal with
         (* TODO might fail to find Words instance *)
         | H: word.unsigned _ mod 4 = 0 |- _ => unique pose proof (divisibleBy4Signed _ H)
         end;
  repeat match goal with
         | H: ?T |- _ => lazymatch T with
                         | word.ok _ => fail
                         | Bitwidth _ => fail
                         | _ => clear H
                         end
         end;
  repeat match goal with
         | |- _ mod 4 = 0 -> _ => intro
         end;
  try apply mod4_0_opp;
  try apply divisibleBy4Signed;
  repeat (rewrite ?word.unsigned_add, ?word.signed_add,
                  ?word.unsigned_sub, ?word.signed_sub,
                  ?word.unsigned_mul, ?word.signed_mul,
                  ?word.unsigned_of_Z, ?word.signed_of_Z
          || unfold word.wrap, word.swrap).

Ltac solve_divisibleBy4 := divisibleBy4_pre; solve_mod4_0.

(* tests from FlatToRiscv *)
Goal forall {width}{BW: Bitwidth width}{word: word.word width}{ok: word.ok word} (pc: word) (l n m: Z),
    divisibleBy4 pc -> False.
  intros.
  assert (divisibleBy4 (word.add pc (word.of_Z (l * 4)))) as A by solve_divisibleBy4. clear A.
  assert (divisibleBy4 (word.add pc (word.of_Z 4))) as A by solve_divisibleBy4. clear A.
  assert (divisibleBy4
            (word.add
               (word.add (word.add pc (word.of_Z 4))
                         (word.mul (word.of_Z 4) (word.of_Z l)))
               (word.of_Z (n * 4)))) as A by solve_divisibleBy4. clear A.
  assert (divisibleBy4
            (word.add
               (word.add pc
                         (word.mul (word.of_Z 4) (word.of_Z l)))
               (word.of_Z (n * 4)))) as A by solve_divisibleBy4. clear A.
  assert (divisibleBy4
            (word.add
               (word.add pc
                         (word.mul (word.of_Z 4)
                                   (word.of_Z l)))
               (word.of_Z 4))) as A by solve_divisibleBy4. clear A.
  assert (divisibleBy4
            (word.add
               (word.add
                  (word.add
                     (word.add pc
                               (word.mul (word.of_Z 4)
                                         (word.of_Z l)))
                     (word.of_Z 4))
                  (word.mul (word.of_Z 4) (word.of_Z n)))
               (word.of_Z
                  (- m * 4)))) as A by solve_divisibleBy4. clear A.
Abort.

Section Modu.
  Context {width} {BW: Bitwidth width} {word: word.word width} {ok: word.ok word}.

  Definition divisibleBy4'(x: word): Prop := word.modu x (word.of_Z 4) = word.of_Z 0.

  Lemma four_fits: 4 < 2 ^ width.
  Proof.
    destruct width_cases as [C | C]; rewrite C; reflexivity.
  Qed.

  Ltac div4_sidecondition :=
    pose proof four_fits;
    rewrite ?word.unsigned_of_Z; unfold word.wrap; rewrite ?Z.mod_small;
    blia.

  Lemma divisibleBy4_alt(x: word): divisibleBy4 x -> divisibleBy4' x.
  Proof.
    intro H. unfold divisibleBy4, divisibleBy4' in *.
    apply word.unsigned_inj.
    rewrite word.unsigned_modu_nowrap by div4_sidecondition.
    replace (word.unsigned (word.of_Z 4)) with 4 by div4_sidecondition.
    rewrite H.
    div4_sidecondition.
  Qed.

End Modu.

Ltac simpl_modu4_0 :=
  simpl;
  match goal with
  | |- context [word.eqb ?a ?b] =>
    rewrite (word.eqb_eq a b) by (apply divisibleBy4_alt; solve_divisibleBy4)
  end;
  simpl.


(*******************************************)
(*******************************************)
(****                                   ****)
(****   A proof that maybe is a monad   ****)
(****                                   ****)
(*******************************************)
(*******************************************)

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Main.CategoryTheory.Category.
Require Import Main.CategoryTheory.Examples.Set.
Require Import Main.CategoryTheory.Functor.
Require Import Main.CategoryTheory.Monad.
Require Import Main.CategoryTheory.NaturalTransformation.
Require Import Main.Tactics.

(* A `maybe` is a wrapper for value that might be missing. *)

Inductive maybe x : Type :=
| nothing : maybe x
| just : x -> maybe x.

Arguments nothing {_}.
Arguments just {_}.

(* Here's a proof that `maybe` is a functor. *)

#[local] Theorem maybeFIdent (x : object setCategory) :
  (
    fun e : maybe x =>
      match e with
      | nothing => nothing
      | just e0 => just (@id setCategory x e0)
      end
  ) = @id setCategory (maybe x).
Proof.
  clean.
  apply functional_extensionality.
  destruct x0; search.
Qed.

#[local] Theorem maybeFComp
  (x y z : object setCategory)
  (f : arrow x y)
  (g : arrow y z)
: @compose setCategory _ _ _
    (
      fun e : maybe y =>
        match e with
        | nothing => nothing
        | just e0 => just (g e0)
        end
    )
    (
      fun e : maybe x =>
        match e with
        | nothing => nothing
        | just e0 => just (f e0)
        end
    ) =
  (
    fun e : maybe x =>
      match e with
      | nothing => nothing
      | just e0 => just (compose g f e0)
      end
  ).
Proof.
  clean.
  apply functional_extensionality.
  destruct x0; search.
Qed.

Definition maybeFunctor : functor setCategory setCategory := newFunctor
  setCategory
  setCategory
  maybe
  (fun _ _ f e =>
    match e with
    | nothing => nothing
    | just e => just (f e)
    end
  )
  maybeFIdent
  maybeFComp.

(* This is the "return" natural transformation for `maybe`. *)

#[local] Theorem maybeEtaNaturality
  (x y : object setCategory)
  (f : arrow x y)
:
  @compose setCategory _ _ _ just (fMap idFunctor f) =
  @compose setCategory _ _ _ (fMap maybeFunctor f) just.
Proof.
  search.
Qed.

Definition maybeEta : naturalTransformation idFunctor maybeFunctor :=
  newNaturalTransformation
    idFunctor
    maybeFunctor
    (@just)
    maybeEtaNaturality.

(* This is the "join" natural transformation for `maybe`. *)

#[local] Theorem maybeMuNaturality (x y : object setCategory) (f : arrow x y) :
  @compose
    setCategory _ _ _
    (
      fun e1 : oMap (compFunctor maybeFunctor maybeFunctor) y =>
        match e1 with
        | nothing => nothing
        | just e2 => e2
        end
    )
    (fMap (compFunctor maybeFunctor maybeFunctor) f) =
  compose
    (fMap maybeFunctor f)
    (
      fun e1 : oMap (compFunctor maybeFunctor maybeFunctor) x =>
        match e1 with
        | nothing => nothing
        | just e2 => e2
        end
    ).
Proof.
  clean.
  apply functional_extensionality.
  destruct x0; search.
Qed.

Definition maybeMu :
  naturalTransformation (compFunctor maybeFunctor maybeFunctor) maybeFunctor
:= newNaturalTransformation
  (compFunctor maybeFunctor maybeFunctor)
  maybeFunctor
  (
    fun x e1 =>
      match e1 with
      | nothing => nothing
      | just e2 => e2
      end
  )
  maybeMuNaturality.

(* Now we can prove that `maybe` is a monad. *)

#[local] Theorem maybeMAssoc :
  eta (
    vertCompNaturalTransformation maybeMu (leftWhisker maybeMu maybeFunctor)
  ) = eta (
    vertCompNaturalTransformation maybeMu (rightWhisker maybeFunctor maybeMu)
  ).
Proof.
  clean.
  apply functional_extensionality_dep.
  clean.
  apply functional_extensionality.
  destruct x0; search.
Qed.

#[local] Theorem maybeMIdent1 :
  eta (
    vertCompNaturalTransformation maybeMu (leftWhisker maybeEta maybeFunctor)
  ) = eta idNaturalTransformation.
Proof.
  search.
Qed.

#[local] Theorem maybeMIdent2 :
  eta (
    vertCompNaturalTransformation maybeMu (rightWhisker maybeFunctor maybeEta)
  ) = eta idNaturalTransformation.
Proof.
  clean.
  apply functional_extensionality_dep.
  clean.
  apply functional_extensionality.
  destruct x0; search.
Qed.

Definition maybeMonad : monad maybeEta maybeMu := newMonad
  setCategory
  maybeFunctor
  maybeEta
  maybeMu
  maybeMAssoc
  maybeMIdent1
  maybeMIdent2.