(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Supplementary Coq material: proof by reflection
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)

Require Import Frap.

Set Implicit Arguments.
Set Asymmetric Patterns.

(* Our last "aside" on effective Coq use (in IntroToProofScripting.v)
 * highlighted a very heuristic approach to proving.  As an alternative, we will
 * study a technique called proof by reflection.  We will write, in Gallina (the
 * logical functional-programming language of Coq), decision procedures with
 * proofs of correctness, and we will appeal to these procedures in writing very
 * short proofs.  Such a proof is checked by running the decision procedure.
 * The term _reflection_ applies because we will need to translate Gallina
 * propositions into values of inductive types representing syntax, so that
 * Gallina programs may analyze them, and translating such a term back to the
 * original form is called _reflecting_ it. *)

(** * Proving Evenness *)

(* Proving that particular natural number constants are even is certainly
 * something we would rather have happen automatically.  The Ltac-programming
 * techniques that we learned last week make it easy to implement such a
 * procedure. *)

Inductive isEven : nat -> Prop :=
| Even_O : isEven O
| Even_SS : forall n, isEven n -> isEven (S (S n)).

Ltac prove_even := repeat constructor.

Theorem even_256 : isEven 256.
Proof.
  prove_even.
Qed.

Set Printing All.
Print even_256.
Unset Printing All.

(* Here we see a term of Coq's core proof language, which we don't explain in
 * detail, but roughly speaking such a term is a syntax tree recording which
 * lemmas were used, and how their quantifiers were instantiated, to prove a
 * theorem.  This Ltac procedure always works (at least on machines with
 * infinite resources), but it has a serious drawback, which we see when we
 * print the proof it generates that 256 is even.  The final proof term has
 * length super-linear in the input value, which we reveal with
 * [Set Printing All], to disable all syntactic niceties and show every node of
 * the internal proof AST.  The problem is that each [Even_SS] application needs
 * a choice of [n], and we wind up giving every even number from 0 to 254 in
 * that position, at some point or another, for quadratic proof-term size.
 *
 * It is also unfortunate not to have static typing guarantees that our tactic
 * always behaves appropriately.  Other invocations of similar tactics might
 * fail with dynamic type errors, and we would not know about the bugs behind
 * these errors until we happened to attempt to prove complex enough goals.
 *
 * The techniques of proof by reflection address both complaints.  We will be
 * able to write proofs like in the example above with constant size overhead
 * beyond the size of the input, and we will do it with verified decision
 * procedures written in Gallina. *)

Fixpoint check_even (n : nat) : bool :=
  match n with
  | 0 => true
  | 1 => false
  | S (S n') => check_even n'
  end.

(* To prove [check_even] sound, we need two IH strengthenings:
 * - Effectively switch to _strong induction_ with an extra numeric variable,
 *   asserted to be less than the one we induct on.
 * - Express both cases for how a [check_even] test might turn out. *)
Lemma check_even_ok' : forall n n', n' < n
  -> if check_even n' then isEven n' else ~isEven n'.
Proof.
  induct n; simplify.

  linear_arithmetic.

  cases n'; simplify.
  constructor.
  cases n'; simplify.
  propositional.
  invert H0.
  specialize (IHn n').
  cases (check_even n').
  constructor.
  apply IHn.
  linear_arithmetic.
  propositional.
  invert H0.
  apply IHn.
  linear_arithmetic.
  assumption.
Qed.

Theorem check_even_ok : forall n, check_even n = true -> isEven n.
Proof.
  simplify.
  assert (n < S n) by linear_arithmetic.
  apply check_even_ok' in H0.
  rewrite H in H0.
  assumption.
Qed.

(* As this theorem establishes, the function [check_even] may be viewed as a
 * _verified decision procedure_.  It is now trivial to write a tactic to prove
 * evenness. *)

Ltac prove_even_reflective :=
  match goal with
    | [ |- isEven ?N] => apply check_even_ok; reflexivity
  end.

Theorem even_256' : isEven 256.
Proof.
  prove_even_reflective.
Qed.

Set Printing All.
Print even_256'.
Unset Printing All.

(* Notice that only one [nat] appears as an argument to an applied lemma, and
 * that's the original number to test for evenness.  Proof-term size scales
 * linearly.
 *
 * What happens if we try the tactic with an odd number? *)

Theorem even_255 : isEven 255.
Proof.
  (*prove_even_reflective.*)
Abort.
(* Coq reports that [reflexivity] can't prove [false = true], which makes
 * perfect sense! *)

(* Our tactic [prove_even_reflective] is reflective because it performs a
 * proof-search process (a trivial one, in this case) wholly within Gallina. *)

(** * Reifying the Syntax of a Trivial Tautology Language *)

(* We might also like to have reflective proofs of trivial tautologies like
 * this one: *)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
Proof.
  tauto.
Qed.

Print true_galore.

(* As we might expect, the proof that [tauto] builds contains explicit
 * applications of deduction rules.  For large formulas, this can add a linear
 * amount of proof-size overhead, beyond the size of the input.
 *
 * To write a reflective procedure for this class of goals, we will need to get
 * into the actual "reflection" part of "proof by reflection."  It is impossible
 * to case-analyze a [Prop] in any way in Gallina.  We must_reify_ [Prop] into
 * some type that we _can_ analyze.  This inductive type is a good candidate: *)

(* begin thide *)
Inductive taut : Set :=
| TautTrue : taut
| TautAnd : taut -> taut -> taut
| TautOr : taut -> taut -> taut
| TautImp : taut -> taut -> taut.

(* We write a recursive function to _reflect_ this syntax back to [Prop].  Such
 * functions are also called _interpretation functions_, and we have used them
 * in previous examples to give semantics to small programming languages. *)

Fixpoint tautDenote (t : taut) : Prop :=
  match t with
    | TautTrue => True
    | TautAnd t1 t2 => tautDenote t1 /\ tautDenote t2
    | TautOr t1 t2 => tautDenote t1 \/ tautDenote t2
    | TautImp t1 t2 => tautDenote t1 -> tautDenote t2
  end.

(* It is easy to prove that every formula in the range of [tautDenote] is
 * true. *)

Theorem tautTrue : forall t, tautDenote t.
Proof.
  induct t; simplify; propositional.
Qed.

(* To use [tautTrue] to prove particular formulas, we need to implement the
 * syntax-reification process.  A recursive Ltac function does the job. *)

Ltac tautReify P :=
  match P with
    | True => TautTrue
    | ?P1 /\ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautAnd t1 t2)
    | ?P1 \/ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautOr t1 t2)
    | ?P1 -> ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautImp t1 t2)
  end.

(* With [tautReify] available, it is easy to finish our reflective tactic.  We
 * look at the goal formula, reify it, and apply [tautTrue] to the reified
 * formula.  Recall that the [change] tactic replaces a conclusion formula with
 * another that is equal to it, as shown by partial execution of terms. *)

Ltac obvious :=
  match goal with
    | [ |- ?P ] =>
      let t := tautReify P in
      change (tautDenote t); apply tautTrue
  end.

