Require Export C12_Angles_Opposes.

Section SUPPLEMENTARY_ANGLES.

Definition Supplementary (alpha beta : AS) :=
exists A  : Point,  exists B  : Point,  exists C : Point,  exists D : Point,
	A <> C /\ Between B A D /\ Angle B A C = alpha /\ Angle C A D = beta.

Lemma SupplementaryCommut : forall alpha beta : AS,
	Supplementary alpha beta ->
	Supplementary beta alpha.
Proof.
	unfold Supplementary in |- *;
	 intros alpha beta (A, (B, (C, (D, (H0, (H1, (H2, H3))))))).
	exists A; exists D; exists C; exists B; intuition.
	 apply BetweenSym; trivial.
	 rewrite AngleSym.
	  trivial.
	  apply (BetweenDistinctBC _ _ _ H1).
	  trivial.
	 rewrite AngleSym.
	  trivial.
	  trivial.
	  apply (sym_not_eq (BetweenDistinctAB _ _ _ H1)).
Qed.

Lemma HalfLineBetweenBetween : forall A B C D : Point,
       	Between A C D ->
	HalfLine C A B ->
	Between B C D.
Proof.
	intros.
	apply BetweenSym; apply (BetweenHalfLineBetween D C A B).
	 apply BetweenSym; trivial.
	 trivial.
Qed.

Lemma SupplementBC : forall A B C D A' B' C' D' : Point,
	A <> C ->
	A' <> C' ->
	B <> C ->
	Between B A D ->
	Between B' A' D' ->
	Angle B A C = Angle B' A' C' ->
	Angle C A D = Angle C' A' D'.
