Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Require Import rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_lhs_top_reduce :
  forall T2, subtype t_top T2 = match T2 with
                           | t_top => true
                           | t_sel_low x L T2' => subtype t_top T2'
                           | t_sel_equ x L T2' => subtype t_top T2'
                           | _ => false
                           end.
Proof.
  intros.

  remember (subtype t_top T2) as sub_fn.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto.
Qed.


(*Require Import Coq.Relations.Relations.*)
Require Import Coq.Program.Equality.

Require Export CatSem.COMP.PCF_rep_quant.
Require Export CatSem.ULC.ULC_Monad.
Require Export CatSem.ULC.ULC_terms.
Require Export CatSem.CAT.unit_type_monad.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.

Unset Printing Implicit Defensive.
(* this will suppress printing
  of implicit arguments of Var *)

Definition PCF_ULC_type_mor : TY -> unit := fun _ => tt.

Definition uULC := unit_Monad ULCM.

Program Instance ULCApp_s u v :
Module_Hom_struct
  (S:=Prod_Mod TYPE_prod (ITFibre_Mod uULC tt) (ITFibre_Mod uULC u))
  (T:=ITFibre_Mod uULC v)  (fun V y => App (fst y) (snd y)).

Definition ULCApp  r s := Build_Module_Hom (ULCApp_s r s).

(*
Definition bla r s :
(forall x : ITYPE unit,
  (ITFibre_Mod (IT_Der_Mod uULC (PCF_ULC_type_mor r))
 (PCF_ULC_type_mor s)) x --->
  (ITFibre_Mod uULC (PCF_ULC_type_mor (PCF.arrow r s))) x).
simpl.
intros.
apply Abs.
apply (lift (M:=ULCM) (@unit_passing _ _ _ ) X).
Defined.
*)

Lemma unit_passing_shift u t (V W : ITYPE unit)
 (f : V ---> uULC W)
  (y : opt u V t):
shift f y //- (@unit_passing _ _ _ )= unit_passing y >- f tt.
Proof.
  destruct y;
  unfold unit_weta_car;
  repeat elim_unit;
  simpl; auto.
  unfold inj;
  simpl.
  rewrite <- lift_rename.
  unfold lift. simpl.
  unfold unit_kleisli.
  simpl.
  rewrite subst_subst.
  simpl.
  rewrite lift_rename.
  auto.
Qed.

Program Instance ULCAbs_s u v :
Module_Hom_struct
  (S:=ITFibre_Mod (IT_Der_Mod uULC u) v)
  (T:=ITFibre_Mod uULC tt)
  (fun V y => Abs (lift (M:=ULCM) (@unit_passing _ _ _ ) y)).
Next Obligation.
Proof.
  unfold unit_kleisli.
  simpl.
  apply f_equal.
  simpl.
  unfold lift.
  simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  simpl in *; intros.
  rewrite lift_rename.
  rew unit_passing_shift.
Qed.

Definition ULCAbs r s := Build_Module_Hom (ULCAbs_s r s).

Program Instance ULCRec_s t :
  Module_Hom_struct
  (S:=ITFibre_Mod uULC tt)
  (T:=ITFibre_Mod uULC t)
      (fun V y => App (ULC_theta _ ) y).

Definition ULCRec t := Build_Module_Hom (ULCRec_s t).

Program Instance ULCttt_s :
Module_Hom_struct
  (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC (PCF_ULC_type_mor PCF.Bool))

  (fun V _ => ULC_True (sunit V)).

Definition ULCttt :=
 Build_Module_Hom ULCttt_s.

Program Instance ULCfff_s :
Module_Hom_struct
  (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC (PCF_ULC_type_mor PCF.Bool))
  (fun V _ => ULC_False (sunit V)).

Definition ULCfff :
Term ---> (ITFIB_MOD uULC (PCF_ULC_type_mor Bool)) uULC :=
 Build_Module_Hom ULCfff_s.

Program Instance ULCNat_s m :
Module_Hom_struct (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC (PCF_ULC_type_mor Nat))
  (fun V _ => ULC_Nat m (sunit V)).
Next Obligation.
Proof.
  unfold unit_kleisli;
  simpl.
  rewrite <- ulc_nats_subst.
  auto.
Qed.

Definition ULCNat m :
 Term ---> (ITFIB_MOD uULC (PCF_ULC_type_mor Nat)) uULC :=
  Build_Module_Hom (ULCNat_s m).

Program Instance ULCSucc_s :
Module_Hom_struct (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC (PCF_ULC_type_mor (PCF.Arrow Nat Nat)))
  (fun V _ => ULCsucc (sunit V)).

Definition ULCSucc :
Term ---> (ITFIB_MOD uULC (PCF_ULC_type_mor (PCF.Arrow Nat Nat))) uULC :=
 Build_Module_Hom ULCSucc_s.

Program Instance ULCCondN_s :
Module_Hom_struct (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC (PCF_ULC_type_mor (PCF.Arrow Nat Bool)))
  (fun V _ => ULC_cond (sunit V)).

Definition ULCCondN :
Term ---> (ITFIB_MOD uULC (PCF_ULC_type_mor (PCF.Arrow Nat Bool))) uULC :=
Build_Module_Hom ULCCondN_s.

Obligation Tactic := simpl; intros; repeat elim_unit; auto.

Program Instance ULCBottom_s t :
 Module_Hom_struct
   (S:=MOD_Term uULC TYPE_term)
   (T:=(ITFibre_Mod uULC t))
  (fun V _ => match t with tt => ULC_omega (sunit V) end).

Definition ULCBottom t := Build_Module_Hom (ULCBottom_s t).

Program Instance ULCZero_s :
Module_Hom_struct
  (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC tt)
  (fun V _ => ULC_zero (sunit V)).

Definition ULCZero := Build_Module_Hom ULCZero_s.

Program Instance ULCPred_s :
Module_Hom_struct
  (S:=MOD_Term uULC TYPE_term)
  (T:=ITFibre_Mod uULC tt)
  (fun V _ => ULC_pred_alt (sunit V)).

Definition ULCPred := Build_Module_Hom ULCPred_s.

(*

Program Instance ULCzero_pos :
forall V : unit -> Type,
PO_mor_struct (a:=PO_TERM)
  (b:=ipo_proj (ULCBETAM V) (PCF_ULC_type_mor
                         (Nat ~> Bool)))
  (fun _ => ULC_zero (sunit V)).

Definition ULCzero_car V :
Term (C:=RMOD ULCBETAM _ ) V --->
 (ULCBETAM [PCF_ULC_type_mor (Nat ~> Nat)]) V :=
  Build_PO_mor (ULCzero_pos V).

Program Instance ulc_zero_s : RModule_Hom_struct
  (M:= Term (C := RMOD ULCBETAM PO))
  (N:= ULCBETAM [PCF_ULC_type_mor (Nat ~> Bool)])
  ULCzero_car.

Definition ulc_zero := Build_RModule_Hom ulc_zero_s.

Program Instance ULCpred_pos :
forall V : unit -> Type,
PO_mor_struct (a:=PO_TERM)
  (b:=ipo_proj (ULCBETAM V) (PCF_ULC_type_mor
                         (Nat ~> Nat)))
  (fun _ => ULC_pred_alt (sunit V)).

Definition ULCpred_car V :
Term (C:=RMOD ULCBETAM _ ) V --->
 (ULCBETAM [PCF_ULC_type_mor (Nat ~> Nat)]) V :=
  Build_PO_mor (ULCpred_pos V).

Program Instance ulc_pred_s : RModule_Hom_struct
  (M:= Term (C := RMOD ULCBETAM PO))
  (N:= ULCBETAM [PCF_ULC_type_mor (Nat ~> Nat)])
  ULCpred_car.

Definition ulc_pred := Build_RModule_Hom ulc_pred_s.

Ltac sim := unfold substar; simpl ;
            unfold inj; simpl.
*)

Obligation Tactic := idtac.

Program Instance PCF_ULC_rep_s :
 PCF_rep_struct (U:=unit) uULC (PCF_ULC_type_mor) (fun _ _ => tt) := {
  app r s := ULCApp r s
;
  abs r s := ULCAbs r s
;
  rec t := ULCRec t
;
  tttt := ULCttt;
  ffff := ULCfff;
  nats m := ULCNat m ;
  Succ := ULCSucc ;
  CondN := ULCCondN ;
  CondB := ULCCondN ;
  bottom t := ULCBottom t ;
  Zero := ULCZero ;
  Pred := ULCPred
}.

Definition PCF_ULC : PCF_rep := Build_PCF_rep
      (type_type:=unit) (type_arrow := fun _ _ => tt)
      (pcf_rep_monad:=uULC)
      (type_mor:=fun t => tt)
      (fun _ _ => eq_refl)
      PCF_ULC_rep_s.