(* We can verify that [obvious] solves our original example, with a proof term
 * that does not mention details of the proof. *)

Theorem true_galore' : (True /\ True) -> (True \/ (True /\ (True -> True))).
Proof.
  obvious.
Qed.

Set Printing All.
Print true_galore'.
Unset Printing All.

(* It is worth considering how the reflective tactic improves on a pure-Ltac
 * implementation.  The formula-reification process is just as ad-hoc as before,
 * so we gain little there.  In general, proofs will be more complicated than
 * formula translation, and the "generic proof rule" that we apply here _is_ on
 * much better formal footing than a recursive Ltac function.  The dependent
 * type of the proof guarantees that it "works" on any input formula.  This
 * benefit is in addition to the proof-size improvement that we have already
 * seen.
 *
 * It may also be worth pointing out that our previous example of evenness
 * testing used a test [check_even] that could sometimes fail, while here we
 * avoid the extra Boolean test by identifying a syntactic class of formulas
 * that are always true by construction.  Of course, many interesting proof
 * steps don't have that structure, so let's look at an example that still
 * requires extra proving after the reflective step. *)

(** * A Monoid Expression Simplifier *)

(* Proof by reflection does not require encoding of all of the syntax in a goal.
 * We can insert "variables" in our syntax types to allow injection of arbitrary
 * pieces, even if we cannot apply specialized reasoning to them.  In this
 * section, we explore that possibility by writing a tactic for normalizing
 * monoid equations. *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A -> A.

  Infix "+" := f.

  Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
  Hypothesis identl : forall a, e + a = a.
  Hypothesis identr : forall a, a + e = a.

  (* We add variables and hypotheses characterizing an arbitrary instance of the
   * algebraic structure of monoids.  We have an associative binary operator and
   * an identity element for it.
   *
   * It is easy to define an expression-tree type for monoid expressions.  A
   * [Var] constructor is a "catch-all" case for subexpressions that we cannot
   * model.  These subexpressions could be actual Gallina variables, or they
   * could just use functions that our tactic is unable to understand. *)

  Inductive mexp : Set :=
  | Ident : mexp
  | Var : A -> mexp
  | Op : mexp -> mexp -> mexp.

  (* Next, we write an interpretation function. *)

  Fixpoint mdenote (me : mexp) : A :=
    match me with
      | Ident => e
      | Var v => v
      | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  (* We will normalize expressions by flattening them into lists, via
   * associativity, so it is helpful to have a denotation function for lists of
   * monoid values. *)

  Fixpoint mldenote (ls : list A) : A :=
    match ls with
      | nil => e
      | x :: ls' => x + mldenote ls'
    end.

  (* The flattening function itself is easy to implement. *)

  Fixpoint flatten (me : mexp) : list A :=
    match me with
      | Ident => []
      | Var x => [x]
      | Op me1 me2 => flatten me1 ++ flatten me2
    end.

  (* This function has a straightforward correctness proof in terms of our
   * [denote] functions. *)

  Lemma flatten_correct' : forall ml2 ml1,
    mldenote (ml1 ++ ml2) = mldenote ml1 + mldenote ml2.
  Proof.
    induction ml1; simplify; equality.
  Qed.

  Hint Rewrite flatten_correct'.

  Theorem flatten_correct : forall me, mdenote me = mldenote (flatten me).
  Proof.
    induction me; simplify; equality.
  Qed.

  (* Now it is easy to prove a theorem that will be the main tool behind our
   * simplification tactic. *)

  Theorem monoid_reflect : forall me1 me2,
    mldenote (flatten me1) = mldenote (flatten me2)
    -> mdenote me1 = mdenote me2.
  Proof.
    simplify; repeat rewrite flatten_correct; assumption.
  Qed.

  (* We implement reification into the [mexp] type. *)

  Ltac reify me :=
    match me with
      | e => Ident
      | ?me1 + ?me2 =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          constr:(Op r1 r2)
      | _ => constr:(Var me)
    end.

  (* The final [monoid] tactic works on goals that equate two monoid terms.  We
   * reify each and change the goal to refer to the reified versions, finishing
   * off by applying [monoid_reflect] and simplifying uses of [mldenote]. *)

  Ltac monoid :=
    match goal with
      | [ |- ?me1 = ?me2 ] =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          change (mdenote r1 = mdenote r2);
            apply monoid_reflect; simplify
    end.

  (* We can make short work of theorems like this one: *)

  Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
    simplify; monoid.

    (* Our tactic has canonicalized both sides of the equality, such that we can
     * finish the proof by reflexivity. *)

    reflexivity.
  Qed.

  (* It is interesting to look at the form of the proof. *)

  Set Printing All.
  Print t1.
  Unset Printing All.

  (* The proof term contains only restatements of the equality operands in
   * reified form, followed by a use of reflexivity on the shared canonical
   * form. *)
End monoid.

(* Extensions of this basic approach are used in the implementations of the
 * [ring] and [field] tactics that come packaged with Coq. *)

(** * Set Simplification for Model Checking *)

(* Let's take a closer look at model-checking proofs like from last class. *)

(* Here's a simple transition system, where state is just a [nat], and where
 * each step subtracts 1 or 2. *)

Inductive subtract_step : nat -> nat -> Prop :=
| Subtract1 : forall n, subtract_step (S n) n
| Subtract2 : forall n, subtract_step (S (S n)) n.

Definition subtract_sys (n : nat) : trsys nat := {|
  Initial := {n};
  Step := subtract_step
|}.

Lemma subtract_ok :
  invariantFor (subtract_sys 5)
               (fun n => n <= 5).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.
  (* Here we'll see that the Frap libary uses slightly different, optimized
   * versions of the model-checking relations.  For instance, [multiStepClosure]
   * takes an extra set argument, the _worklist_ recording newly discovered
   * states.  There is no point in following edges out of states that were
   * already known at previous steps. *)

  (* Now, some more manual iterations: *)
  eapply MscStep.
  closure.
  (* Ew.  What a big, ugly set expression.  Let's shrink it down to something
   * more readable, with duplicates removed, etc. *)
  simplify.
  (* How does the Frap library do that?  Proof by reflection is a big part of
   * it!  Let's develop a baby version of that automation.  The full-scale
   * version is in file Sets.v. *)
Abort.

(* We'll specialize our representation to unions of set literals, whose elements
 * are constant [nat]s.  The full-scale version in the library is more
 * flexible. *)
Inductive setexpr :=
| Literal (ns : list nat)
| Union (e1 e2 : setexpr).

(* Here's what our expressions mean. *)
Fixpoint setexprDenote (e : setexpr) : set nat :=
  match e with
  | Literal ns => constant ns
  | Union e1 e2 => setexprDenote e1 \cup setexprDenote e2
  end.

(* Simplification reduces all expressions to flat, duplicate-free set
 * literals. *)
Fixpoint normalize (e : setexpr) : list nat :=
  match e with
  | Literal ns => dedup ns
  | Union e1 e2 => setmerge (normalize e1) (normalize e2)
  end.
(* Here we use functions [dedup] and [setmerge] from the Sets module, which is
 * especially handy because that module has proved some key theorems about
 * them. *)

(* Let's prove that normalization doesn't change meaning. *)
Theorem normalize_ok : forall e,
    setexprDenote e = constant (normalize e).
Proof.
  induct e; simpl. (* Here we use the more primitive [simpl], because [simplify]
                    * calls the fancier set automation from the book library,
                    * which would be "cheating." *)

  pose proof (constant_dedup (fun x => x) ns).
  repeat rewrite map_id in H.
  equality.

  rewrite IHe1, IHe2.
  pose proof (constant_map_setmerge (fun x => x) (normalize e2) (normalize e1)).
  repeat rewrite map_id in H.
  equality.
Qed.

(* Reification works as before, with one twist. *)
Ltac reify_set E :=
  match E with
  | constant ?ns => constr:(Literal ns)
  | ?E1 \cup ?E2 =>
    let e1 := reify_set E1 in
    let e2 := reify_set E2 in
    constr:(Union e1 e2)
  | _ => let pf := constr:(eq_refl : E = {}) in constr:(Literal [])
    (* The twist is in this case: we instantiate all unification variables with
     * the empty set.  It's a sound proof step, and it so happens that we only
     * call this tactic in spots where this heuristic makes sense. *)
  end.

(* Now the usual recipe for a reflective tactic, this time using rewriting
 * instead of [apply] for the key step, to allow simplification deep within the
 * structure of a goal. *)
Ltac simplify_set :=
  match goal with
  | [ |- context[?X \cup ?Y] ] =>
    let e := reify_set (X \cup Y) in
    let Heq := fresh in
    assert (Heq : X \cup Y = setexprDenote e) by reflexivity;
    rewrite Heq; clear Heq;
    rewrite normalize_ok; simpl
  end.

(* Back to our example, which we can now finish without calling [simplify] to
 * reduces trees of union operations. *)
Lemma subtract_ok :
  invariantFor (subtract_sys 5)
               (fun n => n <= 5).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.

  (* Now, some more manual iterations: *)
  eapply MscStep.
  closure.
  simplify_set.
  (* Success!  One subexpression shrunk.  Now for the other. *)
  simplify_set.
  (* Our automation doesn't handle set difference, so we finish up calling the
   * library tactic. *)
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  model_check_done.

  simplify.
  linear_arithmetic.
Qed.

(** * A Smarter Tautology Solver *)

(* Now we are ready to revisit our earlier tautology-solver example.  We want to
 * broaden the scope of the tactic to include formulas whose truth is not
 * syntactically apparent.  We will want to allow injection of arbitrary
 * formulas, like we allowed arbitrary monoid expressions in the last example.
 * Since we are working in a richer theory, it is important to be able to use
 * equalities between different injected formulas.  For instance, we cannot
 * prove [P -> P] by translating the formula into a value like
 * [Imp (Var P) (Var P)], because a Gallina function has no way of comparing the
 * two [P]s for equality. *)

(* We introduce a synonym for how we name variables: natural numbers. *)
Definition propvar := nat.

Inductive formula : Set :=
| Atomic : propvar -> formula
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.

(* Now we can define our denotation function.  First, a type of truth-value
 * assignments to propositional variables: *)
Definition asgn := nat -> Prop.

Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => atomics v
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 -> formulaDenote atomics f2
  end.

Section my_tauto.
  Variable atomics : asgn.

  (* Now we are ready to define some helpful functions based on the [ListSet]
   * module of the standard library, which (unsurprisingly) presents a view of
   * lists as sets. *)

  Require Import ListSet.

  (* The [eq_nat_dec] below is a richly typed equality test on [nat]s.  We'll
   * get to the ideas behind it next week. *)
  Definition add (s : set propvar) (v : propvar) := set_add eq_nat_dec v s.

  (* We define what it means for all members of an variable set to represent
   * true propositions, and we prove some lemmas about this notion. *)

  Fixpoint allTrue (s : set propvar) : Prop :=
    match s with
      | nil => True
      | v :: s' => atomics v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> atomics v
    -> allTrue (add s v).
  Proof.
    induct s; simplify; propositional;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; simplify; propositional.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> atomics v.
  Proof.
    induct s; simplify; equality.
  Qed.

  (* Now we can write a function [forward] that implements deconstruction of
   * hypotheses, expanding a compound formula into a set of sets of atomic
   * formulas covering all possible cases introduced with use of [Or].  To
   * handle consideration of multiple cases, the function takes in a
   * continuation argument (advanced functional-programming feature that often
   * puzzles novices, so don't worry if it takes a while to digest!), which will
   * be called once for each case. *)

  Fixpoint forward (f : formula) (known : set propvar) (hyp : formula)
           (cont : set propvar -> bool) : bool :=
    match hyp with
    | Atomic v => cont (add known v)
    | Truth => cont known
    | Falsehood => true
    | And h1 h2 => forward (Imp h2 f) known h1 (fun known' =>
                     forward f known' h2 cont)
    | Or h1 h2 => forward f known h1 cont && forward f known h2 cont
    | Imp _ _ => cont known
    end.

  (* A [backward] function implements analysis of the final goal.  It calls
   * [forward] to handle implications. *)

  Fixpoint backward (known : set propvar) (f : formula) : bool :=
    match f with
    | Atomic v => if In_dec eq_nat_dec v known then true else false
    | Truth => true
    | Falsehood => false
    | And f1 f2 => backward known f1 && backward known f2
    | Or f1 f2 => backward known f1 || backward known f2
    | Imp f1 f2 => forward f2 known f1 (fun known' => backward known' f2)
    end.
End my_tauto.

Lemma forward_ok : forall atomics hyp f known cont,
    forward f known hyp cont = true
    -> (forall known', allTrue atomics known'
                       -> cont known' = true
                       -> formulaDenote atomics f)
    -> allTrue atomics known
    -> formulaDenote atomics hyp
    -> formulaDenote atomics f.
Proof.
  induct hyp; simplify; propositional.

  apply H0 with (known' := add known p).
  apply allTrue_add.
  assumption.
  assumption.
  assumption.

  eapply H0.
  eassumption.
  assumption.

  eapply IHhyp1 in H.
  simplify; propositional.
  simplify.
  eapply IHhyp2.
  eassumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHhyp1.
  eassumption.
  assumption.
  assumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHhyp2.
  eassumption.
  assumption.
  assumption.
  assumption.

  eapply H0.
  eassumption.
  assumption.
Qed.

Lemma backward_ok' : forall atomics f known,
    backward known f = true
    -> allTrue atomics known
    -> formulaDenote atomics f.
Proof.
  induct f; simplify; propositional.

  cases (in_dec Nat.eq_dec p known); propositional.
  eapply allTrue_In.
  eassumption.
  unfold set_In.
  assumption.
  equality.

  equality.

  apply andb_true_iff in H; propositional.
  eapply IHf1.
  eassumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHf2.
  eassumption.
  assumption.

  apply orb_true_iff in H; propositional.
  left.
  eapply IHf1.
  eassumption.
  assumption.
  right.
  eapply IHf2.
  eassumption.
  assumption.

  eapply forward_ok.
  eassumption.
  simplify.
  eapply IHf2.
  eassumption.
  assumption.
  assumption.
  assumption.
Qed.

Theorem backward_ok : forall f,
    backward [] f = true
    -> forall atomics, formulaDenote atomics f.
Proof.
  simplify.
  apply backward_ok' with (known := []).
  assumption.
  simplify.
  propositional.
Qed.

(* Find the position of an element in a list. *)
Ltac position x ls :=
  match ls with
  | [] => constr:(@None nat)
  | x :: _ => constr:(Some 0)
  | _ :: ?ls' =>
    let p := position x ls' in
    match p with
    | None => p
    | Some ?n => constr:(Some (S n))
    end
  end.

(* Compute a duplicate-free list of all variables in [P], combining it with
 * [acc]. *)
Ltac vars_in P acc :=
  match P with
  | True => acc
  | False => acc
  | ?Q1 /\ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 \/ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 -> ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | _ =>
    let pos := position P acc in
    match pos with
    | Some _ => acc
    | None => constr:(P :: acc)
    end
  end.

(* Reification of formula [P], with a pregenertaed list [vars] of variables it
 * may mention *)
Ltac reify_tauto' P vars :=
  match P with
  | True => Truth
  | False => Falsehood
  | ?Q1 /\ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(And q1 q2)
  | ?Q1 \/ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Or q1 q2)
  | ?Q1 -> ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Imp q1 q2)
  | _ =>
    let pos := position P vars in
    match pos with
    | Some ?pos' => constr:(Atomic pos')
    end
  end.

(* Our final tactic implementation is now fairly straightforward.  First, we
 * [intro] all quantifiers that do not bind [Prop]s.  Then we reify.  Finally,
 * we call the verified procedure through a lemma. *)

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1
               | _ => intro
             end
         end;
  match goal with
    | [ |- ?P ] =>
      let vars := vars_in P (@nil Prop) in
      let p := reify_tauto' P vars in
      change (formulaDenote (nth_default False vars) p)
  end;
  apply backward_ok; reflexivity.

(* A few examples demonstrate how the tactic works: *)

Theorem mt1 : True.
Proof.
  my_tauto.
Qed.

Print mt1.

Theorem mt2 : forall x y : nat, x = y -> x = y.
Proof.
  my_tauto.
Qed.

Print mt2.

(* Crucially, both instances of [x = y] are represented with the same variable
 * 0. *)

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
Proof.
  my_tauto.
Qed.

Print mt3.

(* Our goal contained three distinct atomic formulas, and we see that a
 * three-element environment is generated.
 *
 * It can be interesting to observe differences between the level of repetition
 * in proof terms generated by [my_tauto] and [tauto] for especially trivial
 * theorems. *)

Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
Proof.
  my_tauto.
Qed.

Print mt4.

Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
Proof.
  tauto.
Qed.

Print mt4'.

(* The traditional [tauto] tactic introduces a quadratic blow-up in the size of
 * the proof term, whereas proofs produced by [my_tauto] always have linear
 * size. *)


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type :=Zero : natural | Succ : natural -> natural .

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 plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint exp (exp_arg0 : natural) (exp_arg1 : natural) : natural
           := match exp_arg0, exp_arg1 with
              | n, Zero => Succ Zero
              | n, Succ m => mult (exp n m) n
              end.

Fixpoint qexp (qexp_arg0 : natural) (qexp_arg1 : natural) (qexp_arg2 : natural) : natural
           := match qexp_arg0, qexp_arg1, qexp_arg2 with
              | n, Zero, m => m
              | n, Succ m, p => qexp n m (mult p n)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x). rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
   intros.
   induction x.
   - rewrite mult_zero. reflexivity.
   - simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl.  rewrite IHx.  rewrite plus_assoc. lfind.  rewrite <- plus_assoc.  reflexivity.
Admitted.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : natural), eq (mult (exp x y) z) (qexp x y z).
Proof.
   intros.
   generalize dependent z.
   induction y.
   - reflexivity.
   - intros. simpl. rewrite <- IHy. rewrite mult_assoc. rewrite (mult_commut x z). reflexivity.
Qed.


Require Import HoTT.
Require Import ED.polynomial.
Require Import ED.hit_structure.

(** A groupoid consists of a relation with a certain structure.
   This relation has two parts.
   First of all, it has objects.
   Second of all, for each pair of objects there is a set of arrows between them.
*)
Definition relation (A : Type) := A -> A -> Type.

(** Now we can define what a groupoid is.
    In addition to a relation, we also have algebraic structure.
*)
Record groupoid (A : Type) :=
  Build_grpd { hom : relation A ;
               e : forall (x : A), hom x x ;
               inv : forall (x y : A), hom x y -> hom y x ;
               comp : forall (x y z : A), hom x y -> hom y z -> hom x z ;
               ca : forall (x y z v : A) (p : hom x y) (q : hom y z) (r : hom z v),
                   comp _ _ _ p (comp _ _ _ q r) = comp _ _ _ (comp _ _ _ p q) r ;
               ce : forall (x y : A) (p : hom x y), comp x y y p (e y) = p ;
               ec : forall (x y : A) (p : hom x y), comp x x y (e x) p = p ;
               ci : forall (x y : A) (p : hom x y), comp x y x p (inv x y p) = e x ;
               ic : forall (x y : A) (p : hom x y), comp y x y (inv x y p) p = e y ;
             }.

Arguments e {_} {_} _.
Arguments hom {_} _.
Arguments inv {_} {_} {_} {_}.
Notation "p × q" := (comp _ _ _ _ _ p q) (at level 80).

(** Now let's discuss some examples of groupoids.
    The first example is the paths on a certain type.
*)
Definition path_space (X : Type) : relation X
  := fun (x y : X) => x = y.

Definition path_groupoid (X : Type) : groupoid X.
Proof.
  unshelve esplit ; simpl.
  - exact (path_space X).
  - exact (fun _ => idpath).
  - exact (fun _ _ => fun p => p^).
  - exact (fun _ _ _ p q => p @ q).
  - intros ; apply concat_p_pp.
  - intros ; apply concat_p1.
  - intros ; apply concat_1p.
  - intros ; apply concat_pV.
  - intros ; apply concat_Vp.
Defined.

(** Groupoids are closed under products. *)
Definition prod_groupoid
           (A B : Type) (G₁ : groupoid A) (G₂ : groupoid B)
  : groupoid (A * B).
Proof.
  unshelve esplit.
  - exact (fun x y => hom G₁ (fst x) (fst y) * hom G₂ (snd x) (snd y)).
  - intros ; simpl.
    split ; apply e.
  - intros ? ? [p1 p2] ; simpl.
    exact (inv p1, inv p2).
  - intros ? ? ? [p1 p2] [q1 q2].
    exact (p1 × q1, p2 × q2).
  - intros ? ? ? ? [p1 p2] [q1 q2] [r1 r2].
    apply path_prod ; apply ca.
  - intros ? ? [p1 p2].
    apply path_prod ; apply ce.
  - intros ? ? [p1 p2].
    apply path_prod ; apply ec.
  - intros ? ? [p1 p2].
    apply path_prod ; apply ci.
  - intros ? ? [p1 p2].
    apply path_prod ; apply ic.
Defined.

(** Groupoids are closed under sums. *)
Definition sum_groupoid
           (A B : Type) (G₁ : groupoid A) (G₂ : groupoid B)
  : groupoid (A + B).
Proof.
  unshelve esplit.
  - exact (fun x y =>
             match x, y with
             | inl x, inl y => hom G₁ x y
             | inl _, inr _ => Empty
             | inr _, inl _ => Empty
             | inr x, inr y => hom G₂ x y
             end).
  - intros [x | x] ; apply e.
  - intros [? | ?] [? | ?] ; contradiction || apply inv.
  - intros [? | ?] [? | ?] [? | ?] ; contradiction || apply comp.
  - intros [? | ?] [? | ?] [? | ?] [? | ?] ; try contradiction ; apply ca.
  - intros [? | ?] [? | ?] ; try contradiction ; apply ce.
  - intros [? | ?] [? | ?] ; try contradiction ; apply ec.
  - intros [? | ?] [? | ?] ; try contradiction ; apply ci.
  - intros [? | ?] [? | ?] ; try contradiction ; apply ic.
Defined.

(** We can apply polynomial functors to groupoids. *)
Definition lift_groupoid
           {A : Type} (G : groupoid A) (P : polynomial)
  : groupoid (poly_act P A).
Proof.
  induction P ; simpl.
  - exact G.
  - exact (path_groupoid T).
  - apply prod_groupoid ; assumption.
  - apply sum_groupoid ; assumption.
Defined.

(** To give specifications for these constructions, we need to define morphisms of groupoids.
    For that, we first define morphisms of relations.
    These come in two kinds: the underlying type could be the same or we have a map between them.
*)
Definition relation_morph
           {A B : Type}
           (f : A -> B)
           (R₁ : relation A) (R₂ : relation B)
  := forall (x y : A), R₁ x y -> R₂ (f x) (f y).

(** A groupoid morphism is a relation morphism which preserves the algebraic structure. *)
Class is_grpd_morph
      {A B : Type}
      (f : A -> B)
      {G₁ : groupoid A} {G₂ : groupoid B}
      (map : relation_morph f (hom G₁) (hom G₂))
  := { morph_e : forall (x : A), map _ _ (e x) = e (f x) ;
       morph_i : forall (x y : A) (p : hom G₁ x y),
           map _ _ (inv p) = inv (map _ _ p) ;
       morph_c : forall (x y z : A) (p : hom G₁ x y) (q : hom G₁ y z),
           map x z (p × q) = (map x y p × map y z q)
     }.

Class is_Agrpd_morph
      {A : Type}
      {G₁ G₂ : groupoid A}
      (Amap : relation_morph idmap (hom G₁) (hom G₂))
  := is_idd_Agrpd_morph : is_grpd_morph idmap Amap.

Global Instance to_grpd_morph
       {A : Type}
       {G₁ G₂ : groupoid A}
       (Amap : relation_morph idmap (hom G₁) (hom G₂))
       `{is_Agrpd_morph _ _ _ Amap}
  : is_grpd_morph idmap Amap.
Proof.
  assumption.
Defined.

Arguments morph_e {_} {_} _ {_} {_} _ {_} _.
Arguments morph_i {_} {_} _ {_} {_} _ {_} _ _ _.
Arguments morph_c {_} {_} _ {_} {_} _ {_} _ _ _ _ _.

(** We need the identity. *)
Definition id_relation_morph {A : Type} (G₁ : groupoid A)
  : relation_morph idmap (hom G₁) (hom G₁)
  := fun _ _ => idmap.

Global Instance id_is_Agrpd_morph {A : Type} (G₁ : groupoid A)
  : @is_Agrpd_morph A G₁ G₁ (id_relation_morph G₁).
Proof.
  esplit; reflexivity.
Defined.

(** Now we show lifting is functorial. *)
Definition sum_func
           {A B : Type}
           (G₁ : groupoid A) (G₂ : groupoid B)
           (G₃ : groupoid A) (G₄ : groupoid B)
           (F₁ : relation_morph idmap (hom G₁) (hom G₃))
           (F₂ : relation_morph idmap (hom G₂) (hom G₄))
  : relation_morph idmap (hom (sum_groupoid _ _ G₁ G₂)) (hom (sum_groupoid _ _ G₃ G₄)).
Proof.
  intros [x | x] [y | y] p ; try contradiction.
  * exact (F₁ _ _ p).
  * exact (F₂ _ _ p).
Defined.

Global Instance sum_func_grpd
           {A B : Type}
           (G₁ : groupoid A) (G₂ : groupoid B)
           (G₃ : groupoid A) (G₄ : groupoid B)
           (F₁ : relation_morph idmap (hom G₁) (hom G₃))
           (F₂ : relation_morph idmap (hom G₂) (hom G₄))
           `{is_Agrpd_morph _ _ _ F₁}
           `{is_Agrpd_morph _ _ _ F₂}
  : is_Agrpd_morph (sum_func _ _ _ _ F₁ F₂).
Proof.
  unshelve eexists.
  + intros [x | x] ; simpl.
    * exact (morph_e _ F₁ _).
    * exact (morph_e _ F₂ _).
  + intros [x | x] [y | y] p ; try contradiction ; simpl.
    * exact (morph_i _ F₁ _ _ _).
    * exact (morph_i _ F₂ _ _ _).
  + intros [x | x] [y | y] [z | z] p q ; try contradiction ; simpl.
    * exact (morph_c _ F₁ _ _ _ _ _).
    * exact (morph_c _ F₂ _ _ _ _ _).
Defined.

Definition prod_func
           {A B : Type}
           (G₁ : groupoid A) (G₂ : groupoid B)
           (G₃ : groupoid A) (G₄ : groupoid B)
           (F₁ : relation_morph idmap (hom G₁) (hom G₃))
           (F₂ : relation_morph idmap (hom G₂) (hom G₄))
  : relation_morph idmap (hom (prod_groupoid _ _ G₁ G₂)) (hom (prod_groupoid _ _ G₃ G₄)).
Proof.
  intros [x1 x2] [y1 y2] p.
  split.
  * exact (F₁ _ _ (fst p)).
  * exact (F₂ _ _ (snd p)).
Defined.

Global Instance prod_func_grpd
       {A B : Type}
       (G₁ : groupoid A) (G₂ : groupoid B)
       (G₃ : groupoid A) (G₄ : groupoid B)
       (F₁ : relation_morph idmap (hom G₁) (hom G₃))
       (F₂ : relation_morph idmap (hom G₂) (hom G₄))
       `{is_Agrpd_morph _ _ _ F₁}
       `{is_Agrpd_morph _ _ _ F₂}
  : is_Agrpd_morph (prod_func _ _ _ _ F₁ F₂).
Proof.
  unshelve eexists.
  + intros [x1 x2] ; simpl.
    apply path_prod'.
    * exact (morph_e _ F₁ _).
    * exact (morph_e _ F₂ _).
  + intros [x1 x2] [y1 y2] p ; simpl.
    apply path_prod'.
    * exact (morph_i _ F₁ _ _ _).
    * exact (morph_i _ F₂ _ _ _).
  + intros [x1 x2] [y1 y2] [z1 z2] p q ; simpl.
    apply path_prod'.
    * exact (morph_c _ F₁ _ _ _ _ _).
    * exact (morph_c _ F₂ _ _ _ _ _).
Defined.

Definition poly_func
           {A : Type}
           (P : polynomial)
           (G₁ G₂ : groupoid A)
           (F₁ : relation_morph idmap (hom G₁) (hom G₂))
  : relation_morph idmap (hom (lift_groupoid G₁ P)) (hom (lift_groupoid G₂ P)).
Proof.
  induction P ; simpl.
  - exact F₁.
  - apply (id_relation_morph (path_groupoid T)).
  - apply prod_func ; assumption.
  - apply sum_func ; assumption.
Defined.

Global Instance poly_func_grpd
       {A : Type}
       (P : polynomial)
       (G₁ G₂ : groupoid A)
       (F₁ : relation_morph idmap (hom G₁) (hom G₂))
       `{is_Agrpd_morph _ _ _ F₁}
  : is_Agrpd_morph (poly_func P G₁ G₂ F₁).
Proof.
  induction P ; apply _.
Defined.

(** Now we suppose that we are given a HIT.
    We define a class of groupoids with the same structure as the path space of that HIT.
*)
Section H_alg.
  Variable (Σ : hit_signature) (H : HIT Σ).

  (** First of all, we have the `ap` operation on paths.
      This gives an algebra structure using the lifted groupoid.
   *)
  (** For every constuctor `C_i : P_i[H] -> H` of `H`, require a morphism
        P_i[G] -> G
      which lies over `C_i`.
   *)
  Definition hit_point_morph (G : groupoid H) (i : sig_point_index Σ) :=
    relation_morph
      (hit_point i)
      (hom (lift_groupoid G (sig_point Σ i)))
      (hom G).

  Definition P_alg (G : groupoid H) : Type
    := forall (i : sig_point_index Σ), hit_point_morph G i.

  (** Second of all, we need to have the path constructors. *)
  Definition contains
             {A B : Type}
             (G : groupoid B)
             (f g : A -> B)
    := forall (x : A), hom G (f x) (g x).

  (** Lastly, we need a coherency.
      The path constructors can be obtained in two ways.
      Either we can use `contains` or we can use `transport`.
   *)
  Definition coherent
             (j : sig_path_index Σ)
             (G : groupoid H)
             (Gpath : contains G
                   (endpoint_act hit_point (sig_path_lhs Σ j))
                   (endpoint_act hit_point (sig_path_rhs Σ j)))
    : Type
    := forall (u : poly_act (sig_path_param Σ j) H),
      Gpath u = transport (fun z => hom G _ z) (hit_path j u) (e _).

  (** Now we can define the structure of the path space. *)
  Record Halg :=
    { H_grpd : groupoid H ;
      point_alg : P_alg H_grpd ;
      point_alg_grpd :
        forall (i : sig_point_index Σ),
          is_grpd_morph (hit_point i) (point_alg i);
      path_alg : forall (j : sig_path_index Σ),
          contains H_grpd
                   (endpoint_act hit_point (sig_path_lhs Σ j))
                   (endpoint_act hit_point (sig_path_rhs Σ j)) ;
      coherent_alg : forall (j : sig_path_index Σ),
          coherent j H_grpd (path_alg j)
    }.

  (** For the morphisms, we have multiple requirements. *)
  Definition preserves_alg
             {G₁ G₂ : Halg}
             (F : relation_morph idmap (hom (H_grpd G₁)) (hom (H_grpd G₂)))
    : Type
    := forall (i : sig_point_index Σ)
              (a₁ a₂ : poly_act (sig_point Σ i) H)
              (x : hom (lift_groupoid (H_grpd G₁) (sig_point Σ i)) a₁ a₂),
      F _ _ ((point_alg G₁ i) _ _ x)
      =
      (point_alg G₂ i)
        _
        _
        ((poly_func (sig_point Σ i) (H_grpd G₁) (H_grpd G₂) F) _ _ x).

  Definition preserves_paths
             {G₁ G₂ : Halg}
             (F : relation_morph idmap (hom (H_grpd G₁)) (hom (H_grpd G₂)))
    : Type
    := forall (j : sig_path_index Σ) (u : poly_act (sig_path_param Σ j) H),
      path_alg G₂ j u = F _ _ (path_alg G₁ j u).

  Class isHalg_morph
        (G₁ G₂ : Halg)
        (F : relation_morph idmap (hom (H_grpd G₁)) (hom (H_grpd G₂)))
    := { p_alg : preserves_alg F ;
         p_paths : preserves_paths F}.
End H_alg.


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed. (* The assertion we've just made
can be proved by observing that both sides of the equality
evaluate to the same thing *)

(* def bool type *)

Inductive bool : Type :=
  | true
  | false.

(* functions over booleans *)
Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.
Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.
Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

(* using Notation *)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).
Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

