Load loadpath.
Require Import ZArith Coq.Lists.List Permutation.
Require Import VST.msl.Axioms veric.Coqlib2.
Require Import VST.msl.predicates_sa.
Require Import veristar.datatypes veristar.clauses veristar.clause_lemmas
               veristar.list_denote veristar.superpose veristar.basic
               veristar.compare.
Import Superposition.
Require Import veristar.model_type veristar.model.

Module Type SP_SOUND.
Declare Module VSM : VERISTAR_MODEL.
Import VSM VeriStarLogic.

Axiom check_clauseset_Valid_sound: forall init g u,
  check_clauseset init = (Valid, g, u) ->
  setd clause_denote inter TT init |-- clause_denote empty_clause.

Axiom check_clauseset_Cexample_sound: forall init final empty R selected,
  check_clauseset init = (C_example R selected, final, empty) ->
  setd clause_denote inter TT init |--
    setd clause_denote inter TT selected &&
    setd clause_denote inter TT final.

End SP_SOUND.

Module SP_Sound (VSM : VERISTAR_MODEL) : SP_SOUND with Module VSM := VSM.
Module VSM := VSM.
Import VSM VeriStarLogic.

Implicit Arguments list_denote [A T].
Local Notation "'listd'" := list_denote.

Implicit Arguments andp [A].
Local Notation "'inter'" := (@andp _). (*implicit arguments acting weird*)

(* the following five rules (barring reflexivity resolution, which is performed
   during the simplification phase) are collected in rule "sp" *)

Require Import Bool.