From HoTT Require Import Basics Types Pointed HSet Spaces.Int Spaces.Finite Spaces.Pos
  Algebra.Groups Algebra.AbGroups Spaces.Nat Classes.implementations.peano_naturals
  Spaces.Circle Homotopy.ClassifyingSpace Homotopy.Pi1S1 Homotopy.HomotopyGroup Homotopy.Bouquet
  Homotopy.ExactSequence Modalities.ReflectiveSubuniverse.

Require Import Z.
Require Import BaerSumLaws.
Local Open Scope positive_scope.
Local Open Scope int_scope.
Local Open Scope mc_mult_scope.

Lemma mod_plus {n : nat} (m k : nat) : @fin_nat n (Nat.add m (fin_to_nat (@fin_nat n k)) ) = @fin_nat n (Nat.add m k).
Proof.
  induction k.
  + apply ap, ap. exact path_nat_fin_zero.
Admitted.

Lemma cancellation {n : nat} (x y : Fin n.+1) : fin_to_nat (@fin_nat n (Nat.add (fin_to_nat x) (fin_to_nat y))) = Nat.add (fin_to_nat x) (fin_to_nat y).
Admitted.

Lemma inclusion_reduction {n : nat} (x : Fin n.+1) : fin_nat (fin_to_nat x) = x.
Admitted.

Axiom admit : forall {T}, T.

(** * Finite cyclic groups *)

(** Define an abelian group structure on [Fin n]. Look at Spaces.Finite.Fin for how to work with [Fin n]. *)
Definition abgroup_fin (n : nat) : AbGroup.
Proof.
  snrapply Build_AbGroup.
  - snrapply Build_Group.
    + exact (Fin n.+1).
    + intros k l. apply fin_nat. exact (Nat.add (fin_to_nat k) (fin_to_nat l)).
    + unfold MonUnit. exact fin_zero.
    + unfold Negate. intro x. apply fin_nat. exact (Nat.sub (n.+1) (fin_to_nat x)).
    + split; try split.
      * split.
        ** intros x y p. destruct p. intro y. cbn. exact _.
        ** unfold Associative. unfold HeteroAssociative.
           intros x y z. unfold "*".
           refine ((mod_plus (fin_to_nat x) (fin_to_nat y + fin_to_nat z)) @ _).
           apply ap. refine ((add_assoc (fin_to_nat x) (fin_to_nat y) (fin_to_nat z)) @ _).
           exact ((ap (fun m => Nat.add m (fin_to_nat z)) (cancellation x y))^).
      * unfold LeftIdentity. intro y. unfold "*". unfold mon_unit.
        refine (ap (fin_nat) (ap (fun m => Nat.add m (fin_to_nat y)) path_nat_fin_zero) @ _).
        cbn. apply inclusion_reduction.
      * unfold RightIdentity. intro y. unfold "*". unfold mon_unit.
        refine (ap (fin_nat) (ap (fun m => Nat.add (fin_to_nat y) m) path_nat_fin_zero) @ _).
        refine ((ap (fin_nat) (add_n_O (fin_to_nat y)))^ @ _). apply inclusion_reduction.
      * apply admit.
      * apply admit.
  - apply admit.
Defined.

(** The inclusion of the naturals into the integers. Note that [pos_of_nat] sends [0] to [1], since [Pos] only encodes strictly positive naturals. (I can't believe that this isn't already in the library!) *)
Definition toZ : nat -> Int.
Proof.
  intro n; induction n.
  - exact 0.
  - exact (pos (pos_of_nat n.+1)).
Defined.

Definition pos_to_nat : Core.Pos -> nat.
Proof.
  intro p. induction p.
  + exact (S O).
  + exact (Nat.add IHp IHp).
  + exact (S (Nat.add IHp IHp)).
Defined.

(* Special case of the free group on an n-bouquet *)
Definition unit_bouquet_is_free `{Univalence} : IsFreeGroupOn Unit (Pi 1 (Bouquet Unit)) (pi1bouquet_incl Unit).
Proof.
  apply isfreegroupon_pi1bouquet.
Defined.

(* Universal property of free_Z - my version *)
Definition free_Z_rec (G : Group) (g : G) : GroupHomomorphism Z G.
Proof.
  apply FreeGroup_rec.
  exact (fun tt => g).
Defined.

(** The universal property of the integers - Jarl's version, with the current definition of Z *)
Definition Z_rec `{Univalence} (G : Group) (g : G)
  : GroupHomomorphism abgroup_Z G.
Proof.
  refine (grp_homo_compose _ (grp_iso_inverse Pi1Circle)).
  apply (equiv_bg_pi1_adjoint _ _)^-1.
  srapply Build_pMap.
  1: exact (Circle_rec _ (point _) (bloop g)).
  reflexivity.
Defined.

(** Define the group homomorphism [abgroup_Z -> abgroup_fin_n] which computes the modulus. *)

(* Defined with my free group - previously the old Int was used *)
Definition modulo (n : nat) : GroupHomomorphism Z (abgroup_fin n).
Proof.
 exact (free_Z_rec (abgroup_fin n) (@fin_nat n (S O))).
Defined.

(*
Compute toZ 0.
Compute toZ 1.
Compute toZ 2.
*)

(** Show that [n : abgroup_Z] is sent to zero. *)