(* conditional expressions *)
Definition negb' (b:bool) : bool :=
  if b then false
  else true.


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.bitblast.
Require Import coqutil.Z.ZLib.
Require Import coqutil.Z.Lia.
Require Import coqutil.Z.div_mod_to_equations.

Local Open Scope Z_scope.

Lemma or_to_plus: forall a b,
    Z.land a b = 0 ->
    Z.lor a b = a + b.
Proof.
  intros.
  rewrite <- Z.lxor_lor by assumption.
  symmetry. apply Z.add_nocarry_lxor. assumption.
Qed.

(** ** bitSlice *)

Definition bitSlice(x: Z)(start eend: Z): Z :=
  Z.land (Z.shiftr x start) (Z.lnot (Z.shiftl (-1) (eend - start))).

Definition bitSlice'(w start eend: Z): Z :=
  (w / 2 ^ start) mod (2 ^ (eend - start)).

Lemma bitSlice_alt: forall w start eend,
    0 <= start <= eend ->
    bitSlice w start eend = bitSlice' w start eend.
Proof.
  intros. unfold bitSlice, bitSlice'.
  rewrite <- Z.land_ones by blia.
  rewrite <- Z.shiftr_div_pow2 by blia.
  f_equal.
  rewrite Z.shiftl_mul_pow2 by blia.
  rewrite Z.mul_comm.
  rewrite <- Z.opp_eq_mul_m1.
  replace (Z.lnot (- 2 ^ (eend - start))) with (2 ^ (eend - start) - 1).
  - rewrite Z.ones_equiv. reflexivity.
  - pose proof (Z.add_lnot_diag (- 2 ^ (eend - start))). blia.
