(** * Types: Type Systems *)

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of the simplest
    imaginable language, to introduce the basic ideas of types and
    typing rules and the fundamental theorems about type systems:
    _type preservation_ and _progress_.  In chapter [Stlc] we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq!). *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Arith.Arith.
From LF Require Import Maps.
From LF Require Import Imp.
From LF Require Import Smallstep.

Hint Constructors multi : core.

(* ################################################################# *)
(** * Typed Arithmetic & Boolean Expressions *)
(* ================================================================= *)
(** ** Syntax *)

(** Here is the syntax, informally:

    t ::= tru
        | fls
        | test t then t else t
        | zro
        | scc t
        | prd t
        | iszro t

    And here it is formally: *)

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm
  | zro : tm
  | scc : tm -> tm
  | prd : tm -> tm
  | iszro : tm -> tm.

(** (Since it is so simple, we will not bother introducing custom
    concrete syntax for this language.) *)

(** _Values_ are [tru], [fls], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_tru : bvalue tru
  | bv_fls : bvalue fls.

Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall t, nvalue t -> nvalue (scc t).

Definition value (t : tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue : core.
Hint Unfold value : core.

(* ================================================================= *)
(** ** Operational Semantics *)

(** Here is the single-step relation, first informally...

                   -------------------------------                  (ST_TestTru)
                   test tru then t1 else t2 --> t1

                   -------------------------------                  (ST_TestFls)
                   test fls then t1 else t2 --> t2

                               t1 --> t1'
            ----------------------------------------------------       (ST_Test)
            test t1 then t2 else t3 --> test t1' then t2 else t3

                             t1 --> t1'
                         ------------------                             (ST_Scc)
                         scc t1 --> scc t1'

                           ---------------                           (ST_PrdZro)
                           prd zro --> zro

                         numeric value v
                        -------------------                          (ST_PrdScc)
                        prd (scc v) --> v

                              t1 --> t1'
                         ------------------                             (ST_Prd)
                         prd t1 --> prd t1'

                          -----------------                        (ST_IszroZro)
                          iszro zro --> tru

                         numeric value v
                      ---------------------                       (ST_IszroScc)
                      iszro (scc v) --> fls

                            t1 --> t1'
                       ----------------------                         (ST_Iszro)
                       iszro t1 --> iszro t1'
*)

(** ... and then formally: *)

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      (scc t1) --> (scc t1')
  | ST_PrdZro :
      (prd zro) --> zro
  | ST_PrdScc : forall v,
      nvalue v ->
      (prd (scc v)) --> v
  | ST_Prd : forall t1 t1',
      t1 --> t1' ->
      (prd t1) --> (prd t1')
  | ST_IszroZro :
      (iszro zro) --> tru
  | ST_IszroScc : forall v,
       nvalue v ->
      (iszro (scc v)) --> fls
  | ST_Iszro : forall t1 t1',
      t1 --> t1' ->
      (iszro t1) --> (iszro t1')

where "t '-->' t'" := (step t t').

Hint Constructors step : core.

(** Notice that the [step] relation doesn't care about whether the
    expression being stepped makes global sense -- it just checks that
    the operation in the _next_ reduction step is being applied to the
    right kinds of operands.  For example, the term [scc tru] cannot
    take a step, but the almost as obviously nonsensical term

       scc (test tru then tru else tru)

    can take a step (once, before becoming stuck). *)

(* ================================================================= *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about this [step] relation
    is that the strong progress theorem from the [Smallstep]
    chapter fails here.  That is, there are terms that are normal
    forms (they can't take a step) but not values (they are not
    included in our definition of possible "results of reduction").
    Such terms are said to be _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck : core.

(** **** Exercise: 2 stars, standard (some_term_is_stuck) *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (scc tru).
  unfold stuck. split.
  + unfold step_normal_form. unfold not; intros.
    destruct H. inversion H. inversion H1.
  + unfold not; intros. inversion H.
    - inversion H0.
    - inversion H0. inversion H2.
Qed.

(** [] *)

(** However, although values and normal forms are _not_ the same in
    this language, the set of values is a subset of the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars, standard (value_is_nf) *)
Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  (* FILL IN HERE *) Admitted.

(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.)

    [] *)

(* ================================================================= *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are always nonsensical, mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | Bool : ty
  | Nat : ty.

(** In informal notation, the typing relation is often written
    [ |- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol
    is called a "turnstile."  Below, we're going to see richer typing
    relations where one or more additional "context" arguments are
    written to the left of the turnstile.  For the moment, the context
    is always empty.

                           ---------------                     (T_Tru)
                           |- tru \in Bool

                          ---------------                      (T_Fls)
                          |- fls \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------     (T_Test)
                    |- test t1 then t2 else t3 \in T

                             --------------                    (T_Zro)
                             |- zro \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Scc)
                          |- scc t1 \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Prd)
                          |- prd t1 \in Nat

                            |- t1 \in Nat
                        --------------------                 (T_IsZro)
                        |- iszro t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_Tru :
       |- tru \in Bool
  | T_Fls :
       |- fls \in Bool
  | T_Test : forall t1 t2 t3 T,
       |- t1 \in Bool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- test t1 t2 t3 \in T
  | T_Zro :
       |- zro \in Nat
  | T_Scc : forall t1,
       |- t1 \in Nat ->
       |- scc t1 \in Nat
  | T_Prd : forall t1,
       |- t1 \in Nat ->
       |- prd t1 \in Nat
  | T_Iszro : forall t1,
       |- t1 \in Nat ->
       |- iszro t1 \in Bool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type : core.

Example has_type_1 :
  |- test fls zro (scc zro) \in Nat.
Proof.
  apply T_Test.
  + apply T_Fls.
  + apply T_Zro.
  + apply T_Scc. apply T_Zro.
Qed.

(*
        -------------- (T_Fls)
        |- fls \in Bool

        --------------- (T_Zro)
        |- zro \in Nat

          --------------- (T_Zro)
            |- zro \in Nat
        ----------------------- (T_Scc)
        |- scc zro \in Nat
      ------------------------------------------------------- (T_Test)
      |- test fls zro (scc zro) \in Nat
*)

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not consider
    what happens when the term is reduced -- in particular, it does
    not calculate the type of its normal form. *)

Example has_type_not :
  ~ ( |- test fls zro tru \in Bool ).
Proof.
  intros Contra. solve_by_inverts 2.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Canonical forms *)

(** The following two lemmas capture the fundamental property that the
    definitions of boolean and numeric values agree with the typing
    relation. *)

Lemma bool_canonical : forall t,
  |- t \in Bool -> value t -> bvalue t.
Proof.
  intros t HT [Hb | Hn].
  - assumption.
  - destruct Hn as [ | Hs].
    + inversion HT.
    + inversion HT.
Qed.

Lemma nat_canonical : forall t,
  |- t \in Nat -> value t -> nvalue t.
Proof.
  intros t HT [Hb | Hn].
  - inversion Hb; subst; inversion HT.
  - assumption.
Qed.

(* ================================================================= *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are not stuck -- or conversely, if a
    term is well typed, then either it is a value or it can take at
    least one step.  We call this _progress_. *)

(** **** Exercise: 3 stars, standard (finish_progress) *)
Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.

(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the parts we've given of the informal proof in the
    following exercise before starting -- this will save you a lot of
    time.) *)
Proof.
  intros t T HT.
  induction HT; auto.
  (* The cases that were obviously values, like T_Tru and
     T_Fls, are eliminated immediately by auto *)
  - (* T_Test *)
    right. destruct IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    destruct H.
      * exists t2. auto.
      * exists t3. auto.
    + (* t1 can take a step *)
      destruct H as [t1' H1].
      exists (test t1' t2 t3). auto.
  - (* T_Scc *)
    destruct IHHT. apply (nat_canonical t1 HT) in H.
    destruct H.
    + auto.
    + auto 6.
    + destruct H. right. exists (scc x). auto.
  - (* Case T_Prd *)
    destruct IHHT. apply (nat_canonical t1 HT) in H.
    destruct H.
    + right. exists zro; auto.
    + right. exists t. auto.
    + right. destruct H. exists (prd x). auto.
  - (* Case T_IsZro *)
    destruct IHHT. apply (nat_canonical t1 HT) in H.
    destruct H.
    + right. exists tru. auto.
    + right. exists fls. auto.
    + right. destruct H. exists (iszro x). auto.
Qed.

(*

  (* FILL IN HERE *) Admitted.
(** [] *)

*)

(* ================================================================= *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is a well-typed term (of the same type). *)

(** **** Exercise: 2 stars, standard (finish_preservation) *)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.
Proof.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_Test *) inversion HE; subst.
      + (* ST_TESTTru *) assumption.
      + (* ST_TestFls *) assumption.
      + (* ST_Test *) apply T_Test; try assumption.
        apply IHHT1; assumption.
    - (* T_Scc *) inversion HE; subst. apply T_Scc.
      apply IHHT; try assumption.
    - (* T_Prd *) inversion HE; subst; auto.
      inversion HT; subst; auto.
    - (* T_isZro *) inversion HE; subst; auto.
Qed.

(*
    (* FILL IN HERE *) Admitted.
(** [] *)
*)
(* ================================================================= *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we see that a
    well-typed term can never reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  - apply progress in HT. destruct HT; auto.
  - apply IHP.
    + apply preservation with (t := x); auto.
    + unfold stuck. split; auto.
Qed.


Require Import
  Bignums.BigZ.BigZ
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers
  MathClasses.interfaces.additional_operations MathClasses.implementations.fast_naturals.
Require Export
  MathClasses.implementations.ZType_integers.

Module BigZ_Integers := ZType_Integers BigZ.

#[global]
Instance inject_fastN_fastZ: Cast bigN bigZ := BigZ.Pos.

#[global]
Instance: SemiRing_Morphism inject_fastN_fastZ.
Proof. repeat (split; try apply _); intuition. Qed.

#[global]
Program Instance bigZ_pow: Pow bigZ bigN := λ x n, BigZ.pow x ('n).

#[global]
Instance: NatPowSpec bigZ bigN _.
Proof.
  split; unfold pow, bigZ_pow.
    solve_proper.
   intro. apply BigZ.pow_0_r.
  intros x n.
  rewrite rings.preserves_plus, rings.preserves_1, BigZ.add_1_l.
  apply BigZ.pow_succ_r.
  change (0 ≤ cast bigN bigZ n).
  now apply nat_int.to_semiring_nonneg.
Qed.

#[global]
Instance fastZ_shiftl: ShiftL bigZ bigN := λ x n, BigZ.shiftl x ('n).

#[global]
Instance: ShiftLSpec bigZ bigN _.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros. apply BigZ.shiftl_mul_pow2.
  change (0 ≤ cast bigN bigZ n).
  now apply nat_int.to_semiring_nonneg.
Qed.


Require Import GeoCoq.Tarski_dev.Ch09_plane.
Require Import NArith.
Require Import GeoCoq.Utils.sets.
Require Import GeoCoq.Meta_theory.Models.tarski_to_coinc_theory_for_concyclic.
Require Import GeoCoq.Tactics.Coinc.CoincR.

Section CoincR_for_concyclic.

Context `{TE:Tarski_euclidean}.

Definition ss_ok_for_concy ss interp :=
  @ss_ok Tarski_is_a_Arity_for_concy
         Tarski_is_a_Coinc_predicates_for_concy ss interp.

Lemma ss_ok_empty_for_concy : forall interp, ss_ok_for_concy SS.empty interp.
Proof. exact ss_ok_empty. Qed.

Lemma collect_coincs_for_concy : forall A B C D pa pb pc pd ss interp,
  Concyclic_gen A B C D ->
  interp pa = A ->
  interp pb = B ->
  interp pc = C ->
  interp pd = D ->
  ss_ok_for_concy ss interp ->
  ss_ok_for_concy (SS.add (@CPToSS 4 (pa, (pb, (pc, pd)))) ss) interp.
Proof.
intros A B C D pa pb pc pd ss interp HConcy HA HB HC HD HSS.
apply (@collect_coincs Tarski_is_a_Arity_for_concy
                       Tarski_is_a_Coinc_predicates_for_concy);
[apply Tarski_is_a_Coinc_theory_for_concy|simpl|auto].
rewrite HA; rewrite HB; rewrite HC; rewrite HD; auto.
Qed.

Definition st_ok_for_concy st interp :=
  @st_ok Tarski_is_a_Arity_for_concy
         Tarski_is_a_Coinc_predicates_for_concy st interp.

Lemma st_ok_empty_for_concy : forall interp, st_ok_for_concy STempty interp.
Proof. exact st_ok_empty. Qed.

Lemma collect_wds_for_concy : forall A B C pa pb pc st interp,
  ~ Col A B C ->
  interp pa = A ->
  interp pb = B ->
  interp pc = C ->
  st_ok_for_concy st interp ->
  st_ok_for_concy (STadd (pa, (pb, pc)) st) interp.
Proof.
intros A B C pa pb pc st interp HNCol HA HB HC HST.
apply (@collect_wds Tarski_is_a_Arity_for_concy
                    Tarski_is_a_Coinc_predicates_for_concy);
[apply Tarski_is_a_Coinc_theory_for_concy|simpl|auto].
rewrite HA; rewrite HB; rewrite HC; auto.
Qed.

Definition test_coinc_for_concy ss st (pa pb pc pd : positive) :=
  @test_coinc Tarski_is_a_Arity_for_concy ss st (pa, (pb, (pc, pd))).

Definition interp_CP_for_concy (pa pb pc pd : positive) interp :=
  @interp_CP Tarski_is_a_Arity_for_concy 3 (pa, (pb, (pc, pd))) interp.

Lemma test_coinc_ok_for_concy : forall pa pb pc pd ss st interp,
  ss_ok_for_concy ss interp ->
  st_ok_for_concy st interp ->
  test_coinc_for_concy ss st pa pb pc pd = true ->
  Concyclic_gen (interp pa) (interp pb) (interp pc) (interp pd).
Proof.
intros pa pb pc pd ss st interp HSS HST HTest.
assert (HConcy := @test_coinc_ok Tarski_is_a_Arity_for_concy
                               Tarski_is_a_Coinc_predicates_for_concy
                               Tarski_is_a_Coinc_theory_for_concy
                               ss st interp (pa, (pb, (pc, pd))) HSS HST HTest).
simpl in HConcy; auto.
Qed.

End CoincR_for_concyclic.

Ltac assert_ss_ok Tpoint Concyclic_gen lvar :=
  repeat
  match goal with
    | HConcy : Concyclic_gen ?A ?B ?C ?D, HOK : ss_ok_for_concy ?SS ?Interp |- _ =>
      let pa := List_assoc Tpoint A lvar in
      let pb := List_assoc Tpoint B lvar in
      let pc := List_assoc Tpoint C lvar in
      let pd := List_assoc Tpoint D lvar in
      apply PropToTagged in HConcy;
      apply (collect_coincs_for_concy A B C D pa pb pc pd SS Interp HConcy) in HOK;
      try reflexivity
  end.

Ltac assert_st_ok Tpoint Col lvar :=
  repeat
  match goal with
    | HNCol : ~ Col ?A ?B ?C, HOK : st_ok_for_concy ?ST ?Interp |- _ =>
      let pa := List_assoc Tpoint A lvar in
      let pb := List_assoc Tpoint B lvar in
      let pc := List_assoc Tpoint C lvar in
      apply PropToTagged in HNCol;
      apply (collect_wds_for_concy A B C pa pb pc ST Interp HNCol) in HOK;
      try reflexivity
  end.

Ltac Concy_refl Tpoint Col Concyclic_gen :=
  match goal with
    | Default : Tpoint |- Concyclic_gen ?A ?B ?C ?D =>
      let lvar := build_numbered_points_list Tpoint in
      let pa := List_assoc Tpoint A lvar in
      let pb := List_assoc Tpoint B lvar in
      let pc := List_assoc Tpoint C lvar in
      let pd := List_assoc Tpoint D lvar in
      let c := ((vm_compute;reflexivity) || fail 2 "Can not be deduced") in
      let HSS := fresh in
      assert (HSS := ss_ok_empty_for_concy (interp lvar Default));
      assert_ss_ok Tpoint Concyclic_gen lvar;
      let HST := fresh in
      assert (HST := st_ok_empty_for_concy (interp lvar Default));
      assert_st_ok Tpoint Concyclic_gen lvar;
      match goal with
        | HOKSS : ss_ok_for_concy ?SS ?Interp, HOKST : st_ok_for_concy ?ST ?Interp |- _ =>
          apply (test_coinc_ok_for_concy pa pb pc pd SS ST
                                       Interp HOKSS HOKST); c
      end
  end.
(*
Section Test.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Goal forall P24 P23 P22 P21 P20 P19 P18 P17 P16 P15 P14 P13 P12 P11 P10 P9 P8 P7 P6 P5 P4 P3 P2 P1 P0,
  Coplanar P1 P0 P2 P12 -> Coplanar P8 P2 P0 P1 -> ~ Col P18 P20 P19 ->
  Coplanar P19 P2 P1 P0 -> Coplanar P1 P15 P2 P0 -> Coplanar P23 P13 P12 P14 ->
  ~ Col P10 P9 P11 -> Coplanar P1 P2 P18 P0 -> Coplanar P11 P2 P1 P0 ->
  ~ Col P2 P1 P0 -> Coplanar P0 P1 P2 P6 -> Coplanar P16 P2 P1 P0 ->
  Coplanar P15 P22 P16 P17 -> Coplanar P2 P1 P0 P17 -> Coplanar P20 P0 P2 P1 ->
  Coplanar P1 P2 P0 P4 -> Coplanar P13 P1 P2 P0 -> ~ Col P7 P8 P6 ->
  Coplanar P2 P9 P1 P0 -> Coplanar P2 P10 P0 P1 -> Coplanar P1 P0 P14 P2 ->
  Coplanar P1 P7 P0 P2 -> ~ Col P4 P5 P3 -> Coplanar P0 P3 P1 P2 ->
  Coplanar P24 P11 P9 P10 -> ~ Col P14 P13 P12 -> ~ Col P15 P17 P16 ->
  Coplanar P18 P21 P20 P19 -> Coplanar P0 P5 P2 P1 ->
  Coplanar P21 P22 P23 P24.
Proof.
intros.
Time Cop_refl Tpoint Col Coplanar.
Qed.

End Test.
*)


Require Export Program.

Require Export CoqUtil.Tactic CoqUtil.MoreRelations.

Inductive type :=
| tytop
| tybot
| tyreal
| tysum (l r : type)
| typrod (l r : type)
| tyarr (l r : type).

Infix "~>" := tyarr (at level 55, right associativity).

Require Export Reals.Rdefinitions Reals.Ranalysis.

Inductive term : type -> Type :=
| tapp { A B } (f : term (A ~> B)) (x : term A) : term B
| ttt : term tytop
| texf { A } : term (tybot ~> A)
| tlit : R -> term tyreal
| tplus : term (tyreal ~> tyreal ~> tyreal)
| tminus : term (tyreal ~> tyreal ~> tyreal)
| tmult : term (tyreal ~> tyreal ~> tyreal)
| tdiv : term (tyreal ~> tyreal ~> tyreal)
| tleft { A B } : term (A ~> (tysum A B))
| tright { A B } : term (B ~> (tysum A B))
| tsummatch { A B C } : term ((tysum A B) ~> (A ~> C) ~> (B ~> C) ~> C)
| tmkprod { A B } : term (A ~> B ~> (typrod A B))
| tzro { A B } : term ((typrod A B) ~> A)
| tfst { A B } : term ((typrod A B) ~> B)
| tS { A B C } : term ((A ~> B ~> C) ~> (A ~> B) ~> (A ~> C))
| tK { A B } : term (A ~> B ~> A)
| tI { A } : term (A ~> A)
| tB { A B C } : term ((B ~> C) ~> (A ~> B) ~> (A ~> C))
| tC { A B C } : term ((A ~> B ~> C) ~> (B ~> A ~> C))
| tW { A B } : term ((A ~> A ~> B) ~> (A ~> B))
| tZ { A B } : term (((A ~> B) ~> (A ~> B)) ~> (A ~> B)).

Inductive val : forall { A }, term A -> Prop :=
| vttt : val ttt
| vtexf A : val (@texf A)
| vtlit r : val (tlit r)
| vtplus : val tplus
| vtplus' x : val x -> val (tapp tplus x)
| vtminus : val tminus
| vtminus' x : val x -> val (tapp tminus x)
| vtmult : val tmult
| vtmult' x : val x -> val (tapp tmult x)
| vtdiv : val tdiv
| vtdiv' x : val x -> val (tapp tdiv x)
| vtleft A B : val (@tleft A B)
| vtleft' A B a : val a -> val (tapp (@tleft A B) a)
| vtright A B : val (@tright A B)
| vtright' A B b : val b -> val (tapp (@tright A B) b)
| vtsummatch A B C : val (@tsummatch A B C)
| vtsummatch' A B C s : val s -> val (tapp (@tsummatch A B C) s)
| vtsummatch'' A B C s f : val s -> val f -> val (tapp (tapp (@tsummatch A B C) s) f)
| vtmkprod A B : val (@tmkprod A B)
| vtmkprod' A B a : val a -> val (tapp (@tmkprod A B) a)
| vtmkprod'' A B a b : val a -> val b -> val (tapp (tapp (@tmkprod A B) a) b)
| vtzro A B : val (@tzro A B)
| vtfst A B : val (@tfst A B)
| vtS A B C : val (@tS A B C)
| vtS' A B C f : val f -> val (tapp (@tS A B C) f)
| vtS'' A B C f x : val f -> val x -> val (tapp (tapp (@tS A B C) f) x)
| vtK A B : val (@tK A B)
| vtK' A B a : val a -> val (tapp (@tK A B) a)
| vtI A : val (@tI A)
| vtB A B C : val (@tB A B C)
| vtB' A B C f : val f -> val (tapp (@tB A B C) f)
| vtB'' A B C f g : val f -> val g -> val (tapp (tapp (@tB A B C) f) g)
| vtC A B C : val (@tC A B C)
| vtC' A B C f : val f -> val (tapp (@tC A B C) f)
| vtC'' A B C f x : val f -> val x -> val (tapp (tapp (@tC A B C) f) x)
| vtW A B : val (@tW A B)
| vtW' A B f : val f -> val (tapp (@tW A B) f)
| vtZ A B : val (@tZ A B)
| vtZ' A B f : val f -> val (tapp (@tZ A B) f).

Hint Constructors val.

Inductive red : forall { A }, term A -> term A -> Prop :=
| rtplus l r : red (tapp (tapp tplus (tlit l)) (tlit r)) (tlit (Rplus l r))
| rtminus l r : red (tapp (tapp tminus (tlit l)) (tlit r)) (tlit (Rminus l r))
| rtmult l r : red (tapp (tapp tmult (tlit l)) (tlit r)) (tlit (Rmult l r))
| rtdiv l r : red (tapp (tapp tdiv (tlit l)) (tlit r)) (tlit (Rdiv l r))
| rtleft { A B C } a f g :
    val a -> val f -> val g ->
    red (tapp (tapp (tapp (@tsummatch A B C) (tapp tleft a)) f) g) (tapp f a)
| rtright { A B C } b f g :
    val b -> val f -> val g ->
    red (tapp (tapp (tapp (@tsummatch A B C) (tapp tright b)) f) g) (tapp g b)
| rtzro { A B } a b :
    val a -> val b ->
    red (tapp tzro (tapp (tapp (@tmkprod A B) a) b)) a
| rtfst { A B } a b :
    val a -> val b ->
    red (tapp tfst (tapp (tapp (@tmkprod A B) a) b)) b
| rtS { A B C } f x arg :
    val f -> val x -> val arg ->
    red (tapp (tapp (tapp (@tS A B C) f) x) arg) (tapp (tapp f arg) (tapp x arg))
| rtK { A B } x y :
    val x -> val y ->
    red (tapp (tapp (@tK A B) x) y) x
| rtI { A } x :
    val x ->
    red (tapp (@tI A) x) x
| rtB { A B C } f g x :
    val f -> val g -> val x ->
    red (tapp (tapp (tapp (@tB A B C) f) g) x) (tapp f (tapp g x))
| rtC { A B C } f x y :
    val f -> val x -> val y ->
    red (tapp (tapp (tapp (@tC A B C) f) x) y) (tapp (tapp f y) x)
| rtW { A B } f x :
    val f -> val x ->
    red (tapp (tapp (@tW A B) f) x) (tapp (tapp f x) x)
| rtZ { A B } f x :
    val f -> val x ->
    red (tapp (tapp (@tZ A B) f) x) (tapp (tapp f (tapp tZ f)) x)
| rtappf { A B } f f' x : @red (A ~> B) f f' -> red (tapp f x) (tapp f' x)
| rtappx { A B } f x x' : val f -> red x x' -> red (@tapp A B f x) (tapp f x').

Hint Constructors red.
Hint Resolve rtappx.

Definition val_func { A B } { f } { x } : val (@tapp A B f x) -> val f :=
  ltac:(intros H; dependent induction H; constructor; tauto).

Definition val_arg { A B } { f } { x } : val (@tapp A B f x) -> val x :=
  ltac:(intros H; dependent induction H; tauto).

Definition vexf { A } x : val (tapp (@texf A) x) -> False :=
  ltac:(intros H; dependent destruction H).

Inductive checked (X : Prop) { T : Type } (t : T) : Prop :=
| is_checked (x : X) : checked X t.

Ltac check H t :=
  pose proof (is_checked _ t H); clear H.

Ltac uncheck H := inversion H; clear H.

Ltac uncheck_all t :=
  repeat
    match goal with
    | H : checked _ t |- _ => uncheck H
    end.

Definition vreal x : val x -> { r | x = tlit r } :=
  ltac:(dependent destruction x;
          intros H;
          solve[eauto] ||
               exfalso; dependent destruction H).


Require Export GeoCoq.Tarski_dev.Ch12_parallel.
Require Export GeoCoq.Tarski_dev.Annexes.perp_bisect.

Section Triangles.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Section ABC.

Variable A B C : Tpoint.

Definition isosceles A B C :=
 Cong A B B C.

Lemma isosceles_sym :
  isosceles A B C ->
  isosceles C B A.
Proof.
unfold isosceles.
intros.
Cong.
Qed.

Lemma isosceles_conga :
  A<>C -> A<>B ->
  isosceles A B C ->
  CongA C A B A C B.
Proof.
intros.
apply cong3_conga.
auto.
auto.
unfold Cong_3.
unfold isosceles in H.
repeat split;Cong.
Qed.

Lemma conga_isosceles :
 ~ Col A B C ->
 CongA C A B A C B ->
 isosceles A B C.
Proof.
intros.
assert (Cong B A B C)
 by (apply l11_44_1_b;finish;CongA).
unfold isosceles.
Cong.
Qed.

(** In a triangle isosceles in A the altitude wrt. A, is also the bisector and median. *)

Lemma isosceles_foot__midpoint_conga :
 forall H,
 isosceles A B C ->
 Col H A C ->
 Perp H B A C ->
 ~ Col A B C /\ A<>H /\ C<>H /\ Midpoint H A C /\ CongA H B A H B C.
Proof.
intros.
assert_diffs.
assert (~ Col A B C).
 {
   intro;apply perp_not_col2 in H2.
   destruct H2;apply H2;ColR.
 }
assert_diffs.
assert (A<>H).
 { (** these point are distinct
      because otherwise the hypothenuse is not larger than the side *)
 intro.
 treat_equalities.
 assert (Lt A B B C /\ Lt A C B C).
 apply (l11_46 B A C);Col; left;apply perp_per_2;auto.
 spliter.
 unfold isosceles in *.
 apply (cong__nlt A B B C);auto.
 }
assert (C<>H).
 {
 intro.
 treat_equalities.
 assert (Lt C B B A /\ Lt C A B A).
 apply (l11_46 B C A);Col; left;apply perp_per_2;finish.
 spliter.
 unfold isosceles in *.
 apply (cong__nlt C B B A);finish.
 }
assert (Perp_at H A C B H)
 by (apply l8_14_2_1b_bis;finish).
assert (Per A H B) by (apply perp_in_per_1 with C H;finish).
assert (Per C H B) by (apply perp_in_per_3 with A H;finish).
(* We prove that A H B and C H B are congruent triangles *)
assert (Cong H A H C /\ CongA H A B H C B /\ CongA H B A H B C)
 by (apply (cong2_per2__cong_conga2 A H B C H B);finish).
spliter.
assert (Midpoint H A C)
 by (apply l7_20_bis;finish).
auto.
Qed.

Definition equilateral A B C :=
 Cong A B B C /\ Cong B C C A.

Definition equilateral_strict A B C :=
 equilateral A B C /\ A <> B.

Lemma equilateral_strict_equilateral :
 equilateral_strict A B C ->
 equilateral A B C.
Proof.
unfold equilateral_strict in *. tauto.
Qed.

Lemma equilateral_cong:
  equilateral A B C ->
  Cong A B B C /\ Cong B C C A /\ Cong C A A B.
Proof.
unfold equilateral;intros;intuition Cong.
assert (T:=cong_transitivity A B B C C A H0 H1).
Cong.
Qed.

Lemma equilateral_rot :
 equilateral A B C ->
 equilateral B C A.
Proof.
intro.
apply equilateral_cong in H.
unfold equilateral.
intuition Cong.
Qed.

Lemma equilateral_swap :
 equilateral A B C ->
 equilateral B A C.
Proof.
intro.
apply equilateral_cong in H.
unfold equilateral.
intuition Cong.
Qed.

Lemma equilateral_rot_2 :
 equilateral A B C ->
 equilateral C B A.
Proof.
intro.
apply equilateral_cong in H.
unfold equilateral.
intuition Cong.
Qed.

Lemma equilateral_swap_2 :
 equilateral A B C ->
 equilateral A C B.
Proof.
intro.
apply equilateral_cong in H.
unfold equilateral.
intuition Cong.
Qed.

Lemma equilateral_swap_rot :
 equilateral A B C ->
 equilateral C A B.
Proof.
intro.
apply equilateral_cong in H.
unfold equilateral.
intuition Cong.
Qed.

Hint Resolve equilateral_swap equilateral_swap_2
 equilateral_swap_rot equilateral_rot equilateral_rot_2 : equilateral.

Lemma equilateral_isosceles_1 :
  equilateral A B C ->
  isosceles A B C.
Proof.
unfold equilateral, isosceles.
tauto.
Qed.

Lemma equilateral_isosceles_2 :
  equilateral A B C ->
  isosceles B C A.
Proof.
unfold equilateral, isosceles.
tauto.
Qed.

Lemma equilateral_isosceles_3 :
  equilateral A B C ->
  isosceles C A B.
Proof.
intros.
apply equilateral_cong in H.
unfold isosceles.
tauto.
Qed.

Hint Resolve equilateral_isosceles_1 equilateral_isosceles_2 equilateral_isosceles_3 : equilateral.

Lemma equilateral_strict_neq :
 equilateral_strict A B C ->
 A <> B /\ B <> C /\ A <> C.
Proof.
intros.
unfold equilateral_strict, equilateral in H.
decompose [and] H;clear H.
repeat split;Cong.
eauto using cong_diff.
eapply cong_diff.
assert (T:=cong_transitivity A B B C C A H2 H3).
apply H1.
assert (T:=cong_transitivity A B B C C A H2 H3).
Cong.
Qed.

Hint Resolve equilateral_strict_neq : equilateral.

Lemma equilateral_strict_swap_1 :
 equilateral_strict A B C ->
 equilateral_strict A C B.
Proof.
intros.
assert (T:= equilateral_strict_neq H).
unfold equilateral_strict in *.
intuition (eauto with equilateral).
Qed.

Lemma equilateral_strict_swap_2 :
 equilateral_strict A B C ->
 equilateral_strict B A C.
Proof.
intros.
assert (T:= equilateral_strict_neq H).
unfold equilateral_strict in *.
intuition (eauto with equilateral).
Qed.

Lemma equilateral_strict_swap_3 :
 equilateral_strict A B C ->
 equilateral_strict B C A.
Proof.
intros.
assert (T:= equilateral_strict_neq H).
unfold equilateral_strict in *.
intuition (eauto with equilateral).
Qed.

Lemma equilateral_strict_swap_4 :
 equilateral_strict A B C ->
 equilateral_strict C A B.
Proof.
intros.
assert (T:= equilateral_strict_neq H).
unfold equilateral_strict in *.
intuition (eauto with equilateral).
Qed.

Lemma equilateral_strict_swap_5 :
 equilateral_strict A B C ->
 equilateral_strict C B A.
Proof.
intros.
assert (T:= equilateral_strict_neq H).
unfold equilateral_strict in *.
intuition (eauto with equilateral).
Qed.

Hint Resolve equilateral_strict_swap_1 equilateral_strict_swap_2
equilateral_strict_swap_3 equilateral_strict_swap_4 equilateral_strict_swap_5 : equilateral.

Lemma equilateral_strict__not_col :
 equilateral_strict A B C -> ~ Col A B C.
Proof.
intros.
assert (T:=(equilateral_strict_neq H)).
unfold equilateral_strict in *.
unfold equilateral in *.
spliter.
intro.
assert (Midpoint B A C) by (apply (l7_20_bis B A C);finish).
assert (Midpoint C A B) by (apply (l7_20_bis C A B);finish).
apply midpoint_not_midpoint with C A B;auto.
Qed.

Lemma equilateral_strict_conga_1 :
 equilateral_strict A B C ->
 CongA C A B A C B.
Proof.
intros.
assert (T:= equilateral_strict_neq H).
apply equilateral_strict_equilateral in H.
apply equilateral_isosceles_1 in H.
apply isosceles_conga.
tauto.
tauto.
assumption.
Qed.

End ABC.

Lemma equilateral_strict_conga_2 :
 forall A B C,
 equilateral_strict A B C ->
 CongA B A C A B C.
Proof.
intros.
apply equilateral_strict_swap_1 in H.
apply equilateral_strict_conga_1 in H.
assumption.
Qed.

Lemma equilateral_strict_conga_3 :
 forall A B C,
 equilateral_strict A B C ->
 CongA C B A B C A.
Proof.
intros.
apply equilateral_strict_swap_2 in H.
apply equilateral_strict_conga_1 in H.
assumption.
Qed.

Lemma conga3_equilateral :
 forall A B C,
 ~ Col A B C ->
 CongA B A C A B C ->
 CongA A B C B C A ->
 equilateral A B C.
Proof.
intros.
assert (isosceles B C A)
 by (apply conga_isosceles;CongA;Col).
assert (isosceles C A B)
 by (apply conga_isosceles;CongA;Col).
unfold isosceles in *.
unfold equilateral.
split;eCong.
Qed.

End Triangles.


(* Some attempts to build a fixed-point monad transformer *)

Require Import Coq.Program.Basics.
Require Export PredMonad.Monad.

(***
 *** The Fixed-point Monad Transformer
 ***)

Section FixT.
Context `{Monad}.

(* Build the type M (A + M (A + ... M (A + unit))) with depth n *)
Fixpoint nth_M_sum n A : Type :=
  match n with
    | 0 => unit
    | S n' => M (A + nth_M_sum n' A)
  end.

(* Replace the last M (A + unit) with unit, thereby going from nth_M_sum (S n) A
to nth_M_sum n A. *)
Fixpoint nth_M_sum_truncate {A} {n} :
  nth_M_sum (S n) A -> nth_M_sum n A :=
  match n return nth_M_sum (S n) A -> nth_M_sum n A with
    | 0 => fun _ => tt
    | S n' =>
      fun nMs =>
        bindM
          (A:=A + nth_M_sum (S n') A)
          nMs
          (fun sum =>
             match sum with
               | inl a => returnM (inl a)
               | inr nMs' =>
                 returnM (inr (nth_M_sum_truncate nMs'))
             end)
  end.

(* Distinguished equality on nth_M_sum *)
Fixpoint nth_M_sum_equals {A:Type} {EqOp:EqualsOp A} n :
  EqualsOp (nth_M_sum n A) :=
  match n return EqualsOp (nth_M_sum n A) with
    | 0 => fun _ _ => True
    | S n' =>
      equalsM (EqOp:=Sum_EqualsOp _ _ (EqOp_B:=nth_M_sum_equals n'))
  end.

Instance nth_M_sum_EqualsOp `{EqOp:EqualsOp} n :
  EqualsOp (nth_M_sum n A) := nth_M_sum_equals n.

Instance nth_M_sum_Equals `{Equals} n : Equals (nth_M_sum n A).
  induction n; repeat constructor;
    unfold equals, nth_M_sum_EqualsOp;
    unfold nth_M_sum_equals; fold nth_M_sum_equals; intro; intros.
  reflexivity.
  symmetry; assumption.
  transitivity y; assumption.
Qed.

(* Whether one computation is an extension of another *)
Definition nth_M_sum_extends {A} {n} (EqOp:EqualsOp A)
           (nMs1: nth_M_sum n A)
           (nMs2: nth_M_sum (S n) A) : Prop :=
  nMs1 == nth_M_sum_truncate nMs2.

(* FixT represents the infinite type M (A + M (A + ...)) as sequences of
elements of unit, M (A + unit), M (A + M (A + unit)), etc., such that each
element is an extension of the unit part of the computation before. Intuitively,
an A value at depth n represents termination after n steps, while
non-terminating computations always return unit values. *)
Definition FixT A :=
  { f: forall n, nth_M_sum n A |
    forall n, nth_M_sum_extends (Eq_EqualsOp A) (f n) (f (S n))}.

(* Helper assumptions for defining our monad operations *)
Context {A B:Type}.

Local Instance A_EqualsOp : EqualsOp A := Eq_EqualsOp A.
Local Instance A_Equals : Equals A := Eq_Equals A.
Local Instance B_EqualsOp : EqualsOp B := Eq_EqualsOp B.
Local Instance B_Equals : Equals B := Eq_Equals B.

(* Return gives a value in the very first A type *)
Program Definition FixT_returnM (x:A) : FixT A :=
  fun n =>
    match n with
      | 0 => tt
      | S _ => returnM (inl x)
    end.
Next Obligation.
unfold nth_M_sum_extends.
destruct n.
reflexivity.
unfold nth_M_sum_truncate.
rewrite monad_return_bind.
reflexivity.
auto with typeclass_instances.
auto with typeclass_instances.
Qed.

(* Bind... *)
Fixpoint nth_M_sum_bind n :
  nth_M_sum n A -> (A -> nth_M_sum n B) -> nth_M_sum n B :=
  match n return nth_M_sum n A -> (A -> nth_M_sum n B) -> nth_M_sum n B with
  | 0 => fun _ _ => tt
  | S n' =>
    fun m f =>
      bindM
        (A:=A + nth_M_sum n' A)
        m
        (fun sum =>
           match sum with
           | inl x => returnM (inr (nth_M_sum_truncate (f x)))
           | inr m' =>
             returnM (inr (nth_M_sum_bind n' m' (fun x => nth_M_sum_truncate (f x))))
           end)
  end.

Program Definition FixT_bindM (m: FixT A) (f: A -> FixT B) : FixT B :=
  fun n => nth_M_sum_bind n (m n) (fun x => f x n).
Next Obligation.
unfold nth_M_sum_extends.
destruct n.
reflexivity.
unfold nth_M_sum_bind; fold nth_M_sum_bind.

unfold nth_M_sum_truncate; repeat (fold (nth_M_sum_truncate (n:=n) (A:=B))).

FIXME HERE: old stuff below

(***
 *** A diagonalization function, to surjectively map nat -> nat*nat
 ***)

Section Diagonalization.

(* Diagonalize surjectively maps nat onto nat*nat *)
Definition diagonalize n : nat * nat :=
  (Nat.sqrt n - (n - (Nat.square (Nat.sqrt n))),
   (n - (Nat.square (Nat.sqrt n)))).

(* For any x and y, return the n such that diagonalize n = (x,y) *)
Definition undiagonalize x y : nat :=
  Nat.square (x + y) + y.

(* Proof that diagonalize and undiagonalize are correct *)
Lemma diagonalize_surjective x y :
  diagonalize (undiagonalize x y) = (x, y).
  unfold diagonalize, undiagonalize.
  assert (Nat.sqrt (Nat.square (x + y) + y) = x + y).
  apply Nat.sqrt_unique; split.
  unfold Nat.square; apply le_plus_l.
  unfold Nat.square. unfold lt.
  unfold mult; fold mult.
  assert (forall n m, S (n + m) = n + S m); [ intros; apply plus_Snm_nSm | ].
  repeat (rewrite H).
  repeat (first [ rewrite Nat.mul_add_distr_r | rewrite Nat.mul_add_distr_l ]).
  repeat (rewrite Nat.mul_succ_r).
  rewrite (plus_comm _ (S y)).
  rewrite (plus_comm x (S y)).
  rewrite <- (plus_assoc (S y)).
  apply plus_le_compat_l.
  rewrite (plus_comm x); apply le_plus_trans.
  repeat (rewrite <- plus_assoc).
  apply plus_le_compat_l. apply plus_le_compat_l.
  rewrite (plus_comm x); apply le_plus_trans.
  apply plus_le_compat_l.
  apply le_plus_trans.
  reflexivity.
  rewrite H.
  rewrite minus_plus.
  rewrite plus_comm; rewrite minus_plus.
  reflexivity.
Qed.

End Diagonalization.

(* Keep diagonalize opaque, because all that matters is the above lemma *)
Opaque diagonalize.

Section FixT.
Context `{Monad}.

(* approximation relation (FIXME: document this) *)
(* FIXME HERE: this doesn't work; see approx_under2, below, for a newer way... *)
Definition approx_under {A} : relation (M (option A)) :=
  fun m1 m2 =>
    exists (m': M (option A)),
      m2 == bindM m1 (fun sum =>
                        match sum with
                          | None => m'
                          | Some x => returnM (Some x)
                        end).

Instance approx_under_Reflexive {A} : Reflexive (approx_under (A:=A)).
intro m; exists (returnM None).
transitivity (bindM m returnM); [ symmetry; apply monad_bind_return | ].
apply monad_proper_bind; [ reflexivity | ].
intros x y xy_eq; rewrite xy_eq; destruct y; reflexivity.
Qed.

Instance approx_under_Transitive {A} : Transitive (approx_under (A:=A)).
intros m1 m2 m3 approx12 approx23.
destruct approx12 as [ m1' e_12 ].
destruct approx23 as [ m2' e_23 ].
exists (bindM m1' (fun sum => match sum with
                                | None => m2'
                                | Some x => returnM (Some x)
                              end)).
rewrite e_23; rewrite e_12.
rewrite <- monad_assoc.
apply bind_fun_eqM.
intro x; destruct x.
rewrite monad_return_bind; reflexivity.
apply bind_fun_eqM.
intro x; destruct x; reflexivity.
Qed.

(* Helper definition: bind on just the option part of FixT *)
(* FIXME HERE: need something like this, but generalized to nested trees of options... *)
Definition bindM_opt {A B} (m:M (option A)) (f:A -> M (option B)) : M (option (option B)) :=
  bindM m (fun o => match o with
                      | Some x =>
                        bindM (f x)
                              (fun o' => match o' with
                                           | Some y => returnM (Some (Some y))
                                           | None => returnM (Some None)
                                         end)
                      | None => returnM None
                    end).

(* FIXME HERE: this does not work (transitivity fails) *)
(* approximation relation (FIXME: document this) *)
(*
Definition approx_under2 {A} : relation (M (option A)) :=
  fun m1 m2 =>
    exists (T:Type) (mT: M T) (fT: T -> M (option A)),
      m2 == bindM mT fT
      /\
      m1 == bindM mT (fun _ => returnM None).
*)
(*
Inductive approx_under2 {A} (m1 m2 : M (option A)) : Prop :=
  MkApproxUnder2 (T:Type) (mT: M T) (fT: T -> M (option A)) :
    m2 == bindM mT fT ->
    m1 == bindM mT (fun _ => returnM None) ->
    approx_under2 m1 m2.

Instance approx_under2_Transitive {A} : Transitive (approx_under2 (A:=A)).
  intros m1 m2 m3 ap12 ap23.
  destruct ap12; destruct ap23.
  eapply (MkApproxUnder2
            _ _ ((T * M T0)%type)
            (bindM mT (fun t => returnM (t, mT0)))
            (fun t_mt0 =>
               bindM (fT (fst t_mt0))
                     (fun opt_A =>
                        match opt_A with
                          |
bindM (snd t_mt0) fT0))).

  exists ((T * M T0)%type).
*)

(* In order for this to work, we need to know that the underlying bind is
monotonic w.r.t. approx_under *)
Lemma bindM_proper_approx_under {A B} :
  Proper (approx_under (A:=A) ==>
            ((@eq A) ==> (approx_under (A:=B))) ==>
            approx_under (A:=B)) bindM_opt.
  intros m1 m2 approx_m f1 f2 approx_f.
  transitivity (bindM_opt m2 f1).
  destruct approx_m as [m' e_m].
  unfold bindM_opt, approx_under.
  exists (bindM_opt m' f1).
  rewrite e_m.
  repeat (rewrite <- monad_assoc).
  apply bind_fun_eqM; intro x; destruct x.

  replace m2 with (bindM m1
          (fun sum : option A =>
           match sum with
           | Some x => returnM (Some x)
           | None => m'
           end)).
rewrite e_m.

m1 m2 (f: A -> M (option B)) :
  approx_under1 m1 m2 -> approx_under1 (bindM_opt m1 f) (bindM_opt m2 f).
  intro appr; destruct appr as [ m' ]; destruct H0.
  exists (bindM m' (fun sum =>
                      match sum with
                        | inl None => returnM (inl _ None)
                        | inl (Some x) =>
                          bindM (f x) (fun b => returnM (inl _ b))
                        | inr m' =>
                          returnM (inr _ (bindM_opt m' f))
                      end)).
  unfold bindM_opt; rewrite H0; rewrite H1.
  repeat (rewrite <- monad_assoc).
  split.
  apply bind_fun_eqM; intro sum; destruct sum; rewrite monad_return_bind.
  destruct o.
  rewrite <- monad_assoc.
  rewrite bind_fun_eqM.
  rewrite monad_bind_return; reflexivity.
  intro optB; repeat (rewrite monad_return_bind); reflexivity.
  rewrite monad_return_bind; reflexivity.
  rewrite monad_return_bind; reflexivity.
  apply bind_fun_eqM; intro sum; destruct sum.
  rewrite monad_return_bind; destruct o.
  rewrite <- monad_assoc.
  rewrite bind_fun_eqM; [ rewrite monad_bind_return; reflexivity | ].
  intro optB; destruct optB; rewrite monad_return_bind; reflexivity.
  rewrite monad_return_bind; reflexivity.
  rewrite monad_return_bind; reflexivity.
Qed.

(* FIXME: document this *)
Definition FixT (X:Type) :=
  {f:nat -> M (option X) |
   forall n1 n2, n1 < n2 -> approx_under (f n1) (f n2)}.

End FixT.

(* FIXME HERE NOW: old stuff below... *)

Section FixT.
Context `{Monad}.

(* One step of the approximation order for underlying computations: computation
m1 approximates m2 iff there is some way to split m2 into "now" and "later"
parts -- returning an option A is "now" and returning an M (option A) is "later"
-- such that m1 only does the "now" parts. *)
Definition approx_under1 {A} : relation (M (option A)) :=
  fun m1 m2 =>
    exists (m: M (option A + M (option A))),
      m1 == bindM m (fun sum =>
                       match sum with
                         | inl x => returnM x
                         | inr m' => returnM None
                       end) /\
      m2 == bindM m (fun sum =>
                       match sum with
                         | inl x => returnM x
                         | inr m' => m'
                       end).

(* approx_under is then the reflexive-transitive closure of approx_under1 *)
Definition approx_under {A} : relation (M (option A)) :=
  clos_refl_trans _ (approx_under1 (A:=A)).

Global Instance approx_under_Reflexive {A} : Reflexive (approx_under (A:=A)).
apply clos_rt_is_preorder.
Qed.

Global Instance approx_under_Transitive {A} : Transitive (approx_under (A:=A)).
apply clos_rt_is_preorder.
Qed.

(* A fixed-point computation is a countable directed set of underlying
computations, meaning that any two computations in the set have a supremum
(w.r.t. approx_under) also in the set *)
Definition FixT (X:Type) :=
  {f:nat -> M (option X) |
   forall n1 n2, exists n',
     approx_under (f n1) (f n') /\ approx_under (f n2) (f n')}.

(* Helper definition: bind on just the option part of FixT *)
Definition bindM_opt {A B} (m:M (option A)) (f:A -> M (option B)) : M (option B) :=
  bindM m (fun o => match o with
                      | Some x => f x
                      | None => returnM None
                    end).

(* In order for this to work, we need to know that the underlying bind is
monotonic w.r.t. approx_under *)
Lemma bindM_proper_approx_under1 {A B} m1 m2 (f: A -> M (option B)) :
  approx_under1 m1 m2 -> approx_under1 (bindM_opt m1 f) (bindM_opt m2 f).
  intro appr; destruct appr as [ m' ]; destruct H0.
  exists (bindM m' (fun sum =>
                      match sum with
                        | inl None => returnM (inl _ None)
                        | inl (Some x) =>
                          bindM (f x) (fun b => returnM (inl _ b))
                        | inr m' =>
                          returnM (inr _ (bindM_opt m' f))
                      end)).
  unfold bindM_opt; rewrite H0; rewrite H1.
  repeat (rewrite <- monad_assoc).
  split.
  apply bind_fun_eqM; intro sum; destruct sum; rewrite monad_return_bind.
  destruct o.
  rewrite <- monad_assoc.
  rewrite bind_fun_eqM.
  rewrite monad_bind_return; reflexivity.
  intro optB; repeat (rewrite monad_return_bind); reflexivity.
  rewrite monad_return_bind; reflexivity.
  rewrite monad_return_bind; reflexivity.
  apply bind_fun_eqM; intro sum; destruct sum.
  rewrite monad_return_bind; destruct o.
  rewrite <- monad_assoc.
  rewrite bind_fun_eqM; [ rewrite monad_bind_return; reflexivity | ].
  intro optB; destruct optB; rewrite monad_return_bind; reflexivity.
  rewrite monad_return_bind; reflexivity.
  rewrite monad_return_bind; reflexivity.
Qed.

(* Return for FixT: build the set of computations that return x in the
underlying monad; i.e., return (Some x) for all nat inputs *)
Program Instance FixT_MonadRet : MonadRet FixT :=
  fun {X} x _ => returnM (Some x).
Next Obligation.
  exists 0; split; reflexivity.
Qed.

(* Bind for FixT: build the set that includes bindM (m n1) (fun x => f x n2) for
all n1 and n2, by diagonalize, above *)
Program Instance FixT_MonadBind : MonadBind FixT :=
  fun {A B} m f =>
    fun n =>
      bindM_opt
        (m (fst (diagonalize n)))
           (fun x => f x (snd (diagonalize n))).
Next Obligation.
destruct (proj2_sig m n1 n2) as [n_m H_n_m];
  destruct H_n_m as [approx_m1 approx_m2].

(* FIXME HERE NOW: the above doesn't work, because there might not be one single
n' that works for all input values of f in the bind... *)

Class MonadBind (M:Type -> Type) : Type :=
  bindM : forall {A B:Type}, M A -> (A -> M B) -> M B.

Class MonadEquiv (M:Type -> Type) : Type :=
  eqM : forall {A:Type}, M A -> M A -> Prop.

(* FIXME HERE NOW: finish FixT and its operations! *)

End FixT.

(***
 *** A Non-Termination Monad Transformer via Non-Determinism + Errors
 ***)

Section FixT2.

(* We model non-termination with the more general construction of a
non-determinism transformer + option transformer, where each computation has a
countably infinite non-deterministic choice, and can also return no value. The
choice is used to represent different "amounts" of computation, and returning no
value is used to represent non-termination. *)
Definition FixT2 (X:Type) := nat -> M (option X).

(* For return, we build the set of computations that always return x *)
Instance FixT2_returnM : MonadRet FixT2 :=
  fun {A} x => fun _ => returnM (Some x).

(* For bind, we diagonalize over all possible computations for m and f *)
Instance FixT2_bindM : MonadBind FixT2 :=
  fun {A B} m f =>
    fun n => bindM (m (fst (diagonalize n)))
                   (fun opt_x =>
                      match opt_x with
                        | Some x => f x (snd (diagonalize n))
                        | None => returnM None
                      end).

(* Approximation order: each computation in one set, other than the trivial None
computation, also occurs in the other. Excluding the trivial computation allows
our sets to be "empty". *)
Instance FixT2_approxM : MonadApprox FixT2 :=
  fun {A} m1 m2 =>
    forall n, m1 n == returnM None \/ exists n', m1 n == m2 n'.

(* Equivlence: two computations approximate each other *)
Instance FixT2_eqM : MonadEquiv FixT2 :=
  fun {A} => inter_sym approxM.

Definition FixT2_bottomM {A} : FixT2 A :=
  fun _ => returnM None.

(* Building a fixed-point: consider all possible numbers of iterations of f to
the bottom function, and all possible elements of the resulting set *)
Instance FixT2_fixM : MonadFixM FixT2 :=
  fun {A B} f x n =>
    iterate_f
      (fst (diagonalize n)) f (fun _ => FixT2_bottomM)
      x (snd (diagonalize n)).

(* FIXME HERE NOW *)

End FixT2.

(* FIXME HERE: yet another idea for FixT, using the resumption transformer *)
Section FixT3.
Context `{Monad}.

Inductive Ord : Type :=
| Ord0 : Ord
| OrdS (o:Ord) : Ord
| OrdLimit (f:nat -> Ord) : Ord
.

Inductive Resumption (F: Ord -> Type) A : Ord -> Type :=
| Res_Done ord (a:A) : Resumption F A ord
| Res_NonTerm : Resumption F A Ord0
| Res_Step ords (m:M {n:nat & F (ords n)}) : Resumption F A (OrdLimit ords).

End FixT3.

(*** FIXME: old stuff below! ***)

(***
 *** The Least Fixed-Point / Non-Termination Monad
 ***)

(* The non-termination monad as sets with at most one element *)
Definition FixM X : Type :=
  { S:X -> Prop | forall x y, S x /\ S y -> x = y }.

Program Instance FixM_returnM : MonadRet FixM :=
  fun A x => (fun y => x = y).

(* Helper for defining bind on FixM *)
Definition FixM_map {X Y} (m:FixM X) (f:X -> FixM Y) : Y -> Prop :=
  fun y => exists x, proj1_sig m x /\ proj1_sig (f x) y.

(* Helper for the helper for defining bind on FixM *)
Definition FixM_map_proof {X Y} (m:FixM X) (f:X -> FixM Y) :
  forall x y, FixM_map m f x /\ FixM_map m f y -> x = y.
  unfold FixM_map; intros; repeat (destruct H); repeat (destruct H0).
  unfold proj1_sig in * |- *; destruct m.
  rewrite (e x1 x0 $(split; assumption)$) in H2.
  destruct (f x0).
  apply e0; split; assumption.
Qed.

Instance FixM_bindM : MonadBind FixM :=
  fun (A B:Type) m f =>
    exist _ (FixM_map m f) (FixM_map_proof m f).

Instance FixM_leqM : MonadEquiv FixM :=
  fun {A} m1 m2 => forall x, proj1_sig m1 x -> proj1_sig m2 x.

(* Extensionality law for <<< on FixM *)
Lemma FixM_leqM_ext A (m1 m2: FixM A) :
  (forall x, proj1_sig m1 x -> proj1_sig m2 x) -> m1 <<< m2.
  intros H x; apply H.
Qed.

(* Extensionality law for == on FixM *)
Lemma FixM_eqM_ext A (m1 m2: FixM A) :
  (forall x, proj1_sig m1 x <-> proj1_sig m2 x) -> m1 == m2.
  intro equiv; split; intros x elem; destruct (equiv x);
    [ apply H | apply H0 ]; assumption.
Qed.

(* Monad instance for FixM *)
Instance FixM_Monad : Monad FixM.
  constructor;
    unfold returnM, FixM_returnM, bindM, FixM_bindM,
           FixM_map, FixM_map, proj1_sig;
    intros; try (apply FixM_eqM_ext; unfold proj1_sig; intros).
  split; intros.
  destruct H; destruct H. rewrite H; assumption.
  exists x; split; [ reflexivity | assumption ].
  split; intros.
  destruct H; destruct H. rewrite <- H0; assumption.
  exists x; split; [ assumption | reflexivity ].
  split; intros.
  destruct H; destruct H; destruct H0; destruct H0.
  exists x1; split; [ | assumption ].
  exists x0; split; assumption.
  destruct H; destruct H; destruct H; destruct H.
  exists x1; split; [ assumption | ].
  exists x0; split; assumption.

  constructor.
  intros x y H; assumption.
  intros m1 m2 m3 H1 H2 x pf; apply H2; apply H1; assumption.

  intros x y e_xy z elem_z; unfold proj1_sig in * |- *.
  rewrite <- e_xy; assumption.

  intros m1 m2 leqm f1 f2 leqf x elem_x; unfold proj1_sig in * |- *.
  destruct elem_x; destruct H. exists x0. split.
  apply leqm; assumption.
  apply (leqf x0 x0 eq_refl); assumption.
Qed.

(* The MonadFix instances for FixM *)

Definition FixM_Bottom {A} : FixM A :=
  exist (fun P => forall x y, P x /\ P y -> x = y)
        (fun x => False)
        (fun x y (H: False /\ False) => match proj1 H with end).

Program Instance FixM_fixM : MonadFixM FixM :=
  fun {A B} f x =>
    exist _ (fun y =>
               exists n,
                 proj1_sig (iterate_f n f (fun _ => FixM_Bottom) x) y
                 /\ forall n' y',
                      n' < n ->
                      ~(proj1_sig (iterate_f n' f (fun _ => FixM_Bottom) x) y')) _.
Obligation 1.
destruct (lt_eq_lt_dec H H0) as [ comp | l ]; [ destruct comp | ].
elimtype False; apply (H2 _ _ l H3).
rewrite e in H3.
apply (proj2_sig (iterate_f H0 f (fun _ : A => FixM_Bottom) x)).
split; assumption.
elimtype False; apply (H4 _ _ l H1).
Qed.

(*
Instance FixM_MonadFix : MonadFix FixM.
constructor; [ auto with typeclass_instances | ].
intros. unfold fixM, FixM_fixM.
apply FixM_eqM_ext; intros; unfold proj1_sig.
*)

(***
 *** A Better Fixed-Point Monad
 ***)

(* The idea here is that we only actually care about the first non-None value;
this way, we don't have any proofs in computations. *)
Definition FixM2 A := nat -> option A.

(* Whether the first non-None value of a FixM2 computation is x *)
Inductive IsValueBelow {A} (m:FixM2 A) (x:A) : nat -> Prop :=
| IsVB_Base n (e: m n = Some x) :
    (forall n', n' < n -> m n' = None) ->
    IsValueBelow m x n
| IsVB_Cons n : IsValueBelow m x n -> IsValueBelow m x (S n)
.

(* The proposition that a FixM2 computation has value x for some n *)
Definition IsValue {A} (m:FixM2 A) (x:A) : Prop :=
  exists n, IsValueBelow m x n.

(* The proposition that there are no values of m at or below n *)
Definition NoValueBelow {A} (m:FixM2 A) n : Prop :=
  forall n', n' <= n -> m n' = None.

(* IsValueBelow and NoValueBelow are mutually contradictor *)
Lemma IsValueBelow_NoValueBelow_false {A} (m:FixM2 A) n x :
  IsValueBelow m x n -> NoValueBelow m n -> False.
  unfold NoValueBelow; intro isvb; induction isvb; intro novb.
  rewrite novb in e; [ discriminate | apply le_n ].
  apply IHisvb. intros. apply novb.
  transitivity n; [ assumption | apply le_S; apply le_n ].
Qed.

(* IsValueBelow is a functor from <= *)
Lemma IsValueBelow_leq {A} (m:FixM2 A) x n n' :
  n <= n' -> IsValueBelow m x n -> IsValueBelow m x n'.
  intro leq; induction leq; intro H.
  assumption.
  apply IsVB_Cons; apply IHleq; assumption.
Qed.

Lemma IsValueBelow_inversion {A} (m:FixM2 A) x n :
  IsValueBelow m x n ->
  exists n', n' <= n /\ m n' = Some x /\ (forall n'', n'' < n' -> m n'' = None).
  intro isvb; induction isvb.
  exists n; split; [ apply le_n | split; [ assumption | ] ].
  intros n' l; apply H; assumption.
  destruct IHisvb as [ n' H ]; destruct H; destruct H0.
  exists n'; split; [ apply le_S; assumption | split; [ assumption | ]].
  intros; apply H1; assumption.
Qed.

(* A computation can only have one value below n *)
Lemma IsValueBelow_functional {A} (m:FixM2 A) n x1 x2 :
  IsValueBelow m x1 n -> IsValueBelow m x2 n -> x1 = x2.
  intro isvb1; induction isvb1; intro isvb2; inversion isvb2.
  assert (Some x1 = Some x2) as e_some;
    [ rewrite <- e; rewrite <- e0; reflexivity
    | injection e_some; intros; assumption ].
  destruct (IsValueBelow_inversion _ _ _ H0) as [ n' H2 ];
    destruct H2; destruct H3.
  rewrite H in H3; [ discriminate | ].
  apply (le_lt_trans _ n0); [ assumption | rewrite <- H1; apply le_n ].
  destruct (IsValueBelow_inversion _ _ _ isvb1) as [ n' H2 ];
    destruct H2; destruct H2.
  rewrite H in H2; [ discriminate | ].
  apply le_n_S; assumption.
  apply IHisvb1; assumption.
Qed.

(* IsValueBelow is decidable *)
Program Fixpoint IsValueBelow_dec {A} m n :
  {x:A | IsValueBelow m x n} + {NoValueBelow m n} :=
  match n with
    | 0 =>
      match m 0 with
        | Some x => inleft x
        | None => inright _
      end
    | S n' =>
      match IsValueBelow_dec m n' with
        | inleft x => inleft x
        | inright _ =>
          match m (S n') with
            | Some x => inleft x
            | None => inright _
          end
      end
  end.
Next Obligation.
apply IsVB_Base.
symmetry; assumption.
intros n' H; inversion H.
Qed.
Next Obligation.
intros n l; inversion l; symmetry; assumption.
Qed.
Next Obligation.
apply IsVB_Cons; assumption.
Defined.
Next Obligation.
apply IsVB_Base; [ symmetry; assumption | ].
intros n l; apply (n0 n).
apply le_S_n; assumption.
Defined.
Next Obligation.
intros n l; inversion l.
symmetry; assumption.
apply (n0 n); assumption.
Defined.

Lemma IsValueBelow_smaller {A} (m:FixM2 A) n n' x :
  n' <= n -> IsValueBelow m x n ->
  IsValueBelow m x n' \/ NoValueBelow m n'.
  intro l; induction l; intros.
  left; assumption.
  destruct (IsValueBelow_dec m m0). destruct s.
  assert (x0 = x).
  apply (IsValueBelow_functional m (S m0)); [ | assumption ].
  apply (IsValueBelow_leq _ _ m0); [ repeat constructor | assumption ].
  rewrite H0 in i; apply IHl; assumption.
  right. intros n'' l'; apply n; transitivity n'; assumption.
Qed.

(* Get the first value of m at or below n *)
Definition first_value_below {A} (m:FixM2 A) n : option A :=
  match IsValueBelow_dec m n with
    | inleft (exist _ x _) => Some x
    | inright _ => None
  end.

Lemma first_value_below_Some {A} (m:FixM2 A) n x :
  IsValueBelow m x n <-> first_value_below m n = Some x.
  split.
  intro isvb; unfold first_value_below; destruct (IsValueBelow_dec m n).
  destruct s as [ y H ]; unfold proj1_sig.
  f_equal; apply (IsValueBelow_functional _ _ _ _ H isvb).
  elimtype False;
    apply (IsValueBelow_NoValueBelow_false _ _ _ isvb n0).
  unfold first_value_below; destruct (IsValueBelow_dec m n).
  destruct s as [ y H ]; unfold proj1_sig; intro e;
    injection e; intro e2; rewrite <- e2; assumption.
  intro; discriminate.
Qed.

Lemma first_value_below_None {A} (m:FixM2 A) n :
  NoValueBelow m n <-> first_value_below m n = None.
  split.
  intro novb; unfold first_value_below; destruct (IsValueBelow_dec m n).
  destruct s as [ x H ]; elimtype False;
    apply (IsValueBelow_NoValueBelow_false _ _ _ H novb).
  reflexivity.
  unfold first_value_below; destruct (IsValueBelow_dec m n).
  destruct s as [ x H ]; intro; discriminate.
  intros; assumption.
Qed.

(* An alternate definition of first_value_below *)
Fixpoint first_value_below_alt {A} (m:FixM2 A) n : option A :=
  match n with
    | 0 => m 0
    | S n' =>
      match first_value_below_alt m n' with
        | Some x => Some x
        | None => m (S n')
      end
  end.

Lemma first_value_below_alt_correct {A} (m:FixM2 A) n :
  first_value_below m n = first_value_below_alt m n.
  induction n.
  unfold first_value_below, first_value_below_alt.
  destruct (IsValueBelow_dec m 0).
  destruct s. inversion i. symmetry; assumption.
  symmetry; apply n; apply le_n.
  unfold first_value_below_alt; fold (@first_value_below_alt A).
  rewrite <- IHn.
  destruct (IsValueBelow_dec m (S n)).
  destruct s.
  rewrite (proj1 (first_value_below_Some _ _ _) i).
  inversion i.
  rewrite (proj1 (first_value_below_None m n)).
  symmetry; assumption.
  intros n' l; apply H; apply le_n_S; assumption.
  rewrite (proj1 (first_value_below_Some _ _ _) H0).
  reflexivity.
  rewrite (proj1 (first_value_below_None _ _) n0).
  rewrite (proj1 (first_value_below_None m n)).
  symmetry; apply n0; reflexivity.
  intros n' l; apply n0; apply le_S; assumption.
Qed.

(* The return for FixM2: just return x, ignoring n *)
Instance FixM2_returnM : MonadRet FixM2 :=
  fun {A} x => fun n => Some x.

(* For bind, we must be sure we always use the value of m for the least n that
it accepts, even if (f x) takes a much greater value of n, and vice-versa *)
Instance FixM2_bindM : MonadBind FixM2 :=
  fun {A B} m f =>
    fun n =>
      match first_value_below m n with
        | None => None
        | Some x => first_value_below (f x) n
      end.

Instance FixM2_leqM : MonadEquiv FixM2 :=
  fun {A} m1 m2 => forall x, IsValue m1 x -> IsValue m2 x.

Lemma first_value_below_bindM {A B} m f n :
  first_value_below (@FixM2_bindM A B m f) n =
  (match first_value_below m n with
     | Some x => first_value_below (f x) n
     | None => None
   end).
  (* unfold first_value_below, FixM2_bindM. *)
  destruct (IsValueBelow_dec m n).
  destruct s.
  rewrite (proj1 (first_value_below_Some _ _ _) i).
  destruct (IsValueBelow_dec (f x) n).
  destruct s.
  rewrite (proj1 (first_value_below_Some _ _ _) i0).
  unfold FixM2_bindM.
  apply first_value_below_Some.
  destruct (IsValueBelow_inversion _ _ _ i) as [ n1 ];
    destruct H; destruct H0.
  destruct (IsValueBelow_inversion _ _ _ i0) as [ n2 ];
    destruct H2; destruct H3.
  apply (IsValueBelow_leq _ _ (max n1 n2)); [ apply Nat.max_case; assumption | ].
  apply IsVB_Base.
  rewrite (proj1 (first_value_below_Some m _ x)).
  apply first_value_below_Some.
  apply (IsValueBelow_leq _ _ n2); [ apply Nat.le_max_r | ].
  apply IsVB_Base; assumption.
  apply (IsValueBelow_leq _ _ n1); [ apply Nat.le_max_l | ].
  apply IsVB_Base; assumption.
  intros.
  destruct (Nat.max_dec n1 n2); rewrite e in H5.
  rewrite (proj1 (first_value_below_None _ _)); [ reflexivity | ].
  intros n'' l; apply H1. apply (le_lt_trans _ _ _ l H5).
  destruct (IsValueBelow_dec m n').
  destruct s.
  rewrite (proj1 (first_value_below_Some _ _ _) i1).
  apply first_value_below_None.
  rewrite (IsValueBelow_functional m n x1 x); [ | | assumption ].
  intros n'' l; apply H4. apply (le_lt_trans _ _ _ l H5).
  apply (IsValueBelow_leq _ _ n'); [ | assumption ].
  apply le_S_n. apply le_S. transitivity n2; assumption.
  rewrite (proj1 (first_value_below_None m n') n0); reflexivity.
  unfold FixM2_bindM.
  rewrite (proj1 (first_value_below_None _ _) n0).
  apply first_value_below_None.
  intros n' l.
  destruct (IsValueBelow_smaller _ _ _ _ l i).
  rewrite (proj1 (first_value_below_Some _ _ _) H).
  apply first_value_below_None.
  intros n'' l'; apply n0; transitivity n'; assumption.
  rewrite (proj1 (first_value_below_None _ _) H); reflexivity.
  rewrite (proj1 (first_value_below_None _ _) n0).
  unfold FixM2_bindM.
  apply first_value_below_None.
  intros n' l.
  rewrite (proj1 (first_value_below_None m n')); [ reflexivity | ].
  intros n'' l''; apply n0; transitivity n'; assumption.
Qed.

(* Helper for proving FixM2_eqM *)
Lemma FixM2_eqM_helper A (m1 m2: FixM2 A) :
  (forall n, first_value_below m1 n = first_value_below m2 n) -> m1 == m2.
  unfold eqM, leqM, FixM2_leqM, IsValue; intro e; split;
    intros; destruct H as [ n H ]; exists n.
  rewrite first_value_below_Some; rewrite <- e;
    apply first_value_below_Some; assumption.
  rewrite first_value_below_Some; rewrite e;
    apply first_value_below_Some; assumption.
Qed.

(* The Monad instance for FixM2 *)
Instance FixM2_Monad : Monad FixM2.
  constructor;
    unfold returnM, FixM2_returnM, bindM; intros;
  try (apply FixM2_eqM_helper; intros).

  rewrite first_value_below_bindM.
  rewrite (proj1 (first_value_below_Some (fun _ : nat => Some x) n x));
    [ reflexivity | ].
  apply (IsValueBelow_leq _ _ 0); [ apply le_0_n | ].
  apply IsVB_Base; [ reflexivity | ].
  intros n' l; inversion l.

  rewrite first_value_below_bindM.
  destruct (first_value_below m n); [ | reflexivity ].
  apply first_value_below_Some.
  apply (IsValueBelow_leq _ _ 0); [ apply le_0_n | ].
  apply IsVB_Base; [ reflexivity | ].
  intros n' l; inversion l.

  repeat (rewrite first_value_below_bindM).
  destruct (first_value_below m n); [ | reflexivity ].
  rewrite first_value_below_bindM.
  reflexivity.

  constructor.
  intros m x vis; assumption.
  intros m1 m2 m3 H1 H2 x vis. apply H2; apply H1; assumption.
  intros x y e z vis. rewrite <- e; assumption.

  intros m1 m2 leqm f1 f2 leqf y vis.
  unfold IsValue.
  destruct vis as [ n ].
  assert (first_value_below (FixM2_bindM A B m1 f1) n = Some y).
  apply first_value_below_Some; assumption.
  rewrite first_value_below_bindM in H0.
  case_eq (first_value_below m1 n);
    intros; rewrite H1 in H0; [ | discriminate ].
  rewrite <- first_value_below_Some in H1.
  destruct (leqm _ (ex_intro _ n H1)) as [ nm ].
  rewrite <- first_value_below_Some in H0.
  destruct (leqf a a eq_refl y (ex_intro _ n H0)) as [ nf ].
  exists (max nm nf).
  rewrite first_value_below_Some.
  rewrite first_value_below_bindM.
  rewrite (proj1 (first_value_below_Some m2 _ a)).
  apply first_value_below_Some.
  apply (IsValueBelow_leq _ _ nf); [ apply Nat.le_max_r | assumption ].
  apply (IsValueBelow_leq _ _ nm); [ apply Nat.le_max_l | assumption ].
Qed.

(*** The MonadFix instance for FixM2 ***)

(* The least element of FixM2 w.r.t. leqM *)
Definition FixM2_Bottom {A} : FixM2 A :=
  fun n => None.

(* Bottom is in fact least *)
Lemma FixM2_Bottom_least {A} (m:FixM2 A) :
  leqM FixM2_Bottom m.
  intros x isv; destruct isv. rewrite first_value_below_Some in H.
  rewrite (proj1 (first_value_below_None _ _)) in H; [ discriminate | ].
  intros n l. reflexivity.
Qed.

(* For fixM, we must use the value of the fixed-point of f for the least n, even
if it takes some n' <> n steps of iteration of f to reach that fixed-point. *)
Instance FixM2_fixM : MonadFixM FixM2 :=
  fun {A B} f =>
    fun a n => first_value_below (iterate_f n f (fun _ => FixM2_Bottom) a) n.

Instance FixM2_MonadFix : MonadFix FixM2.
  constructor.
  auto with typeclass_instances.
  intros.
  unfold fixM; unfold FixM2_fixM.
  apply FixM2_eqM_helper; intros.


Require Import HoTT.
From HoTT.Categories Require Import
     Category Functor NaturalTransformation GroupoidCategory FunctorCategory.
Require Import GR.bicategories.bicategories.

(** The definition of groupoids. *)
Definition groupoid := {C : PreCategory & IsGroupoid C}.

Class is_univalent (G : groupoid)
  := obj_cat : IsCategory G.1.

Global Instance is_univalent_ishprop `{Funext} (G : groupoid)
  : IsHProp (is_univalent G).
Proof.
  unfold is_univalent.
  apply _.
Defined.

(** The structure of groupoids *)

(** The underlying type of objects. *)
Definition under (G : groupoid) : Type
  := object G.1.

Global Instance univalent_one_type (G : groupoid) `{is_univalent G}
  : IsTrunc 1 (under G).
Proof.
  unfold is_univalent, under in *.
  apply _.
Defined.

Coercion grpd_to_type := under.

(** The homsets. *)
Definition hom (G : groupoid) : G -> G -> hSet
  := fun x y => BuildhSet (morphism G.1 x y)%morphism.

Coercion hom : groupoid >-> Funclass.

(** The unit element. *)
Definition e {G : groupoid} (x : G) : G x x
  := 1%morphism.

(** Composition. *)
Definition comp {G : groupoid} {x y z : G}
  : G x y -> G y z -> G x z
  := fun g h => (h o g)%morphism.

Notation "p ● q" := (comp p q) (at level 40). (* \ci *)

(** Inverses. *)
Definition inv {G : groupoid} {x y : G}
  : G x y -> G y x
  := fun g => @morphism_inverse _ _ _ g (G.2 _ _ g).

(** Left associativity. *)
Definition grpd_left_assoc
           {G : groupoid}
           {v x y z : G}
           (p : G v x) (q : G x y) (r : G y z)
  : (p ● q) ● r = p ● (q ● r)
  := (associativity _ v x y z p q r)^.

(** Right associativity. *)
Definition grpd_right_assoc
           {G : groupoid}
           {v x y z : G}
           (p : hom G v x) (q : hom G x y) (r : hom G y z)
  : p ● (q ● r) = (p ● q) ● r
  := associativity _ v x y z p q r.

(** Right neutrality. *)
Definition grpd_right_identity
           {G : groupoid}
           {x y : G}
           (p : G x y)
  : p ● e y = p
  := left_identity _ x y p.

(** Left neutrality. *)
Definition grpd_left_identity
           {G : groupoid}
           {x y : G}
           (p : G x y)
  : e x ● p = p
  := right_identity _ x y p.

(** Right inverse. *)
Definition grpd_right_inverse
           {G : groupoid}
           {x y : G}
           (p : G x y)
  : p ● inv p = e x
  := @left_inverse _ x y p (G.2 x y p).

(** Left inverse. *)
Definition grpd_left_inverse
           {G : groupoid}
           {x y : G}
           (p : G x y)
  : inv p ● p = e y
  := @right_inverse _ x y p (G.2 x y p).

(** A function for building groupoids. *)
Definition Build_grpd
           (obj : Type)
           (hom : obj -> obj -> hSet)
           (e : forall (x : obj), hom x x)
           (inv : forall {x y : obj}, hom x y -> hom y x)
           (comp : forall {x y z : obj}, hom x y -> hom y z -> hom x z)
           (assoc : forall (x y z v : obj) (p : hom v x) (q : hom x y) (r : hom y z),
               comp p (comp q r) = comp (comp p q) r)
           (ec : forall (x y : obj) (p : hom x y),
               comp (e x) p = p)
           (ce : forall (x y : obj) (p : hom x y),
               comp p (e y) = p)
           (ic : forall (x y : obj) (p : hom x y),
               comp (inv p) p = e y)
           (ci : forall (x y : obj) (p : hom x y),
               comp p (inv p) = e x)
  : groupoid.
Proof.
  simple refine (@Build_PreCategory
                   obj
                   hom
                   e
                   (fun _ _ _ p q => comp _ _ _ q p) _ _ _ _;_).
  - cbn ; intros.
    apply assoc.
  - cbn ; intros.
    apply ce.
  - cbn ; intros.
    apply ec.
  - intros x y g ; cbn in *.
    simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
    + exact (inv _ _ g).
    + apply ci.
    + apply ic.
Defined.

(** Groupoid functors *)
Definition grpd_functor `{Funext} (G₁ G₂ : groupoid) : PreCategory
  := functor_category G₁.1 G₂.1.

(** The object part of a functor. *)
Definition grpd_object_of `{Funext} {G₁ G₂ : groupoid} (F : grpd_functor G₁ G₂)
  : under G₁ -> under G₂
  := object_of F.

(** The morphism part of a functor. *)
Definition grpd_morphism_of `{Funext} {G₁ G₂ : groupoid} (F : grpd_functor G₁ G₂)
  : forall {x y : under G₁},
    hom G₁ x y -> hom G₂ (grpd_object_of F x) (grpd_object_of F y)
  := morphism_of F.

(** Functors preserve the unit. *)
Definition grpd_identity_of `{Funext} {G₁ G₂ : groupoid} (F : grpd_functor G₁ G₂)
  : forall (x : under G₁), grpd_morphism_of F (e x) = e (grpd_object_of F x)
  := identity_of F.

(** Functors preserve the multiplication. *)
Definition grpd_composition_of `{Funext} {G₁ G₂ : groupoid} (F : grpd_functor G₁ G₂)
  : forall {x y z : under G₁} (p : hom G₁ x y) (q : hom G₁ y z),
    grpd_morphism_of F (p ● q) = grpd_morphism_of F p ● grpd_morphism_of F q
  := composition_of F.

(** Functors preserve inverses. *)
Definition grpd_inverse_of `{Funext} {G₁ G₂ : groupoid} (F : grpd_functor G₁ G₂)
  : forall {x y : under G₁} (p : hom G₁ x y),
    grpd_morphism_of F (inv p) = inv (grpd_morphism_of F p).
Proof.
  intros x y p.
  apply iso_moveL_1V.
  refine (((grpd_composition_of F p (inv p))^ @ _ @ grpd_identity_of F x)).
  apply (ap (grpd_morphism_of F)).
  apply grpd_right_inverse.
Defined.

(** We have a bicategory of groupoids. *)
Definition grpd `{Funext} : BiCategory
  := full_sub PreCat (fun C => BuildhProp (IsGroupoid C)).

(** We have a bicategory of univalent groupoids. *)
Definition univalent_grpd `{Funext} : BiCategory
  := full_sub grpd (fun G => BuildhProp (is_univalent G)).

(** Note: it has the expected objects and morphisms. *)
Definition grpd_obj `{Funext} : Obj grpd = groupoid
  := idpath.

Definition grpd_hom `{Funext} : Hom grpd = grpd_functor
  := idpath.

Definition grpd_21 `{Funext} : is_21 grpd.
Proof.
  intros G₁ G₂ F₁ F₂ α ; simpl in *.
  simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
  - simple refine (Build_NaturalTransformation _ _ _ _).
    + intros C.
      apply G₂.
      exact (α C).
    + intros x y g ; cbn.
      refine (iso_moveR_Mp _ _ _) ; cbn.
      refine (_ @ associativity _ _ _ _ _ _ _ _).
      apply iso_moveL_pV.
      apply α.
  - apply path_natural_transformation ; simpl.
    intro x.
    apply left_inverse.
  - apply path_natural_transformation ; simpl.
    intro x.
    apply right_inverse.
Defined.


(**
To define the initial algebra in setoids, we first define the initial prealgebra in sets.
We use Adamek's theorem for this.
 *)
Require Import prelude.all.

Require Import syntax.hit_signature.
Require Import algebras.set_algebra.
Require Import algebras.univalent_algebra.

(**
Polynomial functors are omega cocontinuous.
 *)
Definition poly_is_omega_cocont
           (P : poly_code)
  : is_omega_cocont (⦃ P ⦄).
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply is_omega_cocont_constant_functor.
  - apply is_omega_cocont_functor_identity.
  - apply is_omega_cocont_BinCoproduct_of_functors.
    + exact IHP₁.
    + exact IHP₂.
  - apply is_omega_cocont_BinProduct_of_functors.
    + exact BinProductsHSET.
    + apply is_omega_cocont_constprod_functor1.
      * exact Exponentials_HSET.
    + exact IHP₁.
    + exact IHP₂.
Defined.

(**
By Adamek, they have an initial algebra.
 *)
Definition initial_prealgebra
           (P : poly_code)
  : Initial (set_prealgebras P).
Proof.
  use colimAlgInitial.
  - exact InitialHSET.
  - exact (poly_is_omega_cocont P).
  - apply ColimCoconeHSET.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

Fixpoint count  (count_arg1 : lst) (count_arg0 : natural): natural
           := match  count_arg1,count_arg0 with
              | Nil, x => Zero
              | Cons y z, x => if eqb x y then Succ (count z x) else count z x
              end.

              Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
              := match insort_arg1, insort_arg0 with
                 |  Nil, i => Cons i Nil
                 | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
                 end.

                 Fixpoint sort (sort_arg0 : lst) : lst
                 := match sort_arg0 with
                    | Nil => Nil
                    | Cons x y => insort (sort y) x
                    end.

Theorem eqb_refl: forall n, eqb n n = true.
Proof.
   induction n; simpl.
   { assumption. }
   { reflexivity. }
Qed.

Theorem eqb_diff: forall (x y: natural), x <> y -> eqb x y = false.
Proof.
   induction x; induction y; simpl.
   {
   intros.
   apply IHx.
   intro.
   subst.
   assert (Succ y = Succ y). reflexivity.
   apply H in H0.
   destruct H0.
   }
   {
   intros. reflexivity.
   }
   {
   intros. reflexivity.
   }
   {
   intros.
   assert (Zero = Zero). reflexivity.
   apply H in H0.
   destruct H0.
   }
Qed.

Theorem eqb_elim: forall (x y: natural), Bool.Is_true (eqb x y) -> x = y.
Proof.
   induction x; induction y; simpl in *.
   intros.
   {
   apply IHx in H.
   subst.
   reflexivity.
   }
   {
   intros.
   destruct H.
   }
   { intros; destruct H. }
   {
   intros. reflexivity.
   }
Qed.

Theorem count_cons: forall (x: natural) (l: lst), count (Cons x l) x = Succ (count l x).
Proof.
   intros.
   simpl.
   rewrite eqb_refl.
   reflexivity.
Qed.

Theorem count_insort: forall (x: natural) (l: lst), count (insort l x) x= Succ (count l x).
Proof.
   intros.
   induction l.
   {
   simpl in *.
   destruct (less x n).
   {
      rewrite count_cons.
      f_equal.
   }
   {
      destruct (eqb x n) eqn:E.
      {
         apply Bool.Is_true_eq_left in E.
         apply eqb_elim in E.
         rewrite E in *.
         lfind. Admitted.


Require Export b_soundness.
Require Export Decidable.
Set Implicit Arguments.

(** * Completeness Theorem

The general proof idea is to put a formula in Conjunctive Normal Form (CNF),
and then prove that validity and provability are both equivalent
to a syntactical validity check. The proof consists of six parts.
 - If a formula is valid, then so is its NNF;
 - If a (formula in) NNF is valid, then so is its CNF;
 - If a (formula in) CNF is valid then it's syntactically valid;
 - If a CNF is syntactically valid, then its provable;
 - If the CNF of a NNF formula is provable, then so is the NNF formula itself.
 - If the NNF of a formula is provable, then so is the formula itself.*)

Module Type complete_mod (X: base_mod) (Y: sound_mod X).
Import X Y.

(*First we transform a formula to its Negation Normal Form (NNF) by expanding all implications,
and pushing Negations to the atomic formulas.*)
Inductive NNF : Set :=
 | NPos : PropVars -> NNF
 | NNeg : PropVars -> NNF
 | NBot : NNF
 | NTop : NNF
 | NConj : NNF -> NNF -> NNF
 | NDisj : NNF -> NNF -> NNF
.

(*MakeNNF A pushes all negations in A to the literals and removes implications.
 MakeNNFN A does the same for ¬A*)
Fixpoint MakeNNF (A:PropF) : NNF := match A with
 | # P   => NPos P
 | ⊥     => NBot
 | B ∨ C => NDisj (MakeNNF B) (MakeNNF C)
 | B ∧ C => NConj (MakeNNF B) (MakeNNF C)
 | B → C => NDisj (MakeNNFN B) (MakeNNF C)
 end
with MakeNNFN (A:PropF) : NNF := match A with
 | # P   => NNeg P
 | ⊥     => NTop
 | B ∨ C => NConj (MakeNNFN B) (MakeNNFN C)
 | B ∧ C => NDisj (MakeNNFN B) (MakeNNFN C)
 | B → C => NConj (MakeNNF B) (MakeNNFN C)
 end.

(** The inclusion from NNF to formulas*)
Fixpoint NNFtoPropF (A:NNF) : PropF := match A with
 | NPos P    => #P
 | NNeg P    => ¬ #P
 | NBot      => ⊥
 | NTop      => ¬⊥
 | NConj B C => NNFtoPropF B ∧ NNFtoPropF C
 | NDisj B C => NNFtoPropF B ∨ NNFtoPropF C
end.

(** I'm going to model clauses as list of literals
and formulas in Conjuntive Normal Form (CNF) as lists of clauses*)
Inductive Literal :=
| LPos : PropVars -> Literal
| LNeg : PropVars -> Literal
| LBot : Literal
| LTop : Literal
.
Fixpoint Bar P := match P with
| LPos Q => LNeg Q
| LNeg Q => LPos Q
| LBot   => LTop
| LTop   => LBot
end.

Fixpoint LiteraltoPropF (P:Literal) : PropF := match P with
| LPos Q => #Q
| LNeg Q => ¬#Q
| LBot   => ⊥
| LTop   => ¬⊥
end.

Definition Clause := list Literal.

(** A clause is the disjunction of literals.
As an artifact of this encoding, there is always an ⊥ at the end of a clause).
The alternative was to use non-empty lists, i.e. a new inductive type List' defined as
Inductive List' (A:Type) : Type :=
| Singleton : A -> List'
| Cons' : A -> List' A -> List' A.
I decided against this, since then I have to re-prove basic facts about lists,
and I thought that the meta-theoretical proofs would be longer,
since parts of the Cons'-case must (perhaps) also be proven for the Singleton-case.
*)
Definition ClausetoPropF := map_fold_right LiteraltoPropF Disj ⊥.

Definition CNF := list Clause.

Definition CNFtoPropF := map_fold_right ClausetoPropF Conj ⊤.

(** Definition of the disjunction of
 - A clause and a formula in CNF
 - Two formulas in CNF*)
Definition AddClause (l:Clause) (ll:CNF) : CNF := map (fun l2 => l++l2) ll.
Definition Disjunct (ll ll2:CNF) : CNF := flat_map (fun l => AddClause l ll2) ll.

(**MakeCNF A transforms A to CNF*)
Fixpoint MakeCNF (A:NNF) : CNF := match A with
 | NPos P    => [[LPos P]]
 | NNeg P    => [[LNeg P]]
 | NBot      => [[LBot]]
 | NTop      => [[LTop]]
 | NConj B C => MakeCNF B ++ MakeCNF C
 | NDisj B C => Disjunct (MakeCNF B) (MakeCNF C)
 end.

(** Syntactical requirement for validity of a clause*)
Definition Valid_Clause (l:Clause) := In LTop l\/exists A,(In (LPos A) l/\In (LNeg A) l).
Definition Valid_CNF ll := forall l, In l ll->Valid_Clause l.

(** * Theorems

We start with the decidability for literals*)

Lemma Literal_eqdec : forall x y : Literal, {x = y} + {x <> y}.
intros;destruct x;destruct y;try (right;discriminate);try (left;reflexivity);
 destruct (Varseq_dec p p0);
  (left;f_equal;assumption)||(right;intro HH;injection HH;contradiction).
Qed.

(** Proof that A is valid iff NNF A is valid*)

Lemma NNF_equiv_valid : forall v A, TrueQ v (NNFtoPropF (MakeNNF  A))=TrueQ v  A /\
                                    TrueQ v (NNFtoPropF (MakeNNFN A))=TrueQ v ¬A.
intros v A;induction A;try destruct IHA;try destruct IHA1;try destruct IHA2;split;simpl in *;
try trivial;try rewrite H;try rewrite H0;try rewrite H1;try rewrite H2;try trivial;
repeat rewrite orb_false_r;repeat rewrite orb_false_l;
try rewrite negb_andb;try rewrite negb_orb;try rewrite negb_involutive;reflexivity.
Qed.

(** Proof that NNF A is valid iff CNF A is valid*)

Lemma CNF_and_valid : forall v ll1 ll2, TrueQ v (CNFtoPropF (ll1 ++ ll2)) =
                                        TrueQ v (CNFtoPropF ll1) && TrueQ v (CNFtoPropF ll2).
intros;induction ll1;simpl.
 reflexivity.
 unfold CNFtoPropF in IHll1 at 1;rewrite IHll1.
  apply andb_assoc.
Qed.

Lemma CNF_or_clause_valid : forall v l1 l2, TrueQ v (ClausetoPropF (l1++l2)) =
                                            TrueQ v (ClausetoPropF l1) || TrueQ v (ClausetoPropF l2).
intros;induction l1;simpl.
 reflexivity.
 unfold ClausetoPropF in IHl1 at 1;rewrite IHl1.
  apply orb_assoc.
Qed.

Lemma CNF_add_clause_valid : forall v l ll, TrueQ v (CNFtoPropF (AddClause l ll)) =
                                            TrueQ v (ClausetoPropF l) || TrueQ v (CNFtoPropF ll).
intros;induction ll;simpl.
 rewrite orb_true_r;reflexivity.
 unfold CNFtoPropF in IHll at 1;rewrite IHll.
  rewrite CNF_or_clause_valid.
   rewrite orb_andb_distrib_r.
    reflexivity.
Qed.

Lemma CNF_or_valid : forall v ll1 ll2, TrueQ v (CNFtoPropF (Disjunct ll1 ll2)) =
                                       TrueQ v (CNFtoPropF ll1) || TrueQ v (CNFtoPropF ll2).
intros;induction ll1;simpl.
 reflexivity.
 rewrite CNF_and_valid;rewrite IHll1;rewrite CNF_add_clause_valid.
  rewrite orb_andb_distrib_l;reflexivity.
Qed.

Theorem CNF_equiv_valid : forall v A, TrueQ v (CNFtoPropF (MakeCNF A)) = TrueQ v (NNFtoPropF A).
intros;induction A;simpl;try reflexivity;try (destruct (v p);simpl;reflexivity;fail);
 [rewrite CNF_and_valid|rewrite CNF_or_valid];rewrite IHA1;rewrite IHA2;reflexivity.
Qed.

(** Proof that if a formula in CNF is valid then it is syntactically valid*)

Definition Countervaluation l P := if (in_dec Literal_eqdec (LNeg P) l) then true else false.
Definition Validates v Δ := exists A, In A Δ /\ Is_true (TrueQ v A).

Lemma TrueQ_impl_Validates : forall v m, Is_true (TrueQ v (ClausetoPropF m)) -> Validates v (map LiteraltoPropF m).
intros;induction m.
 contradiction.
 simpl in H;case_bool v (LiteraltoPropF a).
   exists (LiteraltoPropF a);split;[in_solve|rewrite H0;trivial].
   destruct (IHm H) as (?&?&?);exists x;split;[in_solve|assumption].
Qed.

Lemma Validated_valid : forall l, Validates (Countervaluation l) (map LiteraltoPropF l) -> Valid_Clause l.
intros l (A&H&K). apply in_map_iff in H as (p&?&H);subst;destruct p;unfold Countervaluation in K;simpl in K.
  destruct (in_dec Literal_eqdec (LNeg p) l).
    right;eauto.
    contradiction.
  destruct (in_dec Literal_eqdec (LNeg p) l);contradiction.
  contradiction.
  left;assumption.
Qed.

Theorem Clause_valid : forall l, Valid (ClausetoPropF l) -> Valid_Clause l.
intros;apply Validated_valid;apply TrueQ_impl_Validates;apply H;intros ? Q;destruct Q.
Qed.

Theorem CNF_valid : forall ll, Valid (CNFtoPropF ll) -> Valid_CNF ll.
induction ll;intros ? ? H0;destruct H0;subst.
  apply Clause_valid;intros v K;remember (H v K) as i eqn:x;clear x;
   simpl in i;case_bool v (ClausetoPropF l).
  apply IHll.
    intros v K. remember (H v K). eapply proj2. apply andb_prop_elim.
     rewrite <- CNF_and_valid. change (a::ll) with ([a]++ll) in H. eapply H;assumption.
    assumption.
Qed.

(** Proof that if a formula in CNF is syntactically valid then it's provable*)

Lemma Clause_provable_3 : forall a l1 l2 Γ, In (LiteraltoPropF a) Γ -> Γ ⊢ ClausetoPropF (l1++a::l2).
intros;induction l1.
 apply OrI1;is_ass.
 apply OrI2;assumption.
Qed.

Lemma Clause_provable_2 : forall a l1 l2 l3, Provable (ClausetoPropF (l1++(Bar a)::l2++a::l3)).
intros;induction l1.
 apply BotC;mp;[is_ass|destruct a;simpl;apply OrI1];
   try (apply ImpI;mp;[is_ass|apply OrI2;apply Clause_provable_3;in_solve]);
       (apply BotC;mp;[constructor;constructor 2;in_solve|apply OrI2;apply Clause_provable_3;in_solve]).
 apply OrI2;assumption.
Qed.

Theorem Clause_provable : forall l, Valid_Clause l -> Provable (ClausetoPropF l).
intros ? [?|(?&?&?)];apply in_split in H as (?&?&?);subst.
 induction x;simpl.
   apply OrI1;simpl;apply ImpI;is_ass.
   apply OrI2;apply IHx.
 apply in_app_or in H0 as [].
   apply in_split in H as (?&?&?);subst.
    rewrite app_ass;apply (Clause_provable_2 (LPos x)).
   inversion H;[discriminate|].
    apply in_split in H0 as (?&?&?);subst.
     apply (Clause_provable_2 (LNeg x)).
Qed.

Theorem CNF_provable : forall ll, Valid_CNF ll -> Provable (CNFtoPropF ll).
intros;induction ll;unfold CNFtoPropF;simpl.
 apply ImpI;is_ass.
 eapply AndI.
   apply Clause_provable;apply H;constructor;reflexivity.
   apply IHll;intro;intro;apply H;constructor 2;assumption.
Qed.

(** Proof that (CNF A) → (NNF A) is provable*)

Lemma prov_or : forall A1 A2 B1 B2 Γ, Provable (A1 → A2) -> Provable (B1 → B2) -> In (A1∨B1) Γ -> Γ ⊢ A2∨B2.
intros; prov_impl_in H;prov_impl_in H0. eapply OrE.
  is_ass.
  apply OrI1;apply K;is_ass.
  apply OrI2;apply K0;is_ass.
Qed.

Lemma CNF_and_prov : forall ll1 ll2, Provable (CNFtoPropF (ll1 ++ ll2) → CNFtoPropF ll1 ∧ CNFtoPropF ll2).
intros;induction ll1;simpl.
 unfold CNFtoPropF at 2;unfold ClausetoPropF;simpl.
   apply ImpI;apply AndI.
     unfold Top;unfold Neg;apply ImpI;is_ass.
     is_ass.
 prov_impl_in IHll1; apply ImpI;apply AndI.
   unfold CNFtoPropF;simpl;apply AndI.
     eapply AndE1;is_ass.
     eapply AndE1;apply K. eapply AndE2;is_ass.
   eapply AndE2;apply K;eapply AndE2;is_ass.
Qed.

Lemma CNF_or_clause_prov : forall l1 l2, Provable (ClausetoPropF (l1++l2) → ClausetoPropF l1 ∨ ClausetoPropF l2).
intros;induction l1;simpl;unfold ClausetoPropF;simpl.
 apply ImpI;eapply OrI2;is_ass.
 prov_impl_in IHl1. apply ImpI. eapply OrE.
   is_ass.
   do 2 eapply OrI1;is_ass.
   apply OrE with (ClausetoPropF l1) (ClausetoPropF l2).
     apply K;is_ass.
     apply OrI1;apply OrI2;is_ass.
     apply OrI2;is_ass.
Qed.

Lemma CNF_add_clause_prov : forall l ll, Provable (CNFtoPropF (AddClause l ll) → ClausetoPropF l ∨ CNFtoPropF ll).
intros;induction ll;simpl;unfold CNFtoPropF;simpl.
 apply ImpI;eapply OrI2;is_ass.
 prov_impl_in IHll;apply ImpI; apply OrE with (ClausetoPropF l) (ClausetoPropF a).
   eapply prov_impl.
     apply CNF_or_clause_prov.
     eapply AndE1;is_ass.
   apply OrI1;is_ass.
   apply OrE with (ClausetoPropF l) (CNFtoPropF ll).
     apply K;eapply AndE2;is_ass.
     apply OrI1;is_ass.
     apply OrI2;apply AndI;is_ass.
Qed.

Lemma CNF_or_prov : forall ll1 ll2, Provable (CNFtoPropF (Disjunct ll1 ll2) → CNFtoPropF ll1 ∨ CNFtoPropF ll2).
intros;induction ll1;simpl;unfold CNFtoPropF;simpl.
 apply ImpI;eapply OrI1;is_ass.
 prov_impl_in IHll1;apply ImpI; apply OrE with (ClausetoPropF a) (CNFtoPropF ll2).
     eapply prov_impl;[apply CNF_add_clause_prov|].
       eapply AndE1;eapply prov_impl;[apply CNF_and_prov|is_ass].
     apply OrE with (CNFtoPropF ll1) (CNFtoPropF ll2).
       apply K;eapply AndE2;eapply prov_impl;[apply CNF_and_prov|is_ass].
       apply OrI1;apply AndI;is_ass.
       apply OrI2;is_ass.
     apply OrI2;is_ass.
Qed.

Theorem CNF_impl_prov : forall A, Provable (CNFtoPropF (MakeCNF A) → NNFtoPropF A).
induction A;simpl;
 try (unfold CNFtoPropF; unfold ClausetoPropF;simpl;
   apply ImpI;eapply OrE;
     [eapply AndE1;is_ass|
     is_ass|
     apply BotC;is_ass];fail).
 apply ImpI;apply AndI;(eapply prov_impl;[eassumption|]);
  [eapply AndE1|eapply AndE2];(eapply prov_impl;[apply CNF_and_prov|is_ass]).
 apply ImpI;eapply prov_impl.
   apply ImpI;eapply prov_or;try eassumption;in_solve.
   eapply prov_impl;[apply CNF_or_prov|is_ass].
Qed.

(**Proof that (NNF A) → A is provable *)

Lemma prov_and : forall A1 A2 B1 B2 Γ, Provable (A1 → A2) -> Provable (B1 → B2) -> In (A1∧B1) Γ -> Γ ⊢ A2∧B2.
intros; prov_impl_in H;prov_impl_in H0. apply AndI;[apply K;eapply AndE1|apply K0;eapply AndE2];is_ass.
Qed.

Lemma NNF_impl_prov : forall A, Provable (NNFtoPropF (MakeNNF  A) →  A) /\
                                Provable (NNFtoPropF (MakeNNFN A) → ¬A).
induction A;simpl;split;try destruct IHA;try destruct IHA1;try destruct IHA2;apply ImpI;try (is_ass;fail).
 eapply prov_and;try eassumption;in_solve.
 apply ImpI. apply OrE with ¬A1 ¬A2.
   eapply prov_or;try eassumption;in_solve.
   mp;[|eapply AndE1];is_ass.
   mp;[|eapply AndE2];is_ass.
 eapply prov_or;try eassumption;in_solve.
 apply ImpI. eapply OrE;[is_ass|mp;[|is_ass];eapply prov_impl;try eassumption..].
   eapply AndE1;is_ass.
   eapply AndE2;is_ass.
 apply ImpI. apply OrE with ¬A1 A2.
   eapply prov_or;try eassumption;in_solve.
   apply BotC. eapply ImpE with A1;is_ass.
   is_ass.
 apply ImpI. apply ImpE with A2.
   eapply prov_impl;try eassumption. eapply AndE2;is_ass.
   mp.
     is_ass.
     eapply prov_impl;try eassumption. eapply AndE1;is_ass.
Qed.

(** * Completeness Theorem*)

Theorem Completeness : Prop_Completeness.
do 2 intro.
mp. apply NNF_impl_prov.
mp. apply CNF_impl_prov.
apply CNF_provable.
apply CNF_valid.
intros ? ?.
rewrite CNF_equiv_valid.
rewrite ((and_ind (fun A _ => A)) (NNF_equiv_valid v A)).
apply H;assumption.
Qed.

Theorem prov_equiv_models : forall Γ A, Γ ⊢ A <-> Γ ⊨ A.
split;[apply Soundness_general|revert A;induction Γ].
 apply Completeness.
 intros. apply deduction. apply IHΓ.
  intros ? ?. case_bool v a;rewrite H1;simpl.
     apply H. intros ? ?. destruct H2;subst.
      rewrite H1;exact I.
      apply H0;in_solve.
    exact I.
Qed.

Print Assumptions prov_equiv_models.

End complete_mod.