(* The inclusion toZ : Nat -> Int doesn't work anymore of course. *)

Lemma modulo_n_n (n : nat) : modulo n (nat_to_Z n) = mon_unit.
Proof.
  refine ((@Z_rec_nat_beta (abgroup_fin n) (@fin_nat n (S O)) n) @ _).
  induction n.
  + cbn. reflexivity.
  +
Admitted.

(** ** Subgroups of [abgroup_Z] *)

Lemma cancel_x (x : Int) : -x + x = 0.
Proof.

Admitted.

(** Subgroups are defined in Algebra.Groups.Subgroup, and they are represented as predicates (i.e. families of propositions) which are appropriately closed (go look at the definition of [IsSubgroup]). *)

(** Define the subgroup [nZ] of [abgroup_Z]. (If you want to multiply by [toZ] on the left, you can write [sg_op (A:=abgroup_Z (toZ) a]. For multiplication on the right, Coq understands [a * (toZ n)] since it infers the group structure [abgroup_Z] from [a].) *)
(* I've filled some of the definition in to illustrate, but you might want to swap the order of multiplication, for example. Figure out what's best! *)
Definition subgroup_Z (n : nat) : Subgroup (abgroup_Z).
  snrapply Build_Subgroup'. (* This is a "smart constructor" for subgroups. *)
  - intro a. (* You can write Sigma-types as follows: *)
    exact ( merely { b : abgroup_Z & grp_pow b n = a }).
  - exact _. (* Coq should already knows it's a proposition. *)
  - cbn. exact admit. (* exact (0 ; ). *)
  - cbn. intros x y.
Admitted.

Definition ab_mul (n : Int) {A : AbGroup} : GroupHomomorphism A A.
Proof.
  induction n.
  - exact (grp_homo_compose ab_homo_negation (ab_mul_nat (pos_to_nat p))).
  - exact grp_homo_const.
  - exact (ab_mul_nat (pos_to_nat p)).
Defined.

Lemma Z_hom_equiv `{Funext} (A : AbGroup) : GroupIsomorphism (ab_hom ab_Z A) A.
Proof.
  snrapply Build_GroupIsomorphism'.
  - refine (_ oE (equiv_freegroup_rec A Unit)).
    symmetry. exact (Build_Equiv _ _ (Unit_rec A) _).
  - intros f g. cbn. reflexivity.
Defined.

Lemma ab_mul_homo {A B : AbGroup} (n : Int) (f : GroupHomomorphism A B)
  : grp_homo_compose f (ab_mul n) ==  grp_homo_compose (ab_mul n) f.
Proof.
  intro x.
  induction n.
  - cbn.
    refine (grp_homo_inv _ _ @ _).
    refine (ap negate _).
    apply grp_pow_homo.
  - cbn. apply grp_homo_unit.
  - cbn.
    apply grp_pow_homo.
Defined.

Lemma ab_mul_precomp `{Funext} (A : AbGroup) (n : Int)
  : (Z_hom_equiv A) o (fun f : ab_hom ab_Z A => grp_homo_compose f (ab_mul n))
    == (ab_mul n) o (Z_hom_equiv A).
Proof.
  intro f.
  cbn.
  apply (ab_mul_homo n f _).
Defined.

Lemma isequiv_hset_bijection `{Funext} {A B : Type} `{IsHSet A, IsHSet B} (f : A -> B)
  `{S: IsSurjection f, E: IsEmbedding f}
  : IsEquiv f.
Proof.
  apply isequiv_contr_map.
  intro b.
  assert (z : ((Tr (-1)) (hfiber f b))).
  1: apply S.
  revert z.
  rapply Trunc_rec.
  intros z.
  exists z.
  apply E.
Defined.

Local Instance isequiv_cxfib_isembedding `{Funext} {A B C : pType} `{IsHSet A, IsHSet B, IsHSet C}
  (f : A ->* B) (g : B ->* C) (G : IsExact (Tr (-1)) f g) `{E : IsEmbedding f}
  : IsEquiv (cxfib cx_isexact).
Proof.
  nrapply isequiv_hset_bijection.
  1-3: exact _.
  rapply (cancelL_mapinO (Tr (-1))).
Defined.

Lemma exactsequence_quotient_iso `{Funext}  (A B C : AbGroup) (f : ab_hom A B) (g : ab_hom B C) (H0 : IsEmbedding f) (H1 : IsSurjection g) (G : IsExact (Tr (-1)) f g)
  : GroupIsomorphism (QuotientAbGroup B (ab_image_embedding f)) C.
Proof.
  snrapply Build_GroupIsomorphism.
    - snrapply equiv_quotient_abgroup_ump.
      split with g.
      intros b x.
      destruct x as [x p].
      refine (ap g p^ @ _).
      rapply cx_isexact.
    - apply isequiv_hset_bijection.
      + rapply cancelR_conn_map.
      + rapply isembedding_isinj_hset.
        srapply Quotient_ind_hprop; intro x.
        srapply Quotient_ind_hprop; intro y.
        intro p.
        apply qglue.
        unfold in_cosetL.
        cbn.
        assert (q : g ((- x)%mc * y) = mon_unit).
        {  refine (grp_homo_op _ _ _ @ _).
          rewrite grp_homo_inv.
          apply grp_moveL_M1^-1.
          exact p^. }
        srefine (((cxfib cx_isexact)^-1 _ ; _)).
          * exact (_ ; q).
          * exact (ap pr1 (eisretr (cxfib cx_isexact) _)).
Defined.

Lemma trivial_surjection_kernel `{Univalence} {A : Group} (f : GroupHomomorphism A grp_trivial)
  : grp_kernel f = maximal_subgroup :> Subgroup A.
Proof.
  rapply equiv_path_subgroup'.
  intro g. cbn.
  split.
    - exact (fun _ => tt).
    - intro x. symmetry; apply eta_unit.
Defined.

(* To do: For a s.e.s. A -> B ->> 0, left map is an epi*)
Lemma exactsequence_leftmap_epi `{Funext} {A B : AbGroup}
  (f : ab_hom A B) (g : ab_hom B abgroup_trivial) (G : IsExact (Tr (-1)) f g)
    : IsSurjection f.
Proof.
  intro b.
  rapply contr_inhabited_hprop.
  rapply isexact_preimage.
  symmetry; apply eta_unit.
Defined.

(** ** Quotients of [abgroup_Z] *)

(** Define the multiplication-by-n map using [int_mul] (from Spaces.Int.Core). You may find [int_mul_add_distr_l] from Spaces.Int.Spec useful. *)
Definition mul (n : Int) : GroupHomomorphism Z Z.
  exact (ab_mul n).
Admitted.

(** We can form quotients of subgroups using [QuotientAbGroup], and [grp_image] gives the image of a map. Coq already knows that subgroups of abelian groups are normal by [isnormal_ab_subgroup]. We currently lack cokernels of maps in the library (though they're easy to define by what I just explained). *)

(** Define the cokernel of a map. *)
Definition ab_cokernel {G : Group} {A : AbGroup} (f : GroupHomomorphism G A)
  : AbGroup.
Admitted.

(** The universal property of [ab_cokernel f] is given by [grp_quotient_rec] in Algebra.Groups.QuotientGroup. *)

(** Define the n-th cyclic group as the cokernel of [mul n]. *)
Definition cyclic (n : nat) : AbGroup.
Admitted.

(** Define the induced homomorphism [cyclic n -> abgroup_fin n]. *)
Definition cyclic_to_fin (n : nat) : GroupHomomorphism (cyclic n) (abgroup_fin n).
Admitted.

(** Give an alternative definition of [cyclic n] by taking the quotient by [nZ]. *)
Definition cyclic' (n : nat) : AbGroup.
Admitted.

(** Define the induced homomorphism [cyclic' n -> abgroup_fin n]. *)

(** ** Short exact sequences *)

(** Define the short exact sequence [nZ -> Z -> Z/n] using [abses_from_inclusion]. You might find [subgroup_incl] from Algebra.Groups.Subgroup useful. *)


(* Copland terms, events, and annotated terms *)

(* LICENSE NOTICE

Copyright (c) 2018 The MITRE Corporation.
All Rights Reserved.

This proof script is free software: you can redistribute it and/or
modify it under the terms of the BSD License as published by the
University of California.  See license.txt for details. *)

(** This module contains the basic definitions for Copland terms,
    events, and annotated terms. *)

Require Import PeanoNat Compare_dec Lia.
Require Import Preamble StructTactics.

(** * Terms and Evidence

    A term is either an atomic ASP, a remote call, a sequence of terms
    with data a dependency, a sequence of terms with no data
    dependency, or parallel terms. *)

(** [Plc] represents a place. *)

Notation Plc := nat (only parsing).
Notation ASP_ID := nat (only parsing).
Notation N_ID := nat (only parsing).

Inductive ASP: Set :=
| CPY: ASP
| ASPC: ASP_ID -> ASP
| SIG: ASP
| HSH: ASP.

Inductive SP: Set :=
| ALL
| NONE.

Definition Split: Set := (SP * SP).

Inductive Term: Set :=
| asp: ASP -> Term
| att: Plc -> Term -> Term
| lseq: Term -> Term -> Term
| bseq: Split -> Term -> Term -> Term
| bpar: Split -> Term -> Term -> Term.

(** The structure of evidence. *)

Inductive Evidence: Set :=
| mt: Evidence
| uu: ASP_ID -> Plc -> Evidence -> Evidence
| gg: Plc -> Evidence -> Evidence
| hh: Plc -> Evidence -> Evidence
| nn: N_ID -> Evidence -> Evidence
| ss: Evidence -> Evidence -> Evidence
| pp: Evidence -> Evidence -> Evidence.

Definition splitEv_T (sp:SP) (e:Evidence) : Evidence :=
  match sp with
  | ALL => e
  | NONE => mt
  end.

Fixpoint eval_asp t p e :=
  match t with
  | CPY => e
  | ASPC i => uu i p e
  | SIG => gg p e
  | HSH => hh p e
  end.

(** The evidence associated with a term, a place, and some initial evidence. *)

Fixpoint eval (t:Term) (p:Plc) (e:Evidence) : Evidence :=
  match t with
  | asp a => eval_asp a p e
  | att q t1 => eval t1 q e
  | lseq t1 t2 => eval t2 p (eval t1 p e)
  | bseq s t1 t2 => ss (eval t1 p (splitEv_T (fst s) e))
                       (eval t2 p (splitEv_T (snd s) e))
  | bpar s t1 t2 => pp (eval t1 p (splitEv_T (fst s) e))
                      (eval t2 p (splitEv_T (snd s) e))
  end.

(** * Events

    There are events for each kind of action. This includes ASP
    actions such as measurement or data processing. It also includes
    control flow actions: a [split] occurs when a thread of control
    splits, and a [join] occurs when two threads join.  Each event is
    distinguished using a unique natural number.

 *)

Inductive Ev: Set :=
| copy: nat -> Plc -> Ev
| umeas: nat -> Plc -> ASP_ID -> Ev
| sign: nat -> Plc -> Ev
| hash: nat -> Plc -> Ev
| req: nat -> Plc -> Plc -> Term -> Ev
| rpy: nat -> Plc -> Plc -> Ev
| split: nat -> Plc -> Ev
| join:  nat -> Plc -> Ev.

Definition eq_ev_dec:
  forall x y: Ev, {x = y} + {x <> y}.
Proof.
  intros;
    repeat decide equality.
Defined.
Hint Resolve eq_ev_dec : core.

(** The natural number used to distinguish evidence. *)

Definition ev x :=
  match x with
  | copy i _ => i
  | umeas i _ _  => i
  | sign i _ => i
  | hash i _ => i
  | req i _ _ _ => i
  | rpy i _ _ => i
  | split i _ => i
  | join i _ => i
  end.

(** Events are used in a manner that ensures that
[[
    forall e0 e1, ev e0 = ev e1 -> e0 = e1.
]]
See Lemma [events_injective].
 *)

Definition asp_event i x p :=
  match x with
  | CPY => copy i p
  | ASPC id => umeas i p id
  | SIG => sign i p
  | HSH => hash i p
  end.

(** * Annotated Terms

    Annotated terms are used to ensure that each distinct event has a
    distinct natural number.  To do so, each term is annotated by a
    pair of numbers called a range.  Let [(i, k)] be the label for
    term [t].  The labels will be chosen to have the property such
    that for each event in the set of events associated with term [t],
    its number [j] will be in the range [i <= j < k].  *)

Definition Range: Set := nat * nat.

Inductive AnnoTerm: Set :=
| aasp: Range -> ASP -> AnnoTerm
| aatt: Range -> Plc -> AnnoTerm -> AnnoTerm
| alseq: Range -> AnnoTerm -> AnnoTerm -> AnnoTerm
| abseq: Range -> Split -> AnnoTerm -> AnnoTerm -> AnnoTerm
| abpar: Range -> Split -> AnnoTerm -> AnnoTerm -> AnnoTerm.

(** The number of events associated with a term.  The branching terms
add a split and a join to the events of their subterms. Similarly, the
remote calls add a request and receive to the events of their subterm.
*)

Fixpoint esize t :=
  match t with
  | aasp _ _ => 1
  | aatt _ _ t1 => 2 + esize t1
  | alseq _ t1 t2 => esize t1 + esize t2
  | abseq _ _ t1 t2 => 2 + esize t1 + esize t2
  | abpar _ _ t1 t2 => 2 + esize t1 + esize t2
  end.

Definition range x :=
  match x with
  | aasp r _ => r
  | aatt r _ _ => r
  | alseq r _ _ => r
  | abseq r _ _ _ => r
  | abpar r _ _ _ => r
  end.

(** This function annotates a term.  It feeds a natural number
    throughout the computation so as to ensure each event has a unique
    natural number. *)

Fixpoint anno (t: Term) i: nat * AnnoTerm :=
  match t with
  | asp x => (S i, aasp (i, S i) x)
  | att p x =>
    let (j, a) := anno x (S i) in
    (S j, aatt (i, S j) p a)
  | lseq x y =>
    let (j, a) := anno x i in
    let (k, b) := anno y j in
    (k, alseq (i, k) a b)
  | bseq s x y =>
    let (j, a) := anno x (S i) in
    let (k, b) := anno y j in
    (S k, abseq (i, S k) s a b)
  | bpar s x y =>
    let (j, a) := anno x (S i) in
    let (k, b) := anno y j in
    (S k, abpar (i, S k) s a b)
  end.

Ltac hihi' tac :=
  match goal with
  | [H: anno _ ?x = (?y,_) |- _] => assert (y > x) by tac; clear H
  end.

Ltac hihi := hihi' eauto.

Lemma anno_mono : forall t i j t',
  anno t i = (j, t') ->
  j > i.
Proof.
  induction t; intros;
    try (
        simpl in *;
        repeat break_let;
        find_inversion;
        repeat hihi;
        lia).
Defined.

Lemma anno_range:
  forall x i,
    range (snd (anno x i)) = (i, fst (anno x i)).
Proof.
  induction x; intros; simpl; auto;
    repeat expand_let_pairs;
    simpl; auto.
Qed.

Definition annotated x :=
  snd (anno x 0).

Lemma pairsinv : forall (a a' b b':nat),
    a <> a' -> (a,b) <> (a',b').
Proof.
  congruence.
Defined.

Ltac asdff := eapply anno_mono; eauto.

Ltac haha := hihi' asdff.

Lemma afaf : forall i k s a b t' n,
    (abpar (i, k) s a b) = snd (anno t' n)(*(bpar s x y)*) ->
    (fst (range a)) <> (fst (range b)).
Proof.
  intros.
  destruct t'; try (
                   unfold annotated in H;
                   unfold anno in H;
                   repeat break_let;
                   simpl in *;
                   solve_by_inversion).

  cbn in *.
  repeat break_let.
  simpl in *.
  repeat find_inversion.

  (*
  remember (anno t'1 (S n)) as oo.
  destruct oo.
  remember (anno t'2 n0) as oo.
  destruct oo. *)

  pose proof anno_range.

  assert ( range (snd (anno t'1 (S n))) = ((S n), fst (anno t'1 (S n)))).

  eapply anno_range; eauto.
  find_rewrite.
  simpl in *.

  assert ( range (snd (anno t'2 n0)) = (n0, fst (anno t'2 n0))).
  eapply anno_range; eauto.
  find_rewrite.
  simpl in *.
  repeat find_rewrite.
  simpl in *.
  repeat haha.
  lia.
Defined.

Fixpoint unanno a :=
  match a with
  | aasp _ a => asp a
  | aatt _ p t => att p (unanno t)
  | alseq _ a1 a2 => lseq (unanno a1) (unanno a2)

  | abseq _ spl a1 a2 => bseq spl (unanno a1) (unanno a2)
  | abpar _ spl a1 a2 => bpar spl (unanno a1) (unanno a2)
  end.

(** This predicate determines if an annotated term is well formed,
    that is if its ranges correctly capture the relations between a
    term and its associated events. *)

Inductive well_formed: AnnoTerm -> Prop :=
| wf_asp: forall r x,
    snd r = S (fst r) ->
    well_formed (aasp r x)
| wf_att: forall r p x,
    well_formed x ->
    S (fst r) = fst (range x) ->
    snd r = S (snd (range x)) ->
    well_formed (aatt r p x)
| wf_lseq: forall r x y,
    well_formed x -> well_formed y ->
    fst r = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = snd (range y) ->
    well_formed (alseq r x y)
| wf_bseq: forall r s x y,
    well_formed x -> well_formed y ->
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = S (snd (range y)) ->
    well_formed (abseq r s x y)
| wf_bpar: forall r s x y,
    well_formed x -> well_formed y ->
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = S (snd (range y)) ->
    well_formed (abpar r s x y).
Hint Constructors well_formed : core.

Lemma well_formed_range:
  forall t,
    well_formed t ->
    snd (range t) = fst (range t) + esize t.
Proof.
  induction t; intros; simpl; inv H; simpl.
  - rewrite Nat.add_1_r; auto.
  - apply IHt in H3; lia.
  - apply IHt1 in H3.
    apply IHt2 in H4.
    lia.
  - apply IHt1 in H4.
    apply IHt2 in H5.
    lia.
  - apply IHt1 in H4.
    apply IHt2 in H5.
    lia.
Qed.

Lemma anno_well_formed:
  forall t i,
    well_formed (snd (anno t i)).
Proof.
  induction t; intros; simpl; auto.
  - repeat expand_let_pairs.
    simpl.
    apply wf_att; simpl; auto;
      rewrite anno_range; simpl; reflexivity.
  - repeat expand_let_pairs.
    simpl.
    apply wf_lseq; simpl; auto;
      repeat rewrite anno_range; simpl;
        reflexivity.
  - repeat expand_let_pairs; simpl.
    apply wf_bseq; simpl; auto;
      repeat rewrite anno_range; simpl;
        reflexivity.
  - repeat expand_let_pairs; simpl.
    apply wf_bpar; simpl; auto;
      repeat rewrite anno_range; simpl;
        reflexivity.
Qed.

(** Eval for annotated terms. *)

Fixpoint aeval t p e :=
  match t with
  | aasp _ x => eval (asp x) p e
  | aatt _ q x => aeval x q e
  | alseq _ t1 t2 => aeval t2 p (aeval t1 p e)
  | abseq _ s t1 t2 => ss (aeval t1 p ((splitEv_T (fst s)) e))
                         (aeval t2 p ((splitEv_T (snd s)) e))
  | abpar _ s t1 t2 => pp (aeval t1 p ((splitEv_T (fst s)) e))
                         (aeval t2 p ((splitEv_T (snd s)) e))
  end.

Lemma eval_aeval:
  forall t p e i,
    eval t p e = aeval (snd (anno t i)) p e.
Proof.
  induction t; intros; simpl; auto.
  - repeat expand_let_pairs; simpl;
      rewrite <- IHt; auto.
  - repeat expand_let_pairs.
    simpl.
    rewrite <- IHt1.
    rewrite <- IHt2; auto.
  - repeat expand_let_pairs.
    simpl.
    rewrite <- IHt1.
    rewrite <- IHt2; auto.
    - repeat expand_let_pairs.
    simpl.
    rewrite <- IHt1.
    rewrite <- IHt2; auto.
Qed.

(** This predicate specifies when a term, a place, and some initial
    evidence is related to an event.  In other words, it specifies the
    set of events associated with a term, a place, and some initial
    evidence. *)

Inductive events: AnnoTerm -> Plc -> Ev -> Prop :=
| evtscpy:
    forall r i p,
      fst r = i ->
      events (aasp r CPY) p (copy i p)
| evtsusm:
    forall i id r p,
      fst r = i ->
      events (aasp r (ASPC id)) p (umeas i p id)
| evtssig:
    forall r i p,
      fst r = i ->
      events (aasp r SIG) p (sign i p)
| evtshsh:
    forall r i p,
      fst r = i ->
      events (aasp r HSH) p (hash i p)

| evtsattreq:
    forall r q t i p,
      fst r = i ->
      events (aatt r q t) p (req i p q (unanno t))
| evtsatt:
    forall r q t ev p,
      events t q ev ->
      events (aatt r q t) p ev
| evtsattrpy:
    forall r q t i p,
      snd r = S i ->
      events (aatt r q t) p (rpy i p q)
| evtslseql:
    forall r t1 t2 ev p,
      events t1 p ev ->
      events (alseq r t1 t2) p ev
| evtslseqr:
    forall r t1 t2 ev p,
      events t2 p ev ->
      events (alseq r t1 t2) p ev
| evtsbseqsplit:
    forall r i s t1 t2 p,
      fst r = i ->
      events (abseq r s t1 t2) p
             (split i p)
| evtsbseql:
    forall r s t1 t2 ev p,
      events t1 p ev ->
      events (abseq r s t1 t2) p ev
| evtsbseqr:
    forall r s t1 t2 ev p,
      events t2 p ev ->
      events (abseq r s t1 t2) p ev
| evtsbseqjoin:
    forall r i s t1 t2 p,
      snd r = S i ->
      events (abseq r s t1 t2) p
             (join i p)
| evtsbparsplit:
    forall r i s t1 t2 p,
      fst r = i ->
      events (abpar r s t1 t2) p
             (split i p)
| evtsbparl:
    forall r s t1 t2 ev p,
      events t1 p ev ->
      events (abpar r s t1 t2) p ev
| evtsbparr:
    forall r s t1 t2 ev p,
      events t2 p ev ->
      events (abpar r s t1 t2) p ev
| evtsbparjoin:
    forall r i s t1 t2 p,
      snd r = S i ->
      events (abpar r s t1 t2) p
             (join i p).
Hint Constructors events : core.

Lemma events_range:
  forall t v p,
    well_formed t ->
    events t p v ->
    fst (range t) <= ev v < snd (range t).
Proof.

  intros.
  pose proof H as G.
  apply well_formed_range in G.
  rewrite G.
  clear G.
  induction H0; inv H; simpl in *; auto; try lia.
  - apply IHevents in H4; lia.
  - Check well_formed_range.

    apply well_formed_range in H4; lia.
  - apply IHevents in H4; lia.
  - apply IHevents in H5.
    apply well_formed_range in H4.
    lia.
  - apply IHevents in H5; lia.
  - apply IHevents in H6.
    apply well_formed_range in H5.
    lia.
  - apply well_formed_range in H5.
    apply well_formed_range in H6.
    lia.
  - apply IHevents in H5; lia.
  - apply IHevents in H6.
    apply well_formed_range in H5.
    lia.
  - apply well_formed_range in H5.
    apply well_formed_range in H6.
    lia.
Qed.

Lemma at_range:
  forall x r i,
    S (fst r) = fst x ->
    snd r = S (snd x) ->
    fst r <= i < snd r ->
    i = fst r \/
    fst x <= i < snd x \/
    i = snd x.
Proof.
  intros.
  pose proof lt_dec i (S (fst r)) as G.
  destruct G as [G|G]; [left; lia| right].
  pose proof lt_dec i (snd x) as F.
  destruct F as [F|F]; [left; lia| right].
  lia.
Qed.

Lemma lin_range:
  forall x y i,
    snd x = fst y ->
    fst x <= i < snd y ->
    fst x <= i < snd x \/
    fst y <= i < snd y.
Proof.
  intros.
  pose proof lt_dec i (snd x) as G.
  destruct G; lia.
Qed.

Lemma bra_range:
  forall x y r i,
    S (fst r) = fst x ->
    snd x = fst y ->
    snd r = S (snd y) ->
    fst r <= i < snd r ->
    i = fst r \/
    fst x <= i < snd x \/
    fst y <= i < snd y \/
    i = snd y.
Proof.
  intros.
  pose proof lt_dec i (S (fst r)) as G.
  destruct G as [G|G]; [left; lia| right].
  pose proof lt_dec i (snd x) as F.
  destruct F as [F|F]; [left; lia| right].
  pose proof lt_dec i (snd y) as E.
  destruct E; lia.
Qed.

(** Properties of events. *)

Lemma events_range_event:
  forall t p i,
    well_formed t ->
    fst (range t) <= i < snd (range t) ->
    exists v, events t p v /\ ev v = i.
Proof.
  intros t p i H; revert i; revert p.
  induction H; intros; simpl in *.
  - destruct x; eapply ex_intro; split; auto;
      destruct r as [j k]; simpl in *; lia.
  - eapply at_range in H2; eauto.
    repeat destruct_disjunct; subst.
    + eapply ex_intro; split; auto.
    + apply IHwell_formed with (p:=p) in H2.
      destruct H2 as [v].
      destruct H2; subst.
      exists v; split; auto.
    + eapply ex_intro; split.
      apply evtsattrpy; auto.
      * rewrite H1; auto.
      * simpl; auto.
  - apply lin_range with (i:=i) in H2; eauto.
    destruct H2.
    + apply IHwell_formed1 with (p:=p) in H2; auto.
      destruct H2 as [v]; destruct H2; subst.
      exists v; split; auto.
    + apply IHwell_formed2 with (p:=p) in H2; auto.
      destruct H2 as [v]; destruct H2; subst.
      exists v; split; auto.
    + lia.
  - apply bra_range with (i:=i) (r:=r) in H2; eauto.
    repeat destruct_disjunct; subst.
    + eapply ex_intro; split; auto.
    + apply IHwell_formed1 with (p:=p) in H2.
      destruct H2 as [v]; destruct H2; subst.
      exists v; split; auto.
    + apply IHwell_formed2 with (p:=p) in H2.
      destruct H2 as [v]; destruct H2; subst.
      exists v; split; auto.
    + eapply ex_intro; split.
      * apply evtsbseqjoin; auto.
        rewrite H3; auto.
      * simpl; auto.
  - apply bra_range with (i:=i) (r:=r) in H2; eauto.
    repeat destruct_disjunct; subst.
    + eapply ex_intro; split; auto.
    + apply IHwell_formed1 with (p:=p) in H2.
      destruct H2 as [v]; destruct H2; subst.
      exists v; split; auto.
    + apply IHwell_formed2 with (p:=p) in H2.
      destruct H2 as [v]; destruct H2; subst.
      exists v; split; auto.
    + eapply ex_intro; split.
      * apply evtsbparjoin; auto.
        rewrite H3; auto.
      * simpl; auto.
Qed.

Ltac events_event_range :=
  repeat match goal with
         | [ H: events _ _ _ |- _ ] =>
           apply events_range in H; auto
         end; lia.

Lemma events_injective:
  forall t p v1 v2,
    well_formed t ->
    events t p v1 ->
    events t p v2 ->
    ev v1 = ev v2 ->
    v1 = v2.
Proof.
  intros t p v1 v2 H; revert v2; revert v1;
    revert p.
  induction H; intros.
  - inv H0; inv H1; auto.
  - pose proof H as G.
    apply well_formed_range in G.
    inv H2; inv H3; simpl in *; subst; auto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + eapply IHwell_formed in H11; eauto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
  - pose proof H as G.
    pose proof H0 as G0.
    apply well_formed_range in G.
    apply well_formed_range in G0.
    inv H4; inv H5; simpl in *; auto.
    + eapply IHwell_formed1 in H13; eauto.
    + events_event_range.
    + events_event_range.
    + eapply IHwell_formed2 in H13; eauto.
  - pose proof H as G.
    pose proof H0 as G0.
    apply well_formed_range in G.
    apply well_formed_range in G0.
    inv H4; inv H5; simpl in *; subst; auto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + eapply IHwell_formed1 in H13; eauto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + eapply IHwell_formed2 in H13; eauto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + events_event_range.
  - pose proof H as G.
    pose proof H0 as G0.
    apply well_formed_range in G.
    apply well_formed_range in G0.
    inv H4; inv H5; simpl in *; subst; auto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + eapply IHwell_formed1 in H13; eauto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + eapply IHwell_formed2 in H13; eauto.
    + events_event_range.
    + events_event_range.
    + events_event_range.
    + events_event_range.
Qed.

Inductive splitEv_T_R : SP -> Evidence -> Evidence -> Prop :=
| spAll: forall e, splitEv_T_R ALL e e
| spNone: forall e, splitEv_T_R NONE e mt.

Inductive evalR : Term -> Plc -> Evidence -> Evidence -> Prop :=
| evalR_asp: forall a p e,
    evalR (asp a) p e (eval_asp a p e)
| evalR_att: forall t1 q e e' p,
    evalR t1 q e e' ->
    evalR (att q t1) p e e'
| evalR_lseq: forall t1 t2 p e e' e'',
    evalR t1 p e e' ->
    evalR t2 p e' e'' ->
    evalR (lseq t1 t2) p e e''
| evalR_bseq: forall s e e1 e2 e1' e2' p t1 t2,
    splitEv_T_R (fst s) e e1 ->
    splitEv_T_R (snd s) e e2 ->
    evalR t1 p e1 e1' ->
    evalR t2 p e2 e2' ->
    evalR (bseq s t1 t2) p e (ss e1' e2')
| evalR_bpar: forall s e e1 e2 e1' e2' p t1 t2,
    splitEv_T_R (fst s) e e1 ->
    splitEv_T_R (snd s) e e2 ->
    evalR t1 p e1 e1' ->
    evalR t2 p e2 e2' ->
    evalR (bpar s t1 t2) p e (pp e1' e2').

Lemma eval_iff_evalR: forall t p e e',
    evalR t p e e' <-> eval t p e = e'.
Proof.
  split.
  - (* -> case *)
    intros.
    generalize dependent p.
    generalize dependent e.
    generalize dependent e'.

    induction t; intros.
    + destruct a; try (inv H; reflexivity).
    + inv H. simpl.
      eauto.
    + inv H.
      assert (eval t1 p e = e'0).
      eauto.
      subst.
      simpl.
      eauto.
    + inv H.
      assert (eval t1 p e1 = e1') by eauto.
      assert (eval t2 p e2 = e2') by eauto.
      simpl.
      destruct s. simpl.
      destruct s; destruct s0;
        try (simpl; subst; inv H3; inv H4; reflexivity).
    + inv H.
      assert (eval t1 p e1 = e1') by eauto.
      assert (eval t2 p e2 = e2') by eauto.
      simpl.
      destruct s. simpl.
      destruct s; destruct s0;
        try (simpl; subst; inv H3; inv H4; reflexivity).
  - (* <- case *)
    intros.
    generalize dependent p.
    generalize dependent e.
    generalize dependent e'.

    induction t; intros.
    + inv H.
      destruct a; try econstructor.
    + inv H.
      simpl.
      econstructor.
      eauto.
    + econstructor; eauto.
    + destruct s.
      simpl in H.
      destruct s; destruct s0; simpl in *; subst;
        econstructor; (try simpl); eauto; try (econstructor).
    + destruct s.
      simpl in H.
      destruct s; destruct s0; simpl in *; subst;
        econstructor; (try simpl); eauto; try (econstructor).
Defined.


Require Import Coq.Lists.List.
Require Import MirrorShard.Expr MirrorShard.Env.
Require Import MirrorShard.Prover.

Set Implicit Arguments.
Set Strict Implicit.

Local Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(** * The Assumption Prover **)

Section AssumptionProver.
  Variable types : list type.
  Variable fs : functions types.

  Definition assumption_summary : Type := list (expr types).

  Definition assumptionSummarize (hyps : list (expr types)) : assumption_summary := hyps.

  Fixpoint assumptionProve (hyps : assumption_summary)
    (goal : expr types) : bool :=
    match hyps with
      | nil => false
      | exp :: b => if expr_seq_dec exp goal
        then true
        else assumptionProve b goal
    end.

  Definition assumptionLearn (sum : assumption_summary) (hyps : list (expr types)) : assumption_summary :=
    sum ++ hyps.

  Definition assumptionValid (uvars vars : env types) (sum : assumption_summary) : Prop :=
    AllProvable fs uvars vars sum.

  Lemma assumptionValid_extensible : forall u g f ue ge,
    assumptionValid u g f -> assumptionValid (u ++ ue) (g ++ ge) f.
  Proof.
    unfold assumptionValid. eauto using AllProvable_weaken.
  Qed.

  Lemma assumptionSummarizeCorrect : forall uvars vars hyps,
    AllProvable fs uvars vars hyps ->
    assumptionValid uvars vars (assumptionSummarize hyps).
  Proof.
    auto.
  Qed.

  Lemma assumptionLearnCorrect : forall uvars vars sum,
    assumptionValid uvars vars sum -> forall hyps,
    AllProvable fs uvars vars hyps ->
    assumptionValid uvars vars (assumptionLearn sum hyps).
  Proof.
    unfold assumptionLearn, assumptionValid. intuition.
    apply AllProvable_app; auto.
  Qed.

  Theorem assumptionProverCorrect : ProverCorrect fs assumptionValid assumptionProve.
    apply ProverCorrect_ProverCorrect'.
    t; induction sum; t.
  Qed.

  Definition assumptionProver : ProverT types :=
  {| Facts := assumption_summary
   ; Summarize := assumptionSummarize
   ; Learn := assumptionLearn
   ; Prove := assumptionProve
   |}.
  Definition assumptionProver_correct : ProverT_correct (types := types) assumptionProver fs.
  eapply Build_ProverT_correct with (Valid := assumptionValid);
    eauto using assumptionValid_extensible, assumptionSummarizeCorrect, assumptionLearnCorrect, assumptionProverCorrect.
  Qed.

End AssumptionProver.

Definition AssumptionProver : ProverPackage :=
{| ProverTypes := nil_Repr EmptySet_type
 ; ProverFuncs := fun ts => nil_Repr (Default_signature ts)
 ; Prover_correct := fun ts fs => assumptionProver_correct fs
|}.


Check Empty_set.

Theorem all_equal : forall x y : Empty_set, x = y.
Proof.
 simple destruct x.
Qed.

Theorem all_diff : forall x y : Empty_set, x <> y.
Proof.
 simple destruct x.
Qed.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                            2004 -2005                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export struct_tacs.
Require Export struct_props.
Set Implicit Arguments.

(* some structural rules that will be used to analyse Dutch cross-dependencies *)
(*******************************************************************************)
(*           weak distributivity of the structural connective <>               *)
(*               <>j (A oi B) --> A oi <>jB                                    *)
(*******************************************************************************)

Definition K2Diam(I J:Set)(i:I) (j:J):structrule I J:=
((pdiam j (pcomma i (pvar 1) (pvar 2))),
 (pcomma i (pvar 1) (pdiam j (pvar 2)))).

Lemma K2Diam_ws:forall(I J:Set)(i:I) (j:J),
                     weakSahlqvist (K2Diam i j).
solve_ws.
Qed.

Lemma K2Diam_rw:forall I J decI decJ  A W  (t1 t2 :context I J A W)
                 (i:I)(j:J),
                (apply_rule (K2Diam i j) decI decJ
                  (TDiamond j (Comma i t1 t2)))=
                Some (Comma i t1 (TDiamond j t2)).
solve_rw_bis.
Qed.

Hint Rewrite K2Diam_rw:ctl_db.

Lemma K2Diam_Inv:forall I J decI decJ A W (t t':context I J A W)(i:I)(j:J),
                       (apply_rule (K2Diam i j) decI decJ  t)=Some t'->
                       {t1:context I J A W &{
                          t2:context I J A W |
                           t=(TDiamond j (Comma i t1 t2))}}.
solve_inv.
Qed.

Lemma K2DiamImgInv:forall I J decI decJ A W (t1 t2 Gamma:context I J A
W) (i:I)(j:J),
                (apply_rule (K2Diam i j) decI decJ Gamma)=
                Some (Comma i t1 (TDiamond j t2))->
               Gamma=(TDiamond j (Comma i t1 t2)).
solve_img_inv.
Qed.

(******************************************************************************)
(*                        inclusion postulate                                 *)
(*                         <>j1 A --><>j2 A                                   *)
(******************************************************************************)

Definition incDiam (I J:Set)(j1 j2 :J):structrule I J :=
((pdiam j1 (pvar 1)),
 (pdiam j2 (pvar 1))).

Definition incDiam_rw:forall I J decI decJ A W   (t1 :context I J A W)(j1 j2:J),
                      (apply_rule (incDiam I j1 j2) decI decJ (TDiamond j1 t1))=
                      Some (TDiamond j2 t1).
solve_rw_bis.
Qed.

Hint Rewrite incDiam_rw:ctl_db.
Lemma incDiam_Inv :forall I J decI decJ A W   (t t' :context I J A W)(j1 j2:J),
                     (apply_rule (incDiam I j1 j2) decI decJ    t)=Some t'->
                     {t1:context I J A W | t = TDiamond j1 t1}.
solve_inv.
Qed.

Lemma incDiamImgInv:forall I J decI decJ A W   (t1 t2 :context I J A W)(j1 j2:J),
                      (apply_rule (incDiam I j1 j2) decI decJ   t2)=
                      Some (TDiamond j2 t1)->
                      t2=(TDiamond j1 t1).
 solve_img_inv.
Qed.

(******************************************************************************)
(*                     Strong distributivity of <>                            *)
(*                    <>j (A oi B) --><>j A oi <>j B                          *)
(******************************************************************************)

Definition KDiam(I J:Set)(i:I)(j:J) :structrule I J:=
((pdiam j (pcomma i (pvar 1) (pvar 2))),
 (pcomma i (pdiam j (pvar 1)) (pdiam j (pvar 2)))).

Lemma KDiam_rw:forall (I J:Set) decI decJ A W   (t1 t2 :context I J A W) (i:I)(j:J),
                (apply_rule (KDiam i j) decI decJ   (TDiamond j (Comma i t1 t2)))=
                Some (Comma i (TDiamond j t1) (TDiamond j t2)).
solve_rw_bis.
Qed.

Hint Rewrite KDiam_rw:ctl_db.
Lemma KDiam_Inv:forall I J decI decJ A W   (t t':context I J A W)(i:I)(j:J),
                       (apply_rule (KDiam i j) decI decJ    t)=Some t'->
                       {t1:context I J A W &{
                          t2:context I J A W |
                           t=(TDiamond j (Comma i t1 t2))}}.
solve_inv.
Qed.

Lemma KDiamImgInv:forall I J decI decJ A W   (t1 t2 t3 :context I J A W) (i:I)(j:J),
                (apply_rule (KDiam i j) decI decJ   t3)=
                Some (Comma i (TDiamond j t1) (TDiamond j t2))->
                t3=(TDiamond j (Comma i t1 t2)).
 solve_img_inv.
Qed.

(******************************************************************************)
(*                  Controled Mixed commutativity                             *)
(*            A oi1 (<>j B oi2 C) --> <>j B oi2 (A oi1 C)                     *)
(******************************************************************************)

Definition MPDiam (I J:Set)(i1 i2:I)(j:J):structrule I J :=
((pcomma i1 (pvar 1) (pcomma i2 (pdiam j (pvar 2)) (pvar 3))),
 (pcomma i2 (pdiam j (pvar 2)) (pcomma i1 (pvar 1) (pvar 3)))).

Lemma MPDiam_rw :forall I J decI decJ A W   (t1 t2 t3 :context I J A W) (i1 i2:I)(j:J),
                (apply_rule (MPDiam i1 i2 j) decI decJ
                (Comma i1 t1 (Comma i2 (TDiamond j t2) t3)))=
                 Some (Comma i2 (TDiamond j t2) (Comma i1 t1 t3)).
solve_rw_bis.
Qed.

Hint Rewrite MPDiam_rw:ctl_db.

Lemma MPDiam_Inv:forall I J decI decJ A W   (t t':context I J A W) (i1 i2:I)(j:J),
                 (apply_rule (MPDiam i1 i2 j) decI decJ   t)=Some t'->
                 {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                      t=(Comma i1 t1 (Comma i2 (TDiamond j t2) t3))}}}.
solve_inv.
Qed.

Lemma MPDiamImgInv:forall I J decI decJ A W   (t1 t2 t3 t :context I J A W) (i1 i2:I)(j:J),
                (apply_rule (MPDiam i1 i2 j) decI decJ    t)=
                 Some (Comma i2 (TDiamond j t2) (Comma i1 t1 t3))->
                 t = (Comma i1 t1 (Comma i2 (TDiamond j t2) t3)).

 solve_img_inv.
Qed.

(* end of cross-dependencies postulates *)

(* other rules usually used *)

(* simpl rules *)

(******************************************************************************)
(*                       Simpl Associativity 1                                *)
(*                      A oi (B oi C) --> (A oi B) oi C                       *)
(******************************************************************************)

Definition L1 (I J:Set)(i:I) : structrule I J :=
   ((pcomma i (pvar 1) (pcomma i (pvar 2) (pvar 3))),
    (pcomma i (pcomma i (pvar 1) (pvar 2)) (pvar 3))).

Lemma L1_rw : forall I J decI decJ A W   (t1 t2 t3 :context I J A W) (i:I),
                (apply_rule (L1 J i) decI decJ   (Comma i t1 (Comma i t2 t3))) =
                Some (Comma i (Comma i t1 t2) t3).
solve_rw_bis.
Qed.

Hint Rewrite L1_rw:ctl_db.

Lemma L1_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i :I),
                (apply_rule (L1 J i) decI decJ   t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                       t=  (Comma i t1 (Comma i t2 t3))}}}.
solve_inv.
Qed.

Lemma L1ImgInv: forall I J decI decJ A W   (t1 t2 t3 t:context I J A W) (i:I),
                (apply_rule (L1 J i) decI decJ   t) =
                Some (Comma i (Comma i t1 t2) t3)->
                t=(Comma i t1 (Comma i t2 t3)).

 solve_img_inv.
Qed.

(******************************************************************************)
(*                           Simpl Associativity 2                            *)
(*                     (A oi B) oi C --> A oi (B oi c)                        *)
(******************************************************************************)

Definition L2(I J:Set) (i:I) : structrule I J :=
   ((pcomma i (pcomma i (pvar 1) (pvar 2)) (pvar 3)),
    (pcomma i (pvar 1) (pcomma i (pvar 2) (pvar 3)))).

Lemma L2_rw : forall (I J:Set)decI decJ A W   (t1 t2 t3 :context  I J A W) (i:I),
                (apply_rule (L2 J i) decI decJ   (Comma i (Comma i t1 t2) t3)
                     = Some (Comma i t1 (Comma i t2 t3))).
solve_rw_bis.
Qed.

Hint Rewrite L2_rw:ctl_db.

Lemma L2_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i :I),
                (apply_rule (L2 J i) decI decJ t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                       t=  (Comma i (Comma i t1 t2) t3)}}}.
solve_inv.
Qed.

Lemma L2ImgInv:forall I J decI decJ A W   (t1 t2 t3 t:context  I J A W) (i:I),
                (apply_rule (L2 J i) decI decJ   t)
                 = Some (Comma i t1 (Comma i t2 t3))->
                 t=(Comma i (Comma i t1 t2) t3).

 solve_img_inv.
Qed.

(******************************************************************************)
(*                          Simpl Commutativity                               *)
(*                           A oi B --> B oi A                                *)
(******************************************************************************)

Definition P (I J:Set)(i:I) : structrule I J :=
   ((pcomma i (pvar 1) (pvar 2)),
    (pcomma i (pvar 2) (pvar 1))).

Lemma P_rw : forall I J decI decJ A W   (t1 t2  :context I J A W) (i:I),
                (apply_rule (P J i) decI decJ   (Comma i t1 t2))
                     = Some (Comma i t2 t1).
solve_rw_bis.
Qed.

Hint Rewrite P_rw:ctl_db.

Lemma P_Inv :  forall I J decI decJ A W    (t t':context I J A W) (i :I),
                (apply_rule (P J i)  decI decJ   t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W |
                       t=  (Comma i t1 t2)}}.
solve_inv.
Qed.

Lemma PImgInv:forall I J decI decJ A W   (t1 t2 t :context I J A W) (i:I),
                (apply_rule (P J i) decI decJ   t)
                     = Some (Comma i t2 t1)->
                t=(Comma i t1 t2).
 solve_img_inv.
Qed.

(* interaction postulates *)

(******************************************************************************)
(*                    Controled permutation                                   *)
(*                   <>j A oi B --> B oi <>jA                                 *)
(******************************************************************************)

Definition comDiam(I J:Set) (i:I)(j:J) : structrule I J :=
   ((pcomma i (pdiam j (pvar 1)) (pvar 2)),
    (pcomma i (pvar 2) (pdiam j (pvar 1)))).

Lemma comDiam_rw : forall I J decI decJ A W   (t1 t2 :context I J A W)
                           (i:I)(j:J),
                (apply_rule (comDiam i j) decI decJ
                            (Comma i (TDiamond j t1) t2)
                     = Some (Comma i t2 (TDiamond j t1))).
solve_rw_bis.
Qed.

Hint Rewrite comDiam_rw:ctl_db.

Lemma comDiam_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i :I)(j:J),
                (apply_rule (comDiam  i j) decI decJ   t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W |
                       t=  (Comma i (TDiamond j t1) t2)}}.
solve_inv.
Qed.

Lemma comDiamImgInv :forall I J decI decJ A W   (t1 t2 t3 t:context I J A W)
                           (i:I)(j:J),
                (apply_rule (comDiam i j) decI decJ    t)
                = Some (Comma i t2 (TDiamond j t1)) ->
                t=(Comma i (TDiamond j t1) t2).
 solve_img_inv.
Qed.

(******************************************************************************)
(*                        Mixed associativity 1                               *)
(*                     A oi (B oj C) -->(A oi B) oj C                         *)
(******************************************************************************)

Definition MA1(I J:Set) (i j:I) : structrule I J :=
   ((pcomma i (pvar 1) (pcomma j (pvar 2) (pvar 3))),
    (pcomma j (pcomma i  (pvar 1) (pvar 2)) (pvar 3))).

Lemma MA1_rw : forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i j:I),
                (apply_rule (MA1 J i j) decI decJ   (Comma i t1 (Comma j t2 t3)))
                     = Some  (Comma j (Comma i t1 t2) t3).
solve_rw_bis.
Qed.

Hint Rewrite MA1_rw :ctl_db.

Lemma MA1_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i j :I),
                (apply_rule (MA1 J i j) decI decJ   t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                       t=  (Comma i t1 (Comma j t2 t3))}}}.
solve_inv.
Qed.

Lemma MA1ImgInv:forall I J decI decJ A W   (t1 t2 t3 t:context  I J A W) (i j:I),
                (apply_rule (MA1 J i j) decI decJ   t)
                     = Some  (Comma j (Comma i t1 t2) t3)->
                  t=(Comma i t1 (Comma j t2 t3)).
 solve_img_inv.
Qed.

(******************************************************************************)
(*                        Mixed Associativity  2                              *)
(*                     (A oi B) oj C --> A oi (B oj C)                        *)
(******************************************************************************)

Definition MA2 (I J:Set)(i j:I) : structrule I J :=
   ((pcomma j (pcomma i  (pvar 1) (pvar 2)) (pvar 3)),
    (pcomma i (pvar 1) (pcomma j (pvar 2) (pvar 3)))).

Lemma MA2_rw : forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i j:I),
                (apply_rule (MA2 J i j) decI decJ   (Comma j (Comma i t1 t2) t3))
                     = Some (Comma i t1 (Comma j t2 t3)).
solve_rw_bis.
Qed.

Hint Rewrite MA2_rw :ctl_db.

Lemma MA2_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i j :I),
                (apply_rule (MA2 J i j) decI decJ   t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                       t=  (Comma j (Comma i t1 t2) t3)}}}.
solve_inv.
Qed.

Lemma MA2ImgInv:forall I J decI decJ A W   (t1 t2 t3 t:context  I J A W) (i j:I),
                (apply_rule (MA2 J i j) decI decJ   t)
                     = Some (Comma i t1 (Comma j t2 t3))->
                  t=(Comma j (Comma i t1 t2) t3).
 solve_img_inv.
Qed.
(******************************************************************************)
(*                       Controled Mixed Associativity 2                      *)
(*                      (A oi B) oi <>j C -->A oi (B oi <>j C)                *)
(******************************************************************************)

Definition MA2Diam(I J:Set) (i:I)(j:J):structrule I J :=
 ((pcomma i (pcomma i (pvar 1) (pvar 2)) (pdiam j (pvar 3))),
   (pcomma i (pvar 1) (pcomma i (pvar 2) (pdiam j (pvar 3))))).

Lemma MA2Diam_rw:forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i:I)(j:J),
                 (apply_rule (MA2Diam i j) decI decJ   (Comma i (Comma i t1 t2) (TDiamond j t3)))=
                  Some (Comma i t1 (Comma i t2 (TDiamond j t3))).
solve_rw_bis.
Qed.

Hint Rewrite MA2Diam_rw:ctl_db.

Lemma MA2Diam_Inv :forall I J decI decJ A W   (t t':context I J A W) (i :I)(j:J),
                 (apply_rule (MA2Diam i j) decI decJ   t)= Some t' ->
                 {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                        t = (Comma i (Comma i t1 t2)(TDiamond j t3))}}}.
solve_inv.
Qed.

Lemma MA2DiamImgInv:forall I J decI decJ A W   (t1 t2 t3 t :context  I J A W) (i:I)(j:J),
                 (apply_rule (MA2Diam i j) decI decJ   t)=
                  Some (Comma i t1 (Comma i t2 (TDiamond j t3)))->
                  t=(Comma i (Comma i t1 t2) (TDiamond j t3)).
solve_img_inv.
Qed.

(******************************************************************************)
(*                        Mixed Permutation                                   *)
(*                     A oj (B oi C) -->B oi (A oj C)                         *)
(******************************************************************************)

Definition  MP (I J:Set) (i j:I): structrule I J  :=
  ((pcomma j (pvar 2) (pcomma i (pvar 1) (pvar 3))),
   (pcomma i (pvar 1) (pcomma j (pvar 2) (pvar 3)))).

Lemma MP_rw : forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i j:I),
                (apply_rule (MP J i j) decI decJ   (Comma j t2 (Comma i t1 t3)))
                     = Some (Comma i t1 (Comma j t2 t3)).
solve_rw_bis.
Qed.

Hint Rewrite MP_rw:ctl_db.

Lemma MP_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i j :I),
                (apply_rule (MP J i j) decI decJ   t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                       t=  (Comma j t2 (Comma i t1 t3))}}}.
solve_inv.
Qed.

Lemma MPImgInv: forall I J decI decJ A W   (t1 t2 t3 t :context  I J A W) (i j:I),
                (apply_rule (MP J i j) decI decJ   t)
                     = Some (Comma i t1 (Comma j t2 t3))->
                t=(Comma j t2 (Comma i t1 t3)).
 solve_img_inv.
Qed.
(******************************************************************************)
(*                    Controled Mixed Permutation1                            *)
(*                    (A oi B) oi <>j C --> (A oi <>j C) oi B                 *)
(******************************************************************************)

Definition MP1Diam(I J:Set) (i:I)(j:J):structrule I J :=
 ((pcomma i (pcomma i (pvar 1) (pvar 2)) (pdiam j (pvar 3))),
   (pcomma i (pcomma i (pvar 1) (pdiam j (pvar 3))) (pvar 2))).

Lemma MP1Diam_rw:forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i:I)(j:J),
                 (apply_rule (MP1Diam i j) decI decJ
                   (Comma i (Comma i t1 t2) (TDiamond j t3)))=
                  Some (Comma i (Comma i t1 (TDiamond j t3)) t2).
solve_rw_bis.
Qed.

Hint Rewrite MP1Diam_rw:ctl_db.

Lemma MP1Diam_Inv :forall I J decI decJ A W   (t t':context I J A W) (i :I)(j:J),
                 (apply_rule (MP1Diam i j) decI decJ   t)= Some t' ->
                 {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                        t = (Comma i (Comma i t1 t2)(TDiamond j t3))}}}.
solve_inv.
Qed.

Lemma MP1DiamImgInv:forall I J decI decJ A W   (t1 t2 t3 t:context  I J A W) (i:I)(j:J),
                 (apply_rule (MP1Diam i j) decI decJ   t)=
                  Some (Comma i (Comma i t1 (TDiamond j t3)) t2)->
                 t= (Comma i (Comma i t1 t2) (TDiamond j t3)).
 solve_img_inv.
Qed.

(*****************************************************************************)
(*                     Controled Mixed Permutation                           *)
(*                      <>j A oi (B oi C) --> B oi (<>j A oi C)              *)
(*****************************************************************************)

Definition MP2Diam(I J:Set) (i:I)(j:J):structrule I J :=
 ((pcomma i (pdiam j (pvar 3)) (pcomma i (pvar 1) (pvar 2))),
   (pcomma i (pvar 1) (pcomma i (pdiam j (pvar 3)) (pvar 2)))).

Lemma MP2Diam_rw:forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i:I)(j:J),
                 (apply_rule (MP2Diam i j) decI decJ   (Comma i (TDiamond j t3) (Comma i t1 t2)))=
                  Some (Comma i t1 (Comma i (TDiamond j t3) t2)).
solve_rw_bis.
Qed.

Hint Rewrite MP2Diam_rw:ctl_db.

Lemma MP2Diam_Inv :forall I J decI decJ A W   (t t':context I J A W) (i :I)(j:J),
                 (apply_rule (MP2Diam i j) decI decJ   t)= Some t' ->
                 {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                        t = (Comma i (TDiamond j t3) (Comma i t1 t2))}}}.
solve_inv.
Qed.

Lemma MP2DiamImgInv:forall I J decI decJ A W   (t1 t2 t3 t:context  I J A W) (i:I)(j:J),
                 (apply_rule (MP2Diam i j) decI decJ   t)=
                  Some (Comma i t1 (Comma i (TDiamond j t3) t2))->
                  t=(Comma i (TDiamond j t3) (Comma i t1 t2)).
 solve_img_inv.
Qed.
(******************************************************************************)
(*                      Mixed contraction                                     *)
(*                (A oi B) oj C --> (A oj C) oi (B oj C)                      *)
(******************************************************************************)

Definition  MC (I J :Set) (i j:I): structrule I J :=
   ((pcomma j (pcomma i (pvar 1) (pvar 2)) (pvar 3)),
    (pcomma i (pcomma j (pvar 1) (pvar 3)) (pcomma j (pvar 2) (pvar 3)))).

Lemma MC_rw : forall I J decI decJ A W   (t1 t2 t3 :context  I J A W) (i j:I),
                (apply_rule (MC J i j) decI decJ   (Comma j (Comma i t1 t2) t3)
                     = Some (Comma i (Comma j t1 t3) (Comma j t2 t3))).
solve_rw_bis.
Qed.

Hint Rewrite MC_rw:ctl_db.

Lemma MC_Inv :  forall I J decI decJ A W   (t t':context I J A W) (i j :I),
                (apply_rule (MC J i j) decI decJ    t)= Some t' ->
                {t1 : context I J A W &
                   {t2 : context I J A W &
                       {t3 :  context I J A W |
                       t=  (Comma j (Comma i t1 t2) t3)}}}.
solve_inv.
Qed.

Lemma MCImgInv: forall I J decI decJ A W   (t1 t2 t3 t :context  I J A W) (i j:I),
                (apply_rule (MC J i j) decI decJ   t)
                     = Some (Comma i (Comma j t1 t3) (Comma j t2 t3))->
                t=(Comma j (Comma i t1 t2) t3).
 solve_img_inv.
Qed.

Implicit Arguments L1 [I J].
Implicit Arguments L2 [I J].
Implicit Arguments P[I J].
Implicit Arguments MP[I J].
Implicit Arguments MC[I J].