Qed.

Lemma bitSlice_range: forall sz z,
    0 <= sz ->
    0 <= bitSlice z 0 sz < 2 ^ sz.
Proof.
  intros.
  rewrite bitSlice_alt by blia.
  unfold bitSlice'.
  change (2 ^ 0) with 1.
  rewrite Z.div_1_r.
  rewrite Z.sub_0_r.
  apply Z.mod_pos_bound.
  apply Z.pow_pos_nonneg; blia.
Qed.

Lemma bitSlice_split: forall sz1 sz2 v,
    0 <= sz1 ->
    0 <= sz2 ->
    bitSlice v sz1 (sz1 + sz2) * 2 ^ sz1 + bitSlice v 0 sz1 = bitSlice v 0 (sz1 + sz2).
Proof.
  intros. rewrite? bitSlice_alt by blia. unfold bitSlice'.
  change (2 ^ 0)%Z with 1%Z.
  rewrite Z.div_1_r.
  rewrite! Z.sub_0_r.
  replace (sz1 + sz2 - sz1)%Z with sz2 by blia.
  rewrite Z.pow_add_r by assumption.
  assert (0 < 2 ^ sz1)%Z by (apply Z.pow_pos_nonneg; blia).
  assert (0 < 2 ^ sz2)%Z by (apply Z.pow_pos_nonneg; blia).
  rewrite Z.rem_mul_r by blia.
  Lia.nia.