Proof.
	intros A B C D A' B' C' D' dAC dA'C' dBC H0 H1 H2.
	assert (dAB := sym_not_eq (BetweenDistinctAB _ _ _ H0)).
	assert (dA'B' := sym_not_eq (BetweenDistinctAB _ _ _ H1)).
	destruct (ExistsHalfLineEquidistant A' B' A B dA'B' dAB) as (B'', (H3, H4)).
	destruct (ExistsHalfLineEquidistant A' C' A C dA'C' dAC) as (C'', (H5, H6)).
	assert (dAD := BetweenDistinctBC _ _ _ H0).
	assert (dA'D' := BetweenDistinctBC _ _ _ H1).
	destruct (ExistsHalfLineEquidistant A' D' A D dA'D' dAD) as (D'', (H7, H8)).
	rewrite (HalfLineAngleBC A' C' D' C'' D'' dA'C' dA'D' H5 H7).
	apply (CongruentSSS A C D A' C'' D'' dAC dAD (sym_eq H6) (sym_eq H8)).
	assert (dBD := sym_not_eq (BetweenDistinctCA _ _ _ H0)).
	assert (H9 : Distance B C = Distance B'' C'').
	 apply (CongruentSAS A B C A' B'' C'' dAB dAC (sym_eq H4) (sym_eq H6)).
	   rewrite H2; apply (HalfLineAngleBC A' B' C' B'' C'' dA'B' dA'C' H3 H5).
	 assert (H10 : Distance B D = Distance B'' D'').
	  rewrite <- (ChaslesBetween B A D H0).
	    rewrite (DistSym B A); rewrite <- H4.
	    rewrite <- H8; rewrite (DistSym A' B'').
	    apply ChaslesBetween.
	    apply (BetweenHalfLineBetween B'' A' D' D'').
	   apply (HalfLineBetweenBetween B'); trivial.
	   trivial.
	  apply (CongruentSAS B C D B'' C'' D'' dBC dBD H9 H10).
	    rewrite (HalfLineAngleC B C D A dBC dBD).
	   rewrite (HalfLineAngleC B'' C'' D'' A').
	    apply (CongruentSSS B C A B'' C'' A' dBC (sym_not_eq dAB) H9).
	     autoDistance.
	     autoDistance.
	    apply (EquiDistantDistinct B C B'' C'' dBC H9).
	    apply (EquiDistantDistinct B D B'' D'' dBD H10).
	    apply
	     (HalfLineSym B'' A' D''
	        (sym_not_eq (EquiDistantDistinct A B A' B'' dAB (sym_eq H4)))).
	      apply BetweenHalfLine.
	      apply (BetweenHalfLineBetween B'' A' D' D'').
	     apply (HalfLineBetweenBetween B'); trivial.
	     trivial.
	   apply (HalfLineSym B A D (sym_not_eq dAB)).
	     apply BetweenHalfLine; auto.
 Qed.

Lemma Supplement : forall A B C D A' B' C' D' : Point,
	A <> C ->
	A' <> C' ->
	Between B A D ->
	Between B' A' D' ->
	Angle B A C = Angle B' A' C' ->
	Angle C A D = Angle C' A' D'.
Proof.
	intros A B C D A' B' C' D' dAC dA'C' H0 H1 H2.
	assert (dAB := sym_not_eq (BetweenDistinctAB _ _ _ H0)).
	destruct (CentralSymetPoint A B dAB) as (B'', (H3, H4)).
	assert (dBB'' := BetweenDistinctBC A B B'' H4).
	destruct (Apart B B'' C dBB'').
	 apply (SupplementBC A B C D A' B' C' D' dAC dA'C' H H0 H1 H2).
	 apply (SupplementBC A B'' C D A' B' C' D' dAC dA'C' H).
	  apply (BetweenAssocRight B'' B A D (BetweenSym A B B'' H4) H0).
	  exact H1.
	  rewrite <- (HalfLineAngleB A B C B'' dAB dAC).
	   exact H2.
	   apply BetweenHalfLine; auto.
Qed.

Lemma SupplementaryEq : forall alpha beta gamma : AS,
	Supplementary alpha beta ->
	Supplementary alpha gamma ->
	beta = gamma.
Proof.
	unfold Supplementary in |- *;
	 intros alpha beta gamma (A, (B, (C, (D, (H0, (H1, (H2, H3)))))))
	  (A', (B', (C', (D', (H4, (H5, (H6, H7))))))).
	rewrite <- H3; rewrite <- H7.
	apply (Supplement A B C D A' B' C' D' H0 H4 H1 H5).
	subst; auto.
Qed.

Lemma OpposedAtVertex : forall A B C D E : Point,
	Between B A D ->
	Between C A E ->
	Angle B A C = Angle D A E.
Proof.
	intros.
	assert (dAB := sym_not_eq (BetweenDistinctAB _ _ _ H)).
	assert (dAC := sym_not_eq (BetweenDistinctAB _ _ _ H0)).
	rewrite (AngleSym A B C dAB dAC).
	assert (dAD := BetweenDistinctBC _ _ _ H).
	apply (Supplement A D C B A C D E dAC dAD).
	 apply BetweenSym; auto.
	 trivial.
	 apply AngleSym; auto.
Qed.

Lemma CongruentOpposedTriangles : forall A B C D I : Point,
	Between A I C ->
	Between B I D ->
	Distance I A = Distance I C ->
	Distance I B = Distance I D ->
	CongruentTriangles A I B C I D.
Proof.
	intros.
	apply CongruentTrianglesSASB.
	 trivial.
	 trivial.
	 apply OpposedAtVertex; trivial.
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H).
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H0).
Qed.

Lemma SupplementaryRec : forall A B C D : Point,
	Clockwise B A C ->
	Clockwise C A D ->
	Supplementary (Angle B A C) (Angle C A D) ->
	Between B A D.
Proof.
	intros.
	destruct H1 as (A', (B', (C', (D', (H1, (H2, (H3, H4))))))).
	destruct (ExistsHalfLineEquidistant A B A' B') as (B'', (H5, H6)).
	 autoDistinct.
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H2).
	 destruct (ExistsHalfLineEquidistant A C A' C') as (C'', (H7, H8)).
	  autoDistinct.
	  trivial.
	  destruct (ExistsHalfLineEquidistant A D A' D') as (D'', (H9, H10)).
	   autoDistinct.
	   apply (BetweenDistinctBC _ _ _ H2).
	   destruct (ExistsBetweenEquidistant A B A' D') as (E, (H11, H12)).
	    autoDistinct.
	    apply (BetweenDistinctBC _ _ _ H2).
	    assert (CongruentStrictTriangles B'' A C'' B' A' C').
	     apply CongruentStrictTrianglesSASB.
	      trivial.
	      trivial.
	      rewrite H3; apply sym_eq; apply HalfLineAngleBC.
	       autoDistinct.
	       autoDistinct.
	       trivial.
	       trivial.
	      intro; elim (ClockwiseNotCollinear _ _ _ H).
	        apply CollinearBAC; apply (CollinearTrans A B'' B C).
	       apply (EquiDistantDistinct A' B' A B'').
	        apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H2).
	        autoDistance.
	       apply CollinearACB; apply (HalfLineCollinear _ _ _ H5).
	       apply CollinearACB; apply (CollinearTrans A C'').
	        apply (EquiDistantDistinct A' C' A C''); auto.
	        apply CollinearACB; apply (HalfLineCollinear _ _ _ H7).
	        autoCollinear.
	     assert (CongruentStrictTriangles B'' E C'' B' D' C').
	      apply CongruentStrictTrianglesSASA.
	       rewrite <- (ChaslesBetween B'' A E).
	        rewrite (DistSym B'' A); rewrite H12; rewrite H6.
	          rewrite (DistSym A' B'); apply ChaslesBetween; auto.
	        apply BetweenSym; apply (BetweenHalfLineBetween E A B B''); trivial.
	       rewrite (DistSym B'' C''); rewrite (DistSym B' C').
	         apply (CongruentStrictTrianglesCA _ _ _ _ _ _ H13).
	       apply trans_eq with (y := Angle A B'' C'').
	        apply HalfLineAngleB.
	         intro; subst; canonize.
	           destruct (ClockwiseExists E A H2) as (F, H17).
	           elim (ClockwiseNotClockwise _ _ _ H17); auto.
	         intro; subst; elim (ClockwiseNotCollinear _ _ _ H).
	           apply CollinearBAC; apply (CollinearTrans A C'').
	          apply (EquiDistantDistinct A' C' A C''); auto.
	          apply CollinearACB; apply (HalfLineCollinear _ _ _ H5).
	          apply CollinearACB; apply (HalfLineCollinear _ _ _ H7).
	         apply HalfLineSym.
	          apply sym_not_eq; apply (HalfLineDistinct A B B'').
	           autoDistinct.
	           trivial.
	          apply BetweenHalfLine.
	            apply (HalfLineBetweenBetween B).
	           apply BetweenSym; trivial.
	           trivial.
	        apply trans_eq with (y := Angle A' B' C').
	         apply CongruentStrictTrianglesA; trivial.
	         apply HalfLineAngleB.
	          apply (BetweenDistinctAB _ _ _ H2).
	          intro; subst.
	            elim (ClockwiseNotCollinear _ _ _ H).
	            apply CollinearBAC; apply HalfLineCollinear.
	            apply NullAngleHalfLine.
	           autoDistinct.
	           autoDistinct.
	           rewrite <- H3; apply NullAngle.
	            trivial.
	            canonize.
	          apply BetweenHalfLine; trivial.
	       intro; destruct H13.
	         elim H15; apply (CollinearTrans B'' E).
	        intro; subst; canonize.
	          destruct (ClockwiseExists E A H2) as (F, H20).
	          elim (ClockwiseNotClockwise _ _ _ H20); auto.
	        apply CollinearBCA; apply (CollinearTrans A B).
	         autoDistinct.
	         apply (HalfLineCollinear _ _ _ H5).
	         apply CollinearBCA; apply (BetweenCollinear _ _ _ H11).
	        trivial.
	      assert (E = D'').
	       apply (SSSEqualCD C'' A).
	        clear H5 H2 H9; generalizeChange.
	          apply H15; apply ClockwiseCAB; apply H17; trivial.
	        clear H2 H5 H11; generalizeChangeSense.
	          apply H2; apply ClockwiseCAB; apply H9; autoClockwise.
	        apply trans_eq with (y := Distance C' D').
	         apply
	          (CongruentStrictTrianglesBC _ _ _ _ _ _
	             (CongruentStrictTrianglesACB _ _ _ _ _ _ H14)).
	         assert (CongruentStrictTriangles C'' A D'' C' A' D').
	          apply CongruentStrictTrianglesSASB.
	           trivial.
	           trivial.
	           rewrite H4; apply sym_eq; apply HalfLineAngleBC.
	            autoDistinct.
	            autoDistinct.
	            trivial.
	            trivial.
	           intro; elim (ClockwiseNotCollinear _ _ _ H0).
	             apply CollinearBAC; apply (CollinearTrans A C'').
	            apply (EquiDistantDistinct A' C'); auto.
	            apply CollinearACB; apply (HalfLineCollinear _ _ _ H7).
	            apply (CollinearTrans A D'').
	             apply (EquiDistantDistinct A' D').
	              apply (BetweenDistinctBC _ _ _ H2).
	              auto.
	             autoCollinear.
	             apply CollinearACB; apply (HalfLineCollinear _ _ _ H9).
	          apply sym_eq;
	           apply
	            (CongruentStrictTrianglesCA _ _ _ _ _ _
	               (CongruentStrictTrianglesCBA _ _ _ _ _ _ H15)).
	        autoDistance.
	       apply (BetweenHalfLineBetween B A D'').
	        subst; apply (BetweenSym _ _ _ H11).
	        apply HalfLineSym.
	         autoDistinct.
	         trivial.
Qed.

End SUPPLEMENTARY_ANGLES.


(**
Author: Niels van der Weide

Suppose, we have a set `X` with a binary operation `f : X → X → X`.
Since init elments for `f` are unique, the type of unit elements of `f` is a proposition.

This means we have two ways of defining a univalent category of sets with a unital binary operations:
1. We define it as a full subcategory of the category of sets with a binary operation
2. We use algebras of the signature describing sets with a binary operation and a unit, which satisfy the necessary axioms.
Note that in the first category the morphismms are all functions between sets which preserve the binary relation, while the morphisms in the second category must preserve the unit element as well.
As a consequence, the forgetful is full and faithful in the first construction, while in the second it is only faithful.

On the nLab, there are definitions which describe when functors forget properties and when functors forget stuff.
https://ncatlab.org/nlab/show/stuff%2C+structure%2C+property#definitions
With this terminology, we can argue why the first approach adds the unit as a property while in the second approach it is added as structure.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.limits.binproducts.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Projection.

Local Open Scope cat.

(**
Let us start by defining sets with a binary operation on them.
To do so, we use algebras on the diagonal functor.
Let us repeat the diagonal.
After that, we show we have a univalent category of sets with a binary operation.
 *)
Definition diag
  : HSET ⟶ HSET.
Proof.
  exact (bindelta_functor HSET ∙ binproduct_functor BinProductsHSET).
Defined.

Definition binop_category
  : category.
Proof.
  simple refine (FunctorAlg diag).
Defined.

Definition is_univalent_binop
  : is_univalent binop_category.
Proof.
  exact (is_univalent_FunctorAlg is_univalent_HSET diag).
Defined.

Definition binop
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact binop_category.
  - exact is_univalent_binop.
Defined.

(**
In the remainder, we need some projections.
 *)
Section ProjectionsBinop.
  Variable (m : binop).

  Definition carrier
    : hSet
    := pr1 m.

  Definition operation
    : carrier → carrier → carrier
    := λ x y, pr2 m (x ,, y).
End ProjectionsBinop.

(**
Now we look at two ways of defining a category of sets with a binary operation and a unit.
The first way, is by using the full subcategory.
This gives rise to a univalent category since unit elements are unique.
 *)
Definition is_unit
           (m : binop)
           (e : carrier m)
  : UU
  := (∏ (x : carrier m), operation m x e = x)
     ×
     (∏ (x : carrier m), operation m e x = x).

Definition has_unit
           (m : binop)
  : UU
  := ∑ (e : carrier m), is_unit m e.

Definition isaprop_has_unit
           (m : binop)
  : isaprop (has_unit m).
Proof.
  use invproofirrelevance.
  intros e₁ e₂.
  use subtypePath.
  { intro ; apply isapropdirprod ; use impred ; intro ; apply setproperty. }
  exact (!(pr22 e₂ (pr1 e₁)) @ pr12 e₁ (pr1 e₂)).
Defined.

Definition unit_binop_property_disp_cat
  : disp_cat binop
  := disp_full_sub binop has_unit.

Definition unit_binop_property_cat
  : category
  := total_category unit_binop_property_disp_cat.

Definition is_univalent_property_unit_binop
  : is_univalent unit_binop_property_cat.
Proof.
  use is_univalent_total_category.
  - exact is_univalent_binop.
  - use disp_full_sub_univalent.
    exact isaprop_has_unit.
Defined.

Definition unit_binop_property
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact unit_binop_property_cat.
  - exact is_univalent_property_unit_binop.
Defined.

(**
To argue that the unit element is really added as a property, we look at the forgetful functor to sets with binary operations.
This functor only forgets the unit and, since the unit was added as a property, it is full and faithful.
Note that in this displayed category:
- the displayed objects form a proposition
- the displayed morphisms are contractible
 *)
Definition forget_unit_property_adds_properties
  : adds_properties unit_binop_property_disp_cat.
Proof.
  apply pr1_category_fully_faithful.
  intro ; intros.
  apply iscontrunit.
Defined.

(**
Next we show how to define sets with a binary operation and a unit where the unit is added as structure.
To do so, we use displayed categories.
To prove univalence of the total category, we use displayed univalence.
 *)
Definition point_disp_cat_ob_mor
  : disp_cat_ob_mor binop.
Proof.
  use make_disp_cat_ob_mor ; cbn.
  - exact (λ X, carrier X).
  - exact (λ X Y x y f, pr1 f x = y).
Defined.

Definition point_disp_cat_id_comp
  : disp_cat_id_comp binop point_disp_cat_ob_mor.
Proof.
  use tpair.
  - exact (λ _ _, idpath _).
  - exact (λ X Y Z f g x y z p q, maponpaths (pr1 g) p @ q).
Defined.

Definition point_disp_cat_data
  : disp_cat_data binop.
Proof.
  use tpair.
  - exact point_disp_cat_ob_mor.
  - exact point_disp_cat_id_comp.
Defined.

Definition point_disp_cat_laws
  : disp_cat_axioms binop point_disp_cat_data.
Proof.
  repeat split.
  - cbn ; intros ; apply setproperty.
  - cbn ; intros ; apply setproperty.
  - cbn ; intros ; apply setproperty.
  - cbn ; intros.
    apply isasetaprop.
    apply setproperty.
Qed.

Definition point_disp_cat
  : disp_cat binop.
Proof.
  use tpair.
  - exact point_disp_cat_data.
  - exact point_disp_cat_laws.
Defined.

Definition point_disp_cat_disp_univalent
  : is_univalent_disp point_disp_cat.
Proof.
  use is_univalent_disp_from_fibers.
  intros X x y.
  use isweq_iso.
  - intros f.
    exact (pr1 f).
  - intros e.
    induction e ; cbn.
    apply idpath.
  - intros e.
    use subtypePath.
    { intro ; apply isaprop_is_z_iso_disp. }
    cbn.
    induction (pr1 e).
    apply idpath.
Defined.

Definition pointed_binop_category
  : category
  := total_category point_disp_cat.

Definition pointed_binop
  : univalent_category.
Proof.
  simple refine (_ ,, _).
  - exact pointed_binop_category.
  - refine (is_univalent_total_category
              _
              point_disp_cat_disp_univalent).
    exact is_univalent_binop.
Defined.

(**
Some projections of sets with a binary operation and a point.
 *)
Section ProjectionsPointedBinop.
  Variable (m : pointed_binop).

  Definition pointed_carrier
    : hSet
    := pr11 m.

  Definition pointed_operation
    : pointed_carrier → pointed_carrier → pointed_carrier
    := λ x y, pr21 m (x ,, y).

  Definition point_of
    : pointed_carrier
    := pr2 m.
End ProjectionsPointedBinop.

(**
Up to now, we only added the element which represents the unit.
Beside that, we also need to add the necessary laws.
 *)
Definition is_unit_point
  : pointed_binop → UU
  := λ X, is_unit (pr1 X) (pr2 X).

Definition isaprop_is_unit_point
           (X : pointed_binop)
  : isaprop (is_unit_point X).
Proof.
  use isapropdirprod ; use impred ; intro ; apply setproperty.
Defined.

Definition unit_binop_structure_disp_cat
  : disp_cat binop
  := sigma_disp_cat (disp_full_sub pointed_binop is_unit_point).

Definition unit_binop_structure_cat
  : category
  := total_category unit_binop_structure_disp_cat.

Definition is_univalent_structure_unit_binop
  : is_univalent unit_binop_structure_cat.
Proof.
  use is_univalent_total_category.
  - apply binop.
  - apply is_univalent_disp_from_fibers.
    intros x xx yy.
    use isweqimplimpl.
    + intros f.
      use subtypePath.
      {
        intro ; apply isapropdirprod ; use impred ; intro ; apply setproperty.
      }
      exact (pr11 f).
    + apply isapropifcontr.
      apply isaprop_has_unit.
    + use invproofirrelevance.
      intros f g.
      use subtypePath.
      { intro ; apply isaprop_is_z_iso_disp. }
      use subtypePath.
      { intro ; apply isapropunit. }
      apply setproperty.
Defined.

Definition unit_binop_structure
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact unit_binop_structure_cat.
  - exact is_univalent_structure_unit_binop.
Defined.

(**
We finish by arguing that the unit is indeed added structure for this construction.
To do so, we prove that the forgetful functor is faithful.
 *)
Definition forget_unit_structure_faithful
  : adds_structure unit_binop_structure_disp_cat.
Proof.
  intros m₁ m₂ f.
  apply pr1_category_faithful.
  intro ; intros ; simpl.
  use (@isaprop_total2 (make_hProp _ _) (λ _, make_hProp _ _)).
  - apply setproperty.
  - apply isapropunit.
Defined.

(**
We can also show that this forgetful functor isn't full.
This is because not every homomorphism between sets with binary operations preserve the unit element.
For that, we use the following example.
 *)
Definition nat_unit_binop_structure
  : unit_binop_structure.
Proof.
  simple refine ((natset ,, _) ,, _ ,, _) ; cbn.
  - exact (λ n, pr1 n + pr2 n).
  - exact 0.
  - split ; cbn.
    + apply natplusr0.
    + apply natplusl0.
Defined.

Definition bool_unit_binop_structure
  : unit_binop_structure.
Proof.
  simple refine ((boolset ,, _) ,, _ ,, _) ; cbn.
  - exact (λ b, orb (pr1 b) (pr2 b)).
  - exact false.
  - split ; cbn ; intro x ; induction x ; apply idpath.
Defined.

Definition nat_to_bool
  : nat → bool
  := λ _, true.

Definition nat_plus_to_bool_or
  : pr1_category _ nat_unit_binop_structure
    -->
    pr1_category _ bool_unit_binop_structure.
Proof.
  refine (nat_to_bool ,, _).
  use funextsec.
  intro x ; apply idpath.
Defined.

Definition unit_binop_structure_disp_cat_not_adds_properties
  : ¬(adds_properties unit_binop_structure_disp_cat).
Proof.
  intros H.
  induction H as [H₁ H₂].
  clear H₂.
  specialize (H₁ _ _ nat_plus_to_bool_or).
  revert H₁.
  use (@hinhuniv _ hfalse).
  intros H ; cbn.
  pose (pr121 H) as p.
  cbn in p.
  pose (eqtohomot (maponpaths pr1 (pr2 H)) 0) as q.
  cbn in q.
  pose (!q @ p) as r.
  unfold nat_to_bool in r.
  exact (nopathstruetofalse r).
Qed.

(**
Now let us look at the hlevels of the displayed objects and morphisms of this displayed category.
More specifically, both the type of displayed objects and the type of displayed morphisms form propositions.
 *)
Definition unit_binop_structure_disp_cat_mor_prop
  : locally_propositional unit_binop_structure_disp_cat.
Proof.
  apply disp_cat_is_locally_propositional.
  apply forget_unit_structure_faithful.
Defined.

Definition unit_binop_structure_disp_cat_mor_not_contr
  : ¬(locally_contractible unit_binop_structure_disp_cat).
Proof.
  intro H.
  apply unit_binop_structure_disp_cat_not_adds_properties.
  apply pr1_category_fully_faithful.
  exact H.
Defined.

Definition unit_binop_structure_disp_cat_ob_prop
           (X : binop)
  : isaprop (unit_binop_structure_disp_cat X).
Proof.
  apply isaprop_has_unit.
Defined.


(* CS 499 - Mechanized Reasoning about Programs *)
(* Copyright Northern Arizona University        *)
(* All rights reserved                          *)

Require Import Arith ZArith List String Relation_Operators.
Import ListNotations.

(** * Identifiers and Polymorphic States *)

Module Id.

  Inductive t := Id : nat -> t.

  Definition beq (id1 id2:t) : bool :=
    match (id1, id2) with
    | (Id n1, Id n2) => beq_nat n1 n2
    end.

  (** Properties of Id.beq: reflexivity, symmetry. *)

  Fact beq_refl: forall id, beq id id = true.
  Proof.
    intros id.
    destruct id as [ n ].
    unfold beq.
    symmetry.
    apply beq_nat_refl.
  Qed.

  Fact beq_sym: forall id1 id2, beq id1 id2 = beq id2 id1.
  Proof.
    intros id1 id2.
    destruct id1 as [ n1 ].
    destruct id2 as [ n2 ].
    unfold beq.
    now rewrite Nat.eqb_sym.
  Qed.

  Fact beq_eq: forall id1 id2,
      beq id1 id2 = true -> id1 = id2.
  Proof.
    intros [ id1 ] [ id2 ] H; unfold beq in *; simpl in *.
    apply beq_nat_true in H; now rewrite H.
  Qed.

End Id.

(** Natural numbers can be understood as identifiers *)
Coercion Id.Id: nat >-> Id.t.

(** In the module [State], [t A] is the type of a state, i.e.  a
    partial mapping from identifiers to values of type [A]. *)

Module State.

  Definition t := Id.t -> Z.

  Definition update (s:t)(x:Id.t)(v:Z) : t :=
    fun y => if Id.beq y x
          then v
          else s y.

End State.

(** * Arithmetic Expressions *)

Module Aexp.

  (** * The type of arithmetic expressions *)

  Inductive binary_op : Type :=
    Add | Mul | Sub.

  Inductive t : Type :=
  | Int: Z -> t
  | Var: Id.t -> t
  | Binop : binary_op -> t -> t -> t.

  Definition get_op (op: binary_op): Z->Z->Z :=
    match op with
    | Add => Z.add
    | Mul => Z.mul
    | Sub => Z.sub
    end.

  (** ** Evaluation of expressions *)
  Fixpoint A (a:Aexp.t) (s:Id.t -> Z) : Z :=
    match a with
    | Aexp.Int z => z
    | Aexp.Var id => s id
    | Aexp.Binop op a1 a2 => (Aexp.get_op op) (A a1 s) (A a2 s)
    end.

  Module Notations.

    (* Coercions *)
    Coercion Int : Z >-> t.
    Coercion Var : Id.t >-> t.

    (* Notations *)
    Notation "a0 + a1" := (Binop Add a0 a1).
    Notation "a0 - a1" := (Binop Sub a0 a1).
    Notation "a0 * a1" := (Binop Mul a0 a1).

  End Notations.

  (* Examples of expressions *)
  Module Ex_t.
    Import Notations.

    Definition x : Id.t := Id.Id 0.
    Definition y : Id.t := Id.Id 1.
    Definition z : Id.t := Id.Id 2.

    (* Warning: scope Z is not opened! *)
    Definition a0 : t := Binop Add x 1%Z.
    Definition a1 : t := Binop Add x 1.
    Print a0. (* 1%Z is considered as a numerical constant *)
    Print a1. (* 1 is considered as an identifier! *)

    Definition a2 : t := z - (x * (y + 1)).
  End Ex_t.

  (* Examples of evaluation *)
  Module Ex_A.
    Import Ex_t.

    Definition s :=
      fun z =>
        if Id.beq z x then 42%Z else
          if Id.beq z y then 0%Z else 0%Z.

    Example ex0 : A a0 s = 43%Z.
    Proof. simpl. trivial. Qed.

    Example ex1 : A a1 s = 42%Z.
    Proof. simpl. trivial. Qed.

    Example ex2 : A a2 s = 0%Z.
    Proof. simpl. trivial. Qed.

  End Ex_A.

  (** ** Free variables *)

  (* Instead of using a set of variables, we will use lists, and allow
     a variable to be present several times in the list. *)
  Fixpoint FV (a:t) : list Id.t :=
    match a with
    | Int z   => []
    | Var id  => [id]
    | Binop op a1 a2 => List.app (FV a1) (FV a2)
    end.

  Lemma lemma_1_12:
    forall (s s':State.t) (a:t),
      (forall x, In x (FV a) -> s x = s' x) ->
      A a s = A a s'.
  Proof.
    intros s s' a H.
    induction a as [ z | x | op a1 IH1 a2 IH2].
    - simpl. trivial.
    - simpl. apply H.
      simpl. left. reflexivity.
    - assert(A a1 s = A a1 s') as H1.
      {
        apply IH1.
        intros x Hx.
        apply H. simpl.
        apply in_or_app.
        left. assumption.
      }
      assert(A a2 s = A a2 s') as H2.
      {
        apply IH2.
        intros x Hx.
        apply H. simpl.
        apply in_or_app.
        right. assumption.
      }
      simpl.
      rewrite H1, H2.
      trivial.
  Qed.

  (** ** Substitution *)
  Fixpoint subst (a:t) (y:Id.t) (a0:t) : t :=
    match a with
    | Int z  =>  Int z
    | Var id =>  if Id.beq id y
                then a0
                else Var id
    | Binop op a1 a2 =>
      Binop op (subst a1 y a0) (subst a2 y a0)
    end.

  (** Lemma (Exercice) 1.14 (page 18) of Semantics with Applications
      is written as follows: A[a[y →a0]]s = A[a](s[y →A[a0]s]) for all
      states s.

      A direct ``translation'' one could think of in would be: forall
      s a a0 y, A (subst a y a0) s = A a (State.update s y (A a0 s)).

      However (A a0 s) has type option Z, whereas function
      State.update expect its third argument to be of type Z.

      Therefore the correct statement in Coq is as follows: *)
  Lemma lemma_1_14:
    forall (s:State.t)(a a0:t)(y:Id.t),
      A (subst a y a0) s = A a (State.update s y (A a0 s)).
  Proof.
    intros s a a0 y.
    induction a as [ z | x | op a1 IH1 a2 IH2 ].
    - trivial.
    - unfold State.update. simpl.
      destruct (Id.beq x y).
      + trivial.
      + trivial.
    - simpl.
      now rewrite IH1, IH2.
  Qed.

End Aexp.

(** * Boolean expressions *)

Module Bexp.

  (** ** Definition of boolean expressions *)
  Inductive cmp_op : Type :=
    Equal | LowerEq.

  Definition get_cmp (cmp: cmp_op) : Z -> Z -> bool :=
    match cmp with
    | Equal => Z.eqb
    | LowerEq => Z.leb
    end.

  Inductive t : Type :=
  | Bool: bool -> t      (* Constant: true or false *)
  | Neg: t -> t       (* negation of an expression *)
  | And: t -> t -> t   (* conjunction of two boolean expressions *)
  | Cmp: cmp_op -> Aexp.t -> Aexp.t -> t
                     (* comparison of two arithmetic expressions *)
  .

  (** ** Notations *)
  Module Notations.

    Coercion Bool : bool >-> t.
    Notation "! b":=(Neg b)(at level 70).
    Infix "&&" := And.
    Notation "a1 == a2" := (Cmp Equal a1 a2)(at level 70).
    Notation "a1 <= a2" := (Cmp LowerEq a1 a2)(at level 70).

  End Notations.

  (** ** Examples *)
  Module Ex_t.
    Import Aexp.Notations Notations Aexp.Ex_t.

    Definition b1 : t := true.
    Definition b2 : t := !(a1 == 0%Z).
    Definition b3 : t := (0%Z <= x) && (x <= y).

  End Ex_t.

  Fixpoint B (b:Bexp.t) (s:Id.t -> Z) : bool :=
  match b with
  | Bexp.Bool b => b
  | Bexp.Neg b  => negb(B b s)
  | Bexp.And b1 b2 => andb (B b1 s) (B b2 s)
  | Bexp.Cmp cmp a1 a2 => (Bexp.get_cmp  cmp) (Aexp.A a1 s) (Aexp.A a2 s)
  end.

  Module Ex_B.
    Import Ex_t Aexp.Ex_A.

    Fact f1 : B b1 s = true.
    Proof.  simpl. trivial. Qed.

    Fact f2 : B b2 s = true.
    Proof.  simpl. trivial. Qed.

    Fact f3 : B b3 s = false.
    Proof.  simpl. trivial. Qed.
  End Ex_B.

  (** ** Free variables *)
  Fixpoint FV (b:t) : list Id.t :=
    match b with
    | Bool b   => []
    | Neg b  => FV b
    | And b1 b2 =>
      List.app (FV b1) (FV b2)
    | Cmp _ a1 a2 =>
      List.app (Aexp.FV a1) (Aexp.FV a2)
    end.

  Module Ex_FV.
    Import Ex_t Aexp.Ex_t.

    Fact f1 : FV b1 = [].
    Proof. simpl. trivial. Qed.

    Fact f2 : FV b2 = [x;y].
    Proof. simpl. trivial. Qed.

    Fact f3 : FV b3 = [x;x;y].
    Proof. simpl. trivial. Qed.
  End Ex_FV.

  Lemma lemma_1_13:
    forall (s s':State.t) (b:t),
      (forall x, In x (FV b) -> s x = s' x) ->
      B b s = B b s'.
  Proof.
    intros s s' b Hstates.
    induction b as [ b | b IH | b1 IH1 b2 IH2 | cmp a1 a2 ]; simpl in *.
    - trivial.
    - rewrite IH; auto.
    - rewrite IH1, IH2; auto; intros; intuition.
    - assert(Aexp.A a1 s = Aexp.A a1 s') as H1
          by (apply Aexp.lemma_1_12;intros; intuition).
      assert(Aexp.A a2 s = Aexp.A a2 s') as H2
          by (apply Aexp.lemma_1_12;intros; intuition).
      now rewrite H1, H2.
  Qed.

  (** ** Substitution *)
  Fixpoint subst (b:t) (y:Id.t) (a:Aexp.t) : t :=
    match b with
    | Bool b => Bool b
    | Neg b => Neg(subst b y a)
    | And b1 b2 =>
      And (subst b1 y a) (subst b2 y a)
    | Cmp cmp a1 a2 =>
      Cmp cmp (Aexp.subst a1 y a) (Aexp.subst a2 y a)
    end.

  Lemma lemma_1_15:
    forall (s:State.t)(b:t)(a:Aexp.t)(y:Id.t),
      B (subst b y a) s = B b (State.update s y (Aexp.A a s)).
  Proof.
    intros s; induction b; intros a y; simpl in *.
    - trivial.
    - now rewrite IHb.
    - now rewrite IHb1, IHb2.
    - now repeat rewrite Aexp.lemma_1_14.
  Qed.

End  Bexp.

(** * Semantics as Relations *)

(** ** Syntax *)

Inductive stm : Type :=
| Skip : stm
| Assign : Id.t -> Aexp.t -> stm
| Seq : stm -> stm -> stm
| If : Bexp.t -> stm -> stm -> stm
| While: Bexp.t -> stm -> stm.

(** ** Natural Semantics *)

(** < S, s > -> s' *)
Inductive ns : stm -> State.t -> State.t -> Prop :=
| ns_skip:    (* < Skip, s > -> s *)
    forall s, ns Skip s s
| ns_assign:  (* < x := a, s > -> s[x|->A[x]s] *)
    forall (x:Id.t) (a:Aexp.t) (s:Id.t->Z),
      ns (Assign x a)
           s
           (State.update s x (Aexp.A a s))
| ns_comp:    (* < S1, s > -> s'   < S2, s'-> s"
                 -------------------------------
                       < S1;S2, s > -> s"        *)
    forall S1 S2 s s' s'',
      ns S1 s s' ->
      ns S2 s' s'' ->
      ns (Seq S1 S2) s s''
| ns_if_tt:  (* < S1 , s > -> s'      B[b]s = tt
                --------------------------------
                < if b then S1 else S2, s > -> s' *)
    forall b S1 S2 s s',
      Bexp.B b s = true ->
      ns S1 s s' ->
      ns (If b S1 S2) s s'
| ns_if_ff:  (* < S2 , s > -> s'      B[b]s = ff
                --------------------------------
                < if b then S1 else S2, s > -> s' *)
    forall b S1 S2 s s',
      Bexp.B b s = false ->
      ns S2 s s' ->
      ns (If b S1 S2) s s'
| ns_while_tt:
  (* B[b]s = tt  < S, s > -> s'  <while b do S, s'>->s"
     --------------------------------------------------
     <while b do S, s> -> s"                         *)
    forall b S s s' s'',
      Bexp.B b s = true ->
      ns S s s' ->
      ns (While b S) s' s'' ->
      ns (While b S) s s''
| ns_while_ff:
  (* B[b]s = ff
     -----------------------
     <while b do S, s> -> s                          *)
    forall b S s,
      Bexp.B b s = false ->
      ns (While b S) s s
.

(** ** Structural Operational Semantics *)

Inductive configuration : Type :=
| Rem : stm -> State.t -> configuration
| Fin : State.t -> configuration.

Inductive sos : stm -> State.t -> configuration -> Prop :=
| sos_skip:    (* < Skip, s > -> s *)
    forall s, sos Skip s (Fin s)
| sos_assign:  (* < x := a, s > -> s[x|->A[x]s] *)
    forall (x:Id.t) (a:Aexp.t) (s:Id.t->Z),
      sos (Assign x a)
          s
          (Fin (State.update s x (Aexp.A a s)))
| sos_comp1:
    forall S1 S2 s S1' s',
      sos S1 s (Rem S1' s') ->
      sos (Seq S1 S2) s (Rem (Seq S1' S2) s')
| sos_comp2:
    forall S1 S2 s s',
      sos S1 s (Fin s') ->
      sos (Seq S1 S2) s (Rem S2 s')
| sos_if_tt:
    forall S1 S2 b s,
      Bexp.B b s = true ->
      sos (If b S1 S2) s (Rem S1 s)
| sos_if_ff:
    forall S1 S2 b s,
      Bexp.B b s = false ->
      sos (If b S1 S2) s (Rem S2 s)
| sos_while:
    forall b S s,
      sos (While b S) s
          (Rem (If b (Seq S (While b S)) Skip) s)
.

(*********************** AM Language ***********************)

(* Evaluation Stack *)
Module Stack.

  Inductive A : Type :=
  | z : Z -> A
  | T: bool -> A.

  Definition t : Type := list A.

End Stack.

(** ** Syntax *)
(* Translated from page 68 in text, where c is represented using lists*)
Inductive inst: Type :=
| PUSH   : Z -> inst
| ADD    | MULT | SUB
| TRUE   | FALSE
| EQ     | LE
| AND    | NEG
| FETCH  : Id.t -> inst
| STORE  : Id.t -> inst
| NOOP   : inst
| BRANCH : list inst -> list inst -> inst
| LOOP   : list inst -> list inst -> inst.

(*  Definition of c based of page 68, c is a list of inst which is called code here *)
Definition code: Type := list inst.

(* Configuration has the form <c,e,s> where c is a sequence of inst,
    e is the stack, and s is the storage*)
Definition config : Type := ( code * Stack.t * State.t) .

(** ** Structural Operational Semantics *)
Inductive am : config -> config -> Prop :=
(*NOOP (skip)*)
| am_noop:
    forall (c:code) (e:Stack.t)(s:State.t),
      am  (NOOP::c, e, s)  (c , e, s)
(*PUSH*)
| am_push:
  forall  (n:Z) (c:code) (e:Stack.t)(s:State.t),
      am ((PUSH n)::c, e, s) (c, (Stack.z n)::e, s)

(* Z operations *)
| am_add:
  forall  (z1 z2:Z) (c:code) (s:State.t)  (e:Stack.t),
     am (ADD::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.add z1 z2))::e, s)

| am_sub:
  forall (z1 z2: Z) (c:code) (s:State.t)  (e:Stack.t),
     am (SUB::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.sub z1 z2))::e, s)

| am_mult:
  forall (z1 z2: Z) (c:code) (s:State.t)  (e:Stack.t),
     am (MULT::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.mul z1 z2))::e, s)

(* TRUE and FALSE *)
| am_true:
    forall (c:code) (s:State.t) (e:Stack.t) (tt:bool),
       am (TRUE::c, e, s) (c, (Stack.T tt)::e, s)

| am_false:
    forall (c:code) (s:State.t) (e:Stack.t) (ff:bool),
       am (FALSE::c, e, s) (c, (Stack.T ff)::e, s)

(* EQ and LE *)
| am_eq :
  forall (c:code) (s:State.t) (e:Stack.t) (z1 z2: Z),
    am (EQ::c,e,s) (c, (Stack.T (Z.eqb z1 z2))::e, s)

| am_le :
  forall (c:code) (s:State.t) (e:Stack.t) (z1 z2: Z),
    am (LE::c,e,s) (c, (Stack.T (Z.leb z1 z2))::e, s)

(* AND *)
| am_and:
  forall (c:code) (s:State.t) (e:Stack.t) (t1 t2:bool),
    am (AND::c, e, s) (c,(Stack.T (andb t1 t2))::e,s)

(*NEG *)
|am_neg:
  forall  (c:code) (s:State.t) (e:Stack.t) (t:bool),
    am (NEG::c,(Stack.T t)::e,s) (c,(Stack.T (negb t))::e,s)

(*FETCH*)
| am_fetch:
    forall (c:code) (s:State.t) (e:Stack.t) (x:Id.t),
      am ((FETCH x)::c,e,s) (c, (Stack.z (s x))::e,s)

(*STORE*)
|am_store:
    forall (c:code) (s:State.t) (e:Stack.t) (x:Id.t) (z:Z),
      am ((STORE x)::c,(Stack.z z)::e,s) (c,e, (State.update s x z))

(*BRANCH*)
|am_branch_tt:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((BRANCH c1 c2)::c, (Stack.T true)::e, s) (c1++c, e, s)

|am_branch_ff:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((BRANCH c1 c2)::c, (Stack.T false)::e, s) (c2++c, e, s)

(* LOOP *)
|am_loop:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((LOOP c1 c2)::c, e, s) ( c1++(BRANCH(c2++[(LOOP c1 c2)]) [NOOP])::c,e,s).

Module Examples.

  Definition x : Id.t := Id.Id 0.

  Definition s (y: Id.t) : Z :=
    if Id.beq y x
      then 3%Z
    else 0%Z.

   Example ex_4_1 :
      exists s',
      (clos_refl_trans_1n _ am) ( (PUSH 1%Z)::(FETCH x)::(ADD)::(STORE x)::[],[ ], s )
                                             ([],[],s') /\ s' x = 4%Z.
   Proof.
       repeat eexists.
       do 10  econstructor.
       simpl. reflexivity.
  Qed.

   Example ex_4_2:
          (clos_trans  _ am) ( [ LOOP [TRUE] [NOOP] ], [ ], s) ([ LOOP [TRUE] [NOOP] ], [ ], s).
      Proof.
          do 5 (econstructor; simpl).
      Qed.

    (** ** Exercise 4.4 *)

    (** First, we need to define what corresponds to ->k: *)
    Inductive am_k : nat -> (code*Stack.t*State.t) -> (code*Stack.t*State.t) -> Prop :=
    | am_O: forall config, am_k 0 config config
    | am_Sn: forall config config' config'' k,
        am config config' -> am_k k config' config'' -> am_k (S k) config config''.

    Lemma ex_4_4:
      forall k c1 e1 s c' e' s' c2 e2,
        am_k k (c1, e1, s) (c', e', s') ->
        am_k k (c1++c2, e1++e2, s) (c'++c2, e'++e2, s').
    Proof.
      induction e2.

    Notation am_star := (clos_refl_trans_1n  _ am).

  Lemma ex_4_4':
    forall c1 e1 s c' e' s' c2 e2,
      am_star (c1, e1, s) (c', e', s') ->
      am_star (c1++c2, e1++e2, s) (c'++c2, e'++e2, s').
  Proof.
  Admitted.
    Lemma ex_4_6:
      forall (c:code) (s:State.t) (e:Stack.t),
      exists c' s' e',
        (clos_refl_trans_1n _ am) (c,e,s) (c',e',s').
    Proof.
        repeat eexists.
        admit.
    Admitted.

(*Theorem 2.9 (page 41?)*) (*should do induction on derivation tree*)
(*show table 4.1 is determinisistc; use to prove there is only one
   computation sequence. (pg 73?)
Instead of taking am: prove for am; prove for reflex_trans am.*)

End Examples.


CoInductive conat : Set := O' | S' (n : conat).

CoFixpoint inf : conat := S' inf.

Fixpoint toCo (n : nat) : conat := match n with
  | O => O'
  | S n' => S' (toCo n') end.

CoInductive bisim : conat -> conat -> Prop :=
  | OO : bisim O' O'
  | SS : forall n m : conat, bisim n m -> bisim (S' n) (S' m).

Notation "x == y" := (bisim x y) (at level 70).

Definition conat_u (n : conat) : conat := match n with
  | O' => O'
  | S' n' => S' n' end.

Lemma conat_unfold : forall n : conat, n = conat_u n.
Proof. destruct n; auto. Qed.

Theorem not_fin_then_inf : forall n : conat, ~ (exists m : nat, toCo m == n) -> (n == inf).
Proof.
  cofix CIH. intros. destruct n.
  - destruct H. exists 0. simpl. constructor.
  - rewrite (conat_unfold inf). simpl. constructor.
    apply CIH. intros [m contra]. apply H. exists (S m). simpl.
    constructor. apply contra.
Qed.


Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

Notation "( x , y )" := (pair x y).

Definition fst p : nat :=
  match p with | (x,_) => x end.

Definition snd p : nat :=
  match p with | (_,x) => x end.

Definition swap p : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Ltac pair_simple p := destruct p as [m n]; simpl; reflexivity.

Theorem surjective_pairing : forall p : natprod, p = (fst p, snd p).
Proof.
  intro p. pair_simple p.
Qed.

Theorem snd_fst_is_swap : forall p, swap p = (snd p, fst p).
Proof.
  intro p. pair_simple p.
Qed.

Theorem fst_swap_is_snd : forall p, fst (swap p) = snd p.
Proof.
  intro p. pair_simple p.
Qed.


Inductive N:Set:= (*this is a comment line*)
|zero: N
|succ:N->N.

Fixpoint plus (m n:N):=
match m with
| zero=>n
|succ m'=>succ(plus m' n)
end.

Lemma zero_identity: forall n,n=plus n zero.
Proof.
induction n.
auto.
simpl.
f_equal.
assumption.
Qed.


Require Import ZArith.

Module NaiveLang.
  Definition expr := (nat -> option Z) -> Prop.
  Definition context := expr -> Prop.
  Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
  Definition orp  (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
  Definition falsep : expr := fun st => False.
  Definition truep : expr := fun st => True.

  Definition join : (nat -> option Z) -> (nat -> option Z) -> (nat -> option Z) -> Prop :=
    fun x y z =>
      forall p: nat,
       (exists v, x p = Some v /\ y p = None /\ z p = Some v) \/
       (exists v, x p = None /\ y p = Some v /\ z p = Some v) \/
       (x p = None /\ y p = None /\ z p = None).
  Definition sepcon (e1 e2 : expr) : expr := fun st =>
    exists st1 st2, join st1 st2 st /\ e1 st1 /\ e2 st2.
  Definition emp : expr := fun st =>
    forall p, st p = None.
  Definition derivable1 (e1 e2 : expr) : Prop := forall st, e1 st -> e2 st.
End NaiveLang.

Require Import interface_4.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Axiom falsep_sepcon_left : (forall x : expr, derivable1 (sepcon falsep x) falsep) .
  Axiom orp_sepcon_left : (forall x y z : expr, derivable1 (sepcon (orp x y) z) (orp (sepcon x z) (sepcon y z))) .
  Axiom sepcon_emp_left : (forall x : expr, derivable1 (sepcon x emp) x) .
  Axiom sepcon_emp_right : (forall x : expr, derivable1 x (sepcon x emp)) .
  Axiom derivable1_sepcon_comm : (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) .
  Axiom derivable1_sepcon_assoc1 : (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) .
  Axiom derivable1_sepcon_mono : (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) .
  Axiom derivable1_truep_intros : (forall x : expr, derivable1 x truep) .
  Axiom derivable1_falsep_elim : (forall x : expr, derivable1 falsep x) .
  Axiom derivable1_orp_intros1 : (forall x y : expr, derivable1 x (orp x y)) .
  Axiom derivable1_orp_intros2 : (forall x y : expr, derivable1 y (orp x y)) .
  Axiom derivable1_orp_elim : (forall x y z : expr, derivable1 x z -> derivable1 y z -> derivable1 (orp x y) z) .
  Axiom derivable1_andp_intros : (forall x y z : expr, derivable1 x y -> derivable1 x z -> derivable1 x (andp y z)) .
  Axiom derivable1_andp_elim1 : (forall x y : expr, derivable1 (andp x y) x) .
  Axiom derivable1_andp_elim2 : (forall x y : expr, derivable1 (andp x y) y) .

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Module Solver := IPSolver NaiveLang.
Import T.
Import Solver.


Require Import List Extraction.
Section LLists.

Variable (A:Type).

CoInductive LList :=
  | LNil: LList
  | LCons : A -> LList -> LList.

Inductive Finite : LList -> Prop :=
  |Finite_LNil: Finite LNil
  |Finite_LCons     : forall a l, Finite l-> Finite (LCons a l).

(* An equivalent (one contructor) definition of Finite *)

Inductive Finite_alt (x:LList) :Prop :=
  |finite_alt_intro: (forall a y , x = LCons a y ->Finite_alt y)->
       Finite_alt x.

Lemma Finite_Finite_alt : forall x, Finite x -> Finite_alt x.
Proof.
  intros x H;induction H.
 -  constructor; intros a y H;inversion H.
 -  constructor;intros b y;injection 1; intros;subst y;assumption.
Qed.

Lemma Finite_alt_Finite : forall x, Finite_alt x -> Finite x.
Proof.
 intros x H; induction H as [x H H0]; destruct x;constructor.
 eapply H0;eauto.
Qed.

Definition Finite_rect_0 (P:LList->Type) :
    (forall x : LList,
        (forall(h:A) (y  : LList),  x = LCons h y -> P y) -> P x) ->
    forall x : LList, Finite x -> P x.
Proof.
 intros H x Hx;apply Finite_Finite_alt in Hx.
 induction Hx.
 apply H; auto.
Defined.

Definition Finite_rect (P:LList->Type) :
 P LNil ->
 (forall x (l:LList), P l -> (P (LCons  x l))) ->
 forall l, Finite l -> P l.
Proof.
 intros X X0 l H; induction H using Finite_rect_0.
  destruct x; auto.
  apply X0; apply X1 with a;reflexivity.
Defined.

Fixpoint list_inject (l:list A) : LList :=
 match l with nil => LNil
            |List.cons a l' => LCons a (list_inject l')
 end.

Lemma inj_Finite : forall l, Finite (list_inject l).
Proof.
 induction l;constructor;auto.
Qed.

Definition to_list_strong: forall x, Finite x-> {l:list A | x=list_inject l}.
Proof.
  intros x H;  induction H using Finite_rect.
 -   exists nil;auto.
 -   destruct IHFinite as [l0 H0]; exists (x::l0);subst l;trivial.
Defined.

Definition to_list: forall x, Finite x-> list A.
Proof.
  intros x Hx;destruct (to_list_strong _ Hx) as  [x0 _];  exact x0.
Defined.

End LLists.
Recursive Extraction to_list_strong.


(** * Teorija tipov in λ-račun. *)

(** Tipi so posplošitev množic, topološki prostorov in podatkovnih tipov. Naivno si jih
    lahko predstavljamo kot množice. Dejstvo, da ima izraz [e] tip [A] pišemo [e : A].

    Razne konstrukcije tipov se vedno uvede po istem vzorcu:

    - _formacija_: kako se naredi nov tip

    - _vpeljava_: kako se naredi ali sestavi elemente tipa (konstruktorji)

    - _upraba_: kako se elemente uporabi ali razstavi na sestavne dele (eliminatorji)

    - _enačbe_: kakšne enačbe povezujejo konstruktorje in eliminatorje
*)

(** ** Funkcije

  Za vsaka dva tipa [A] in [B] lahko tvorimo tip funkcij:

  - _formacija_: če sta [A] in [B] tipa, je tudi [A -> B] tip

  - _vpeljava_: če je [x : A] spremenljivka tipa [A] in [t : B] izraz tipa [B],
    odvisen od [x], potem je [fun (x : A) => t] tipa [A -> B]. Izrazu [fun ...]
    pravimo _λ-abstrakcija_, ker se v logiki piše $\lambda x : A . t$.

  - _uporaba_: če je [f : A -> B] in [e : A] potem je [f e : B]. Pravimo, da smo
    funkcijo [f] aplicirali na argumentu [e].

  - _enačbe_:

    - _pravilo $\beta$_: [(fun (x : A) => t) e = t{e/x}] kjer zapis "[t{e/x}]" pomeni,
      da v izrazu [t] vstavimo [e] namesto [x].

    - _pravilo $\eta$_: [(fun (x : A) => f x) = f]
*)

(** ** Kartezični produkt

    Da bomo lahko počeli kaj zanimivega, vpeljemo še kartezični produkt tipov:

    - _formacija_: če sta [A] in [B] tipa, je [A * B] tip (matematični zapis $A \times B$)

    - _vpeljava_: če je [a : A] in [b : B], potem je [(a,b) : A * B], _urejeni par_

    - _uporaba_: če je [p : A * B], potem imamo

      - _prva projekcija_: [fst p : A]
      - _druga projekcija_: [snd p : B]

    - enačbe, pri čemer je [a : A], [b : B] in [p : A * B]:
      - [fst (a, b) = a]
      - [snd (a, b) = b]
      - [p = (fst p, snd p)]

    Poznamo še enotski tip:

    - _formacija_: [unit] je tip
    - _vpeljava_: [tt : unit]
    - _uporaba_: pravil za uporabo ni
    - _enačbe_: če je [u : unit], je [u = tt].
*)

(** V Coqu lahko datoteko razdelimo na posamične razdelke z [Section X.] in [End X.] *)
Section RazneFunkcije.

  (* Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  Definition vaja1_1 : A * B -> B * A :=
    fun (p : A * B) => (snd p, fst p).

  Definition vaja1_2 : (A * B) * C -> A * (B * C) :=
    fun (p : (A * B) * C) => (fst (fst p), (snd (fst p), snd p)).

  Definition vaja1_3 : A -> (B -> A).
  Admitted.

  Definition vaja1_4 : (A -> B -> C) -> (A -> B) -> (A -> C).
  Admitted.

  Definition vaja1_5 : (A * B -> C) -> (A -> (B -> C)).
  Admitted.

  Definition vaja1_6 : (A -> (B -> C)) -> (A * B -> C) :=
    fun (f : A -> (B -> C)) => (fun p : A * B => f (fst p) (snd p)).

  Definition vaja1_7 : unit * A -> A.
  Admitted.

  Definition vaja1_8 : A -> unit * A :=
    fun (a : A) => (tt, a).
End RazneFunkcije.

(** Ko zapremo razdelek [RazneFunkcije] nimamo več predpostavke, da so [A], [B], [C] tipi,
    vse definicije iz razdelka pa postanejo funkcije z dodatnimi parametri [A], [B], [C]. *)
Print vaja1_1.

(** Coq pravi: "Arguments [A], [B] are implicit and maximally inserted". To pomeni,
    da jih ni treba podati, ko uporabimo funkcijo [vaja1_1]. *)
Eval compute in vaja1_1 (42, false).

(* Če želimo eksplicitno nastaviti tudi [A] in [B], pišemo [@vaja1_1] namesto [vaja1_1]: *)
Eval compute in @vaja1_1 nat bool (42, false).

(** ** Izomorfni tipi

   Pravimo, da sta tipa [X] in [Y] izomorfna, če obstajata [f : X -> Y] in
   [g : Y -> X], da velja [g (f x) = x] za vse [x : X] in [g (g y) = y] za vse [y : Y].
*)
Definition iso (X : Type) (Y : Type) :=
  exists (f : X -> Y) (g : Y -> X),
    (forall x : X, g (f x) = x) /\ (forall y : Y, f (g y) = y).

(** V Coqu lahko uvedemo prikladno notacijo za izomorfizem. *)
Notation "X <~> Y" := (iso X Y) (at level 60).

Section Izomorfizmi1.
  (** Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  (** Dokaži, da so naslednji tipi izomorfni. *)

  Lemma vaja2_1 : A * B <~> B * A.
  Proof.
    admit.
  Qed.

  Lemma vaja2_2 : (A * B) * C <~> A * (B * C).
  Proof.
    admit.
  Qed.

  Lemma vaja2_3 : unit * A <~> A.
  Proof.
    admit.
  Qed.

  (** Pravimo, da sta funkciji [f g : X -> Y] _enaki po točkah_, če velja [forall x : X, f
      x = g x]. Aksiom _funkcijske ekstenzionalnosti_ pravi, da sta funkciji enaki,
      če sta enaki po točkah. Coq ne verjame v ta aksiom, zato ga po potrebi predpostavimo.
      Najprej ga definirajmo. *)
  Definition funext :=
    forall (X Y : Type) (f g : X -> Y), (forall x, f x = g x) -> f = g.

  (** S pomočjo ekstenzionalnosti lahko dokažemo nekatere izomorfizme. *)
  Lemma vaja2_4 (F : funext) : (A * B -> C) <~> (A -> (B -> C)).
  Proof.
    admit.
  Qed.

  Lemma vaja2_5 (F : funext) : (unit -> A) <~> A.
  Proof.
    admit.
  Qed.

  Lemma vaja2_6 (F : funext) : (A -> unit) <~> unit.
  Proof.
    admit.
  Qed.
End Izomorfizmi1.

(** ** Vsota tipov

   Vsota tipov je kot disjunktna unija v teorijo množic ali koprodukt v kategorijah:

   - _formacija_: če sta [A] in [B] tipa, je [A + B] tip

   - _vpeljava_:

      - če je [a : A], potem je [inl a : A + B]
      - če je [b : B], potem je [inr b : A + B]

   - _uporaba_: če pri predpostavki [x : A] velja [u(x) : C] in
     če pri predpostavki [y : B] velja [v(y) : C] in če je [t : A + B], potem
     ima
     [(match t with
       | inl x => u(x)
       | inr y => v(y)
      end)]
     tip [C].

   - _enačbe_:

      - [match (inl a) with
         | x => u(x)
         | y => v(y)
         end] je enako [u(a)].

      - [match (inr b) with
         | x => u(x)
         | y => v(y)
         end] je enako [v(b)].

      - [match t with
         | inl x => inl x
         | inr y => inr y
         end] je enako [t].

*)

(** ** Prazen tip

    Nekoliko bolj nenavaden je prazen tip:

    - _formacija_: [Empty_set] je tip

    - _vpeljava_: ni pravil za uporabo

    - _uporaba_: če [t : Empty_set], potem ima [match t with end] tip [A]

    - _enačbe_: [match t with end] je enako [a] za vse [a : A]
*)

Section FunkcijeVsote.
  (** Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  Definition vaja3_1 : (A + B -> C) -> (A -> C) * (B -> C).
  Admitted.

  (* S stavkom match obravnavmo element, ki je vsota tipov. *)

  Definition vaja3_2 : A + B -> B + A.
  Admitted.

  Definition vaja3_3 : (A + B) * C -> A * C + B * C.
  Admitted.

  Definition vaja3_4 : A * C + B * C -> (A + B) * C.
  Admitted.

  Definition vaja3_5 : (A -> C) * (B -> C) -> (A + B -> C).
  Admitted.

  Definition vaja3_6 : Empty_set -> A.
  Admitted.

  Definition vaja3_7 : Empty_set + A -> A.
  Admitted.

  Definition vaja3_8 : A -> ((A -> Empty_set) -> Empty_set).
  Admitted.

  Definition vaja3_9 : A + (A -> Empty_set) -> (((A -> Empty_set) -> Empty_set) -> A).
  Admitted.

End FunkcijeVsote.

Section Izomorfizmi2.
  (** Sam ugotovi, kje potrebuješ funkcijsko ekstenzionalnost. *)

  Context {A B C : Type}.

  Definition vaja4_1 : A + B <~> B + A.
  Proof.
    admit.
  Qed.

  Definition vaja4_2 : (A + B) * C <~> A * C + B * C.
  Proof.
    admit.
  Qed.

  Definition vaja4_3 : (A + B -> C) <~> (A -> C) * (B -> C).
  Proof.
    admit.
  Qed.

  Definition vaja4_4 : Empty_set + A <~> A.
  Proof.
    admit.
  Qed.

  Definition vaja4_5 : (A -> Empty_set) <~> Empty_set.
  Proof.
    admit.
  Qed.

  Definition vaja5_5 : (Empty_set -> A) <~> unit.
  Proof.
    admit.
  Qed.

End Izomorfizmi2.

Section Zabava.
  (** Pa še neka vaj za zabavo. *)
  Context {A B : Type}.

  (* Koliko funkcij A * B -> A + B lahko definiraš? *)
  Definition vaja5_1_XX : A * B -> A + B.
  Admitted.

  (* Koliko funkcij tipa (A * A) * A -> A * A lahko definiraš? *)
  Definition vaja5_2_XX : (A * A) * A -> A * A.
  Admitted.

  (* Koliko funkcij tipa (A -> A) -> (A -> A) lahko definiraš? *)
  Definition vaja5_3_XX : (A -> A) -> (A -> A).
  Admitted.

End Zabava.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq choice fintype.
Require Import finfun bigop finset.

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

Goal FinSet [ffun x : 'I_3 => true] = setT.
apply/setP => /= x.
rewrite {1}SetDef.pred_of_setE /=.
rewrite {1}/in_mem.
rewrite {1}/mem.
rewrite /=.
rewrite ffunE.
rewrite in_setT.
done.
Qed.

(* おまけ。 *)
Goal [set: 'I_3] = setT.
apply/setP.
by case => /=.
Qed.

Section finset_example.

Variable T : finType.
Variables A B C : {set T}.

(* use setP *)
Lemma exo20 : (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
Proof.
  Search (_ :&: _ :|: _).
  by rewrite setUIl.
Qed.

End finset_example.


Theorem my_first_proof : (forall A : Prop, forall value_of_A: A, A).
Proof.
  intros A.
  (* intros proof_of_A.
  exact proof_of_A. *)
  intros value_of_B.
  exact value_of_B.
  (* case value_of_B. *)
  (* elim value_of_B. *)
Qed.

Theorem my_second_proof : (forall A : Prop, A -> A).
trivial.
Qed.

Theorem forward_small : (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A B.
 (* intros B. *)
 intros proof_of_A A_implies_B.
 (* intros A_implies_B. *)
 pose (proof_of_B := A_implies_B proof_of_A).
 exact proof_of_B.
Qed.

Theorem lalal : (forall A B : Prop, A -> (A -> B) -> B).
Proof.
  intros A B.
  intros proof_of_A A_implies_B.
  exact (A_implies_B proof_of_A).
Qed.

Theorem forward_small_2 :
 (forall A B : Prop,
  (forall value_of_A: A,
   (forall A_implies_B: A->B, B))).
Proof.
 intros A B.
 (* intros B. *)
 intros proof_of_A A_implies_B.
 (* intros A_implies_B. *)
 pose (proof_of_B := A_implies_B proof_of_A).
 exact proof_of_B.
Qed.

Theorem forward_small_3 : (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A B.
 (* intros B. *)
 intros proof_of_A A_implies_B.
 (* intros A_implies_B. *)
 exact (A_implies_B proof_of_A).
Qed.

Theorem backward_small : (forall A B : Prop, A -> (A->B)->B).
Proof.
 intros A B.
 intros proof_of_A A_implies_B.
 (* refine (A_implies_B _). *)
 refine (A_implies_B proof_of_A).
 (*  exact proof_of_A. *)
Qed.

Theorem backward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 refine (A_imp_B_imp_C _ _).
  exact proof_of_A.

  refine (A_implies_B _).
   exact proof_of_A.
Show Proof.
Qed.

Theorem backward_huge2 : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 exact (A_imp_B_imp_C proof_of_A (A_implies_B proof_of_A)).
Show Proof.
Qed.

Theorem forward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 pose (proof_of_B := A_implies_B proof_of_A).
 pose (proof_of_C := A_imp_B_imp_C proof_of_A proof_of_B).
Show Proof.
 (*exact proof_of_C.*)
 refine proof_of_C.
Show Proof.
Qed.
Extraction forward_huge.

(* Inductive False : Prop := . *)

(* Inductive True : Prop :=
  | I : True.
*)

(*
Inductive bool : Set :=
  | true : bool
  | false : bool.
*)

(*
Definition not (A:Prop) := A -> False.
*)

(* Notation "~ x" := (not x) : type_scope. *)

Theorem False_cannot_be_proven : ~False.
Proof.
  (* unfold not. *)
  (*unfold "~ _".*)
  (* simpl. *)
  intros proof_of_False.
  exact proof_of_False.
Qed.

Theorem False_cannot_be_proven2 : ~False.
Proof.
  intros proof_of_False.
  elim proof_of_False.
Qed.

Theorem thm_true_imp_true : True -> True.
Proof.
  intros proof_of_True.
  exact I.
Qed.

Theorem thm_false_imp_false : False -> False.
Proof.
  intros.
  case H.
Qed.

Theorem thm_true_imp_false : ~(True -> False).
Proof.
  unfold not.
  intros True_implies_False.
  case (True_implies_False I).
Qed.

Theorem thm_true_imp_false_2 : ~(True -> False).
Proof.
  intros T_implies_F.
  refine (T_implies_F _).
    case I.
    case I.
    elim I.
    exact I.
Qed.

Theorem thm_true_imp_false_3 : ~(True -> False).
Proof.
  intros T_implies_F.
  pose (f := T_implies_F I).
  exact f.
Qed.

Theorem absurd2 : forall A C : Prop, A -> ~ A -> C.
Proof.
  intros A C.
  intros proof_of_A.
  intros not_A.
  unfold not in not_A.
  pose (f := not_A proof_of_A).
  (* unfold not.
  intros A_implies_False.
  pose (f := A_implies_False proof_of_A). *)
  case f.
Qed.

Theorem absurd2_2 : forall A C : Prop, A -> ~ A -> C.
Proof.
  intros A C.
  intros proof_of_A.
  intros not_A.
  pose (f := not_A proof_of_A).
  case f.
Qed.

Require Import Bool.

Definition eqb' (b1 b2:bool) : bool :=
  match b1, b2 with
    | true, true => true
    | true, false => false
    | false, true => false
    | false, false => true
  end.

Definition Is_true' (b:bool) :=
  match b with
    | true => True
    | false => False
  end.

(*
Theorem llala2 : forall b1 b2 : bool, eqb' b1 b2 = eqb b1 b2.
Proof.
  intros b1 b2.
  simpl.
  case b1.
    case b2.
      pose (resEqb' := eqb' b1 b2).
      pose (resEqb := eqb b1 b2).
      exact (eqb' true true = eqb true true).
*)

Theorem true_is_True: Is_true true.
Proof.
  unfold Is_true.
  simpl.
  exact I.
Qed.

Theorem not_true_is_True: not (Is_true false).
  unfold "~".
  intros is_true_false.
  simpl is_true_false.
  unfold Is_true.
  case is_true_false.
Qed.

Theorem not_eqb_true_false: ~(Is_true (eqb true false)).
Proof.
  simpl.
  (*
  unfold "~".
  intros proof_of_False.
  exact proof_of_False.
  *)
  exact False_cannot_be_proven.
Qed.

Theorem eqb_a_a : (forall a : bool, Is_true (eqb a a)).
Proof.
  intros a.
  case a.
    unfold Is_true.
    simpl.
    exact I.

    simpl.
    exact I. Qed.

Theorem thm_eqb_a_t: (forall a:bool, (Is_true (eqb a true)) -> (Is_true a)).
Proof.
  intros a.
  case a.
    simpl.
    intros.
    exact I.

    simpl.
    intros.
    case H.
Qed.

(*
Theorem thm_eqb_a_t_2: (forall a:bool, (Is_true (eqb a true)) -> (Is_true a)).
Proof.
  intros a.
  simpl.
  intros H.
  case a.
    simpl. trivial.

    simpl. simpl in H.

Qed.
*)

(* Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B
where "A \/ B" := (or A B) : type_scope. *)

Theorem left_or : (forall A B : Prop, A -> A \/ B).
Proof.
  intros A B.
  intros proof_of_A.
  (* exact (or_introl proof_of_A). *)
  pose (proof_of_A_or_B := or_introl proof_of_A : A \/ B).
  exact proof_of_A_or_B.
Qed.

Theorem right_or : (forall A B : Prop, B -> A \/ B).
  intros A B.
  intros proof_of_B.
  refine (or_intror _).
    exact proof_of_B.
Qed.

Theorem right_or2 : (forall A B : Prop, B -> A \/ B).
  intros A B.
  intros proof_of_B.
  refine (or_intror proof_of_B).
Qed.

Theorem or_commutes : (forall A B, A \/ B -> B \/ A).
Proof.
  intros A B.
  intros A_or_B.
  case A_or_B.
    intros proof_of_A.
    exact (or_intror proof_of_A).

    intros proof_of_B.
    exact (or_introl proof_of_B).
Qed.

(*
Inductive and (A B:Prop) : Prop :=
  conj : A -> B -> A /\ B

where "A /\ B" := (and A B) : type_scope.
*)

Theorem both_and : (forall A B : Prop, A -> B -> A /\ B).
Proof.
  intros A B.
  intros proof_of_A proof_of_B.
  refine (conj _ _).
    exact proof_of_A.
    exact proof_of_B.
Qed.
Extraction both_and.

Theorem and_commutes : (forall A B, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros A_and_B.
  case A_and_B.
    intros proof_of_A.
    intros proof_of_B.
    exact (conj proof_of_B proof_of_A).
Qed.

Theorem and_commutes__again : (forall A B, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros A_and_B.
  destruct A_and_B as [ proof_of_A proof_of_B].
  refine (conj _ _).
    exact proof_of_B.
    exact proof_of_A.
Qed.

(*
Infix "&&" := andb : bool_scope.
Infix "" := orb : bool_scope.
*)

(*
Definition iff (A B:Prop) := (A -> B) /\ (B -> A).
Notation "A <-> B" := (iff A B) : type_scope.
*)

Theorem orb_is_or : (forall a b, Is_true (orb a b) <-> Is_true a \/ Is_true b).
Proof.
  intros a b.
  unfold iff.

  refine (conj _ _).
    intros H.
    case a, b.
      simpl. exact (or_introl I).
      simpl. exact (or_introl I).
      simpl. exact (or_intror I).
      simpl. simpl in H. (* exact (or_introl H). *) case H.

    intros H.
    case a, b.
      simpl. exact I.
      simpl. exact I.
      simpl. exact I.
      simpl. simpl in H. case H. trivial. trivial.

  (*
  case a.
    case b.
      simpl.
      refine (conj _ _).
        intros.
        exact (or_introl I).

        intros.
        exact I.

      simpl.
      refine (conj _ _).
        intros.
        exact (or_introl I).

        intros.
        exact I.

    case b.
      simpl.
      refine (conj _ _).
        intros.
        exact (or_intror I).

        intros _.
        exact I.

      simpl.
      refine (conj _ _).
        intros f.
        exact (or_introl f).

        intros f_or_f.
        case f_or_f.
          intros f.
          exact f.

          intros f.
          exact f.
  *)
Qed.

Theorem andb_is_and : (forall a b, Is_true (andb a b) <-> Is_true a /\ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      simpl. exact (conj I I).
      simpl. simpl in H. case H.
      simpl. simpl in H. case H.
      simpl. simpl in H. case H.

    intros lala.
    case a,b.
      simpl. trivial.
      simpl in lala. destruct lala as [ A B]. case B. (* case lala. intros _ f. exact f. *)
      simpl. simpl in lala. case lala. intros f _. case f.
      simpl. simpl in lala. case lala. intros f _. case f.
Qed.

Theorem negb_is_not : (forall a, Is_true (negb a) <-> (~(Is_true a))).
Proof.
  intros a.
  unfold "<->".
  unfold not.
  (* case a. *)
  refine (conj _ _).
    case a.
      simpl. intros f _. case f.
      simpl. intros _ f. case f.

    case a.
      simpl. intros True_implies_False. exact (True_implies_False I).
      simpl. intros _. exact I.
Qed.

Print ex.

Print or.

(*
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
  ex_intro : forall x : A, P x -> ex (A) P.
*)

(*

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.
*)

Definition basic_predicate : bool -> Prop
:=
  (fun a => Is_true (andb a true))
.

Theorem thm_exists_basics : (ex basic_predicate).
Proof.
  (*
  pose (witness := true).
  refine (ex_intro basic_predicate witness _).
    unfold basic_predicate.
    simpl.
    exact I.
  *)
(*
Unset Printing Notations.
  simpl.
SearchAbout .
Locate "exists".
Print ex.
Check ex.
Extraction ex.
  pose (witness := true).
  refine (ex_intro basic_predicate witness _).
    simpl.
    exact I.
    intros H.
    Check basic_predicate.
    exact (basic_predicate true).
*)
(*
refine (ex_intro basic_predicate true _).
  simpl.
  unfold basic_predicate.
  simpl.
  unfold Is_true.
  exact (I).
*)

refine (ex_intro _ true I).

Qed.

 Theorem thm_exists_basics__again : (exists a, Is_true (andb a true)).
Proof.
  pose (witness := true).
(*
  refine (ex_intro _ _ _).
  exact (Is_true (andb true true)).
*)
  refine (ex_intro _ witness _).
    simpl.
    exact I.
Qed.

Theorem thm_forall_exists : (forall b, (exists a, Is_true(eqb a b))).
Proof.
  intros b.
  case b.
    refine (ex_intro _ true I).
    refine (ex_intro _ false I).
Qed.

Theorem thm_forall_exists__again : (forall b, (exists a, Is_true(eqb a b))).
Proof.
  intros b.
  refine (ex_intro _ b _).
     exact (eqb_a_a b).
Qed.

Theorem thm_forall_exists__again2 : (forall (b : bool), (exists (a : bool), Is_true(eqb a b))).
Proof.
  intros b.
  refine ((ex_intro _) b _).
    case b.
      simpl.
      exact I.

      simpl.
      exact I.
Qed.

Theorem forall_exists : (forall P : Set->Prop, (forall x, ~(P x)) -> ~(exists x, P x)).
Proof.
  intros p.
  intros lala.
  unfold not.
  unfold not in lala.
  intros existsbaba.
  destruct existsbaba as [ ].
  pose (haha := lala x).
  pose (gaga := haha H).
  case gaga.
Qed.

Theorem forall_exists_2 : (forall P : Set->Prop, (forall x, ~(P x)) -> ~(exists x, P x)).
Proof.
  intros P forallXNotPX notExistsPX.
  unfold not in forallXNotPX, notExistsPX.
  case notExistsPX.
  intros x.
  intros Px.
  case (forallXNotPX x Px).

  (*
  intros P forallXNotPX notExistsPX.
  unfold not in forallXNotPX, notExistsPX.
  destruct notExistsPX.
  exact (forallXNotPX x H).
  *)
Qed.

Theorem exists_forall : (forall P : Set->Prop, ~(exists x, P x) -> (forall x, ~(P x))).
Proof.
  intros.
  unfold not.
  unfold not in H.
  intros Px.
  case H.
  exact (ex_intro P x Px).
Qed.

Theorem lalala_eq : (forall (A : Set) (x : A), eq x x).
Proof.
  intros.
  exact (eq_refl : eq x x).
Qed.

Theorem thm_eq_sym : (forall x y : Set, x = y -> y = x).
Proof.
intros x y.
intros eq_x_y.
(*
case eq_x_y.
exact eq_refl.
*)
destruct eq_x_y.
exact eq_refl.
Qed.

Theorem thm_eq_trans : (forall x y z: Set, x = y -> y = z -> x = z).
Proof.
intros.
destruct H, H0.
exact eq_refl.
Qed.

(*Require Coq.*)
Require Coq.Setoids.Setoid.
Theorem thm_eq_trans__again : (forall x y z: Set, x = y -> y = z -> x = z).
Proof.
intros.
rewrite H.
rewrite <- H0.
exact eq_refl.
Qed.

Theorem andb_sym : (forall a b, a && b = b && a).
Proof.
intros.
case a,b.
  simpl. exact eq_refl.
  simpl. exact eq_refl.
  simpl. exact eq_refl.
  simpl. exact eq_refl.
Qed.

Theorem neq_nega: (forall a, a <> (negb a)).
Proof.
intros.
unfold not.
case a.
  unfold negb. discriminate.
  unfold negb. intros. discriminate H.
Qed.

Theorem plus_2_3 : (S (S O)) + (S (S (S O))) = (S (S (S (S (S O))))).
Proof.
  simpl.
  (* exact (eq_refl 5). *)
  exact (eq_refl (S (S (S (S (S O)))))).
Qed.

Theorem plus_O_n : (forall n, O + n = n).
Proof.
  intros.
  simpl.
  exact (eq_refl n).
Qed.

Theorem associativity_of_plus : (forall (n : nat) (m : nat), n + m = m + n).
Proof.
  admit.
Qed.

Theorem plus_n_O : (forall n, n + O = n).
Proof.
  intros.
  (* case n. *)
  (*
  induction n.
    exact eq_refl.

    simpl.
    rewrite IHn.
    exact eq_refl.
  *)
  (* apply nat_ind with (n := n). *)
  elim n.
    (* apply eq_refl. *)
    exact eq_refl.

    intros m H.
    simpl.
    rewrite H.
    exact (eq_refl).
Qed.

Theorem plus_sym: (forall n m, n + m = m + n).
Proof.
  intros n.
  elim n.
    intros m.
    elim m.
      simpl. exact (eq_refl).

      intros.
      simpl.
      rewrite <- H.
      simpl.
      exact (eq_refl (S n0)).

    intros.
    simpl.
    simpl H.
    rewrite (H m).
    elim m.
      simpl. exact (eq_refl).

      intros.
      simpl.
      rewrite H0.
      exact (eq_refl).
Qed.

Require Import List.

Theorem cons_adds_one_to_length :
   (forall A:Type, (forall (x : A) (lst : list A),
    length (x :: lst) = (S (length lst)))
   ).
Proof.
  intros.
  simpl.
  exact (eq_refl).
Qed.

(*
Definition hd (A : Type) (default : A) (l : list A) : A
:=
  match l with
    | nil => default
    | h :: _ => h
  end.
*)

Definition my_hd_for_nat_lists : list nat -> nat
:=
  hd 0.

Compute my_hd_for_nat_lists nil.

Compute my_hd_for_nat_lists (5 :: 4 :: nil).

Theorem correctness_of_hd :
   (forall A:Type,
   (forall (default : A) (x : A) (lst : list A),
   (hd default nil) = default /\ (hd default (x :: lst)) = x)).
Proof.
  intros.
  simpl.
  refine (conj _ _).
    exact eq_refl.
    exact eq_refl.
Qed.

Definition hd_error (A : Type) (l : list A)
:=
  match l with
    | nil => None
    | x :: _ => Some x
  end.

Compute hd_error nat nil.

Compute hd_error nat (5 :: 4 :: nil).

Theorem correctness_of_hd_error :
   (forall A:Type,
   (forall (x : A) (lst : list A),
   (hd_error A nil) = None /\ (hd_error A (x :: lst)) = Some x)).
Proof.
  intros.
  simpl.
  refine (conj _ _).
    exact eq_refl.
    exact eq_refl.
Qed.

Definition hd_never_fail (A : Type) (lst : list A) (safety_proof : lst <> nil)
  : A
:=
  (match lst as b return (lst = b -> A) with
    | nil => (fun foo : lst = nil =>
                   match (safety_proof foo) return A with
                   end
                )
    | x :: _ => (fun foo : lst = x :: _ =>
                   x
                )
  end) eq_refl.

Theorem cons_cant_equal_nil : (forall (A: Type), (forall (x : A) (rest : list A),
  (x :: rest) <> nil)).
Proof.
  unfold not.
  intros.
  discriminate H.
Qed.

Goal forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C.
  intros.
  decompose [and or] H.
    assumption.
    assumption.
    assumption.
Qed.

Theorem correctness_of_hd_never_fail :
   (forall A:Type,
   (forall (x : A) (rest : list A),
   (exists safety_proof : ((x :: rest) <> nil),
      (hd_never_fail A (x :: rest) safety_proof) = x))).
Proof.
  unfold not.
  intros.
  assert (witness : ((x :: rest) = nil -> False)).
    exact (cons_cant_equal_nil A x rest).

  refine (ex_intro _ witness _).
  simpl.
  exact (eq_refl).
Qed.

Definition tl_error (A : Type) (l : list A)
  : option (list A)
:= match l with
   | nil => None
   | _ :: tail => Some tail
   end.

Theorem correctness_of_tl_error :
   (forall A:Type,
   (forall (x : A) (lst : list A),
   (tl_error A nil) = None /\ (tl_error A (x :: lst)) = Some lst)).
Proof.
  intros.
  refine (conj _ _).
    simpl.  trivial.
    simpl.  trivial.
Qed.

Theorem hd_tl :
   (forall A:Type,
   (forall (default : A) (x : A) (lst : list A),
   (hd default (x::lst)) :: (tl (x::lst)) = (x :: lst))).
Proof.
  intros.
  simpl.
  trivial.
Qed.

Theorem app_nil_l : (forall A:Type, (forall l:list A, nil ++ l = l)).
Proof.
  intros.
  simpl.
  trivial.
Qed.

Theorem app_nil_r : (forall A:Type, (forall l:list A, l ++ nil = l)).
Proof.
  intros.
  elim l.
    simpl. trivial.

    intros.
    simpl.
    rewrite H.
    trivial.
Qed.

Theorem app_comm_cons : forall A (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
Proof.
  intros.
  simpl.
  trivial.
Qed.

Theorem app_assoc : forall A (l m n:list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  simpl.
  case l,m,n.
    simpl. trivial.

    simpl. trivial.

    simpl. trivial.

    simpl. trivial.

    simpl.
    replace (app l nil) with (l).
    replace (app l nil) with (l).
    trivial.

    pose (witness := app_nil_r A l).
    rewrite (witness).
    trivial.

    pose (witness := app_nil_r A l).
    rewrite (witness).
    trivial.

    simpl.
    replace (app l nil) with (l).
    trivial.

    pose (witness := app_nil_r A l).
    rewrite (witness).
    trivial.

    simpl.

    admit.

    admit.
Qed.

Theorem app_cons_not_nil : forall A (x y:list A) (a:A), nil <> x ++ a :: y.
Proof.
  intros.
  unfold not.
  intros.
  case x, y.
    simpl in H.
    discriminate H.

    discriminate H.

    discriminate H.

    discriminate H.
Qed.


Inductive day : Type :=
| sun : day
| mon : day
| tue : day
| wed : day
| thu : day
| fri : day
| sat : day.

Let next_day d :=
  match d with
  | sun => mon
  | mon => tue
  | tue => wed
  | wed => thu
  | thu => fri
  | fri => sat
  | sat => sun
  end.

Definition prev_day d :=
  match d with
  | sun => sat
  | mon => sun
  | tue => mon
  | wed => tue
  | thu => wed
  | fri => thu
  | sat => fri
  end.

Theorem wed_after_tue : next_day tue = wed.
Proof.
  auto.
Qed.

Theorem wed_after_tue' : next_day tue = wed.
Proof.
  simpl. trivial.
Qed.

Theorem day_never_repeats : forall d : day, next_day d <> d.
Proof.
  intros d. destruct d.
  all: discriminate.
Qed.

Theorem day_never_repeats'' : forall d : day, next_day d <> d.
Proof.
  intros d. destruct d; discriminate.
Qed.

Theorem mon_preceds_tues : forall d : day,
  next_day d = tue -> d = mon.
Proof.
  intros d next_day_is_tue.
  destruct d.
  all: discriminate || trivial.
Qed.


From Coq Require Export List.
From Coq Require Import Nat Recdef Lia.
Export ListNotations.

(* Verification of a simple SAT solver
 * -----------------------------------
 *)

(* Types defining the problem and solution
   ---------------------------------------

   The solver takes as input a query in CNF form, representing a conjunction of
   clauses, where each clause represents a conjunction of literals.

   Each literal represents a boolean variable (or its negation), and the goal of
   the solver is to produce a boolean assignation for each literal present in
   the input formula.
*)

(* A literal. [Pos n] corresponds to literal n, and [Neg n] to its negation.
*)
Inductive literal :=
  | Pos : nat -> literal
  | Neg : nat -> literal.

(* A clause represents a disjunction of literals *)
Definition clause := list literal.

(* A SAT problem in Conjunctive Normal Form:
   it corresponds to a conjunction of clauses *)
Definition cnf := list clause.

(* Example:

   The following cnf:
   [[Pos 1; Neg 2];
    [Neg 1; Pos 3; Pos 4]]

   corresponds to the boolean formula:
   (x1 \/ ~x2) /\
   (~x1 \/ x3 \/ x4)

   where x1, x2, x3 and x4 are boolean variables.
*)

(* The goal of the solver is to produce an assignment. We represent it as a list
   of literals, which correspond to the literals that are taken to be true.

   In other words, if the assignment list contains [Neg 3], then the boolean
   variable x3 should be assigned to false.

   Note: we generally only want to consider "valid" assignments, which do not
   include both a literal and its negation. We will come back to this later (see
   [valid_assignment]).
*)
Definition assignment := list literal.

(* In fact, the solver we implement will return a list of all possible
   solutions.

   (This would be terribly inefficient if we were to run the solver and compute
   the full list of solutions, but we can instead compute it using a
   call-by-name strategy (thus, the list of solutions becomes a lazy list), and
   only retrieve the first solution of the list.)
*)
Definition solutions := list assignment.

(* Helper functions and lemmas
   ---------------------------

   Mainly define the (computable) equality function on literals,
   literal negation, and associated lemmas.
*)

(* Some auxiliary functions on literals. *)
Definition lit_eqb (l1 l2: literal): bool :=
  match l1, l2 with
  | Pos u, Pos v
  | Neg u, Neg v => u =? v
  | _, _ => false
  end.

Lemma lit_eqb_eq l1 l2: lit_eqb l1 l2 = true <-> l1 = l2.
Proof.
  destruct l1, l2; cbn; try now (split; congruence).
  all: rewrite PeanoNat.Nat.eqb_eq; split; congruence.
Qed.

Lemma lit_eqb_neq l1 l2 : lit_eqb l1 l2 = false <-> l1 <> l2.
Proof.
  destruct l1, l2; cbn; try now (split; congruence).
  all: rewrite PeanoNat.Nat.eqb_neq; split; congruence.
Qed.

Definition lit_neg (l: literal): literal :=
  match l with
  | Pos n => Neg n
  | Neg n => Pos n
  end.

Lemma lit_neg_idemp (l: literal) : lit_neg (lit_neg l) = l.
Proof. destruct l; auto. Qed.

(* The size of a CNF, defined as the the number of its literals.
   Used to prove termination of the solver. *)
Fixpoint cnf_size (c: cnf): nat :=
  match c with
  | [] => 0
  | cl :: rest => length cl + cnf_size rest
  end.

Ltac case_if :=
  match goal with
    |- context [if ?b then _ else _] =>
    destruct b eqn:?
  end.

Lemma existsb_lit_notin l c : existsb (lit_eqb l) c = false <-> ~ In l c.
Proof.
  split.
  { intros ? ?. enough (existsb (lit_eqb l) c = true) by congruence.
    apply existsb_exists. eexists; split; eauto. apply lit_eqb_eq; auto. }
  { intros HH. destruct (existsb (lit_eqb l) c) eqn:Heq; auto. exfalso.
    apply existsb_exists in Heq as [? [? ->%lit_eqb_eq]]. apply HH. auto. }
Qed.

(* The solver definition
   ------------------------

   This is the implementation of the SAT solver itself.

   Its main function is [resolve]. It relies on the [propagate] auxiliary
   function, which implements literal propagation.

   The high-level intuition is that [propagate l c] takes a literal [l] and a
   cnf [c], and, assuming that [l] is to be assigned to true, simplifies [c]
   into a new cnf which does not rely on [l] or [lit_neg l] anymore.

   The [_variant] lemmas can be ignored, they are only used in the (included)
   proof of termination for defining [resolve].
*)

Definition remove_lit (l: literal) (cl: clause) :=
  List.filter (fun l' => negb (lit_eqb l l')) cl.

Fixpoint propagate (l: literal) (c: cnf) : cnf :=
  match c with
  | [] => []
  | cl :: rest =>
    if List.existsb (lit_eqb l) cl
    then propagate l rest
    else (remove_lit (lit_neg l) cl) :: (propagate l rest)
  end.

Lemma remove_lit_variant (l: literal) (cl: clause):
  length (remove_lit l cl) <= length cl.
Proof.
  induction cl as [| ? ? IHcl]; cbn; try case_if; cbn; auto.
  unfold remove_lit in IHcl. lia.
Qed.

Lemma propagate_variant (l: literal) (c: cnf):
  cnf_size (propagate l c) <= cnf_size c.
Proof.
  induction c as [| cl c IHc]; cbn; auto.
  case_if; cbn; try lia. pose proof (remove_lit_variant (lit_neg l) cl).
  lia.
Qed.

Function resolve (c: cnf) {measure cnf_size c}: solutions :=
  match c with
  | [] => [[]]
  | cl :: rest =>
    match cl with
    | [] => []
    | l :: cl' =>
      let c1 := propagate l rest in
      let c2 := propagate (lit_neg l) (cl' :: rest) in
      let solutions1 := List.map (List.cons l) (resolve c1) in
      let solutions2 := List.map (List.cons (lit_neg l)) (resolve c2) in
      solutions1 ++ solutions2
    end
  end.
Proof.
  (* Proof of termination *)
  all: intros c cl rest l cl'; intros -> ->; cbn.
  { destruct (existsb (lit_eqb (lit_neg l))); cbn.
    - pose proof (propagate_variant (lit_neg l) rest). lia.
    - pose proof (remove_lit_variant (lit_neg (lit_neg l)) cl').
      pose proof (propagate_variant (lit_neg l) rest). lia. }
  { pose proof (propagate_variant l rest). lia. }
Defined.

(* NB: Function generates an induction principle for [resolve], and a lemma to
   unfold its body. You will need to use them. *)
Check resolve_ind.
Check resolve_equation.

(* Interpretation of clauses and cnf
   ------------------------------------

   Given an assignment, we can "evaluate" a clause/a cnf as a boolean.
   This is done by the [interp] functions below.
 *)

Fixpoint interp_clause (cl: clause) (a: assignment): bool :=
  match cl with
  | [] => false
  | l :: cl' => List.existsb (lit_eqb l) a || interp_clause cl' a
  end.

Fixpoint interp (c: cnf) (a: assignment): bool :=
  match c with
  | [] => true
  | cl :: rest => interp_clause cl a && interp rest a
  end.

(* To prove correctness of [resolve] in the unsat case we will need to define
what a *valid* assignment is, i.e. one that does not contain both a literal and
its negation. *)
Definition valid_assignment (a: assignment) :=
  forall (l: literal),
    List.In l a ->
    ~ List.In (lit_neg l) a.

    From Coq Require Import List Nat Recdef Lia.
    Import ListNotations.

    (* 1) Correctness of solutions returned by [resolve]
    -------------------------------------------------

       A first correctness lemma: assignments produced by [resolve] are correct wrt
       [interp].
    *)

    (* The core of the proof relies on a similar correctness lemma for [propagate]. *)
    Lemma propagate_correct (a: assignment) (l: literal) (c: cnf) :
      interp (propagate l c) a = true ->
      interp c (l :: a) = true.
    Admitted.

    Lemma resolve_correct (c: cnf) (a: assignment):
      List.In a (resolve c) ->
      interp c a = true.
    Admitted.

    (* 2) Correctness of [resolve] in the unsat case
       ---------------------------------------------

       If [resolve] returns no solutions (the empty list), then the input CNF should
       be unsatisfiable.

       To formally state this property, we first need to define what a *valid*
       assignment is, i.e. one that does not contain both a literal and its negation.
    *)

    (* You will need to formulate a lemma for [propagate], in a similar vein as
       [propagate_correct].

       However, there's an extra subtlety here. Think: does the following hold
       if (lit_neg) is in a?

         interp (propagate l c) a = false ->
         interp c (l :: a) = false
    *)

    Lemma resolve_unsat_correct (c: cnf):
      resolve c = [] ->
      forall a, valid_assignment a -> interp c a = false.
    Admitted.

    (* ==== This part is OPTIONAL and it is NOT graded. === *)
    (* ==== We keep this for the sake of completeness of the specification === *)
    (* ==== but exclude it from grading to keep the task complexity at bay. === *)

    (* 3) Validity of assignments produced by [resolve]
       ------------------------------------------------

       To complete the proof of the solver, we finally need to prove that it only
       produces valid assignments. Otherwise, a solver could simply return an
       assignment containing every literal and its negation, which would be
       considered as a valid solution according to [interp].

       The key idea is to prove that, for any literal that appears in an assignment
       returned by [resolve c], then either the literal or its negation were present
       in [c].
    *)

    (* useful helper lemmas *)
    Lemma valid_assignment_nil : valid_assignment [].
    Proof. intros ? ?. cbn in *. auto. Qed.

    Lemma valid_assignment_cons a l:
      valid_assignment a ->
      ~ List.In (lit_neg l) a ->
      valid_assignment (l :: a).
    Proof.
      intros Hv Ha l'. cbn. intros [->|Hl'].
      { intros HH. apply Ha. destruct HH; auto. exfalso.
        destruct l'; cbn in *; congruence. }
      { intros [?|HH].
        { subst l. rewrite lit_neg_idemp in Ha. auto. }
        { eapply (Hv l' Hl'); auto. } }
    Qed.

    Lemma resolve_valid (c: cnf) (a: assignment):
      List.In a (resolve c) ->
      valid_assignment a.
    Admitted.