Definition positive_superposition (c d : clause) l0 : list clause :=
  match c , d with
  | PureClause nil (Eqv s t :: pos) _ _ ,
    PureClause nil (Eqv s' v :: pos') _ _ =>
    if expr_eq s s' && expr_lt t s && expr_lt v s' &&
       pure_atom_gt1 (Eqv s t) pos && pure_atom_gt1 (Eqv s' v) pos' &&
       pure_atom_gt (Eqv s' v) (Eqv s t)
    then mkPureClause nil (insert_uniq pure_atom_cmp (norm_pure_atom (Eqv t v))
                          (merge pure_atom_cmp pos pos')) :: l0
    else l0
  | _ , _ => l0
  end.

Definition negative_superposition (c d : clause) l0 : list clause :=
  match c , d with
  | PureClause nil (Eqv s t :: pos) _ _,
    PureClause (Eqv s' v :: neg') pos' _ _ =>
    if expr_eq s s' && expr_lt t s && expr_lt v s'
    then mkPureClause (insert_uniq pure_atom_cmp (norm_pure_atom (Eqv t v)) neg')
                      (merge pure_atom_cmp pos pos') :: l0
    else l0
  | _ , _ => l0
  end.

Definition reflexivity_resolution (d : clause) l0 : list clause :=
  match d with
  | PureClause (Eqv u v :: neg) pos _ _ =>
    if expr_eq u v then mkPureClause neg pos :: l0 else l0
  | _ => l0
  end.

Definition ordered_factoring (c : clause) l0 : list clause :=
  match c with
  | PureClause nil (Eqv s t :: Eqv u v :: pos) _ _ =>
    if pure_atom_eq (Eqv s t) (Eqv u v)
    then mkPureClause nil
            (insert_uniq pure_atom_cmp (norm_pure_atom (Eqv s t)) pos)
                :: l0
    else l0
  | _ => l0
  end.

Definition equality_factoring (c : clause) l0 : list clause :=
  match c with
  | PureClause nil (Eqv u v :: Eqv s t :: pos) _ _ =>
    if expr_eq s u && pure_atom_gt (Eqv u v) (Eqv s t)
    then mkPureClause [norm_pure_atom (Eqv v t)]
               (insert_uniq pure_atom_cmp (norm_pure_atom (Eqv u t)) pos) :: l0
    else l0
  | _ => l0
  end.

Lemma positive_superposition_sound c d l0 s :
  clause_denote c s -> clause_denote d s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (positive_superposition c d l0) s.
Proof with simpl; auto.
intros A B; destruct c as [gamma delta| |]; destruct d as [gamma' delta'| |]...
2: simpl; destruct gamma, delta... 2: destruct p...
2: simpl; destruct gamma, delta... 2: destruct p...
destruct gamma, delta as [|atm delta]...
destruct atm as [e1 e2], delta'... (*destruct p...*) simpl in A; spec A...
destruct gamma'... destruct gamma'... destruct p...
remember (expr_eq e1 e) as b; destruct b. 2: simpl; auto.
if_tac... split... intro H1. specialize (B H1). simpl in B.
rewrite (@listd_insert_uniq_un _ state)... 2: apply pure_atom_cmp_eq.
destruct A as [A|A];destruct B as [B|B]... rewrite <-(expr_eq_eq' _ _ Heqb) in B.
assert (C: (e0 === e2) s) by (eapply var_eq_trans; apply var_eq_sym in B; eauto).
left; if_tac... solve[apply var_eq_sym; auto].
right; apply listd_merge_un2... solve[apply pure_atom_cmp_eq].
right; apply listd_merge_un1... solve[apply pure_atom_cmp_eq].
right; apply listd_merge_un2... solve[apply pure_atom_cmp_eq].
Qed.

Lemma negative_superposition_sound c d l0 s :
  clause_denote c s -> clause_denote d s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (negative_superposition c d l0) s.
Proof with simpl; auto.
intros A B; destruct c as [gamma delta| |]; destruct d as [gamma' delta'| |]...
2: simpl; destruct gamma, delta... 2: destruct p...
2: simpl; destruct gamma, delta... 2: destruct p...
destruct gamma, delta... destruct p... destruct gamma'... destruct p...
remember (expr_eq e e1) as b; destruct b. 2: simpl; auto.
if_tac; [simpl|simpl; auto]; rewrite interS; simpl. intro H3. split...
rewrite (@listd_insert_uniq_inter _ state)... 2: apply pure_atom_cmp_eq.
intros [H1 H2].
assert ((e2 === e0) s). if_tac in H1; simpl in H1... apply var_eq_sym...
simpl in A; spec A... inversion A.
simpl in B; spec B. split... apply expr_eq_eq' in Heqb; subst e1.
eapply var_eq_trans; eapply var_eq_sym in H; eauto.
apply listd_merge_un2... solve[apply pure_atom_cmp_eq].
apply listd_merge_un1... solve[apply pure_atom_cmp_eq].
Qed.

Lemma reflexivity_resolution_sound c l0 s :
  clause_denote c s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (reflexivity_resolution c l0) s.
Proof with
try solve [simpl; destruct delta as [|p]; simpl; auto; destruct p; simpl; auto].
intros A; destruct c as [gamma delta| |]...
simpl; destruct gamma as [|p]; simpl; auto; destruct p...
remember (expr_eq e e0) as b; destruct b; simpl; try split; auto.
intro Hyp; apply A; rewrite (expr_eq_eq' _ _ Heqb); simpl; split; auto.
solve[apply var_eq_refl].
Qed.

Lemma ordered_factoring_sound c l0 s :
  clause_denote c s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (ordered_factoring c l0) s.
Proof with
simpl; auto;
try solve [simpl; destruct delta as [|p]; simpl; auto; destruct p; simpl; auto].
intros A; destruct c as [gamma delta| |]...
destruct gamma... destruct delta... destruct p... destruct delta... destruct p...
(*simpl; destruct delta as [|p]; simpl; auto; destruct p...
destruct delta as [|p]; simpl; auto; destruct p...*)
remember (expr_eq e e1) as b1; remember (expr_eq e0 e2) as b2.
destruct b1, b2...
if_tac... simpl; split; auto. intro Hyp.
rewrite (listd_insert_uniq_un pure_atom_denote FF). 2: apply pure_atom_cmp_eq.
rewrite (expr_eq_eq' _ _ Heqb1), (expr_eq_eq' _ _ Heqb2) in A |- *.
simpl in A; destruct A as [A|[A|A]]; [auto| | |right; auto].
solve [left; if_tac; simpl; solve[auto | apply var_eq_sym; auto]].
solve [left; if_tac; simpl; solve[auto | apply var_eq_sym; auto]].
replace (pure_atom_eq (Eqv e e0) (Eqv e1 e2)) with false; auto.
unfold pure_atom_eq; simpl.
unfold expr_eq in Heqb1. destruct (expr_cmp e e1); simpl; try congruence.
unfold expr_eq in Heqb2. destruct (expr_cmp e0 e2);simpl; try congruence.
replace (pure_atom_eq (Eqv e e0) (Eqv e1 e2)) with false; auto.
unfold pure_atom_eq; simpl.
unfold expr_eq in Heqb1. destruct (expr_cmp e e1); simpl; try congruence.
replace (pure_atom_eq (Eqv e e0) (Eqv e1 e2) ) with false; auto.
unfold pure_atom_eq; simpl.
unfold expr_eq in Heqb1. destruct (expr_cmp e e1); simpl; try congruence.
Qed.

Lemma equality_factoring_sound c l0 s :
  clause_denote c s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (equality_factoring c l0) s.
Proof with
simpl; auto;
try solve [simpl; destruct gamma as [|p]; simpl; auto; destruct p; simpl; auto].
intros A; destruct c as [gamma delta| |]... simpl.
destruct gamma... destruct delta... destruct p... destruct delta... destruct p...
remember (expr_eq e1 e) as b; destruct b...
if_tac... simpl; split; auto. intro Hyp.
rewrite (listd_insert_uniq_un pure_atom_denote FF). 2: apply pure_atom_cmp_eq.
destruct Hyp as [B C].
simpl in A; destruct A as [A|[A|A]]; [auto| | |right; auto].
assert (D : (e === e2) s).
  if_tac in B; simpl in B;
  apply (var_eq_trans _ _ _ _ A); [apply var_eq_sym; auto | auto].
solve[left; if_tac; simpl; [apply var_eq_sym; auto | auto]].
assert (D : (e === e2) s).
  rewrite <- (expr_eq_eq' _ _ Heqb) .
  if_tac in B; simpl in B;
  apply (var_eq_trans _ _ _ _ A); [apply var_eq_sym; auto | auto];
    apply var_eq_refl.
solve[left; if_tac; simpl; [apply var_eq_sym; auto | auto]].
Qed.

Lemma sp_sound c d l0 s :
  clause_denote c s -> clause_denote d s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (sp c d l0) s.
Proof with simpl; auto.
intros H1 H2 H3.
generalize (negative_superposition_sound c d l0 s) as H4; intro.
generalize (positive_superposition_sound c d l0 s) as H5; intro.
generalize (equality_factoring_sound c l0 s) as H6; intro.
generalize (ordered_factoring_sound c l0 s) as H7; intro.
specialize (H4 H1 H2 H3); specialize (H5 H1 H2 H3).
specialize (H6 H1 H3); specialize (H7 H1 H3).
rewrite (@listd_unfold_inter _ state). split...
destruct c, d... simpl in H4, H5, H6.
destruct gamma, delta... destruct p...
destruct gamma0, delta0... destruct p... if_tac... split... intros _.
destruct H5 as [H5 _].
rewrite (@listd_unfold_un _ state). left. apply H5...
Qed.

Lemma superpose_sound c d l0 s :
  clause_denote c s -> clause_denote d s -> listd clause_denote inter TT l0 s ->
  listd clause_denote inter TT (superpose c d l0) s.
Proof with simpl; auto.
intros H1 H2 H3. unfold superpose. apply sp_sound... apply sp_sound...
Qed.

Lemma remove_trivial_atoms_sound b atms s :
  listd pure_atom_denote inter b atms s ->
  listd pure_atom_denote inter b (remove_trivial_atoms atms) s.
Proof.
intro A; induction atms; auto.
destruct a; simpl in A |- *; destruct A as [A1 A2]; specialize (IHatms A2).
solve [remember (expr_cmp e e0) as b'; destruct b'; simpl; try split; auto].
Qed.

Lemma remove_trivial_atoms_equiv b atms s :
  listd pure_atom_denote inter b (remove_trivial_atoms atms) s <->
  listd pure_atom_denote inter b atms s.
Proof.
split; intro A;
[ |solve[apply remove_trivial_atoms_sound; auto]].
induction atms; auto; destruct a; simpl in A |- *.
remember (expr_cmp e e0) as b'; destruct b'; simpl in A;
[ |solve[destruct A as [A1 A2]; specialize (IHatms A2); split; auto]
  |solve[destruct A as [A1 A2]; specialize (IHatms A2); split; auto]].
apply comp_eq in Heqb'; auto. subst e0.
specialize (IHatms A).
split; auto.
solve[apply var_eq_refl].
Qed.

Lemma delete_resolved_sound c s :
  clause_denote c s -> clause_denote (delete_resolved c) s.
Proof with simpl; auto.
intro H1. destruct c... intros H2.
2: intros; left; unfold var_eq; auto.
2: intros; left; unfold var_eq; auto.
rewrite (@listd_sort_uniq_inter _ state), remove_trivial_atoms_equiv in H2.
rewrite (@listd_sort_uniq_un _ state). apply (H1 H2).
intros x y; rewrite <-pure_atom_cmp_eq; auto.
intros x y; rewrite <-pure_atom_cmp_eq; auto.
Qed.

Lemma rewrite_by_eqv s t atm st :
  (s === t) st ->
  pure_atom_denote atm st = pure_atom_denote (rewrite_by s t atm) st.
Proof with simpl; auto.
intro H1. apply prop_ext; split. intro H2.
destruct atm as [e1 e2]. simpl.
remember (expr_eq s e1) as b1; remember (expr_eq s e2) as b2.
destruct b1. destruct b2...
assert (H3: (t === t) st) by (apply var_eq_refl). if_tac...
assert (H3: (t === e2) st).
  apply var_eq_trans with (y := s). apply var_eq_sym...
  apply expr_eq_eq' in Heqb1; subst s.
  apply var_eq_trans with (y := e1)... apply var_eq_refl.
if_tac... apply var_eq_sym...
destruct b2...
assert (H3: (e1 === t) st).
  apply var_eq_trans with (y := e2)...
  apply var_eq_trans with (y := s)...
  apply expr_eq_eq' in Heqb2; subst s. apply var_eq_refl.
if_tac... apply var_eq_sym...
(* <-- *)
intro H2; destruct atm as [e1 e2]. simpl.
 simpl in H2. remember (expr_eq s e1) as b1; remember (expr_eq s e2) as b2.
destruct b1. destruct b2... if_tac in H2.
apply expr_eq_eq' in Heqb1. apply expr_eq_eq' in Heqb2.
subst. subst e1. apply var_eq_refl.
apply expr_eq_eq' in Heqb1. apply expr_eq_eq' in Heqb2.
subst. subst e1. apply var_eq_refl.
apply expr_eq_eq' in Heqb1. subst s. simpl in H2. if_tac in H2.
simpl in H2. apply var_eq_trans with (y := t)... apply var_eq_sym...
simpl in H2.  apply var_eq_trans with (y := t)... apply var_eq_sym...
simpl in H2. destruct b2. apply expr_eq_eq' in Heqb2. subst s.
if_tac in H2; simpl in H2.
apply var_eq_trans with (y := t)...
apply var_eq_trans with (y := t)... apply var_eq_sym...
simpl in H2. apply var_eq_sym...
Qed.

Lemma rewrite_by_sound s t atm st :
  (s === t) st -> pure_atom_denote atm st ->
  pure_atom_denote (rewrite_by s t atm) st.
Proof with simpl; auto.
intro H1; rewrite <-rewrite_by_eqv...
Qed.

Lemma rewrite_by_complete s t atm st :
  (s === t) st -> pure_atom_denote (rewrite_by s t atm) st ->
  pure_atom_denote atm st.
Proof with simpl; auto.
intro H1; rewrite <-rewrite_by_eqv...
Qed.

Lemma demodulate_sound c d s :
  clause_denote c s -> clause_denote d s ->
  clause_denote (demodulate c d) s.
Proof with simpl; auto.
intros H1 H2. destruct c... destruct gamma, delta...
 destruct p... destruct delta... destruct d... intro H3.
simpl in H1; spec H1; auto.
inversion H1. 2: inversion H. clear H1.
subst priority0.
induction gamma. simpl in H2; spec H2; auto. induction delta...
inversion H2. left. apply rewrite_by_sound... right. apply IHdelta...
destruct H3 as [H3 H4]. apply IHgamma... intro H5. simpl in H2; spec H2.
split... rewrite <-rewrite_by_eqv in H3... auto.
Qed.

Lemma clause_denote_foldl (f: clause -> clause -> clause) l c0 s :
  listd clause_denote inter TT l s -> clause_denote c0 s ->
  (forall c d, clause_denote c s -> clause_denote d s ->
               clause_denote (f c d) s) ->
  clause_denote (fold_left f l c0) s.
Proof with simpl; auto.
intros H1 H2 H3. revert c0 H2. induction l... intros c0 H2.
inversion H1; apply IHl...
Qed.

Lemma simplify_sound l c s :
  listd clause_denote inter TT l s -> clause_denote c s ->
  clause_denote (simplify l c) s.
Proof with simpl; auto.
intros H1 H2. unfold simplify. apply delete_resolved_sound.
apply clause_denote_foldl...
intros c0 d H3 H4; apply demodulate_sound...
Qed.

Lemma infer_list_sound c l s :
  clause_denote c s -> listd clause_denote inter TT l s ->
  listd clause_denote inter TT (infer_list c l) s.
Proof with simpl; auto.
intros A B; unfold infer_list. autounfold with DEBUG_UNFOLD.
apply listd_filter_pred.
apply listd_map_pred with (f := clause_denote).
solve[intros d H1; apply simplify_sound; auto].
apply listd_fold_left... intros d cls H1 H2.
apply superpose_sound...
Qed.

Lemma insert_uniq_In {A} cmp (l : list A) a a' :
  In a' (insert_uniq cmp a l) -> a = a' \/ In a' l.
Proof with auto.
revert a'; induction l... intro a'. simpl. destruct (cmp a a0)...
simpl; intros [B | B]... specialize (IHl a' B). destruct IHl...
Qed.

Lemma rsort_uniq_In {A} cmp (l : list A) a : In a (rsort_uniq cmp l) -> In a l.
Proof with simpl; auto.
revert a; induction l; intro a'... intro B.
cut (a = a' \/ In a' (rsort_uniq cmp l)); [intro C|].
destruct C... eapply insert_uniq_In; eauto.
Qed.

Lemma pick_In (cls : M.t) cl :
  M.min_elt cls = Some cl -> In cl (M.elements cls).
Proof with try inversion 1; auto.
unfold setd.
remember (M.min_elt cls) as b. destruct b... symmetry in Heqb.
apply M.min_elt_spec1 in Heqb; rewrite <- M.elements_spec1 in Heqb.
rewrite SetoidList.InA_alt in Heqb. destruct Heqb as [y [B C]].
subst. subst. auto.
Qed.

Lemma pick_sound (cls : M.t) c s :
  setd clause_denote inter TT cls s -> M.min_elt cls = Some c ->
  clause_denote c s.
Proof with try inversion 1; auto.
intro A. remember (M.min_elt cls) as b. destruct b...
eapply listd_In_inv_pred; eauto. solve[rewrite Heqb in H; eapply pick_In; eauto].
Qed.

Lemma setd_mem_add c cls cls' s :
  clause_denote c s -> setd clause_denote inter TT cls s ->
  mem_add c cls = Some cls' ->
  setd clause_denote inter TT cls' s.
Proof.
intros H1 H2 H3. rewrite mem_add_spec in H3. if_tac in H3; [congruence|].
inversion H3; subst. apply setd_add; auto.
Qed.

Lemma one_inference_step_sound given unselected given' unselected' s :
  setd clause_denote inter TT given s ->
  setd clause_denote inter TT unselected s ->
  one_inference_step (given, unselected) = (given', unselected') ->
  setd clause_denote inter TT given' s /\
  setd clause_denote inter TT unselected' s.
Proof with simpl; auto.
unfold one_inference_step; intros A B C.
(*DEBUGGING*)
autounfold with DEBUG_UNFOLD in *.
(*DEBUGGING*)
remember (M.delete_min unselected) as b. destruct b as [[c unselected'']| ].
2: inversion C; subst; split; auto.
symmetry in Heqb.
apply M.delete_min_spec1 in Heqb.
  destruct Heqb as [Heqb ?]. subst unselected''.
remember (mem_add (simplify (M.elements given) c) given) as q.
  destruct q as [new_given|].
if_tac in C. inversion C; subst. split. clear C.
symmetry in Heqq; eapply setd_mem_add with (cls := given); eauto.
apply simplify_sound; auto. eapply pick_sound; eauto.
apply setd_fold_left...
clear C. intros until s0. intros H1 H2. if_tac... solve[apply setd_add; auto].
apply infer_list_sound... apply simplify_sound... eapply pick_sound; eauto.
apply setd_remove; auto.
inversion C; subst; split; auto. apply setd_remove; auto.
if_tac in C; inversion C; subst. split; auto. apply setd_remove; auto.
split; auto. apply setd_remove; auto.
Qed.

Lemma simple_loop_induction (P : M.t*M.t -> Prop)
                            given unselected r given' unselected' :
  (forall g u g' u',
    P (g, u) ->
    one_inference_step (g, u) = (g', u') -> P (g', u')) ->
  P (given, unselected) ->
  loop (given, unselected) = (r, given', unselected') -> P (given', unselected').
Proof.
set (P' := fun (g_u : M.t * M.t) (res: superposition_result * M.t*M.t) =>
                P g_u ->
                P (snd (fst res), snd res)).
generalize (loop_ind P'). intros H1 H2. unfold P' in H1. intros H3 H4.
assert (given' = snd (fst (loop (given, unselected)))) as -> by (rewrite H4; auto).
assert (unselected' = snd (loop (given, unselected))) as -> by (rewrite H4; auto).
apply H1; auto; intros ? ? ? ?; inversion 1; subst; auto;
                   intros ? ? H7 _; simpl; [intros R sel ? H8|intro H8].
solve[apply (H2 _ _ _ _ H8 H7); auto].
solve[intros H10; apply H8; auto; apply (H2 _ _ _ _ H10 H7); auto].
Qed.

Lemma loop_sound given unselected given' unselected' r s :
  setd clause_denote inter TT given s ->
  setd clause_denote inter TT unselected s ->
  loop (given, unselected) = (r, given', unselected') ->
  setd clause_denote inter TT given' s /\
  setd clause_denote inter TT unselected' s.
Proof.
intros H1 H2.
set (P := fun (g_u: M.t*M.t) =>
               setd clause_denote inter TT (fst g_u) s /\
               setd clause_denote inter TT (snd g_u) s).
generalize (simple_loop_induction P). unfold P; intros H3.
specialize (H3 given unselected r given' unselected').
intros H4. apply H3; auto.
intros ? ? ? ? [? ?] ?; apply one_inference_step_sound
      with (given := g) (unselected := u); auto.
Qed.

Lemma loop_Valid_empty_clause g u g' u' :
  loop (g, u) = (Valid, g', u') -> M.In empty_clause g' \/ M.In empty_clause u'.
Proof.
set (P' := fun (g_u : M.t * M.t) (res: superposition_result * M.t*M.t) =>
              res = (Valid, g', u') ->
              M.In empty_clause g' \/ M.In empty_clause u').
generalize (loop_ind P'). intros H1 H2. unfold P' in H1.
apply H1 with (given_unselected := (g, u)); auto; intros [? ?] ? ?;
  inversion 1; subst.
autounfold with DEBUG_UNFOLD.
intros H3; inversion 1; subst. rewrite orb_true_iff in H3.
inversion H3 as [H4|H4]; rewrite M.mem_spec in H4; auto.
congruence.
Qed.

Lemma clauses_gen_sound1 R R' cs cs' s :
  listd clause_denote inter TT cs s -> clauses_generate R cs = (R', cs') ->
  setd clause_denote inter TT cs' s.
Proof with simpl; auto; try congruence.
revert R R' cs'; induction cs...
 intros. inversion H0; clear H0; subst. apply setd_empty_set.
intros R R' cs'; destruct (clause_generate R a); intros [A B].
destruct p; destruct p; intro C.
remember (clauses_generate ((v, e) :: R) cs) as h; destruct h.
inversion C; subst. clear C.
apply setd_add; auto.
solve [apply IHcs with (R := (v, e) :: R) (R' := R'); auto].
solve [apply IHcs; auto].
Qed.

Lemma loop_Cexample_model given unselected given' unselected' R sel :
  loop (given, unselected) = (C_example R sel, given', unselected') ->
  (R, sel) = clauses_generate nil
    (rsort_uniq (rev_cmp compare_clause) (M.elements given')).
Proof with try congruence.
set (P' := fun (g_u : M.t * M.t) (res: superposition_result * M.t*M.t) =>
              res = (C_example R sel, given', unselected') ->
  (R, sel) = clauses_generate nil
    (rsort_uniq (rev_cmp compare_clause) (M.elements given'))).
generalize (loop_ind P'). intros H1 H2. unfold P' in H1.
apply H1 with (given_unselected := (given, unselected)); auto; intros [? ?] ? ?;
  inversion 1; subst...
Qed.

Lemma loop_Cexample_sel g u g' u' s R sel :
  setd clause_denote inter TT g s ->
  setd clause_denote inter TT u s ->
  loop (g, u) = (C_example R sel, g', u') ->
  setd clause_denote inter TT sel s.
Proof.
intros H1 H2 H3. generalize H3 as H3'; intro.
apply loop_Cexample_model in H3. symmetry in H3.
apply clauses_gen_sound1 with (s:=s) in H3; auto. clear H3.
rewrite (@listd_sort_uniq_inter _ state).
apply loop_sound with (s:=s) in H3'; destruct H3'; auto.
intros x y; apply rev_cmp_eq. apply compare_clause_eq.
Qed.

Lemma loop_Valid_sound given unselected given' unselected' s :
  setd clause_denote inter TT given s ->
  setd clause_denote inter TT unselected s ->
  loop (given, unselected) = (Valid, given', unselected') ->
  clause_denote empty_clause s.
Proof.
intros H1 H2 H3. generalize H3 as H3'; intro.
apply loop_Valid_empty_clause in H3.
inversion H3 as [H7|H7]; rewrite <-elements_In in H7.
destruct (loop_sound _ _ _ _ _ _ H1 H2 H3') as [H0 H].
apply (listd_In_inv_pred _ _ _ _ H0 H7).
destruct (loop_sound _ _ _ _ _ _ H1 H2 H3') as [H0 H].
apply (listd_In_inv_pred _ _ _ _ H H7).
Qed.

Lemma loop_Cexample_sound given unselected given' unselected' s R selected :
  setd clause_denote inter TT given s ->
  setd clause_denote inter TT unselected s ->
  loop (given, unselected) = (C_example R selected, given', unselected') ->
  setd clause_denote inter TT selected s /\
  setd clause_denote inter TT given' s.
Proof.
intros H1 H2 H3; destruct (loop_sound _ _ _ _ _ _ H1 H2 H3) as [H0 H].
split; auto; apply loop_Cexample_sel with (s:=s) in H3; auto.
Qed.

Lemma check_clauseset_Valid_sound init g u :
  check_clauseset init = (Valid, g, u) ->
  setd clause_denote inter TT init |-- clause_denote empty_clause.
Proof.
unfold check_clauseset; intros C s B.
generalize (setd_empty_set _ clause_denote s); intro A.
assert (H: setd clause_denote inter TT (M.filter not_taut init) s) by
  (apply setd_filter; auto).
apply (loop_Valid_sound _ _ _ _ _ A H C).
Qed.

Lemma check_clauseset_Cexample_model init final empty R selected :
  check_clauseset init = (C_example R selected, final, empty) ->
  (R, selected) = clauses_generate nil
    (rsort_uniq (rev_cmp compare_clause) (M.elements final)).
Proof. solve[unfold check_clauseset; apply loop_Cexample_model]. Qed.

Lemma check_clauseset_Cexample_sound init final u R selected :
  check_clauseset init = (C_example R selected, final, u) ->
  setd clause_denote inter TT init |--
    setd clause_denote inter TT selected &&
    setd clause_denote inter TT final.
Proof.
unfold check_clauseset; intros C s B.
generalize (setd_empty_set _ clause_denote s); intro A.
assert (H: setd clause_denote inter TT (M.filter not_taut init) s) by
  (apply setd_filter; auto).
destruct (loop_Cexample_sound _ _ _ _ _ _ _ A H C). split; auto.
Qed.

End SP_Sound.


Require Export low_mods.

Fixpoint REL (alpha : SecOrder) : bool :=
  match alpha with
  | relatSO _ _ => true
  | conjSO alpha1 alpha2 => if REL alpha1 then REL alpha2 else false
  | _ => false
  end.

Lemma REL_conjSO_l : forall rel1 rel2,
  REL (conjSO rel1 rel2) = true ->
  REL rel1 = true.
Proof.
  intros rel1 rel2 H. simpl in H.
  if_then_else_dest_blind; auto.
Qed.

Lemma REL_conjSO_r : forall rel1 rel2,
  REL (conjSO rel1 rel2) = true ->
  REL rel2 = true.
Proof.
  intros rel1 rel2 H. simpl in H.
  if_then_else_dest_blind; auto.
  discriminate.
Qed.

Lemma preds_in_rel  : forall rel,
  REL rel = true ->
  preds_in rel = nil.
Proof.
  induction rel; intros H; try (simpl in *; discriminate).
    destruct f; destruct f0; reflexivity.

    simpl in *. rewrite IHrel1. rewrite IHrel2.
    reflexivity.
      apply REL_conjSO_r in H. assumption.
      apply REL_conjSO_l in H. assumption.
Qed.

Lemma P_occurs_in_rel : forall rel P,
  REL rel = true -> ~ Pred_in_SO rel P .
Proof.
  induction rel; intros P Hrel; try discriminate.
  firstorder.
  pose proof (REL_conjSO_l _ _ Hrel).
  pose proof (REL_conjSO_r _ _ Hrel).
  apply Pred_in_SO_conjSO_f. firstorder.
Qed.


(** * Mapping predicates over [StringLike] things *)

Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section forall_chars.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition forall_chars (str : String) (P : Char -> Prop)
    := forall n ch,
         take 1 (drop n str) ~= [ ch ]
         -> P ch.

  Lemma forall_chars_from_get (str : String) (P : Char -> Prop)
  : (forall n ch, get n str = Some ch -> P ch) -> forall_chars str P.
  Proof.
    unfold forall_chars.
    intros H n ch Heq.
    apply (H n); clear H.
    rewrite get_drop, <- get_0; assumption.
  Qed.

  Global Instance forall_chars_Proper
  : Proper (beq ==> pointwise_relation _ impl ==> impl) forall_chars.
  Proof.
    unfold pointwise_relation, respectful, forall_chars, impl.
    intros ?? H' ?? H'' H''' ?? H.
    rewrite <- H' in H.
    eauto using is_char_Proper.
  Qed.

  Global Instance forall_chars_Proper_flip
  : Proper (beq ==> pointwise_relation _ (flip impl) ==> flip impl) forall_chars.
  Proof.
    unfold pointwise_relation, respectful, forall_chars, flip, impl.
    intros ?? H' ?? H'' H''' ?? H.
    rewrite H' in H.
    eauto using is_char_Proper.
  Qed.

  Global Instance forall_chars_Proper_iff
  : Proper (beq ==> pointwise_relation _ iff ==> iff) forall_chars.
  Proof.
    unfold pointwise_relation, respectful.
    repeat intro; split;
    apply forall_chars_Proper; try assumption; repeat intro;
    match goal with
      | [ H : _ |- _ ] => apply H; assumption
    end.
  Qed.

  Global Instance forall_chars_Proper_eq
  : Proper (beq ==> pointwise_relation _ eq ==> impl) forall_chars.
  Proof.
    unfold pointwise_relation, respectful, forall_chars, impl.
    intros ?? H' ?? H'' H''' ?? H.
    rewrite <- H' in H.
    rewrite <- H''; eauto.
  Qed.

  Global Instance forall_chars_Proper_eq_flip
  : Proper (beq ==> pointwise_relation _ eq ==> flip impl) forall_chars.
  Proof.
    unfold pointwise_relation, respectful, forall_chars, flip, impl.
    intros ?? H' ?? H'' H''' ?? H.
    rewrite H' in H.
    rewrite H''; eauto.
  Qed.

  Global Instance forall_chars_Proper_eq_iff
  : Proper (beq ==> pointwise_relation _ eq ==> iff) forall_chars.
  Proof.
    unfold pointwise_relation, respectful.
    repeat intro; split;
    apply forall_chars_Proper; try assumption; repeat intro;
      match goal with
      | [ H : _ |- _ ] => apply H; assumption
      | [ H : _ |- _ ] => rewrite H; assumption
      | [ H : _ |- _ ] => rewrite <- H; assumption
      end.
  Qed.

  Lemma forall_chars_nil (str : String) P
  : length str = 0 -> forall_chars str P.
  Proof.
    intros H n ch H'.
    apply length_singleton in H'.
    rewrite take_length, drop_length, H in H'.
    simpl in H'; omega.
  Qed.

  Lemma helper
        (P : nat -> nat -> Type)
        n
        (H0 : forall n0, P (min 1 (n - n0)) n0)
        (H1 : forall n0, P 1 (n0 + n))
        {n0}
  : P 1 n0.
  Proof.
    destruct (Compare_dec.le_dec n n0) as [H'|H'].
    { specialize (H1 (n0 - n)).
      rewrite Nat.sub_add in H1 by assumption; assumption. }
    { apply Compare_dec.not_le in H'.
      specialize (H0 n0).
      destruct (n - n0) as [|[|]] eqn:?; simpl in *; trivial; omega. }
  Defined.

  Lemma forall_chars__split (str : String) P n
  : forall_chars str P
    <-> (forall_chars (take n str) P /\ forall_chars (drop n str) P).
  Proof.
    unfold forall_chars; repeat (split || intro);
    repeat match goal with
                         | [ H : _ |- _ ] => setoid_rewrite drop_length in H
                         | [ H : _ |- _ ] => setoid_rewrite take_length in H
                         | [ H : _ |- _ ] => setoid_rewrite drop_take in H
                         | [ H : _ |- _ ] => setoid_rewrite take_take in H
                         | [ H : _ |- _ ] => setoid_rewrite drop_drop in H
                         | [ H : _ /\ _ |- _ ] => destruct H
                         | [ H : context[min 1 ?x] |- _ ] => destruct x eqn:?; simpl in H
                         | [ H : is_true (take 0 _ ~= [ _ ]) |- _ ] => exfalso; apply length_singleton in H
                         | _ => omega
                         | _ => progress simpl in *; omega
                         | _ => solve [ eauto ]
                         | _ => solve [ eapply (@helper (fun a b => take a (drop b str) ~= [ ch ] -> P ch)); eauto ]
                       end.
  Qed.

  Lemma forall_chars_singleton (str : String) P ch
  : str ~= [ ch ] -> (P ch <-> forall_chars str P).
  Proof.
    intro H.
    pose proof (length_singleton _ _ H).
    unfold forall_chars.
    split; intro H'; repeat intro.
    { match goal with
        | [ n : nat |- _ ] => destruct n; [ | exfalso ]
      end;
      repeat match goal with
               | _ => intro
               | _ => omega
               | [ H : _ |- _ ] => rewrite drop_0 in H
               | [ H : _, H' : _ |- _ ] => rewrite (singleton_take H') in H
               | [ H : _ |- False ] => apply length_singleton in H
               | [ H : _ |- _ ] => rewrite take_length in H
               | [ H : _ |- _ ] => rewrite drop_length in H
               | [ H : ?x = 1, H' : context[?x] |- _ ] => rewrite H in H'
               | _ => erewrite singleton_unique; eassumption
               | [ H : context[min] |- _ ] => revert H; apply Min.min_case_strong
             end. }
    { match goal with
        | [ H : _ |- _ ] => apply (H 0)
      end.
      rewrite drop_0.
      rewrite take_long; trivial; omega. }
  Qed.

  Lemma forall_chars_singleton_length (str : String) P (H : length str = 1)
  : forall_chars str P <-> (forall ch, str ~= [ ch ] -> P ch).
  Proof.
    split.
    { intro H''.
      intros ch' H'''.
      apply (forall_chars_singleton _ _ _ H'''); assumption. }
    { destruct (singleton_exists _ H) as [ch H'].
      intro H''.
      apply (forall_chars_singleton _ P ch H'); eauto. }
  Qed.

  Lemma forall_chars_False (str : String) P
  : (forall ch, ~P ch) -> forall_chars str P -> length str = 0.
  Proof.
    intros H' H.
    case_eq (length str); trivial.
    specialize (H (length str - 1)).
    pose proof (singleton_exists (drop (length str - 1) str)) as H''.
    rewrite drop_length in H''.
    intros n H'''.
    rewrite H''' in *.
    rewrite sub_plus in H'' by omega.
    rewrite Minus.minus_diag in *.
    specialize (H'' eq_refl).
    destruct H'' as [ch H''].
    exfalso; eapply H', H.
    rewrite take_long; try eassumption.
    apply length_singleton in H''; omega.
  Qed.

  Global Opaque forall_chars.

  Lemma forall_chars__split_forall (str : String) P
  : forall_chars str P
    <-> (forall n, forall_chars (take n str) P /\ forall_chars (drop n str) P).
  Proof.
    split.
    { intros H n.
      rewrite <- forall_chars__split; assumption. }
    { intro H.
      specialize (H 0).
      rewrite forall_chars__split; eassumption. }
  Qed.

  Lemma forall_chars_take (str : String) P
  : forall_chars str P <-> (forall n, forall_chars (take (S n) str) P).
  Proof.
    split.
    { intros H n.
      revert H; rewrite forall_chars__split; intro H; destruct H; eassumption. }
    { intro H.
      specialize (H (length str)).
      rewrite take_long in H by omega; assumption. }
  Qed.

  Lemma forall_chars_drop (str : String) P
  : forall_chars str P <-> (forall n, forall_chars (drop n str) P).
  Proof.
    split.
    { intros H n.
      revert H; rewrite forall_chars__split; intro H; destruct H; eassumption. }
    { intro H.
      specialize (H 0).
      rewrite drop_0 in H; assumption. }
  Qed.

  Lemma forall_chars_get (str : String) P
  : forall_chars str P <-> (forall n ch, get n str = Some ch -> P ch).
  Proof.
    split.
    { intros H n ch Heq.
      rewrite get_drop in Heq.
      apply get_0 in Heq.
      apply forall_chars__split with (n := n) in H.
      destruct H as [_ H].
      apply forall_chars__split with (n := 1) in H.
      destruct H as [H _].
      rewrite forall_chars_singleton_length in H.
      { auto. }
      { apply length_singleton in Heq; assumption. } }
    { apply forall_chars_from_get. }
  Qed.

  Definition forall_chars__char_in (str : String) (ls : list Char)
    := forall_chars str (fun ch => List.In ch ls).

  Definition forall_chars__impl__forall_chars__char_in {str ls} {P : _ -> Prop}
             (H : forall ch, P ch -> List.In ch ls)
  : impl (forall_chars str P) (forall_chars__char_in str ls).
  Proof.
    unfold forall_chars__char_in.
    apply forall_chars_Proper; trivial; reflexivity.
  Qed.

  Definition forall_chars__char_in__impl__forall_chars {str ls} {P : _ -> Prop}
             (H : forall ch, List.In ch ls -> P ch)
  : impl (forall_chars__char_in str ls) (forall_chars str P).
  Proof.
    unfold forall_chars__char_in.
    apply forall_chars_Proper; trivial; reflexivity.
  Qed.

  Global Instance forall_chars__char_in__Proper
  : Proper (beq ==> eq ==> impl) forall_chars__char_in.
  Proof.
    unfold pointwise_relation, respectful, forall_chars__char_in, impl.
    repeat intro; subst.
    match goal with
      | [ H : _ |- _ ] => rewrite <- H; assumption
    end.
  Qed.

  Global Instance forall_chars__char_in__Proper_iff
  : Proper (beq ==> eq ==> iff) forall_chars__char_in.
  Proof.
    unfold pointwise_relation, respectful, forall_chars__char_in, impl.
    repeat intro; subst.
    match goal with
      | [ H : _ |- _ ] => rewrite <- H; reflexivity
    end.
  Qed.

  Lemma forall_chars__char_in__split n (str : String) ls
  : forall_chars__char_in str ls
    <-> (forall_chars__char_in (take n str) ls /\ forall_chars__char_in (drop n str) ls).
  Proof.
    unfold forall_chars__char_in; apply forall_chars__split.
  Qed.

  Lemma forall_chars__char_in__app_or_iff (str : String) (ls1 ls2 : list Char)
  : forall_chars__char_in str (ls1 ++ ls2)
    <-> (forall_chars str (fun ch => List.In ch ls1 \/ List.In ch ls2)).
  Proof.
    unfold forall_chars__char_in; split; repeat intro.
    { eapply forall_chars_Proper; [ .. | eassumption ]; [ reflexivity | ].
      intro; hnf.
      apply List.in_app_or. }
    { eapply forall_chars_Proper; [ .. | eassumption ]; [ reflexivity | ].
      intro; hnf.
      apply List.in_or_app. }
  Qed.

  Lemma forall_chars__char_in__or_app (str : String) (ls1 ls2 : list Char)
  : forall_chars__char_in str ls1 \/ forall_chars__char_in str ls2 -> forall_chars__char_in str (ls1 ++ ls2).
  Proof.
    unfold forall_chars__char_in.
    intros [?|?]; repeat intro;
    (eapply forall_chars_Proper; [ .. | eassumption ]; [ reflexivity | ]; intros ??);
    apply List.in_or_app; eauto.
  Qed.

  Lemma forall_chars__char_in_nil (str : String)
  : forall_chars__char_in str nil <-> length str = 0.
  Proof.
    unfold forall_chars__char_in.
    split.
    { eapply forall_chars_False; simpl; eauto. }
    { apply forall_chars_nil. }
  Qed.

  Lemma forall_chars__char_in_empty (str : String) (H : length str = 0) ls
  : forall_chars__char_in str ls.
  Proof.
    unfold forall_chars__char_in.
    apply forall_chars_nil; assumption.
  Qed.

  Lemma forall_chars__char_in_singleton_str (str : String) ls ch (H : str ~= [ ch ])
  : forall_chars__char_in str ls <-> List.In ch ls.
  Proof.
    unfold forall_chars__char_in.
    rewrite <- forall_chars_singleton; try eassumption; reflexivity.
  Qed.

  Global Opaque forall_chars__char_in.
End forall_chars.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC BCprime Cprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ BC O /\ (wd_ BC BCprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime BCprime /\ (col_ O Eprime B /\ col_ O Eprime Cprime)))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Limits.Limit Limits.GenProd_GenSum.
Require Import Archetypal.Discr.Discr.
Require Import PreSheaf.PreSheaf.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.

Section PSh_GenSum.
  Context (C : Category) (A : Type) (map : A → PShCat C).

  Local Notation Fm := (Discr_Func_op (PShCat C) map) (only parsing).

  Local Hint Extern 1 => match goal with [h : {x : _ & _} |- _] => destruct x end.
  Local Hint Extern 1 => match goal with
                          [|- context [(?F _a id)%morphism]] => rewrite (F_id F)
                        end.
  Local Hint Extern 1 =>
  match goal with
    [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end.

  (** The pointwise generalized sum presheaf. *)
  Program Definition PSh_GenSum_func : PreSheaf C :=
    {|
      FO :=
        fun c =>
          {x : A & ((Fm _o x) _o c)%object};
      FA :=
        fun _ _ h x => existT _ (projT1 x)
                           ((map (projT1 x) _a h (projT2 x))%morphism)
    |}.

  (** The injection of generalized sum presheaf. *)
  Program Definition PSh_GenProd_inj (x : A) :
    (map x –≻ PSh_GenSum_func)%nattrans :=
    {|
      Trans := fun c y => existT _ x y
    |}.

  (** The cone for generalized sum presheaf. *)
  Program Definition PSh_GenSum_CoCone : CoCone Fm :=
    {|
      cone_apex :=
        {|FO := fun _ => PSh_GenSum_func;
          FA :=
            fun _ _ h => id
        |};
      cone_edge := {|Trans := fun x => PSh_GenProd_inj x |}
    |}.

  Local Hint Extern 1 =>
    match goal with
      [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
      cbn_rewrite (equal_f (Trans_com f h))
    end.

  Local Hint Extern 1 => match goal with [H : unit |- _] => destruct H end.

  Local Hint Resolve NatTrans_eq_simplify.

  Local Hint Extern 1 => rewrite From_Term_Cat.

  (** The morphism that maps to the generalized product given a map to its
      components. *)
  Program Definition PSh_GenSum_morph_ex
          (Cn : LoKan_Cone
                  (Functor_To_1_Cat (Discr_Cat A ^op) ^op)
                  (Discr_Func_op ((PShCat C))  map ^op)
          )
    : (PSh_GenSum_func –≻ (Cn _o)%object tt)%nattrans :=
    {|
      Trans := fun c y => Trans (Trans Cn (projT1 y)) c (projT2 y)
    |}.

  Local Hint Extern 1 => progress cbn.

  Local Obligation Tactic := basic_simpl; auto 10.

  Program Definition PSh_GenSum : (Σ map)%object :=
    {|
      LRKE := PSh_GenSum_CoCone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|
                Trans :=
                  fun x => _
                          match x as u return
                                (PSh_GenSum_func –≻ (Cn _o)%object u)%nattrans
                          with
                            tt => PSh_GenSum_morph_ex Cn
                          end
              |}
          |}
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros Cn h h'.
    apply NatTrans_eq_simplify.
    extensionality x.
    apply NatTrans_eq_simplify.
    extensionality y.
    extensionality z.
    destruct z as [z u].
    cbn in *.
    destruct x.
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (fun w :
                     (
                       (Cn ∘ Functor_To_1_Cat (Discr_Cat A ^op) ^op)
                          –≻ Discr_Func_op (PShCat C) map ^op
                     )%nattrans
               =>
                 Trans (Trans w z) y
              ) (cone_morph_com h)
          )
          u
      ).
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (fun w :
                     (
                       (Cn ∘ Functor_To_1_Cat (Discr_Cat A ^op) ^op)
                          –≻ Discr_Func_op (PShCat C) map ^op
                     )%nattrans
               =>
                 Trans (Trans w z) y
              ) (cone_morph_com h')
          )
          u
      ).
    trivial.
  Qed.

End PSh_GenSum.

(** In category of types, generalized sums are simply dependent sum types. *)
Section Type_Cat_GenSum.
  Context (A : Type) (map : A → Type_Cat).

  Local Notation Fm := (Discr_Func_op Type_Cat map) (only parsing).

  (** The cocone for the colimit of generalized sum. *)
  Program Definition Type_Cat_GenSum_CoCone : CoCone Fm :=
    {|
      cone_apex :=
        {|FO := fun _ => {x : A & (Fm _o x)%object}; FA := fun _ _ _ h => h|};
      cone_edge := {|Trans := fun x => existT _ x |}
    |}.

   Program Definition Type_Cat_GenSum : (Σ map)%object :=
    {|
      LRKE := Type_Cat_GenSum_CoCone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|Trans :=
                  fun c h =>
                    match c as u return ((Cn _o) u)%object with
                    | tt => Trans Cn (projT1 h) (projT2 h)
                    end
              |}
          |}
    |}.

  Next Obligation.
  Proof.
    extensionality x.
    destruct c; destruct c'; destruct h.
    apply (equal_f (@Trans_com _ _ _ _ Cn (projT1 x) (projT1 x) eq_refl)).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Type_Cat_GenSum_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    destruct x.
    destruct y as [y1 y2].
    cbn in *.
    set (hc := (cone_morph_com h')).
    rewrite (cone_morph_com h) in hc.
    set (hc' := (
                 f_equal
                   (fun w :
                        ((Cn ∘ (Functor_To_1_Cat
                                  (Discr_Cat A)^op) ^op) –≻ Fm^op)%nattrans
                    =>
                      Trans w y1 y2) hc
               )
        ); clearbody hc'; clear hc.
    cbn in *.
    apply hc'.
  Qed.

End Type_Cat_GenSum.


(* - Proof that the functor obtained from a multisorted binding signature
  is omega-cocontinuous ([is_omega_cont_MultiSortedSigToFunctor]) *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SumOfSignatures.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.
Require Import UniMath.SubstitutionSystems.MultiSorted_alt.

Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors.

Require Import UniMath.SubstitutionSystems.ContinuitySignature.GeneralLemmas.
Require Import UniMath.SubstitutionSystems.ContinuitySignature.CommutingOfOmegaLimitsAndCoproducts.

Local Open Scope cat.

Section FixTheContext.

  Variables (sort : UU) (Hsort : isofhlevel 3 sort) (C : category).
  Variables (TC : Terminal C) (IC : Initial C)
          (BP : BinProducts C) (BC : BinCoproducts C)
          (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C).

  (** Define the discrete category of sorts *)
  Let sort_cat : category := path_pregroupoid sort Hsort.

  (** This represents "sort → C" *)
  Let sortToC : category := [sort_cat,C].
  Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f.

  Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC.
  Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP.

  Lemma sortToC1_binproducts
    : BinProducts [sortToC, sortToC].
  Proof.
    repeat (apply BinProducts_functor_precat) ; exact BP.
  Defined.

  (* not used in the present file *)
  Lemma sortToC1_coproducts
    : ∏ I : UU, isaset I -> Coproducts I [sortToC, sortToC].
  Proof.
    intros I Iset.
    repeat (apply Coproducts_functor_precat) ; exact (CC I Iset).
  Defined.

  Section DefinitionOfMultiSortedSigToFunctorPrime.

  Definition hat_exp_functor_list'_piece
             (xt : (list sort × sort) × sort)
    : functor [sortToC,sortToC] [sortToC,sortToC].
  Proof.
    induction xt as [[si s] t].
    set (op_f := option_list sort Hsort C TC BC CC si).
    refine (functor_composite (pre_comp_functor op_f) _).
    set (prs := projSortToC sort Hsort C s).
    set (hatt := hat_functor sort Hsort C CC t).
    set (prshatt := functor_composite prs hatt).
    exact (post_comp_functor prshatt).
  Defined.

  Definition hat_exp_functor_list'
             (xst : list (list sort × sort) × sort)
    : functor [sortToC,sortToC] [sortToC,sortToC].
  Proof.
    induction xst as [a t].
    (* a := [a1,...,am]
       Each ai := ([si_1, ... si_n],si)
     *)

    set (T := constant_functor [sortToC,sortToC] [sortToC,C]
                               (constant_functor sortToC C TC)).
    set (TT := (functor_composite T (post_comp_functor (hat_functor sort Hsort C CC t)))).

    use (list_ind _ _ _ a).
    - exact TT.
    - intros ap ap1 ap_func.
      use (BinProduct_of_functors _ ap_func (hat_exp_functor_list'_piece (ap,,t))).
      repeat (apply BinProducts_functor_precat) ; exact BP.
  Defined.

(** optimized version that does not introduce the terminal element in the singleton case: *)
  Definition hat_exp_functor_list'_optimized
             (xst : list (list sort × sort) × sort)
    : functor [sortToC,sortToC] [sortToC,sortToC].
  Proof.
    induction xst as [xs t].
    set (T := constant_functor [sortToC,sortToC] [sortToC,C]
                               (constant_functor sortToC C TC)).
    set (TT := (functor_composite T (post_comp_functor (hat_functor sort Hsort C CC t)))).
    set (HH := fun ap => (hat_exp_functor_list'_piece (ap,,t))).
    exact (foldr1_map (λ F G, BinProduct_of_functors sortToC1_binproducts F G) TT HH xs).
  Defined.

  Definition MultiSortedSigToFunctor' (M : MultiSortedSig sort) :
    functor [sortToC,sortToC] [sortToC,sortToC].
  Proof.
    use (coproduct_of_functors (ops sort M)).
    + apply Coproducts_functor_precat, Coproducts_functor_precat, CC, setproperty.
    + intros op.
      exact (hat_exp_functor_list'_optimized (arity sort M op)).
  Defined.

  End DefinitionOfMultiSortedSigToFunctorPrime.

  (** * the following is a deviation from the main topic of this file *)
  Section OmegaCocontinuityOfMultiSortedSigToFunctorPrime.

    Let BPCsortToC : BinProducts sortToC := BinProducts_functor_precat _ C BP.
    Let BPC1 : BinProducts [sortToC,sortToC] := BinProducts_functor_precat sortToC sortToC BPCsortToC.
    Context (expSortToC1 : Exponentials BPC1) (** this requires exponentials in a higher space than before *)
      (HC : Colims_of_shape nat_graph C).

    Local Lemma is_omega_cocont_hat_exp_functor_list'_piece  (xt : (list sort × sort) × sort) :
      is_omega_cocont (hat_exp_functor_list'_piece xt).
    Proof.
      apply is_omega_cocont_functor_composite.
      - apply is_omega_cocont_pre_composition_functor.
        apply (ColimsFunctorCategory_of_shape nat_graph sort_cat _ HC).
      - use is_omega_cocont_post_composition_functor.
        apply is_left_adjoint_functor_composite.
        + apply MultiSorted_alt.is_left_adjoint_projSortToC, PC.
        + apply MultiSorted_alt.is_left_adjoint_hat.
    Defined.

    Local Lemma is_omega_cocont_hat_exp_functor_list' (xst : list (list sort × sort) × sort) :
      is_omega_cocont (hat_exp_functor_list' xst).
    Proof.
      induction xst as [xs t].
      revert t.
      use (list_ind (fun xs => ∏ t : sort, is_omega_cocont (hat_exp_functor_list' (xs,, t))) _ _ xs).
      - intro t.
        apply is_omega_cocont_functor_composite.
        + apply is_omega_cocont_constant_functor.
        + apply is_omega_cocont_post_composition_functor, MultiSorted_alt.is_left_adjoint_hat.
      - intros ap ap1 ap_func t.
        apply is_omega_cocont_BinProduct_of_functors.
        * apply BinProducts_functor_precat, BinProducts_functor_precat, BP.
        * apply is_omega_cocont_constprod_functor1.
          apply expSortToC1.
        * apply (ap_func t).
        * apply is_omega_cocont_hat_exp_functor_list'_piece.
    Defined.

    Local Lemma is_omega_cocont_hat_exp_functor_list'_optimized (xst : list (list sort × sort) × sort) :
      is_omega_cocont (hat_exp_functor_list'_optimized xst).
    Proof.
      induction xst as [xs t].
      revert t.
      induction xs as [[|n] xs].
      - induction xs.
        intro t.
        apply is_omega_cocont_functor_composite.
        + apply is_omega_cocont_constant_functor.
        + apply is_omega_cocont_post_composition_functor, MultiSorted_alt.is_left_adjoint_hat.
      - induction n as [|n IH].
        + induction xs as [m []].
          change (1,, m,, tt) with (cons m nil).
          intro t.
          unfold hat_exp_functor_list'_optimized.
          rewrite foldr1_map_cons_nil.
          apply is_omega_cocont_hat_exp_functor_list'_piece.
        + induction xs as [m [k xs]].
          intro t.
          assert (IHinst := IH (k,,xs) t).
          change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))).
          unfold hat_exp_functor_list'_optimized.
          rewrite foldr1_map_cons.
          change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst.
          unfold hat_exp_functor_list'_optimized in IHinst.
          apply is_omega_cocont_BinProduct_of_functors.
          * apply sortToC1_binproducts.
          * apply is_omega_cocont_constprod_functor1.
            apply expSortToC1.
          * apply is_omega_cocont_hat_exp_functor_list'_piece.
          * exact IHinst.
    Defined.

    Lemma is_omega_cocont_MultiSortedSigToFunctor' (M : MultiSortedSig sort) :
      is_omega_cocont (MultiSortedSigToFunctor' M).
    Proof.
      apply is_omega_cocont_coproduct_of_functors.
      intros op; apply is_omega_cocont_hat_exp_functor_list'_optimized.
    Defined.

  End OmegaCocontinuityOfMultiSortedSigToFunctorPrime.

  Section OmegaContinuityOfMultiSortedSigToFunctorPrime.

  Variable (LC : Lims_of_shape conat_graph C).
  Variable (distr : ∏ I : HSET, ω_limits_distribute_over_I_coproducts C I LC (CC (pr1 I) (pr2 I))).

  (* Should also be split up into multiple definitions/lemmas *)
  Lemma post_comp_with_pr_and_hat_is_omega_cont (s t : sort)
    :  is_omega_cont (post_comp_functor
                        (A := sortToC)
                        (projSortToC sort Hsort C s ∙ hat_functor sort Hsort C CC t)
                     ).
  Proof.
    intros coch L con isLimcon.

    apply limits.pointwise_Lim_is_isLimFunctor ; intro F.
    apply limits.pointwise_Lim_is_isLimFunctor ; intro G.

    use limits.is_z_iso_isLim.
    { apply LC. }

    transparent assert (x : (t = G → cochain C)).
    {
      intro p.
      use tpair.
      - intro n.
        exact (pr1 (pr1 (dob coch n) F) s).
      - intros n m q.
        exact (pr1 (pr1 (dmor coch q) F) s).
    }

    use make_is_z_isomorphism.
    - refine (pr1 (distr (_,,Hsort t G) x) · _).

      assert (bla : (∏ a : sortToC, LimCone (diagram_pointwise coch a))).
      { intro ; apply ω_complete_functor_cat ; exact LC. }

      assert (bla' : (∏ a : path_pregroupoid sort Hsort, LimCone (diagram_pointwise (diagram_pointwise coch F) a))).
      { intro ; apply LC. }

      set (LF_lim := limits.isLimFunctor_is_pointwise_Lim coch bla _ _ isLimcon F).
      set (LFs_lim := limits.isLimFunctor_is_pointwise_Lim _ bla' _ _ LF_lim s).
      set (LFs_cone := make_LimCone _ _ _ LFs_lim).

      use CoproductOfArrows.
      intro i.

      (* The following proof "justifies" the exact statement *)
      (* assert (diagram_pointwise (diagram_pointwise coch F) s = x i).
         { apply idpath. } *)

      exact (pr1 (z_iso_inv (z_iso_from_lim_to_lim LFs_cone (LC (x i))))).
    - split.
      + etrans.
        1: apply assoc.
        use (z_iso_inv_to_right _ _ _ _ (_ ,, CoproductOfArrowsIsos  _ _ _ _ _ _ _ _: z_iso _ _)).
        { intro ; apply (pr2 (z_iso_inv _)). }
        rewrite ! id_left.

        use (z_iso_inv_to_right _ _ _ _ (z_iso_inv (make_z_iso _ _ (pr2 (distr _ _))))).
        apply pathsinv0, limArrowUnique.
        intro n.

        rewrite assoc'.
        etrans.
        1: {
          apply maponpaths.
          apply limArrowCommutes.
        }

        etrans.
        1: { apply precompWithCoproductArrow. }

        cbn.
        unfold CoproductOfArrows.
        apply maponpaths.
        apply funextsec ; intro p.
        rewrite ! assoc.
        apply maponpaths_2.
        apply (graphs.limits.limArrowCommutes (LC (x p))).
      + etrans.
        1: apply assoc'.
        apply pathsinv0.

        transparent assert (d_i : (is_z_isomorphism ( pr1 (distr ((t = G),, Hsort t G) x)))).
        {
          exists (coproduct_of_limit_to_limit_of_coproduct C LC (CC (t = G) (Hsort t G)) x).
          set (q := distr ((t = G),, Hsort t G) x).
          split ; apply (pr2 q).
        }

        use (z_iso_inv_to_left _ _ _ (_,,d_i)).
        refine (id_right _ @ _).
        use (z_iso_inv_to_left _ _ _ (CoproductOfArrows _ _ _ _ _,, _ : z_iso _ _)).
        {
          use CoproductOfArrowsIsos ; intro.
          apply is_z_iso_inv_from_z_iso.
        }
        apply limArrowUnique.
        intro n.

        etrans.
        1: apply assoc'.
        etrans.
        1: {
          apply maponpaths.
          apply (limArrowCommutes  (LC
         (diagram_pointwise
            (diagram_pointwise
               (mapdiagram
                  (post_comp_functor (projSortToC sort Hsort C s ∙ hat_functor sort Hsort C CC t))
                  coch) F) G))).
        }
        etrans.
        1: { apply precompWithCoproductArrow. }

        cbn.
        unfold CoproductOfArrows.
        apply maponpaths.
        apply funextsec ; intro p.
        rewrite ! assoc.
        apply maponpaths_2.
        apply (graphs.limits.limArrowCommutes (LC (x p))).
  Defined.

  (* In case no constructors were given, i.e. just H := Id. *)
  Lemma pre_comp_option_list_omega_cont
        (xst : (list sort × sort) × sort)
    : is_omega_cont (pre_comp_functor (C := sortToC) (option_list sort Hsort C TC BC CC (pr11 xst))).
  Proof.
    apply is_omega_cont_pre_composition_functor'.
    intro.
    apply ω_complete_functor_cat ; exact LC.
  Defined.

  Lemma is_omega_cont_hat_exp_functor_list'_piece
  (xst : (list sort × sort) × sort)
    :  is_omega_cont (hat_exp_functor_list'_piece xst).
  Proof.
    apply is_omega_cont_functor_composite.
    - exact (pre_comp_option_list_omega_cont xst).
    - exact (post_comp_with_pr_and_hat_is_omega_cont (pr21 xst) (pr2 xst)).
  Defined.

  Lemma is_omega_cont_hat_exp_functor_list'
        (xst : list (list sort × sort) × sort) :
    is_omega_cont (hat_exp_functor_list' xst).
  Proof.
    induction xst as [a t] ; revert a.
    use list_ind.
    - use nat_z_iso_preserve_ωlimits.
      3: apply nat_z_iso_inv, constant_functor_composition_nat_z_iso.
      apply is_omega_cont_constant_functor.
    - intros x xs IHn.
      apply is_omega_cont_BinProduct_of_functors.
      + apply IHn.
      + apply is_omega_cont_hat_exp_functor_list'_piece.
  Defined.

  Lemma is_omega_cont_hat_exp_functor_list'_optimized
        (xst : list (list sort × sort) × sort) :
    is_omega_cont (hat_exp_functor_list'_optimized xst).
  Proof.
    induction xst as [xs t].
      revert t.
      induction xs as [[|n] xs].
      - induction xs.
        intro t.
        use nat_z_iso_preserve_ωlimits.
        3: apply nat_z_iso_inv, constant_functor_composition_nat_z_iso.
        apply is_omega_cont_constant_functor.
      - induction n as [|n IH].
        + induction xs as [m []].
          change (1,, m,, tt) with (cons m nil).
          intro t.
          unfold hat_exp_functor_list'_optimized.
          rewrite foldr1_map_cons_nil.
          apply is_omega_cont_hat_exp_functor_list'_piece.
        + induction xs as [m [k xs]].
          intro t.
          assert (IHinst := IH (k,,xs) t).
          change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))).
          unfold hat_exp_functor_list'_optimized.
          rewrite foldr1_map_cons.
          change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst.
          unfold hat_exp_functor_list'_optimized in IHinst.
          apply is_omega_cont_BinProduct_of_functors.
          * apply is_omega_cont_hat_exp_functor_list'_piece.
          * exact IHinst.
  Defined.

  (** The functor obtained from a multisorted binding signature is omega-continuous *)
  Lemma is_omega_cont_MultiSortedSigToFunctor' (M : MultiSortedSig sort)
    : is_omega_cont (MultiSortedSigToFunctor' M).
  Proof.
    use coproduct_of_functors_omega_cont.
    - do 2 apply ω_complete_functor_cat ; exact LC.
    - do 2 apply functor_category_ω_limits_distribute_over_I_coproducts ; apply distr.
    - intro ; apply is_omega_cont_hat_exp_functor_list'_optimized.
  Defined.

  End OmegaContinuityOfMultiSortedSigToFunctorPrime.

End FixTheContext.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ E Z /\ (wd_ A D /\ (wd_ D E /\ (wd_ A E /\ (wd_ X E /\ (wd_ X Z /\ (wd_ A Z /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Dprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ (col_ Y E Z /\ (col_ B E Z /\ col_ E Y B)))))))))))))))))))))))))))))))))))))) -> col_ B D E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import String.
Require Import Lia.
Require Import List.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import Coq.Vectors.VectorEq.
Require Import Coq.Arith.Bool_nat.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export RelationClasses.
Require Export Morphisms.
Require Import Program.
From ST Require Import EVarsScratchwork.
From ST Require Import Vector.
From ST Require Export Logic.V Logic.Term.
From ST Require Export SoftType.Radix SoftType.Attribute SoftType.Adjective SoftType.SoftType.
Import ListNotations.
Import VectorNotations.
Open Scope string_scope.

(** ** Local Contexts

A local context is just a finite list of [Decl] (declaration of variables and
their types). We will turn this into arguments for a [Term] (or [Attribute],
or...), so we have a [local_vars] helper function to accomodate this.

TODO: I think this is not quite right. Using locally nameless terms, a
declaration simplifies to just a [SoftType]. Then a [LocalContext] is just
a list of [Decl].

TODO 2: Think hard about whether lifting is necessary for local contexts.
*)
Definition Decl : Type := SoftType.
Definition LocalContext := list SoftType.

(**
Given a [LocalContext], we can turn it into a vector of variables, to be used as
the arguments for a [Term], [Attribute], or [SoftType] (or whatever).
*)

Definition local_vars (lc : LocalContext) : Vector.t Term (List.length lc) :=
  Vector.map (fun (n : nat) => Var (BVar n))
  (rev_nat_range_vector (length lc)).

Example local_vars_3 :
  (local_vars [Star; Star; Star]%list) = [Var (BVar 2); Var (BVar 1); Var (BVar 0)].
Proof.
  simpl; auto.
Qed.

Definition evars_local_declaration (d : Decl) :=
  match d with
  | T => (list_evars T)
  end.

Global Instance EnumerateEVarsLocalContext : EnumerateEVars LocalContext := {
list_evars lc := List.fold_left (fun l' => fun (d : Decl) =>
  insert_merge (evars_local_declaration d) l')
 lc []%list
}.

Theorem list_evars_local_context_sorted : forall (lc : LocalContext),
  sorted (list_evars lc).
Proof. intros.
  unfold list_evars; unfold EnumerateEVarsLocalContext.
  apply insert_merge_list_fold_sorted. apply sorted_nil.
Qed.

(* Helper function to turn a [nat] into a [string]. *)
Fixpoint string_of_nat_aux (time n : nat) (acc : string) : string :=
  let d := match n mod 10 with
           | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4" | 5 => "5"
           | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
           end in
  let acc' := d ++ acc in
  match time with
    | 0 => acc'
    | S time' =>
      match n / 10 with
        | 0 => acc'
        | n' => string_of_nat_aux time' n' acc'
      end
  end.

Definition string_of_nat (n : nat) : string :=
  string_of_nat_aux n n "".

(** Given a [LocalContext] and a [Term], we can redefine it using the local
variables from our [LocalContext]. *)
Definition fun_with_locals (t : Term) (lc : LocalContext) : Term :=
  match t with
  | Fun f args => Fun f (local_vars lc)
  | EConst _ => t
  | Var var => match var with
               | FVar x => Fun x (local_vars lc)
               | BVar n => Fun ("BoundVar_" ++ string_of_nat n) (local_vars lc)
               end
  end.

Definition mode_with_locals (R : Radix) (lc : LocalContext) : Radix :=
  match R with
  | Ast => Ast
  | Mode n nm args => Mode (List.length lc) nm (local_vars lc)
  end.

Fixpoint lc_is_subcontext (subcontext lc : LocalContext) : Prop :=
  match subcontext with
  | List.cons (x,T) subcontext' => List.In (x,T) lc /\ lc_is_subcontext subcontext' lc
  | List.nil => True
  end.

Fixpoint capture_free_subst (n : nat) (t : Term) (lc : LocalContext) :=
match lc with
| []%list => lc
| (h::tl)%list => ((subst (BVar n) (lift (S n) 1 t) h)::(capture_free_subst (S n) (lift (S n) 1 t) tl))%list
end.

Example capture_free_subst_ex1 :
let t0 := constant "t0"
in  capture_free_subst 0 t0
[([], Mode 1 "T1" [Var (BVar 0)]%vector); ([], Mode 2 "T2" [Var (BVar 1); Var (BVar 0)]%vector)]%list
=  [([], Mode 1 "T1" [t0]%vector); ([], Mode 2 "T2" [t0; Var (BVar 0)]%vector)]%list.
Proof.
  auto.
Qed.


(* Task 1: Single Supporting Fact *)

(*
1 Mary moved to the bathroom.
2 John went to the hallway.
3 Where is Mary? 	bathroom	1
4 Daniel went back to the hallway.
5 Sandra moved to the garden.
6 Where is Daniel? 	hallway	4
7 John moved to the office.
8 Sandra journeyed to the bathroom.
9 Where is Daniel? 	hallway	4
10 Mary moved to the hallway.
11 Daniel travelled to the office.
12 Where is Daniel? 	office	11
13 John went back to the garden.
14 John moved to the bedroom.
15 Where is Sandra? 	bathroom	8
*)

Set Implicit Arguments.

Require Import Notations.
Require Import Logic.
Require Setoid.
Require Import PeanoNat Le Gt Minus Bool Lt.
Require Import List.

Module ListNotations.
Notation "[ ]" := nil (format "[ ]") : list_scope.
Notation "[ x ]" := (cons x nil) : list_scope.
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.
End ListNotations.

Import ListNotations.

Inductive person : Type := Mary | John | Daniel | Sandra.

Inductive place : Set := bathroom | hallway | office | garden | bedroom | Unknown.

(* Inductive nat : Type :=
  | O : nat
  | S : nat -> nat. *)

(* Inductive natlist : Type :=
  | nil : natlist
  | cons : nat → natlist → natlist. *)

(* Definition update_location :=
fun p plList (l : location p plList) (pl : place) =>
  match l with
  | locate p plList => locate p (pl :: plList)
  end. *)

Inductive location : person -> list place -> Set :=
  | locate : forall p plList, location p plList.

(* Our definition of [location] has type [person -> list place -> Set]
which says that [location] is a dependent type indexed by [person]
and [list place]. The constructor of [location] is [locate] which
creates a term with its corresponding type. *)

Check location.
(* location : person -> list place -> Set *)

Check locate.
(* locate : forall (p : person) (l : list place), locate p plList *)

Check location Mary [bathroom; hallway].
(* location Mary [bathroom; hallway] : Set *)

Check location Sandra [garden; bathroom].
(* location Sandra [garden; bathroom] : Set *)

Check locate Mary [bathroom; hallway].
(* locate Mary [bathroom; hallway] : location Mary [bathroom; hallway] *)

(* Next we want a function that updates the location of a [person] while preserving
the history of places visited by using the function [update_location]. *)

Definition update_location :=
fun p plList (l : location p plList) (pl : place) =>
  match l with
  | locate p plList => locate p (pl :: plList)
  end.

Check update_location.
(* update_location : forall (p : person) (plList : list place),
       location p plList -> forall pl : place, location p (pl :: plList) *)

Eval compute in update_location (locate Mary []) bathroom.
(*   = locate Mary [bathroom] : location Mary [bathroom] *)

Eval compute in update_location (locate Mary [bathroom]) garden.
(*   = locate Mary [garden; bathroom] : location Mary [garden; bathroom] *)

Check locate Mary [bathroom; hallway].
(* locate Mary [bathroom; hallway] : location Mary [bathroom; hallway] *)

Check update_location (locate Mary []) bathroom.
(* update_location (locate Mary []) bathroom : location Mary [bathroom] *)

Check update_location (locate Mary [garden; bathroom]) office.

Lemma record_location: forall (p : person) (pl : place) (plList : list place),
locate p (pl :: plList) = update_location (locate p plList) pl.
Proof.
  intros. unfold update_location. reflexivity.
Qed.

Definition current_loc :=
fun p plList (l : location p plList) =>
  match l with
  | locate p plList => nth O plList Unknown
  end.

Check locate Mary [garden].

Check current_loc.

Eval compute in current_loc (locate Mary [garden]).

Module test.

Definition location := prod person (list place).

Check location. Check pair Mary [bathroom].

End test.


Require Import Core Notations Tactics Int Ptr.
(*
Proposition addr_ge_to_sem_cmp_lt : forall b m b1 b2 i1 i2,
    addr_ge m (b1, i1) (b2, i2) = Some b ->
    sem_cmp Clt (Vptr b1 i1) (tptr tschar) (Vptr b2 i2) (tptr tschar) m =
    Some (Val.of_bool (negb b)).
Proof.
  intros.
  eapply sem_Clt_Cge_ptr.
  eapply ptr_ge_to_sem_cmp;
    eassumption.
Qed.

Proposition distance_to_sem_cmp_lt : forall dist m b1 b2 i1 i2,
    distance m (b1, i1) (b2, i2) = Some (S dist) ->
    sem_cmp Clt (Vptr b1 i1) (tptr tschar)
            (Vptr b2 i2) (tptr tschar) m = Some Vtrue.
Proof.
  intros until i2; intro Dist.
  replace b1 with b2 in *.
  pose proof (dist_to_lt _ _ _ _ _ Dist) as LT.
  unfold distance, sem_cmp, cmp_ptr, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence; repeat destruct_andb_hyp;
      try congruence.
  all: try rewrite <- ptrofs_lt_signed_lt in LT;
    try bool_rewrite; try intuition.
  unfold sem_binarith.
  all: repeat break_match; simpl in *; try congruence.

  simpl in *.
  all: unfold classify_cmp in *.

  unfold distance, sem_cmp, cmp_ptr, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence; repeat destruct_andb_hyp;
      try congruence.
Qed.

Lemma dist_succ : forall m b b' ofs ofs' dist,
    distance m (b', ofs') (b, ofs) = Some (S dist) ->
    Mem.weak_valid_pointer m b' (Ptrofs.unsigned (ofs' + 1)%ptrofs) = true ->
    distance m (b', (Ptrofs.add ofs' Ptrofs.one)) (b, ofs) = Some dist.
Proof.
  unfold distance, snd; intros.
  break_match_hyp; [| discriminate].
  break_if; subst; [| discriminate].
  inversion H; clear H.
  assert (Ptrofs.unsigned ofs' < Ptrofs.max_unsigned)%Z.
  {
    assert ((Ptrofs.unsigned ofs') < (Ptrofs.unsigned ofs))%Z.
    {
      assert ((Z.to_nat (Ptrofs.unsigned ofs')
               <
               Z.to_nat (Ptrofs.unsigned ofs))%nat) by lia.
      unfold Ptrofs.unsigned in *.
      destruct ofs, ofs'; simpl in *.
      pose proof (Z2Nat.inj_lt intval0 intval) as Inj.
      destruct Inj.
      all: try lia.
    }
    assert (Ptrofs.unsigned ofs <= Ptrofs.max_unsigned)%Z.
    pose proof (Ptrofs.unsigned_range_2 ofs).
    all: try lia.
  }
  replace (addr_ge m (b, ofs) (b', (ofs' + 1)%ptrofs))
    with (Some true).
  f_equal.
  enough (S (Z.to_nat (Ptrofs.unsigned (ofs')%ptrofs)) =
             Z.to_nat (Ptrofs.unsigned (ofs' + 1)%ptrofs)) by lia.
  rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr, <-Z2Nat.inj_succ.
  reflexivity.
  apply Ptrofs.unsigned_range.
  replace (Ptrofs.unsigned 1%ptrofs) with 1 by reflexivity.
  pose proof Ptrofs.unsigned_range ofs'.
  lia.

  unfold addr_ge, ptr_ge in *.
  simpl in *.
  repeat break_if; subst.
  all: try discriminate; unfold Mem.weak_valid_pointer in *.
  all: repeat destruct_andb_hyp.
  all: repeat destruct_orb_hyp.
  all: try congruence.
  all: clear - H H2 Heqo.

  all: assert (Z.to_nat (Ptrofs.unsigned ofs') + 1 <=
          Z.to_nat (Ptrofs.unsigned ofs))%nat
    by lia.
  all: unfold Ptrofs.ltu.
  all: break_if.
  all: rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr in *.
  all: replace (Ptrofs.unsigned 1%ptrofs) with 1 in * by reflexivity.
  all: replace (1)%nat with (Z.to_nat 1)%nat in H0 by reflexivity.
  all: rewrite <-Z2Nat.inj_add in H0.
  all: try rewrite <-Z2Nat.inj_le in H0.
  all: try apply Ptrofs.unsigned_range.
  all: try reflexivity.
  all: replace (Ptrofs.unsigned 1%ptrofs) with 1 by reflexivity.
  all: pose proof Ptrofs.unsigned_range ofs'.
  all: try lia.
Qed.

Proposition distance_succ_no_overflow :  forall m b b' ofs ofs' dist,
    distance m (b', ofs') (b, ofs) = Some (S dist) ->
    Ptrofs.unsigned (ofs' + 1)%ptrofs = Ptrofs.unsigned ofs' + 1.
Proof.
  intros.
  unfold distance, snd in *; intros.
  break_match_hyp; [| discriminate].
  break_if; subst; [| discriminate].
  inversion H; clear H.
  assert (Ptrofs.unsigned ofs' < Ptrofs.max_unsigned)%Z.
  {
    assert ((Ptrofs.unsigned ofs') < (Ptrofs.unsigned ofs))%Z.
    {
      assert ((Z.to_nat (Ptrofs.unsigned ofs')
               <
               Z.to_nat (Ptrofs.unsigned ofs))%nat) by lia.
      unfold Ptrofs.unsigned in *.
      destruct ofs, ofs'; simpl in *.
      pose proof (Z2Nat.inj_lt intval0 intval) as Inj.
      destruct Inj.
      all: try lia.
    }
    assert (Ptrofs.unsigned ofs <= Ptrofs.max_unsigned)%Z.
    pose proof (Ptrofs.unsigned_range_2 ofs).
    all: try lia.
  }

  all: rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr in *.
  all: replace (Ptrofs.unsigned 1%ptrofs) with 1 in * by reflexivity.
  auto.
  destruct ofs'; simpl in *.
  nia.
Qed.

Proposition distance_O : forall m b1 b2 i1 i2,
    distance m (b1,i1) (b2,i2) = Some O <->
    ((b1,i1) = (b2,i2))%ptrofs
    /\ Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true.
Proof.
  intros.
  split; unfold distance; intro.
  -  repeat break_match; try congruence.
     unfold addr_ge, ptr_ge,
     Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu in *.
     repeat break_match; simpl in *;
       try congruence.
     + inversion Heqo.
       assert ((Ptrofs.unsigned i1) <= (Ptrofs.unsigned i2))%Z.
       { eapply ptrofs_le_unsigned_le.
         eassumption.
       }
       erewrite <- Z2Nat.inj_sub in H.
       inversion H.
       rewrite <- Z2Nat.inj_0 in H3.
       assert (Ptrofs.unsigned i2 - Ptrofs.unsigned i1 = 0)%Z.
       { eapply Z2Nat.inj.
         all: try nia. }
       assert (i2 = i1)%ptrofs.
       assert (Ptrofs.unsigned i2 = Ptrofs.unsigned i1)%Z by nia.
       apply (ptrofs_to_unsigned_eq).
       eassumption.
       split.
       * f_equal.
         symmetry; eassumption.
         symmetry; eassumption.
       * rewrite H1.
         destruct_andb_hyp. eassumption.
       * destruct i1; simpl; nia.
     + inversion Heqo.
       assert ((Ptrofs.unsigned i1) <= (Ptrofs.unsigned i2))%Z.
       { eapply ptrofs_le_unsigned_le.
         eassumption.
       }
       erewrite <- Z2Nat.inj_sub in H.
       inversion H.
       rewrite <- Z2Nat.inj_0 in H3.
       assert (Ptrofs.unsigned i2 - Ptrofs.unsigned i1 = 0)%Z.
       { eapply Z2Nat.inj.
         all: try nia. }
       assert (i1 = i2)%ptrofs.
       assert (Ptrofs.unsigned i1 = Ptrofs.unsigned i2)%Z by nia.
       apply (ptrofs_to_unsigned_eq).
       eassumption.
       split.
       * f_equal.
         symmetry; eassumption.
         eassumption.
       * rewrite H1.
         destruct_andb_hyp. eassumption.
       * destruct i1; simpl; nia.
  - break_and.
    inversion H.
    rewrite <- H3.
    rewrite <- H2.
    repeat break_match.
    f_equal.
    nia.
    repeat break_match; try congruence.
    unfold addr_ge, ptr_ge,
    Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
    Ptrofs.ltu in *.
    repeat break_match; simpl in *;
      try congruence.
    all: try nia.

    repeat break_match; try congruence.
    unfold addr_ge, ptr_ge,
    Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
    Ptrofs.ltu in *.
    repeat break_match; simpl in *;
      try congruence.

    all: destruct_andb_hyp; try intuition.
    all:unfold Mem.weak_valid_pointer in *;
      congruence.
Qed.

Lemma dist_succ_load : forall dist c m b ofs b' ofs' v,
    Mem.loadv c m (Vptr b' ofs') = Some v ->
    distance m (b', ofs') (b, ofs) = Some (S dist) ->
    distance m (b', (Ptrofs.add ofs' Ptrofs.one)) (b, ofs) = Some dist.
Proof.
  intros until v;
    intros Load Dist.
  eapply loaded_is_valid in Load.
  eapply dist_succ.
  eassumption.
  unfold Mem.weak_valid_pointer.
  replace (Ptrofs.unsigned (ofs' + 1)%ptrofs - 1)%Z with
      (Ptrofs.unsigned ofs')%Z.
  rewrite Load.
  intuition.
  eapply distance_succ_no_overflow in Dist.
  rewrite Dist.
  nia.
Qed.

Proposition addr_lt_ge_eq : forall b m b1 b2 i1 i2 ,
    addr_ge m (b1, i1) (b2, i2) = Some b
    <-> addr_lt m (b1, i1) (b2, i2) = Some (negb b).
Proof.
  intros.
  unfold addr_lt.
  simpl.
  destruct b.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
Qed.

Proposition addr_lt_ge_eq' : forall b m b1 b2 i1 i2 ,
    addr_lt m (b1, i1) (b2, i2) = Some b
    <-> addr_ge m (b1, i1) (b2, i2) = Some (negb b).
Proof.
  intros.
  unfold addr_lt.
  simpl.
  destruct b.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
Qed.

Proposition addr_ge_to_ge : forall b m b1 b2 i1 i2 ,
    addr_ge m (b1, i1) (b2, i2) = Some b
    -> (i2 <=u i1)%ptrofs = b.
Proof.
  intros.
  unfold distance, sem_cmp, cmp_ptr, addr_lt, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence;
      simpl in *;
      try congruence.
Qed.

Proposition addr_lt_to_lt : forall b m b1 b2 i1 i2 ,
    addr_lt m (b1, i1) (b2, i2) = Some b
    -> (i1 <u i2)%ptrofs = b.
Proof.
  intros.
  unfold addr_lt in *.
  Locate addr_lt.
  unfold distance, sem_cmp, cmp_ptr, addr_lt, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence;
      simpl in *;
      try congruence;
      try intuition.
  unfold Ptrofs.ltu in *.
  repeat break_match;
    simpl in *;
    try congruence;
    try nia.
Qed.

Proposition addr_lt_to_sem_cmp_lt : forall b m b1 b2 i1 i2,
  addr_lt m (b1, i1) (b2, i2) = Some b ->
     (sem_cmp Clt (Vptr b1 i1) (tptr tschar)
              (Vptr b2 i2) (tptr tschar) m = Some (Val.of_bool b)).
Proof.
  intros until i2; intro Addr.
  eapply sem_Clt_Cge_ptr'.
  eapply addr_lt_ge_eq' in Addr.
   eapply ptr_ge_to_sem_cmp;
     eassumption.
Qed.

Proposition addr_lt_trans : forall m b1 b2 i1 i2,
    addr_lt m (b1, (i1 + 1)%ptrofs) (b2, i2) = Some true ->
    Ptrofs.unsigned (i1 + 1)%ptrofs = Ptrofs.unsigned i1 + 1 ->
    Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true ->
    addr_lt m (b1, i1) (b2, i2) = Some true.
Proof.
  intros until i2;
    intro Addr; intro OF;
      intro Ptr.
  unfold addr_lt, Mem.weak_valid_pointer in *.
  unfold distance, sem_cmp, cmp_ptr, addr_lt, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence;
    simpl in *;
    try congruence;
    try intuition.
  unfold Ptrofs.ltu in *.
  repeat break_match;
    simpl in *;
    try congruence;
    rewrite OF in *;
    simpl in *;
    try nia.
  repeat destruct_andb_hyp;
    repeat destruct_orb_hyp;
    try congruence.
  Qed.

Proposition addr_lt_succ_to_sem_cmp : forall m b1 b2 i1 i2,
    addr_lt m (b1, (i1 + 1)%ptrofs) (b2, i2) = Some true ->
    Ptrofs.unsigned (i1 + 1)%ptrofs = Ptrofs.unsigned i1 + 1 ->
    Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true ->
    (sem_cmp Clt (Vptr b1 i1) (tptr tschar)
             (Vptr b2 i2) (tptr tschar) m = Some (Val.of_bool true)).
Proof.
  intros until i2;
    intro Addr; intro OF; intro Ptr.
  eapply addr_lt_trans in Addr.
  eapply addr_lt_to_sem_cmp_lt.
  all: eassumption.
Qed.

Proposition mem_load_inj_ptr : forall m b1 b2 b3 i1 i2 i3,
    Mem.load Mptr m b1 (Ptrofs.unsigned i1) = Some (Vptr b2 i2) ->
    Mem.load Mptr m b1 (Ptrofs.unsigned i1) = Some (Vptr b3 i3) ->
    b2 = b3 /\ i2 = i3.
Proof.
  intros until i3;
    intros Mem1 Mem2.
  split; rewrite Mem1 in Mem2;
    inversion Mem2; auto.
Qed.

Lemma ptr_ge_is_valid : forall m b1 b2 i1 i2 ,
  ptr_ge m b1 b2 i1 i2 = Some false ->
  Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true.
Proof.
  unfold Mem.weak_valid_pointer.
  intros.
  unfold distance, sem_cmp, cmp_ptr, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence; repeat destruct_andb_hyp;
      try congruence;
      repeat destruct_orb_hyp;
      try congruence.
  Qed.

Lemma ptrofs_le_unsigned_le_neg : forall a b,
  (a <=u b)%ptrofs = false <->
  not (Ptrofs.unsigned a <= Ptrofs.unsigned b)%Z.
Proof.
  split; intros; unfold not; intros.
  - unfold Ptrofs.ltu in H.
    destruct zlt; [nia | intuition].
  - unfold Ptrofs.ltu.
    destruct zlt; intuition.
Qed.

*)


Require Import Coq.Relations.Relations.

Require Export CatSem.CAT.ind_potype.
Require Export CatSem.PCF.PCF_syntax.

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

Section close_notation.
Notation "'TY'" := PCF.Sorts.
Notation "'Bool'" := PCF.Bool.
Notation "'Nat'" := PCF.Nat.

Notation "'IT'" := (ITYPE TY).
Notation "a '~>' b" := (PCF.Arrow a b)
   (at level 69, right associativity).
Notation "M [*:= N ]" := (substar N M) (at level 50).
Notation "'$' f" := (@_shift _ _ _ f) (at level 30).
Notation "y >>- f" := (_shift f y) (at level 44).
Notation "y >>= f" := (@subst _ _ f _ y) (at level 42).

Notation "a @ b" := (App a b)(at level 20, left associativity).
Notation "M '" := (Const _ M) (at level 15).

Ltac opt := simpl; intros; elim_opt.

Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin; simpl;
	try reflexivity.
Hint Unfold lift : fin.
Hint Extern 1 (_ = _) => f_equal : fin.
Hint Resolve rename_eq : fin.
Hint Rewrite rename_eq : fin.
Hint Resolve  rename_id shift_eq : fin.
Hint Rewrite  rename_id shift_eq : fin.
Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.
Hint Resolve var_lift_shift_eq : fin.
Hint Resolve shift_lift : fin.
Hint Rewrite shift_lift : fin.
Hint Resolve subst_eq : fin.
Hint Rewrite subst_eq : fin.
Hint Rewrite subst_rename rename_subst : fin.
Hint Unfold inj : fin.
Hint Resolve subst_shift_shift subst_var subst_var_eta : fin.
Hint Rewrite subst_shift_shift subst_var subst_var_eta : fin.
Hint Resolve subst_var subst_subst : fin.
Hint Rewrite subst_subst : fin.
Hint Rewrite lift_rename : fin.

Section Relations_on_PCF.

Reserved Notation "x :> y" (at level 70).

Variable rel : forall (V:IT) t, relation (PCF V t).

Inductive propag (V: IT)
       : forall t, relation (PCF V t) :=
| relorig : forall t (v v': PCF V t), rel v v' ->  v :> v'
| relApp1: forall (s t : TY)(M M' : PCF V (s ~> t)) N,
       M :> M' -> App M N :> App M' N
| relApp2: forall (s t:TY)(M:PCF V (s ~> t)) N N',
      N :> N' -> M @ N :> M @ N'
| relLam: forall (s t:TY)(M M':PCF (opt s V) t),
      M :> M' -> Lam M :> Lam M'
| relRec: forall (t : TY)(M M' : PCF V (t ~> t)),
      M :> M' -> Rec M :> Rec M'

where "x :> y" := (@propag _ _ x y).

Notation "x :>> y" :=
  (clos_refl_trans_1n _ (@propag _ _ ) x y) (at level 50).

Variable V: IT.
Variables s t: TY.

(** these are some trivial lemmata  which will be used later *)

Lemma cp_App1 (M M': PCF V (s ~> t)) N :
    M :>> M' -> M @ N :>> M' @ N.
Proof.
  induction 1;
  simpl; intros;
  try constructor;
  match goal with
    [H : ?y :>> ?z|- App ?x ?N :>> App ?z ?N ] =>
      constructor 2 with (App y N) end;
  fin;
  constructor 2;
  auto.
Qed.

Lemma cp_App2 (M: PCF V (s ~> t)) N N':
    N :>> N' -> App M N :>> App M N'.
Proof.
  induction 1;
  simpl; intros;
  try constructor;
  match goal with
    [H : ?y :>> ?z|- App ?N ?x :>> App ?N ?z ] =>
      constructor 2 with (App N y) end;
  fin;
  constructor 3;
  fin.
Qed.

Lemma cp_Lam (M M': PCF (opt s V) t ):
      M :>> M' -> Lam M :>> Lam M'.
Proof.
  induction 1;
  simpl; intros;
  try constructor;
  match goal with
    [H : ?y :>> ?z|- Lam ?x :>> Lam ?z ] =>
      constructor 2 with (Lam y) end;
  fin;
  constructor 4;
  fin.
Qed.

Lemma cp_Rec (M M': PCF V (t ~> t)) :
      M :>> M' -> Rec M :>> Rec M'.
Proof.
  induction 1;
  simpl; intros;
  try constructor;
  match goal with
    [H : ?y :>> ?z|- Rec ?x :>> Rec ?z ] =>
      constructor 2 with (Rec y) end;
  fin;
  constructor 5;
  fin.
Qed.

End Relations_on_PCF.

(** Beta reduction *)

Reserved Notation "a >> b" (at level 60).

Inductive eval (V : IT): forall t, relation (PCF V t) :=
| app_abs : forall (s t:TY) (M: PCF (opt s V) t) N,
               eval (Lam M @ N) (M [*:= N])
| condN_t: forall n m, eval (condN ' @ ttt ' @ n @ m) n
| condN_f: forall n m, eval (condN ' @ fff ' @ n @ m) m
| condB_t: forall u v, eval (condB ' @ ttt ' @ u @ v) u
| condB_f: forall u v, eval (condB ' @ fff ' @ u @ v) v
| succ_red: forall n, eval (succ ' @ Nats n ') (Nats (S n) ')
| zero_t: eval ( zero ' @ Nats 0 ') (ttt ')
| zero_f: forall n, eval (zero ' @ Nats (S n)') (fff ')
| pred_Succ: forall n, eval (preds ' @ (succ ' @ Nats n ')) (Nats n ')
| pred_z: eval (preds ' @ Nats 0 ') (Nats 0 ')
| rec_a : forall t g, eval (Rec g) (g @ (Rec (t:=t) g)).

Definition eval_star := propag eval.

Definition eval_rel :=
   fun (V : IT) t => clos_refl_trans_1n _ (@eval_star V t).

Notation "a >> b" := (eval_rel a b) (at level 60, no associativity).

Obligation Tactic := unfold eval_rel; simpl;
           intros; auto using Clos_RT_1n_prf.

Program Instance PCFEVAL_struct (V : IT) : ipo_obj_struct (PCF V) := {
 IRel t := @eval_rel V t
}.

Definition PCFE (V: IT) : IPO TY :=
    Build_ipo_obj (PCFEVAL_struct V ).

Obligation Tactic := intros; try unf_Proper;
   simpl; intros;
   match goal with [H : smallest_irel _ _ |- _ ] => destruct H end;
   reflexivity.

Program Instance Var_s (V : IT) :
    ipo_mor_struct (a:=IDelta _ V) (b:=PCFE V) (Var (V:=V)).

Definition VAR V := Build_ipo_mor (Var_s V).

Lemma eval_eval V (s t:TY) (M: PCF (opt s V) t) N :
        App (Lam M) N >> M [*:= N].
Proof.
  intros;
  apply clos_refl_trans_1n_contains;
  apply relorig;
  constructor.
Qed.

Lemma eval_eq V t (y z : PCF V t) :
      y = z ->  y >> z.
Proof.
  intros; subst;
  reflexivity.
Qed.

Lemma eval_red V t (x y : PCF V t) : eval x y ->  x >> y.
Proof.
  intros;
  apply clos_refl_trans_1n_contains;
  constructor;
  auto.
Qed.

Lemma subst_eval V t (x y : PCF V t) :
   eval x y -> forall (W : IT)
   (f : V ---> PCF W),
     x >>= f >> y >>= f.
Proof.
  induction 1;
  simpl; intros;
  try (apply eval_red; constructor);
  try match goal with[|- eval_rel _ (?M [*:= ?N] >>= ?f)] =>
     transitivity ((M >>= _shift f) [*:=N >>= f]) end;
  try apply eval_eval;
  unfold substar;
  try (apply eval_eq;
  fin;
  try apply subst_eq;
  fin; opt; simpl;
  unfold inj; simpl; fin).
Qed.

Hint Resolve subst_eval : fin.

Ltac sub_beta := match goal with
     [|- App ?M _ >> App ?M _ ] => apply cp_App2
   | [|- App _ ?N >> App _ ?N ] => apply cp_App1
   | [|- Rec _ >> Rec _ ] => apply cp_Rec
   | [|- Lam _ >> Lam _ ] => apply cp_Lam end.

Ltac spec := match goal with
     [H:forall _ _ , _ >> _ |- _] => apply H end.

Lemma subst_eval_star (V : IT) (t : TY) (x y : PCF V t) :
   eval_star x y -> forall (W : IT)
   (f : V ---> PCF W), x >>= f >> y >>= f.
Proof.
  induction 1;
  simpl; intros;
  fin;
  sub_beta; spec.
Qed.

Hint Resolve subst_eval_star : fin.

Lemma subst_eval_rel V t (x y : PCF V t) :
   x >> y -> forall (W : IT)
   (f : V ---> PCF W), x >>= f >> y >>= f.
Proof.
  induction 1;
  fin.
  match goal with
      [H:forall _ _ , ?y >>= _ >> ?z >>= _ |- _ >> ?z >>= ?g] =>
        transitivity (y >>= g) end;
  fin;
  try apply subst_eval_star;
  fin.
Qed.

Hint Resolve subst_eval_rel : fin.

Obligation Tactic := simpl; intros; try unf_Proper;
     simpl; intros;
     try apply subst_eval_rel; fin.

Program Instance subst_s (V W : IT) (f : IDelta _ V ---> PCFE W) :
   ipo_mor_struct (a:=PCFE V) (b:=PCFE W) (subst f).

Definition SUBST V W f := Build_ipo_mor (subst_s V W f).

End close_notation.


Set Implicit Arguments.

Require Import Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Import Structures.Orders NArith.
Require Import String.

Require Import DirectedGraphs DirectedGraphs_morph maxind SimpleUndirectedGraphs.

Definition Comp (state A ERR : Type) := state -> (state * A) + ERR.

Section Comp.
  Variables state A ERR : Type.

  Definition bind (B : Type) (c : Comp state A ERR) (f : A -> Comp state B ERR)
    : Comp state B ERR :=
    fun s =>
      match c s with
      | inl (s', a) => f a s'
      | inr err => inr err
      end.

  Definition ret (a : A) : Comp state A ERR := fun s => inl (s, a).

  Definition get : Comp state state ERR :=
    fun s => inl (s, s).

  Definition upd (f : state -> state) : Comp state unit ERR :=
    fun s => inl (f s, tt).

  Definition raise (err : ERR) : Comp state A ERR := fun _ => inr err.

  Definition trycatch
             (c : Comp state A ERR)
             (d : Comp state A ERR)
    : Comp state A ERR :=
    fun s =>
      match c s with
      | inl p => inl p
      | inr _ => d s
      end.
End Comp.

Arguments bind [_ _ _ _] _ _ _.
Arguments ret [_ _ _] _ _.
Arguments get [_ _] _.
Arguments upd [_ _] _ _.
Arguments raise [_ _ _] _ _.
Arguments trycatch [_ _ _] _ _ _.

Notation "x <- c ; f" := (bind c (fun x => f)) (at level 50).
Notation "c ;; d" := (bind c (fun _ => d)) (at level 50).

Notation "'try' c 'with' d" := (trycatch c d) (at level 49).

Fixpoint mapM (state A B ERR : Type) (f : A -> Comp state B ERR) (l : list A)
  : Comp state (list B) ERR :=
  match l with
  | nil => ret nil
  | a :: l' =>
    bind (f a) (fun b =>
    bind (mapM f l') (fun l => ret (b :: l)))
  end.

Fixpoint omapM (state A B ERR : Type) (f : A -> Comp state (option B) ERR) (l : list A)
  : Comp state (list B) ERR :=
  match l with
  | nil => ret nil
  | a :: l' =>
    bind (f a) (fun ob =>
                  match ob with
                  | None => omapM f l'
                  | Some b => bind (omapM f l') (fun l => ret (b :: l))
                  end)
  end.

Module Lawler (G : SimpleUndirectedGraphs) (X : MAX_IND_SETS G).
  Module GraphExtras := DirectedGraphMorph G.
  Import GraphExtras.

  Module VertexSet <: OrderedType.OrderedType. (*for compat with FMaps*)
    Definition t := G.Vertices.t.
    Definition eq := G.Vertices.eq.
    Definition lt := G.Vertices.lt.
    Lemma eq_refl : forall x : t, eq x x.
    Proof. intros s y; split; auto. Qed.
    Lemma eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. intros s t H x; rewrite H; split; auto. Qed.
    Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros x y z H H1 a; rewrite H, H1; split; auto. Qed.
    Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
    Proof.
      intros x y z H H1.
      destruct G.Vertices.lt_strorder as [X Y].
      apply (Y x y z); auto.
    Qed.
    Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
    Proof.
      intros x y H Hcontra.
      destruct G.Vertices.lt_strorder as [X Y].
      destruct (G.Vertices.compare_spec x y).
      { rewrite H0 in H; apply (X _ H). }
      { rewrite Hcontra in H0; apply (X _ H0). }
      rewrite Hcontra in H0; apply (X _ H0).
    Qed.
    Lemma compare : forall x y : t, Compare lt eq x y.
    Proof. Admitted. (*Does the Sets interface even export decidability of lt?*)
    Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
    Proof. apply G.Vertices.eq_dec. Qed.
  End VertexSet.

  Module M := Make VertexSet. (*map from VertexSet -> ?A*)
  Module MFacts := Facts M.
  Module MProps := Properties M.

  Definition D := M.t positive. (*map from VertexSet -> positive*)

  Definition induced_subgraph (g : G.t) (s : VertexSet.t) : G.t :=
    G.Vertices.fold G.removeVertex s g.

  Definition LawlerComp := Comp D positive string.

  Section Lawler.
    Variable g : G.t.

    Local Open Scope string_scope.

    Definition min (l : list positive) := List.fold_left Pos.min l 1%positive.

    Definition get_chromatic_number (s : VertexSet.t) : LawlerComp :=
      d <- @get _ _;
      match M.find s d with
      | None => raise "Table lookup failed"
      | Some p => ret p
      end.

    Require Import Coq.Program.Wf.
    Program Fixpoint Lawler
            (s : VertexSet.t)
            {measure (G.Vertices.cardinal s)}
      : LawlerComp :=
      try get_chromatic_number s
      with
        if X.ind_set s g then
          let chi := 1%positive in
          upd (M.add s chi);; ret chi
        else
          let gs := induced_subgraph g s in
          l <- omapM (fun s' =>
            match G.Vertices.exists_ (fun x => G.Vertices.mem x s) s' with
            | true => r <- @Lawler (G.Vertices.diff s s') _; ret (Some r)
            | false => ret None
            end)
            (X.max_ind_sets gs);
          let chi := (min l + 1)%positive in
          upd (M.add s chi);; ret chi.
    Next Obligation.
      symmetry in Heq_anonymous.
      rewrite G.Vertices.exists_spec in Heq_anonymous.
      Focus 2.
      intros y z H. apply VertProperties.P.Dec.F.mem_m; auto.
      apply VertProperties.P.equal_refl.
      destruct Heq_anonymous as [x [H1 H2]].
      apply VertProperties.P.subset_cardinal_lt with x.
      { apply VertProperties.P.subset_diff.
        apply VertProperties.P.Dec.F.Subset_refl. }
      { apply VertProperties.P.Dec.F.mem_2; auto. }
      intros H3.
      apply VertProperties.P.FM.diff_2 in H3; apply H3; auto.
    Qed.
  End Lawler.
End Lawler.