Qed.

Lemma bitSlice_all_nonneg: forall n v : Z,
    0 <= n ->
    0 <= v < 2 ^ n ->
    bitSlice v 0 n = v.
Proof.
  clear. intros.
  rewrite bitSlice_alt by blia.
  unfold bitSlice'.
  change (2 ^ 0) with 1.
  rewrite Z.div_1_r.
  rewrite Z.sub_0_r.
  apply Z.mod_small.
  assumption.
Qed.

Lemma bitSlice_all_neg: forall n v : Z,
    0 <= n ->
    - 2 ^ n <= v < 0 ->
    bitSlice v 0 n = 2 ^ n + v.
Proof.
  clear. intros.
  rewrite bitSlice_alt by blia.
  unfold bitSlice'.
  change (2 ^ 0)%Z with 1%Z.
  rewrite Z.div_1_r.
  rewrite Z.sub_0_r.
  assert (0 < 2 ^ n)%Z. {
    apply Z.pow_pos_nonneg; blia.
  }
  Z.div_mod_to_equations.
  rewrite H2 in * by blia.
  clear H2 v.
  rewrite Z.add_assoc.
  assert (q = -1)%Z by Lia.nia.
  subst q.
  Lia.nia.
Qed.

Lemma bitSlice_nonneg: forall start eend v,
    0 <= bitSlice v start eend.
Proof.
  intros. unfold bitSlice.
  eapply Z.land_nonneg.
  right.
  eapply Z.lnot_nonneg.
  eapply Z.shiftl_neg.
  reflexivity.
Qed.

Lemma bitSlice_upper_bound: forall start eend v,
    bitSlice v start eend < 2 ^ (Z.max 0 (eend - start)).
Proof.
  intros. unfold bitSlice.
  assert (eend - start < 0 \/ 0 <= eend - start) as C by Lia.lia.
  destruct C.
  - rewrite Z.shiftl_minus_one_neg by Lia.lia.
    change (Z.lnot (-1)) with 0.
    rewrite Z.land_0_r.
    replace (Z.max 0 (eend - start)) with 0 by Lia.lia.
    reflexivity.
  - replace (Z.max 0 (eend - start)) with (eend - start) by Lia.lia.
    rewrite Z.shiftl_mul_pow2 by assumption.
    rewrite Z.mul_comm.
    rewrite <- Z.opp_eq_mul_m1.
    replace (Z.lnot (- 2 ^ (eend - start))) with (Z.pred (2 ^ (eend - start))). 2: {
       pose proof (Z.add_lnot_diag (- 2 ^ (eend - start))). Lia.lia.
    }
    rewrite <- Z.ones_equiv.
    rewrite Z.land_ones by assumption.
    eapply Z.mod_pos_bound.
    apply Z.pow_pos_nonneg. 1: reflexivity. assumption.
Qed.

Lemma bitSlice_bounds: forall start eend v,
    0 <= bitSlice v start eend < 2 ^ (Z.max 0 (eend - start)).
Proof. eauto using bitSlice_nonneg, bitSlice_upper_bound. Qed.

Lemma mod20_bitSlice: forall n,
    bitSlice n 0 1 = 0 ->
    n mod 2 = 0.
Proof.
  intros. rewrite bitSlice_alt in H by Lia.lia.
  unfold bitSlice' in *.
  Z.div_mod_to_equations.
  Lia.lia.
Qed.

(** ** signExtend *)

Definition signExtend(oldwidth: Z)(z: Z): Z :=
  (z + 2^(oldwidth-1)) mod 2^oldwidth - 2^(oldwidth-1).

Definition signExtend_bitwise(width n: Z): Z :=
  if Z.testbit n (width - 1)
  then (Z.lor (Z.land n (Z.ones width)) (Z.shiftl (-1) width))
  else (Z.land n (Z.ones width)).

Lemma signExtend_alt_bitwise: forall l n,
    0 < l ->
    signExtend l n = signExtend_bitwise l n.
Proof.
  intros.
  unfold signExtend, signExtend_bitwise.
  assert (0 < 2 ^ l) as A by (apply Z.pow_pos_nonneg; blia).
  assert (0 < 2 ^ (l - 1)) as A' by (apply Z.pow_pos_nonneg; blia).
  destruct (Z.testbit n (l - 1)) eqn: E.
  - rewrite or_to_plus by Z.bitblast.
    rewrite Z.shiftl_mul_pow2 by blia.
    rewrite Z.land_ones by blia.
    apply Z.testbit_true in E; [|blia].
    do 2 rewrite Z.mod_eq by blia.
    replace (2 ^ l) with (2 ^ ((l - 1) + 1)) by (f_equal; blia).
    rewrite Z.pow_add_r in * by blia.
    change (2 ^ 1) with 2 in *.
    replace (n + 2 ^ (l - 1)) with (n + 1 * 2 ^ (l - 1)) at 2 by blia.
    rewrite <-! Z.div_div by blia.
    rewrite Z_div_plus_full by blia.
    rewrite Z.mod_eq in E by blia.
    rewrite <-! Z.mul_assoc.
    replace (n / 2 ^ (l - 1)) with (2 * (n / 2 ^ (l - 1) / 2) + 1) at 1 by blia.
    rewrite <- Z.add_assoc.
    change (1 + 1) with (1 * 2).
    rewrite Z_div_plus_full by blia.
    remember (n / 2 ^ (l - 1) / 2) as X.
    rewrite Z.mul_add_distr_l.
    rewrite (Z.mul_comm 2 X).
    rewrite Z.div_mul by blia.
    blia.
  - rewrite Z.land_ones by blia.
    apply Z.testbit_false in E; [|blia].
    do 2 rewrite Z.mod_eq by blia.
    replace (2 ^ l) with (2 ^ ((l - 1) + 1)) by (f_equal; blia).
    rewrite Z.pow_add_r in * by blia.
    change (2 ^ 1) with 2 in *.
    replace (n + 2 ^ (l - 1)) with (n + 1 * 2 ^ (l - 1)) at 2 by blia.
    rewrite <-! Z.div_div by blia.
    rewrite Z_div_plus_full by blia.
    rewrite Z.mod_eq in E by blia.
    rewrite <-! Z.mul_assoc.
    replace (n / 2 ^ (l - 1)) with (2 * (n / 2 ^ (l - 1) / 2)) at 1 by blia.
    remember (n / 2 ^ (l - 1) / 2) as X.
    replace (2 * X + 1) with (1 + X * 2) by blia.
    rewrite Z_div_plus_full by blia.
    change (1 / 2 + X) with X.
    blia.
Qed.

Lemma signExtend_range: forall i z,
    0 < i ->
    - 2 ^ (i - 1) <= signExtend i z < 2 ^ (i - 1).
Proof.
  intros.
  unfold signExtend.
  pose proof (Z.mod_pos_bound (z + (2 ^ (i - 1))) (2 ^ i)) as P.
  assert (0 < 2 ^ i) as A. {
    apply Z.pow_pos_nonneg; blia.
  }
  specialize (P A).
  replace (2 ^ i) with (2 ^ ((i - 1) + 1)) in * by (f_equal; blia).
  rewrite Z.pow_add_r in * by blia.
  change (2 ^ 1) with 2 in *.
  remember (2 ^ (i - 1)) as B.
  blia.
Qed.

Lemma signExtend_bounds: forall i z,
    0 <= i -> - 2 ^ i <= signExtend (i + 1) z < 2 ^ i.
Proof.
  intros. pose proof (signExtend_range (i + 1) z) as P.
  replace (i + 1 - 1) with i in P by Lia.lia. eapply P. Lia.lia.
Qed.

Lemma signExtend_nop: forall l w v,
    - 2 ^ l <= v < 2 ^ l ->
    0 <= l < w ->
    signExtend w v = v.
Proof.
  intros.
  unfold signExtend.
  assert (2 ^ (w - 1) * 2 = 2 ^ w). {
    replace w with (w - 1 + 1) at 2 by blia.
    rewrite Z.pow_add_r by blia.
    reflexivity.
  }
  pose proof (Z.pow_le_mono_r 2 l (w-1)).
  rewrite Z.mod_small; blia.
Qed.


(* Bianchi, Gabina Luz - Parcial 1 *)

(*Ejercicio 1*)
Section Problema1.
Variables L O I C : Prop.
Definition R1 := (L -> O) /\ (I -> C). (* Si era leal, habrìa obedecido las órdenes, y si era inteligente, las habría comprendido*)
Definition R2 := ~ O \/ ~ C. (* O el general desobedeció las órdenes o no las comprendió*)
Definition Conclusion :=  ~ L \/ ~ I. (*el general era desleal o no era inteligente*)

Variable p q : Prop.
Lemma contra :forall p q : Prop, (p -> q) -> (~q -> ~p).
Proof.
intros.
unfold not.
intro.
absurd q0.
assumption.
apply H.
assumption.
Qed.

Lemma ej1: (R1 /\ R2) -> Conclusion.
Proof.
unfold R1.
unfold R2.
unfold Conclusion.
intros.
elim H; intros.
elim H0; intros.
elim H1; intros.
left.
apply (contra L O H2).
assumption.
right.
apply (contra I C H3).
assumption.
Qed.

End Problema1.

(*Ejercicio 2*)
Section Problema2.
Require Import Classical.
Variable C : Set.
Variable P : C -> C -> Prop.
Lemma lema2 : (exists x : C, (exists y : C, P x y)) \/ ~(exists x : C, P x x).
Proof.
elim (classic (exists x : C, P x x)); intros.
left.
elim H.
intros.
(exists x).
(exists x).
assumption.
right.
assumption.
Qed.
End Problema2.

(*Ejercicio 3*)
Section Problema3.
Variable U : Set.
Variable a : U.
Variables P Q R T : U -> Prop.

Lemma Ej3_1 : (forall x : U, P x -> Q x) -> P a -> Q a.
Proof.
exact (fun (H : forall x : U, P x -> Q x) X => H a X).
Qed.
Lemma Ej3_2 : (forall x : U, P x -> Q x) -> (forall x : U, Q x -> R x) ->
forall x : U, P x -> R x.
Proof.
intros.
exact (H0 x (H x H1)).
Qed.

Lemma L3_3: (forall x:U, Q x) \/ (forall y:U, T y) -> forall z:U, Q z \/ T z.
Proof.
intros;elim H; intros; [left | right]; apply H0.
Qed.

End Problema3.

(*Ejercicio 4*)

Section Problema4.

Parameter ABnat : forall n : nat, Set.
Parameter ABnull : ABnat O.
Parameter ABadd : forall (n m : nat), nat -> ABnat n -> ABnat m -> ABnat (n + m + 1).
Check ABadd.

Definition AB1 := ABadd O 0 7 ABnull ABnull. (* Árbol de un único nodo con valor 7*)
Check AB1.
Definition AB2 := ABadd 1 0 8 AB1 ABnull. (*Árbol con un 8 en su raíz y un 7 como hijo izquierdo*)
Check AB2.
Definition AB3 := ABadd 2 0 9 AB2 ABnull. (*Árbol pedido*)
Check AB3.

Parameter ABG : forall (X: Set) (n : nat), Set.
Parameter ABGnull : forall X : Set, ABG X O.
Parameter ABGadd : forall (X : Set) (n m : nat), X -> ABG X n -> ABG X m -> ABG X (n + m + 1).
Check ABGadd.

End Problema4.

(*Ejercicio 5*)

Section Problema5.

Variable Bool: Set.
Variable TRUE : Bool.
Variable FALSE : Bool.
Variable Not : Bool -> Bool.
Variable Imp : Bool -> Bool -> Bool.
Variable Xor : Bool -> Bool -> Bool.

Axiom Disc : ~ (FALSE = TRUE).
Axiom BoolVal : forall b : Bool, b = TRUE \/ b = FALSE.
Axiom NotTrue : Not TRUE = FALSE.
Axiom NotFalse : Not FALSE = TRUE.
Axiom ImpFalse : forall b : Bool, Imp FALSE b = TRUE.
Axiom ImpTrue : forall b : Bool, Imp TRUE b = b.
Axiom XorTrue : forall b : Bool, Xor TRUE b = Not b.
Axiom XorFalse : forall b : Bool, Xor FALSE b = b.

Lemma L51 : forall b: Bool, Xor b b = FALSE.
Proof.
intros.
elim (BoolVal b);intros; rewrite H; [rewrite XorTrue | rewrite XorFalse].
rewrite NotTrue.
reflexivity.
reflexivity.
Qed.

Lemma L52: forall b1 b2: Bool, Imp b1 b2 = FALSE -> b1 = TRUE /\ b2 = FALSE.
Proof.
intros.
elim (BoolVal b1);intros.
rewrite H0 in H.
rewrite ImpTrue in H.
split; assumption.
rewrite H0 in H.
rewrite ImpFalse in H.
symmetry in H.
absurd (FALSE = TRUE).
apply Disc.
assumption.
Qed.

End Problema5.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus lf1 (mult y x).