Require Import Ctl.BinaryRelations.
Require Import Ctl.Paths.
Require Import Ctl.Definition.
Require Import Ctl.Basic.
Require Import Ctl.Tactics.

Require Import Glib.Glib.
Require Import Lia.

Section Properties.
Open Scope tprop_scope.

Context {state: Type}.
Variable R: relation state.
Context {t: transition R}.

(* Properties of implication *)

Theorem timpl_refl : forall (s: state) a,
  R @s ⊨ a ⟶ a.
Proof using.
  intros.
  tintro.
  assumption.
Qed.

Theorem timpl_trans : forall (s: state) a b c,
  R @s ⊨ (a ⟶ b) ⟶ (b ⟶ c) ⟶ a ⟶ c.
Proof using.
  intros s a b c.
  tintros Hab Hbc Ha.
  tapplyc Hbc.
  tapplyc Hab.
  assumption.
Qed.

Theorem timpl_trans' : forall (s: state) a b c,
  R @s ⊨ a ⟶ b ->
  R @s ⊨ b ⟶ c ->
  R @s ⊨ a ⟶ c.
Proof using.
  intros s a b c Hab Hbc.
  tintros Ha.
  tapplyc Hbc.
  tapplyc Hab.
  assumption.
Qed.

Ltac treflexivity := simple apply timpl_refl.
Ltac treflexive :=
  match goal with
  | |- _ @_ ⊨ ?a ⟶ ?a => treflexivity
  | |- _ @_ ⊨ ?a ⟶ ?b =>
      replace a with b;
        [ treflexivity
        | try easy; symmetry
        ]
  end.

Ltac ttransitivity x :=
  match goal with
  | |- ?R @?s ⊨ ?a ⟶ ?b =>
      simple apply (timpl_trans' R s a x b)
  end.

Ltac ettransitivity :=
  match goal with
  | |- ?R @?s ⊨ ?a ⟶ ?b =>
      simple eapply (timpl_trans' R s a _ b)
  end.

Theorem textensionality : forall s P Q,
  R @s ⊨ P ⟷ Q ->
  (R @s ⊨ P) = (R @s ⊨ Q).
Proof using.
  intros.
  extensionality.
  assumption.
Qed.

Lemma tNNPP : forall s P,
(* TODO: fix precedence so parantheses not necessary *)
  R @s ⊨ (¬¬P) ⟶ P.
Proof using.
  intros *.
  tintro H.
  now apply NNPP.
Qed.

Lemma rew_tNNPP : forall s P,
  (R @s ⊨ ¬¬P) = (R @s ⊨ P).
Proof using.
  intros *.
  extensionality.
  split.
  - tapply tNNPP.
  - intro.
    tintro contra.
    now tapply contra.
Qed.

(* Properties of CTL path-quantifying formulas *)

Theorem star__AG : forall s P,
  (forall s', R^* s s' -> R @s' ⊨ P) ->
  R @s ⊨ AG P.
Proof using.
  intros * H.
  tsimpl.
  intros * Hin.
  applyc H.
  enow eapply in_path__star.
Qed.

Theorem AG__star : forall s P,
  R @s ⊨ AG P ->
  forall s', R^* s s' -> R @s' ⊨ P.
Proof using.
  intros * H.
  intros s' Hstar.
  apply (star__in_path _ _ _ trans_serial) in Hstar.
  destruct exists Hstar p.
  enow etapply H.
Qed.

Theorem rew_AG_star : forall s P,
  R @s ⊨ AG P =
    forall s', R^* s s' -> R @s' ⊨ P.
Proof using.
  intros *.
  extensionality.
  split.
  - now apply AG__star.
  - apply star__AG.
Qed.

Theorem star__EF : forall s P,
  (exists s', R^* s s' /\ R @s' ⊨ P) ->
  R @s ⊨ EF P.
Proof using.
  intros * H.
  tsimpl.
  destruct H as (s' & Hstar & H).
  apply (star__in_path _ _ _ trans_serial) in Hstar.
  destruct exists Hstar p.
  now exists p s'.
Qed.

Theorem EF__star : forall s P,
  R @s ⊨ EF P ->
  exists s', R^* s s' /\ R @s' ⊨ P.
Proof using.
  intros * H.
  tsimpl in *.
  destruct H as (p & s' & Hin & H).
  exists s'.
  split.
  - enow eapply in_path__star.
  - assumption.
Qed.

Theorem rew_EF_star : forall s P,
  R @s ⊨ EF P =
    exists s', R^* s s' /\ R @s' ⊨ P.
Proof using.
  intros *.
  extensionality.
  split.
  - now apply EF__star.
  - apply star__EF.
Qed.

Theorem AU_trivial : forall s P Q,
  R @s ⊨ Q ⟶ A[P U Q].
Proof using.
  intros *.
  tintro H.
  tsimpl.
  intros.
  exists s 0.
  split; [|split].
  - destruct p. constructor.
  - intros * Hin_before.
    now inv Hin_before.
  - assumption.
Qed.

(* Extract the first satisfactory state *)
Lemma first_state : forall s (p: path R s) P,
  (exists s', in_path s' p /\ R @s' ⊨ P) ->
  exists s' i,
    in_path_at s' i p /\
    (forall x, in_path_before x i p -> R @x ⊨ ¬P) /\
    R @s' ⊨ P.
Proof using.
  intros * H.
  destruct H as (s'' & Hin & H).
  induction Hin.
  - exists s 0.
    max split.
    + constructor.
    + intros * contra.
      now inv contra.
    + assumption.
  - forward IHHin by assumption.
    destruct IHHin as (s'0 & i & Hin' & IH1 & IH2).
    destruct classic (R @s ⊨ P) as case.
    + exists s 0.
      max split.
      * constructor.
      * intros * contra.
        now inv contra.
      * assumption.
    + exists s'0 (S i).
      max split.
      * now constructor.
      * intros * Hbefore.
        destruct Hbefore as (m & Hlt & Hin'').
        destruct m.
       -- now inv Hin''.
       -- apply IH1.
          dependent invc Hin''.
          exists m.
          split.
         ++ lia.
         ++ assumption.
      * assumption.
Qed.

Theorem seq__AW : forall s P Q,
  (R @s ⊨ P ∨ Q ->
  forall s' (seq: R#* s s'),
    (forall x, in_seq x seq -> R @x ⊨ P ∧ ¬Q) ->
    forall s'',
      R s' s'' ->
      R @s'' ⊨ P ∨ Q) ->
  R @s ⊨ A[P W Q].
Proof using.
  tsimpl.
  intros * H *.
  (* Proceed by classical destruction on whether there exists some
     state sQ in p entailing Q.
   *)
  destruct classic (
    exists sQ, in_path sQ p /\ R @sQ ⊨ Q
  ) as case.
  - right.
    (* Need to strengthen case to the *first* such sQ *)
    apply first_state in case.
    destruct case as (sQ & i & Hin & Hbefore_entails & HsQ).
    exists sQ i.
    max split; try assumption.
    intros * Hbefore.

    (* Strategy:
         get prefix sequence including state before sQ.
         reflect in_path_before to in_seq
         Induct over in_seq. apply to H to get P ∨ Q.
         Show Q contradicts that sQ is first. Therefore, P
     *)

    copy Hin _temp;
      apply in_path_at__seq'' in _temp as [seq Hbefore_seq].

    destruct seq as [|s sQ' sQ].
    { exfalso; clear - Hbefore_seq Hbefore.
      destruct (path_at R p 1) as [y Hat].
      specialize (Hbefore_seq y 1).
      forward Hbefore_seq.
      - contradict goal.
        transform contra (i = 0) by lia.
        now inv Hbefore.
      - rewrite Hbefore_seq in Hat.
        dependent invc Hat.
        discriminate H2.
    }

    assert (Hbefore': in_seq sP seq) by todo.

    (* Inconvenient induction principle. Should start from the beginning *)
    (* induction Hbefore'. *)
    todo.
  - overwrite case (not_ex_all_not _ _ case); simpl in case.
    transform case (forall s', in_path s' p -> R @s' ⊨ ¬Q).
    { clear - case.
      intros s' Hin.
      specialize (case s').
      apply not_and_or in case.
      now destruct case.
    }
    left.
    intros * Hin.
    induction Hin.
    + specialize (case s).
      forward case by constructor.
      split; [|assumption].
      (* specialize (H s (seq_refl R s)).
      forward H.
      * intros * contra.
        dependent invc contra. *)
Admitted.

(*
Theorem seq__AW : forall s P Q,
  (forall s' (seq: R#* s s'),
    (forall x, in_seq x seq -> R @x ⊨ P ∧ ¬Q) ->
    forall s'',
      R s' s'' ->
      R @s'' ⊨ P ∨ Q) ->
  R @s ⊨ A[P W Q].
Proof using.
  intros * H.
  tsimpl.
  unfold_tdisj.
  (* Wait, is this correct? What if it's AG on some paths, and AU on
     others? I think I may need to redefine.
   *)
  intros *.

Theorem AW__seq : forall s P Q,
  R @s ⊨ A[P W Q] ->
  forall s' (seq: R#* s s'),
    (forall x, in_seq x seq -> R @x ⊨ P ∧ ¬Q) ->
    forall s'',
      R s' s'' ->
      R @s'' ⊨ P ∨ Q.
Proof using.
  intros * H * H' * Hstep.
  tsimpl in H.
  destruct or H.
  - apply tentails_tdisj_l.
    rewrite rew_AG_star in H.
    applyc H.
    transitivity s'.
    + now apply seq__star.
    + now apply star_lift.
  - tsimpl in H.
    pose proof (prefix := seq_prefix _ _ _ trans_serial
      (seq_step R s s' s'' Hstep seq)).
    destruct exists prefix p.
    specialize (H p).
    destruct H as (sQ & i & Hin_at & Hin_before & H).
    destruct classic (in_path_before s'' i p) as Hbefore.
    + apply tentails_tdisj_l.
      now apply Hin_before.
    + clear Hin_before.
      (* s'' is in p (by prefix), but not before i.
         Therefore, it must be after i.
         This means i/sP is before s''.
         Which means i/sP is in the prefix.
         It is therefore either in `seq`, in which case we get the contradiction
         `R @sQ ⊨ ¬Q` from H', or sQ = s'', in which case
         solve goal by right.
       *)
      pose proof (in_prefix _ _ _ _ _ s'' prefix) as Hin.
      forward Hin by constructor.
      todo.
      (* contradict H.
      specialize (H' sQ).
      applyc H'. *)
Admitted.
*)

(* Lemma in_path_combine {state}: forall (R: relation state),
  forall s (p: path R s) s' (p': path R s') s'',
    in_path s' p ->
    in_path s'' p' ->
    in_path s'' p.
Proof using.
  intros * Hin Hin'.
  induct Hin.
  -
  - apply in_tail.
    find eapplyc.
    find eapplyc. *)

(* TODO: demorgans tactic which uses an extensible hint database for rewriting? *)

Theorem AG_idempotent : forall s P,
  R @s ⊨ AG P ⟶ AG (AG P).
Proof using.
  intros *.
  tintro H.
  tsimpl.
  intros * Hin * Hin'.
  etapply H.
Admitted.

(* De Morgan's Laws *)

Theorem AF_EG : forall s P,
  R @s ⊨ AF (¬P) ⟶ ¬EG P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists Hcontra p.
  specialize (H p).
  destruct exists H s'.
  destruct H; auto.
Qed.

Theorem AF_EG' : forall s P,
  R @s ⊨ ¬AF P ⟶ EG (¬P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  overwrite H (not_all_ex_not _ _ H); simpl in H.
  destruct exists H p.
  exists p.
  intros s' Hin contra.
  overwrite H (not_ex_all_not _ _ H); simpl in H.
  enow eapply H.
Qed.

Theorem EG_AF : forall s P,
  R @s ⊨ EG (¬P) ⟶ ¬AF P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists H p.
  specialize (Hcontra p).
  destruct exists Hcontra s'.
  destruct Hcontra.
  enow etapply H.
Qed.

Theorem EG_AF' : forall s P,
  R @s ⊨ ¬EG P ⟶ AF (¬P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  intros p.
  overwrite H (not_ex_all_not _ _ H); simpl in H.
  specialize (H p).
  overwrite H (not_all_ex_not _ _ H); simpl in H.
  destruct exists H s'.
  exists s'.
  split.
  - enow eapply not_imply_elim.
  - enow eapply not_imply_elim2.
Qed.

Theorem rew_AF_EG : forall s P,
  (R @s ⊨ AF (¬P)) = (R @s ⊨ ¬EG P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply AF_EG.
  - tapply EG_AF'.
Qed.

Theorem rew_EG_AF : forall s P,
  (R @s ⊨ EG (¬P)) = (R @s ⊨ ¬AF P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply EG_AF.
  - tapply AF_EG'.
Qed.

Theorem AG_EF : forall s P,
  R @s ⊨ AG (¬P) ⟶ ¬EF P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists Hcontra p s'.
  specialize (H p s').
  now destruct H.
Qed.

Theorem AG_EF' : forall s P,
  R @s ⊨ ¬AG P ⟶ EF (¬P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  overwrite H (not_all_ex_not _ _ H); simpl in H.
  destruct exists H p.
  overwrite H (not_all_ex_not _ _ H); simpl in H.
  destruct exists H s'.
  exists p s'.
  split.
  - enow eapply not_imply_elim.
  - enow eapply not_imply_elim2.
Qed.

Theorem EF_AG : forall s P,
  R @s ⊨ EF (¬P) ⟶ ¬AG P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists H p s'.
  specialize (Hcontra p s').
  destruct H as [H1 H2].
  enow etapply H2.
Qed.

Theorem EF_AG' : forall s P,
  R @s ⊨ ¬EF P ⟶ AG (¬P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  intros p s' Hin contra.
  overwrite H (not_ex_all_not _ _ H); simpl in H.
  specialize (H p).
  overwrite H (not_ex_all_not _ _ H); simpl in H.
  enow eapply H.
Qed.

Theorem rew_AG_EF : forall s P,
  (R @s ⊨ AG (¬P)) = (R @s ⊨ ¬EF P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply AG_EF.
  - tapply EF_AG'.
Qed.

Theorem rew_EF_AG : forall s P,
  (R @s ⊨ EF (¬P)) = (R @s ⊨ ¬AG P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply EF_AG.
  - tapply AG_EF'.
Qed.

Theorem AX_EX : forall s P,
  R @s ⊨ AX (¬P) ⟶ ¬EX P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists Hcontra s'.
  specialize (H s').
  destruct Hcontra.
  now apply H.
Qed.

Theorem AX_EX' : forall s P,
  R @s ⊨ ¬AX P ⟶ EX (¬P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  overwrite H (not_all_ex_not _ _ H); simpl in H.
  destruct exists H s'.
  exists s'.
  split.
  - enow eapply not_imply_elim.
  - enow eapply not_imply_elim2.
Qed.

Theorem EX_AX : forall s P,
  R @s ⊨ EX (¬P) ⟶ ¬AX P.
Proof using.
  intros *.
  tintros H Hcontra.
  tsimpl in *.
  destruct exists H s'.
  specialize (Hcontra s').
  destruct H as [H1 H2].
  enow etapply H2.
Qed.

Theorem EX_AX' : forall s P,
  R @s ⊨ ¬EX P ⟶ AX (¬P).
Proof using.
  intros *.
  tintro H.
  tsimpl in *.
  intros s' Hin contra.
  overwrite H (not_ex_all_not _ _ H); simpl in H.
  specialize (H s').
  enow eapply H.
Qed.

Theorem rew_AX_EX : forall s P,
  (R @s ⊨ AX (¬P)) = (R @s ⊨ ¬EX P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply AX_EX.
  - tapply EX_AX'.
Qed.

Theorem rew_EX_AX : forall s P,
  (R @s ⊨ EX (¬P)) = (R @s ⊨ ¬AX P).
Proof using.
  intros.
  apply textensionality.
  split.
  - tapply EX_AX.
  - tapply AX_EX'.
Qed.

(* Expansion Laws *)

Theorem expand_AG : forall s P,
  R @s ⊨ AG P ⟶ P ∧ AX (AG P).
Proof.
  intros *.
  tintro H.
  rewrite rew_AG_star in H.
  split.
  - apply H.
    reflexivity.
  - unfold_AX.
    intros * Hstep.
    rewrite rew_AG_star.
    intros * Hstar.
    apply H.
    etransitivity; [|eassumption].
    econstructor.
    + eassumption.
    + constructor.
Qed.

Theorem unexpand_AG : forall s P,
  R @s ⊨ P ∧ AX (AG P) ⟶ AG P.
Proof.
  intros *.
  tintro H.
  destruct H as [H1 H2].
  unfold_AX in H2.
  rewrite rew_AG_star.
  intros * Hstar.
  apply star_rt1n in Hstar.
  inv Hstar.
  - assumption.
  - specialize (H2 y H).
    rewrite rew_AG_star in H2.
    apply H2.
    now apply rt1n_star.
Qed.

Theorem rew_expand_AG : forall s P,
  (R @s ⊨ AG P) = (R @s ⊨ P ∧ AX (AG P)).
Proof.
  intros *.
  apply textensionality.
  split.
  - tapply expand_AG.
  - tapply unexpand_AG.
Qed.

Close Scope tprop_scope.
End Properties.


Require
  MathClasses.orders.integers MathClasses.theory.dec_fields MathClasses.theory.nat_pow.
Require Import
  Coq.setoid_ring.Ring
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.integers
  MathClasses.interfaces.additional_operations MathClasses.interfaces.orders.

Section shiftl.
Context `{SemiRing A} `{!LeftCancellation (.*.) (2:A)} `{SemiRing B} `{!Biinduction B} `{!ShiftLSpec A B sl}.

Add Ring A: (rings.stdlib_semiring_theory A).
Add Ring B: (rings.stdlib_semiring_theory B).

Global Instance: Proper ((=) ==> (=) ==> (=)) ((≪) : A → B → A) | 1.
Proof shiftl_proper.

Global Instance shiftl_mor_1: ∀ x : A, Setoid_Morphism (x≪) | 0.
Proof. split; try apply _. Qed.

Global Instance shiftl_mor_2: ∀ n : B, Setoid_Morphism (≪n) | 0.
Proof. split; try apply _. solve_proper. Qed.

Lemma shiftl_nat_pow_alt `{Naturals B2} `{!NatPowSpec A B2 pw}
  `{!SemiRing_Morphism (f : B2 → B)} x n : x ≪ f n = x * 2 ^ n.
Proof.
  revert n. apply naturals.induction.
    solve_proper.
   rewrite rings.preserves_0, ?shiftl_0, nat_pow_0. ring.
  intros n E.
  rewrite rings.preserves_plus, rings.preserves_1, shiftl_S.
  rewrite E, nat_pow_S. ring.
Qed.

Lemma shiftl_nat_pow `{!NaturalsToSemiRing B} `{!Naturals B} `{!NatPowSpec A B np} x n :
  x ≪ n = x * 2 ^ n.
Proof. change (x ≪ id n = x * 2 ^ n). apply shiftl_nat_pow_alt. Qed.

Lemma shiftl_1 x : x ≪ (1:B) = 2 * x.
Proof. now rewrite <-(rings.plus_0_r 1), shiftl_S, shiftl_0. Qed.

Lemma shiftl_2 x : x ≪ (2:B) = 4 * x.
Proof. rewrite shiftl_S, shiftl_1. ring. Qed.

Global Instance shiftl_base_0: LeftAbsorb (≪) 0.
Proof.
  intros n. pattern n. apply biinduction; clear n.
    solve_proper.
   now apply shiftl_0.
  intros n; split; intros E.
   rewrite shiftl_S, E. ring.
  apply (left_cancellation (.*.) 2).
  rewrite <-shiftl_S, E. ring.
Qed.

Lemma shiftl_exp_plus x n m : x ≪ (n + m) = x ≪ n ≪ m.
Proof.
  pattern m. apply biinduction; clear m.
    solve_proper.
   now rewrite shiftl_0, rings.plus_0_r.
  intros m.
  setoid_replace (n + (1 + m)) with (1 + (n + m)) by ring.
  rewrite ?shiftl_S.
  split; intros E.
   now rewrite E.
  now apply (left_cancellation (.*.) 2).
Qed.

Lemma shiftl_order x n m: x ≪ n ≪ m  = x ≪ m ≪ n.
Proof. rewrite <-?shiftl_exp_plus. now rewrite commutativity. Qed.

Lemma shiftl_reverse (x : A) (n m : B) : n + m = 0 → x ≪ n ≪ m = x.
Proof. intros E. now rewrite <-shiftl_exp_plus, E, shiftl_0. Qed.

Lemma shiftl_mult_l x y n : x * (y ≪ n) = (x * y) ≪ n.
Proof.
  pattern n. apply biinduction; clear n.
    solve_proper.
   now rewrite ?shiftl_0.
  intros m.
  rewrite ?shiftl_S.
  split; intros E.
   rewrite <-E. ring.
  apply (left_cancellation (.*.) 2). rewrite <-E. ring.
Qed.

Lemma shiftl_mult_r x y n : (x ≪ n) * y = (x * y) ≪ n.
Proof. now rewrite commutativity, shiftl_mult_l, commutativity. Qed.

Lemma shiftl_base_plus x y n : (x + y) ≪ n  = x ≪ n + y ≪ n.
Proof.
  pattern n. apply biinduction; clear n.
    solve_proper.
   now rewrite ?shiftl_0.
  intros m. rewrite ?shiftl_S.
  split; intros E.
   rewrite E. ring.
  apply (left_cancellation (.*.) 2). rewrite E. ring.
Qed.

Lemma shiftl_base_nat_pow `{Naturals B2} `{!NatPowSpec A B2 pw} `{!SemiRing_Morphism (f : B2 → B)} x n m :
  (x ≪ n) ^ m = (x ^ m) ≪ (n * f m).
Proof.
  revert m. apply naturals.induction.
    solve_proper.
   rewrite ?nat_pow_0.
   now rewrite rings.preserves_0, rings.mult_0_r, shiftl_0.
  intros m E.
  rewrite rings.preserves_plus, rings.preserves_1.
  rewrite rings.plus_mult_distr_l, rings.mult_1_r, shiftl_exp_plus.
  rewrite !nat_pow_S, E.
  now rewrite shiftl_mult_l, shiftl_mult_r.
Qed.

Lemma shiftl_negate `{Negate A} `{!Ring A} x n : (-x) ≪ n = -(x ≪ n).
Proof.
  rewrite (rings.negate_mult x), (rings.negate_mult (x ≪ n)).
  symmetry. now apply shiftl_mult_l.
Qed.

Global Instance shiftl_inj: ∀ n, Injective (≪ n).
Proof.
  repeat (split; try apply _).
  pattern n. apply biinduction; clear n.
    solve_proper.
   intros x y E. now rewrite ?shiftl_0 in E.
  intros n; split; intros E1 x y E2.
   apply E1. rewrite ?shiftl_S in E2.
   now apply (left_cancellation (.*.) 2).
  apply E1. now rewrite ?shiftl_S, E2.
Qed.

Instance shiftl_ne_0 x n :
  PropHolds (x ≠ 0) → PropHolds (x ≪ n ≠ 0).
Proof.
  intros E1 E2. apply E1.
  apply (injective (≪ n)).
  now rewrite shiftl_base_0.
Qed.

Context `{Apart A} `{!FullPseudoSemiRingOrder (A:=A) Ale Alt} `{!PropHolds ((1:A) ≶ 0)}.

Let shiftl_strict_order_embedding (x y : A) (n : B) : x < y ↔ x ≪ n < y ≪ n.
Proof.
  revert n. apply (biinduction_iff (x < y) (λ n, x ≪ n < y ≪ n)).
    solve_proper.
   now rewrite 2!shiftl_0.
  intros n. rewrite !shiftl_S.
  split; intros E.
   now apply (strictly_order_preserving (2 *.)).
  now apply (strictly_order_reflecting (2 *.)).
Qed.

Global Instance: ∀ n, StrictOrderEmbedding (≪ n).
Proof.
  repeat (split; try apply _); intros.
   now apply shiftl_strict_order_embedding.
  eapply shiftl_strict_order_embedding. eassumption.
Qed.

Global Instance: ∀ n, OrderEmbedding (≪ n).
Proof.
  split.
   now apply maps.full_pseudo_order_preserving.
  now apply maps.full_pseudo_order_reflecting.
Qed.

Global Instance shiftl_strong_inj: ∀ n, StrongInjective (≪ n).
Proof. intros. apply maps.pseudo_order_embedding_inj. Qed.

Lemma shiftl_le_flip_r `{Negate B} `{!Ring B} (x y : A) (n : B) :
  x ≤ y ≪ (-n)  ↔  x ≪ n ≤ y.
Proof.
  split; intros E.
   apply (order_reflecting (≪ -n)).
   now rewrite shiftl_reverse by now apply rings.plus_negate_r.
  apply (order_reflecting (≪ n)).
  now rewrite shiftl_reverse by now apply rings.plus_negate_l.
Qed.

Lemma shiftl_le_flip_l `{Negate B} `{!Ring B} (x y : A) (n : B) :
  x ≪ (-n) ≤ y  ↔  x ≤ y ≪ n.
Proof. now rewrite <-shiftl_le_flip_r, rings.negate_involutive. Qed.

Instance shiftl_nonneg (x : A) (n : B) : PropHolds (0 ≤ x) → PropHolds (0 ≤ x ≪ n).
Proof.
  intro. rewrite <-(shiftl_base_0 n).
  now apply (order_preserving (≪ n)).
Qed.

Instance shiftl_pos (x : A) (n : B) : PropHolds (0 < x) → PropHolds (0 < x ≪ n).
Proof.
  intro. rewrite <-(shiftl_base_0 n).
  now apply (strictly_order_preserving (≪ n)).
Qed.
End shiftl.

(* Due to bug #2528 *)
#[global]
Hint Extern 18 (PropHolds (_ ≪ _ ≠ 0)) => eapply @shiftl_ne_0 : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (0 ≤ _ ≪ _)) => eapply @shiftl_nonneg : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (0 < _ ≪ _)) => eapply @shiftl_pos : typeclass_instances.

Section preservation.
  Context `{SemiRing B} `{!Biinduction B}
    `{SemiRing A1} `{!ShiftLSpec A1 B sl1} `{SemiRing A2} `{!LeftCancellation (.*.) (2:A2)} `{!ShiftLSpec A2 B sl2}
    `{!SemiRing_Morphism (f : A1 → A2)}.

  Lemma preserves_shiftl x (n : B) : f (x ≪ n) = (f x) ≪ n.
  Proof.
    revert n. apply biinduction.
      solve_proper.
     now rewrite 2!shiftl_0.
    intros n; split; intros IH.
     rewrite 2!shiftl_S.
     now rewrite rings.preserves_mult, rings.preserves_2, IH.
    apply (left_cancellation (.*.) 2).
    rewrite <-(rings.preserves_2 (f:=f)) at 1.
    rewrite <-rings.preserves_mult, <-shiftl_S, IH.
    now rewrite shiftl_S.
  Qed.
End preservation.

Section exp_preservation.
  Context `{SemiRing B1} `{!Biinduction B1} `{SemiRing B2} `{!Biinduction B2}
   `{SemiRing A} `{!LeftCancellation (.*.) (2:A)} `{!ShiftLSpec A B1 sl1} `{!ShiftLSpec A B2 sl2}
   `{!SemiRing_Morphism (f : B1 → B2)}.

  Lemma preserves_shiftl_exp x (n : B1) : x ≪ f n = x ≪ n.
  Proof.
    revert n. apply biinduction.
      solve_proper.
     now rewrite rings.preserves_0, ?shiftl_0.
    intros n.
    rewrite rings.preserves_plus, rings.preserves_1, ?shiftl_S.
    split; intros E.
     now rewrite E.
    now apply (left_cancellation (.*.) 2).
  Qed.
End exp_preservation.

Section shiftl_dec_field.
  Context `{SemiRing R} `{Integers Z} `{!ShiftLSpec R Z sl}
     `{DecField F} `{∀ x y : F, Decision (x = y)} `{!PropHolds ((2:F) ≠ 0)} `{!IntPowSpec F Z ipw}
     `{!SemiRing_Morphism (f : R → F)}.

  Add Ring F: (rings.stdlib_ring_theory F).
  Add Ring Z: (rings.stdlib_ring_theory Z).

  Existing Instance int_pow_proper.

  Lemma shiftl_to_int_pow x n : f (x ≪ n) = f x * 2 ^ n.
  Proof.
    revert n. apply biinduction.
      solve_proper.
     now rewrite shiftl_0, int_pow_0, rings.mult_1_r.
    intros n.
    rewrite shiftl_S, int_pow_S by solve_propholds.
    rewrite rings.preserves_mult, rings.preserves_2.
    rewrite associativity, (commutativity (f x) 2), <-associativity.
    split; intros E.
     now rewrite E.
    now apply (left_cancellation (.*.) 2).
  Qed.

  Lemma shiftl_base_1_to_int_pow n : f (1 ≪ n) = 2 ^ n.
  Proof. now rewrite shiftl_to_int_pow, rings.preserves_1, rings.mult_1_l. Qed.

  Lemma shiftl_negate_1_to_half x : f (x ≪ -1) = f x / 2.
  Proof.
    rewrite shiftl_to_int_pow.
    apply (left_cancellation (.*.) 2).
    transitivity (f x * (2 * 2 ^ (-1))); [ring |].
    transitivity (f x * (2 / 2)); [| ring].
    rewrite dec_recip_inverse, <-int_pow_S by assumption.
    now rewrite rings.plus_negate_r, int_pow_0.
 Qed.

  Lemma shiftl_negate_1_to_fourth x : f (x ≪ -2) = f x / 4.
  Proof.
    rewrite shiftl_to_int_pow.
    apply (left_cancellation (.*.) (2 * 2)).
    transitivity (f x * (2 * (2 * 2 ^ (-2)))); [ring |].
    transitivity (f x * (4 / 4)); [| ring].
    assert ((4:F) ≠ 0).
     setoid_replace 4 with (2*2) by ring.
     solve_propholds.
    rewrite dec_recip_inverse, <-!int_pow_S by assumption.
    setoid_replace (1 + (1 - 2) : Z) with (0 : Z) by ring.
    now rewrite int_pow_0.
 Qed.
End shiftl_dec_field.

Section more_shiftl_dec_field.
  Context `{DecField A} `{Integers B} `{∀ x y : A, Decision (x = y)}
    `{!PropHolds ((2:A) ≠ 0)} `{!ShiftLSpec A B sl} `{!IntPowSpec A B ipw}.

  Lemma shiftl_int_pow x n : x ≪ n = x * 2 ^ n.
  Proof. change (id (x ≪ n) = id x * 2 ^ n). apply shiftl_to_int_pow. Qed.

  Lemma shiftl_base_1_int_pow n : 1 ≪ n = 2 ^ n.
  Proof. now rewrite shiftl_int_pow, rings.mult_1_l. Qed.

  Lemma shiftl_negate_1_half x : x ≪ (-1) = x / 2.
  Proof. change (id (x ≪ (-1)) = id x / 2). now apply shiftl_negate_1_to_half. Qed.

  Lemma shiftl_negate_1_fourth x : x ≪ (-2) = x / 4.
  Proof. change (id (x ≪ (-2)) = id x / 4). now apply shiftl_negate_1_to_fourth. Qed.
End more_shiftl_dec_field.

Section shiftl_field.
  Context `{Ring R} `{Integers Z} `{!ShiftLSpec R Z sl}
    `{Field F} `{!PropHolds ((2:F) ≶ 0)} `{Naturals N} `{!NatPowSpec F N npw}
    `{!SemiRing_Morphism (g : N → Z)} `{!SemiRing_Morphism (f : R → F)}.

  Add Ring F2: (rings.stdlib_ring_theory F).
  Add Ring Z2: (rings.stdlib_ring_theory Z).

  Lemma shiftl_negate_nat_pow x n : f (x ≪ (-g n)) * 2 ^ n = f x.
  Proof.
    pose proof nat_pow_proper.
    pattern n. apply naturals.induction; clear n.
      solve_proper.
     rewrite rings.preserves_0, rings.negate_0, shiftl_0.
     rewrite nat_pow_0. ring.
    intros n E.
    rewrite rings.preserves_plus, rings.preserves_1.
    etransitivity; [| eassumption].
    setoid_replace (-g n) with (1 - (1 + g n)) by ring.
    rewrite shiftl_S, rings.preserves_mult, rings.preserves_2.
    rewrite nat_pow_S. ring.
  Qed.

  Lemma shiftl_negate_to_recip_nat_pow x n P2n : f (x ≪ (-g n)) = f x // (2 ^ n)↾P2n.
  Proof.
    apply (right_cancellation (.*.) (2 ^ n)).
    rewrite shiftl_negate_nat_pow.
    transitivity (f x * (2 ^ n // (2 ^ n)↾P2n)); [| ring].
    rewrite fields.reciperse_alt. ring.
  Qed.
End shiftl_field.

Section default_shiftl_naturals.
  Context `{SemiRing A} `{Naturals B} `{!NatPowSpec A B pw}.

  Global Instance default_shiftl: ShiftL A B | 10 := λ x n, x * 2 ^ n.

  Global Instance: ShiftLSpec A B default_shiftl.
  Proof. now apply shiftl_spec_from_nat_pow. Qed.
End default_shiftl_naturals.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Opaque default_shiftl.

Set Warnings "+unsupported-attributes".

Section default_shiftl_integers.
  Context `{DecField A} `{!PropHolds ((2:A) ≠ 0)} `{Integers B} `{!IntPowSpec A B ipw}.

  Global Instance default_shiftl_int: ShiftL A B | 9 := λ x n, x * 2 ^ n.

  Global Instance: ShiftLSpec A B default_shiftl_int.
  Proof. now apply shiftl_spec_from_int_pow. Qed.
End default_shiftl_integers.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Opaque default_shiftl_int.


Require Import Coq.Strings.String.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVar (x : string)
  | APlus (a a' : aexp).

Coercion ANum : nat >-> aexp.
Coercion AVar : string >-> aexp.
Notation "a1 +' a2" := (APlus a1 a2) (at level 50).

Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
Definition W : string := "W".

Definition state : Type := string -> nat.
Definition update (x : string)(i : nat)(s : state) : state := fun y =>
  if eqb x y then i else s y.
Definition empty : state := fun _ => 0.

Inductive fstep : aexp * state -> nat -> Prop :=
  | num (n : nat)(s : state) : fstep (ANum n , s) n
  | var (x : string)(s : state) : fstep (AVar x , s) (s x)
  | fplusr (n i : nat)(a2 : aexp)(s : state) :
          fstep (a2 , s) i ->
          fstep (APlus (ANum n) a2 , s) (n + i).

Notation "w f=> i" := (fstep w i) (at level 50).

Example ex1 : (3 +' 4 , empty) f=> 7.
apply (fplusr 3). apply num. Qed.

Example ex2 : (AVar X , update X 3 empty) f=> 3.
Proof.
  apply (var X).
Qed.

Example ex3 : (ANum 3 , empty) f=> 3.
Proof.
  apply (num 3).
Qed.

Inductive step : aexp * state -> aexp * state -> Prop :=
  | plusl (a1 a2 a1' : aexp)(s : state) :
          step (a1 , s) (a1' , s) ->
          step (APlus a1 a2 , s) (APlus a1' a2 , s)
  | fplusl (a1 a2 : aexp)(s : state)(i : nat) :
           fstep (a1 , s) i ->
           step (APlus a1 a2, s) (APlus (ANum i) a2, s)
  | plusr (a2 a2' : aexp)(s : state)(n : nat) :
          step (a2 , s) (a2' , s) ->
          step (APlus (ANum n) a2 , s) (APlus (ANum n) a2' , s).

Notation "w => w'" := (step w w') (at level 50).

Definition st : state := update Y 12 (update Z 34 empty).

Example ex4a : ((Y +' 5) +' Z , st) => ((12 +' 5) +' Z , st).
Proof.
  apply (plusl _ _ _ st).
  apply (fplusl _ _ st 12).
  apply (var Y).
Qed.

Example ex4b : ((12 +' 5) +' Z , st) => (17 +' Z , st).
Proof.
  apply fplusl.
  apply (fplusr 12 5).
  apply (num 5).
Qed.

Example ex4c : (17 +' Z , st) f=> 51.
Proof.
  apply (fplusr 17).
  apply (var Z).
Qed.

Lemma determ (a : aexp)(s : state)(i j : nat)
  (p : (a , s) f=> i)(p' : (a , s) f=> j) : i = j.
Proof.
  generalize dependent j.
  induction p.
    intros. inversion p'. trivial.
    intros. inversion p'. trivial.
    intros. inversion p'. rewrite (IHp _ H3). trivial.
Qed.

Inductive fstept : aexp * state -> nat -> Prop :=
  | numt (n : nat)(s : state) : fstept (ANum n , s) n
  | vart (x : string)(s : state) : fstept (AVar x , s) (s x)
  | fplusrt (n i : nat)(a2 : aexp)(s : state) :
            fstept (a2 , s) i ->
            fstept (n +' a2 , s) (n + i)
  | ftranst (w1 w2 : aexp * state)(i : nat) :
            stept w1 w2 -> fstept w2 i -> fstept w1 i
with stept : aexp * state -> aexp * state -> Prop :=
  | pluslt (a1 a2 a1t : aexp)(s : state) :
           stept (a1 , s) (a1t , s) ->
           stept (a1 +' a2 , s) (a1t +' a2 , s)
  | fpluslt (a1 a2 : aexp)(s : state)(i : nat) :
            fstept (a1 , s) i ->
            stept (a1 +' a2 , s) (i +' a2 , s)
  | plusrt (a2 a2t : aexp)(s : state)(n : nat) :
           stept (a2 , s) (a2t , s) ->
           stept (n +' a2 , s) (n +' a2t , s)
  | transt (w1 w2 w3 : aexp * state) :
           stept w1 w2 -> stept w2 w3 -> stept w1 w3.

Notation "w f=>t i" := (fstept w i) (at level 50).
Notation "w =>t w'" := (stept w w') (at level 50).

Example ex4 : ((Y +' 5) +' Z , st) f=>t 51.
Proof.
  apply (ftranst _ (17 +' 5, st)).
    apply (transt _ (17 +' Z, st)).
      apply (pluslt). apply ().
Qed.

(*
FELADAT: atirni ugy, hogy a jobb oldal legyen eloszor kiertekelve
*)


(** * Poly: Polimorfismo y Funciones de Alto-Orden *)

(** En este capitulo continuamos con el desarrollo de conceptos
    basicos de programacion funcional.  Las ideas nuevas son
    fundamentales: _polimorfismo_ (abstraccion de funciones sobre los
    tipos de datos que manipulan) y _funciones de alto-orden_
    (tratando funciones como datos).  *)

Require Export Lists.

(* ###################################################### *)
(** * Polimorfismo *)
(* ###################################################### *)
(** ** Listas Polimorficas *)

(** En los ultimos capitulos hemos trabajado con listas de numeros
    unicamente.  Obviamente, programas mas interesantes tambien
    necesitan manipular listas con elementos de otros tipos -- listas
    de strings, listas de booleanos, listas de listas, etc.  Podemos
    definir tipos inductivos para cada uno de ellos, por ejemplo... *)

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

(** ... pero esto rapidamente se convierte tedioso, en parte porque
    tenemos que crear nombres para cada nuevo constructor de cada tipo
    de datos, pero principalmente porque tenemos que definir nuevas
    versiones de todas las funciones manipulando listas ([length],
    [rev], etc.) para cada tipo de dato nuevo. *)

(** Para evitar esta repeticion, Coq soporta definiciones de tipos
    _polimorficas_.  Por ejemplo, aqui esta la definicion de una lista
    _polimorfica_. *)

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

(** Esto es exactamente como la definicion de [natlist] del capitulo
    anterior, excepto que el argumento [nat] del constructor [cons] ha
    sido reemplazado por un tipo arbitrario [X], que se encuentra
    ligado al [X] definido en el encabezado del tipo, y las
    ocurrencias de [natlist] fueron reemplazadas por [list X].
    (Podemos reusar los nombres de los constructores [nil] y [cons]
    porque hemos puesto las definiciones de [natlist] dentro de una
    definicion [Module] que se encuentra fuera del contexto actual.) *)

(** Que cosa es [list]?  Una forma acertada es pensar que [list] es
    una _funcion_ de tipos [Type] a definiciones inductivas
    [Inductive]; o, para ponerlo de otra forma, [list] es una funcion
    de [Type]s a [Type]s.  Para cualquier [X] particular, el tipo
    [list X] es un tipo definido inductivamente definiendo un conjunto
    de listas cuyos elementos son cosas de tipo [X]. *)

(** Con esta definicion, cuando usamos los constructores [nil] y
    [cons] para construir listas, tenemos que decirle a Coq el tipo de
    los elementos en las listas que estamos construyendo -- es decir,
    [nil] y [cons] son ahora _constructores polimorficos_.  Observe el
    tipo de estos constructores: *)

Check nil.
(* ===> nil : forall X : Type, list X *)
Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** El "[forall X]" en estos tipos puede ser leido como un argumento
    adicional a los constructores que determina los tipos esperados en
    los argumentos que siguen.  Cuando [nil] y [cons] son usados,
    estos arguemntos son provistos como cualquier otro.  Por
    ejemplo, la lista conteniendo [2] y [1] se escribe asi: *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** (Volvemos a escribir [nil] y [cons] explicitamente aqui porque
    todavia no hemos definido la notacion [ [] ] y [::] para la nueva
    version de lista.  Haremos eso en un segundo.) *)

(** Podemos volver atras y hacer polimorficas (o "genericas") las
    versiones de las funciones sobre listas que definimos antes.  Aqui
    esta [length], por ejemplo: *)

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length X t)
  end.

(** Note que los usos de [nil] y [cons] en los patrones del [match] no
    requieren ninguna anotacion: Coq ya sabe que la lista [l] contiene
    elementos de tipo [X], con lo que no hay razon para incluir [X] en
    el patron.  (Mas precisamente, el tipo [X] es un parametero de
    toda la definicion de [list], no de cada constructor individual.
    Volveremos a este punto mas adelante.)

    Como con [nil] y [cons], podemos usar [length] aplicandola primero
    a un tipo y luego a una lista: *)

Example test_length1 :
    length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity.  Qed.

(** Para usar nuestra definicion de [length] con otros tipos de
    listas, simplemente tenemos que instanciar apropiadamente el
    parametro de tipo: *)

Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity.  Qed.

(** Terminamos esta subseccion reimplementando algunas otras funciones
    estandard sobre listas polimorficas: *)

Fixpoint app (X : Type) (l1 l2 : list X)
                : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons X h (app X t l2)
  end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil      => cons X v (nil X)
  | cons h t => cons X h (snoc X t v)
  end.

Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
  | nil      => nil X
  | cons h t => snoc X (rev X t) h
  end.

Example test_rev1 :
    rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity.  Qed.

Module MumbleBaz.
(** **** Ejercicio: 2 stars (mumble_grumble) *)
(** Considere los siguientes dos tipos inductivos. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.
Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Cual de los siguientes son elementos bien tipados de [grumble X] para
    algun tipo [X]?
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]
(* FILL IN HERE *)
[] *)

(** **** Ejercicio: 2 stars (baz_num_elts) *)
(** Considere la siguiente definicion inductiva: *)

Inductive baz : Type :=
   | x : baz -> baz
   | y : baz -> bool -> baz.

(** _Cuantos_ elementos tiene el tipo [baz]?
(* FILL IN HERE *)
[] *)

End MumbleBaz.

(* ###################################################### *)
(** *** Inferencia de Tipos *)

(** Escribamos de vuelta la definicion de [app], pero esta vez sin
    especificar ninguno de los tipos de los argumentos.  Coq va a
    aceptar esta definicion? *)

Fixpoint app' X l1 l2 : list X :=
  match l1 with
  | nil      => l2
  | cons h t => cons X h (app' X t l2)
  end.

(** En efecto, la acepta.  Veamos que tipo le asigno Coq a [app']: *)

Check app'.
(* ===> forall X : Type, list X -> list X -> list X *)
Check app.
(* ===> forall X : Type, list X -> list X -> list X *)

(** Tiene exactamente el mismo tipo que [app].  Coq utilizo un proceso
    que se llama _inferencia de tipos_ que deduce cual debe ser el
    tipo de [X], [l1], y [l2], basado en como son utilizados.  Por
    ejemplo, como [X] es utilizado como primer argumento de [cons],
    debe ser un [Type], puesto que [cons] espera un [Type] como primer
    argumento; "matcheando" [l1] con [nil] y [cons] significa que debe
    ser una lista; y asi sucesivamente.

    Esta poderosa herramienta significa que no tenemos que escribir
    explicitamente abitacuibes de tipo todo el tiempo, aunque las
    anotaciones de tipos muchas veces son util como documentacion y
    "checkeo de sanidad".  Usted debera encontrar el balance en su
    propio codigo entre un exceso de anotaciones (tantas que distraen
    y confunden), y una falta de anotaciones (que obligan al lector a
    realizar inferencia de tipos en sus cavezas para poder entender su
    codigo).  *)

(* ###################################################### *)
(** *** Sintesis de Argumentos de Tipos *)

(** En cada lugar donde usamos una funcion polimorfica debemos pasar
    uno o mas tipos, ademas de los otros argumentos.  Por ejemplo, en
    la llamada recursiva en el cuerpo de la funcion [length] de arriba
    debemos pasar tambien el tipo [X].  Pero proveer este tipo de
    anotaciones explicitas todo el tiempo es pesado y verborragico.
    Como el segundo argumento de [length] es una lista de [X]s,
    resulta obvio que el primer argumento solo puede ser [X] -- por
    que debemos escribirlo explicitamente?

    Afortunadamente, Coq permite evitar esta clase de redundancia.  En
    lugar de cualquier argumento podemos escribir el "argumento
    implicito" [_], que puede leerse como "Por favor, encontra por mi
    que tipo debe ir aca".  Mas precisamente, cuando Coq encuentra un
    [_], intenta _unificar_ la informacion local a disposicion -- el
    tipo de la funcion siendo aplicada, los tipos de los otros
    argumentos, y el tipo esperado en el contexto en el que la
    aplicacion se encuentra -- para determinar que tipo concreto debe
    reemplazar el [_].

    Esto puede sonar similar a la inferencia de anotaciones de tipos
    -- y, de hecho, los dos procedimientos se basan en los mismos
    mechanismos subyacentes.  En vez de simplemente omitir el tipo de
    algunos argumentos en una funcion, como
      app' X l1 l2 : list X :=
    tambien podemos reemplazar los tipos con [_], como
      app' (X : _) (l1 l2 : _) : list X :=
    que le dice a Coq que intente inferir la informacion faltante,
    exactamente igual a con la sintesis de argumentos.

    Usando argumentos implicitos, la funcion [length] puede ser
    escrita de la siguiente forma: *)

Fixpoint length' (X:Type) (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length' _ t)
  end.

(** En este ejemplo, no salvamos mucho escribiendo [_] en vez de [X].
    Pero en muchos casos la diferencia puede ser significativa.  Por
    ejemplo, suponga que queremos escribir una lista conteniendo los
    numeros [1], [2], y [3].  En vez de escribir... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...podemos utilizar la sintesis de argumentos y escribir: *)

Definition list123' := cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ###################################################### *)
(** *** Argumentos Implicitos *)

(** De hecho, podemos ir mas lejos.  Para evitar llenar de [_]s en
    todos nuestros programas, podemos decirle a Coq que _siempre_
    infiera los argumentos de tipos de una dada funcion.  La directiva
    [Implicit Arguments] (Coq 8.3) o [Arguments] (Coq 8.4) especifica
    el nombre de la funcion o constructor, y luego la lista de
    argumentos (entre {} o [] dependiendo de la version) indicado que
    tal argumento debe ser tratado como implicito.  *)

(* Coq 8.4
Arguments nil {X}.
Arguments cons {X} _ _.  (* marcar con [_] por cada argumento que no tiene nombre *)
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.
*)
(* Coq 8.3 *)
Implicit Arguments nil [[X]].
Implicit Arguments cons [[X]].
Implicit Arguments length [[X]].
Implicit Arguments app [[X]].
Implicit Arguments rev [[X]].
Implicit Arguments snoc [[X]].

(* notar: no se requiere nigun _  *)
Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

(** Alternativamente, uno puede declarar un argumento como implicito
    mientras se define la funcion, encerrandolo entre llaves.  Por
    ejemplo: *)

Fixpoint length'' {X:Type} (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length'' t)
  end.

(** (Note que no tenemos que proveer el argumento la llamada recursiva
    de [length'']; de hecho, seria invalido proveer uno).
    Utilizaremos este estilo siempre que sea posible, aunque
    continuaremos utilizando la delcaracion [Argument] para
    constructores inductivos. *)

(** Un pequenio problema al declarar los argumentos como implicitos es
    que, ocasionalmente, Coq no tiene suficiente informacion para
    determinar el argumento de tipo; en tales casos, necesitamos
    decirle a Coq que queremos proveer los argumentos explicitamente
    por esta vez, aunque lo hayamos declarado globalmente como
    [Implicit]o.  Por ejemplo, supongoamos que escribimos esto: *)

(* Definition mynil := nil.  *)

(** Si descomentamos esta definicion, Coq va a darnos un error, porque
    no sabe que tipo darle al argumento de tipo de [nil].  Podemos
    ayudarlo con una declaracion explicita (de forma que Coq tenga mas
    informacion a mano cuando analize la aplicacion implicita de
    [nil]): *)

Definition mynil : list nat := nil.

(** Alternativamente, podemos forzar que los argumentos implicitos
   sean tratados explicitimante prefijando [@] al nombre de la
   funcion.  *)

Check @nil.

Definition mynil' := @nil nat.

(** Usando la sintesis de argumentos y argumentos implicitos, podemos
    definir convenientemente notacion para listas, como antes.  Como
    hicimos el argumento de tipo de los constructores implicitos, Coq
    sabra inferirlo automaticamente cuando usemos las notaciones.*)

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** Ahora las listas pueden ser escritas como antes: *)

Definition list123''' := [1; 2; 3].

(* ###################################################### *)
(** *** Ejercicios: Listas Polimorficas *)

(** **** Ejercicio: 2 stars, optional (poly_exercises) *)
(** Aqui hay algunos simples ejercicios, como los del capitulo
   [Lists], para practicar con polimorfismo.  Llene las definiciones y
   complete las pruebas debajo. *)

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  (* FILL IN HERE *) admit.

Example test_repeat1:
  repeat true 2 = cons true (cons true nil).
 (* FILL IN HERE *) Admitted.

Theorem nil_app : forall X:Type, forall l:list X,
  app [] l = l.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem rev_snoc : forall X : Type,
                     forall v : X,
                     forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
(* FILL IN HERE *) Admitted.

Theorem snoc_with_append : forall X : Type,
                         forall l1 l2 : list X,
                         forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** Pares Polimorficos *)

(** Siguiendo el mismo patron, la definicion de tipo que dimos en el
    capitulo anterior para un par de numeros puede generalizarse a
    _pares polimorficos_ (o _productos_): *)

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

(* Coq 8.4
Arguments pair {X} {Y} _ _.
*)
(* Coq 8.3 *)
Implicit Arguments pair [[X] [Y]].

(** Como con listas, hacemos los argumentos de tipo implicitos y
    definimos la notacion familiar. *)

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

(** Podemos utilizar el mecanismo de [Notation] para definir la
    notacion estandard para el _tipo_ del par: *)

Notation "X * Y" := (prod X Y) : type_scope.

(** (La anotacion [: type_scope] le dice a Coq que esta abreviacion
    debe ser utilizada cuando se "parsean" (consideran) tipos.  Esto
    evita que se superponga con el simbolo de multiplicacion de los
    naturales). *)

(** Nota: es facil al principio confundirse [(x,y)] con [X*Y].
    Recuerde que [(x,y)] es un _valor_ construido de dos valores; [X*Y]
    es un _tipo_ construido con otros dos tipos.  Si [x] tiene tipo
    [X] e [y] tiene tipo [Y], entonces [(x,y)] tiene tipo [X*Y]. *)

(** Las funciones de la primer y segunda proyeccion del par se
    escriben casi como en cualquier otro lenguaje de programacion
    funcional.  *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with (x,y) => y end.

(** La siguiente funcion toma dos listas y las combina en una lista de
    pares.  En muchos lenguajes de programacion, esta funcion es
    llamada [zip].  Aqui la llamamos [combine] por consistencia con la
    libreria estandard de Coq. *)
(** Note de vuelta que la notacion para par puede ser usada en
    expresiones y en patrones... *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match (lx,ly) with
  | ([],_) => []
  | (_,[]) => []
  | (x::tx, y::ty) => (x,y) :: (combine tx ty)
  end.

(** **** Ejercicio: 1 star, opcional (combine_checks) *)
(** Trate respondiendo la siguiente pregunta en papel y verificar sus
    respuestas en Coq:
    - Cual es el tipo de [combine] (es decir, que retorna [Check
      @combine]?)
    - Que responde
        Eval compute in (combine [1;2] [false;false;true;true]).
      ?
*)

(** **** Ejercicio: 2 stars (split) *)
(** La funcion [split] es el inverso de [combine]: toma una lista de
    pares y retorna ina lista de listas.  En muchos lenguajes de
    programacion funcionales, esta funcion se llama [unzip].

    Complete la definicion de [split].  Asegurese que pasa los test
    unitarios dados. *)

Fixpoint split
           {X Y : Type} (l : list (X*Y))
           : (list X) * (list Y) :=
(* FILL IN HERE *) admit.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** "Options" Polimorficos *)

(** Un ultimo tipo polimorfico por el momento: _opciones
    polimorficas_.  La declarcion de tipo generaliza la que dimos para
    [natoption] en el capitulo anterior: *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

(* Coq 8.4
Arguments Some {X} _.
Arguments None {X}.
*)
(* Coq 8.3 *)
Implicit Arguments Some [[X]].
Implicit Arguments None [[X]].

(** Ahora podemos reescribir la funcion [index] para que funcione con
    cualquier tipo de listas.  *)

Fixpoint index {X : Type} (n : nat)
               (l : list X) : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Example test_index1 :    index 0 [4;5;6;7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index  1 [[1];[2]]  = Some [2].
Proof. reflexivity.  Qed.
Example test_index3 :    index  2 [true]  = None.
Proof. reflexivity.  Qed.

(** **** Ejercicio: 1 star, opcional (hd_opt_poly) *)
(** Complete la definicion de una version polimorfica de la funcion
    [hd_opt] del capitulo anterior.  Asegurese que pase los tests
    unitarios de abajo.  *)

Definition hd_opt {X : Type} (l : list X)  : option X :=
  (* FILL IN HERE *) admit.

(** De vuelta, para forzar a Coq a hacer explicitos los argumentos
    implicitos podemos usar [@] antes del nombre de la funcion.  *)

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1;2] = Some 1.
 (* FILL IN HERE *) Admitted.
Example test_hd_opt2 :   hd_opt  [[1];[2]]  = Some [1].
 (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Funciones como Datos *)
(* ###################################################### *)
(** ** Funciones de Alto-Orden *)

(** Como muchos lenguajes de programacion modernos -- incluyendo
    _todos_ los lenguajes de programacion funcionales (ML, Haskell,
    Scheme, etc.) -- Coq trata a las funciones como ciudadanos de
    primera, permitiendo a las funciones ser pasadas como argumentos
    de otras funciones, retornadas como resultado, almacenadas en
    tipos de datos, etc.

    Las funciones que manipulan otras funciones se llaman usalmente
    funciones de _alto-orden_.  Aqui hay un ejemplo sencillo: *)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

(** El argumento [f] aqui es en si mismo una funcion (de [X] a [X]);
    el cuerpo de [doit3times] aplica [f] tres veces a algun valor
    [n]. *)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Aplicacion Parcial *)

(** De hecho, las funciones con varios argumentos que vimos son de por
    si ejemplos de funciones que utilizan funciones como datos.  Para
    ver porque, recuerde el tipo de [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Cada [->] en esta expresion es, de hecho, un operador _binario_ en
    tipos.  (Esto es lo mismo que decir que Coq primitivamente acepta
    solo funciones con un solo argumento -- puede ver porque?)  Este
    operador es _asociado a derecha_, con lo que el tipo de [plus] es
    realmente una version corta de [nat -> (nat -> nat)] -- es decir,
    puede ser leido como "[plus] es una funcion con un argumento que
    toma un natural y retorna una funcion con un argumento de tipo
    [nat] que retorna un [nat]".  En los ejemplos de arriba, siempre
    aplicamos [plus] a ambos de sus argumentos a la vez, pero si
    queremos podemos suplir solo el primer argumento.  Esto se llama
    _aplicacion parcial_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Disgresion: Currificacion *)

(** **** Ejercicio: 2 stars, avanzado (currying) *)
(** En Coq, una funcion [f : A -> B -> C] realmente tiene tipo [A ->
    (B -> C)].  Es decir, si se provee a [f] un valor de tipo [A],
    retorna un valor [f' : B -> C].  Si entonces se le provee a [f']
    un valor de tipo [B], va a retornar un valor de tipo [C].  Esto
    permite aplicaciones parciales, como en [plus3].  Procesar una
    lista de argumentos con funciones que retornan funciones se llama
    _currificacion_, en honor al logico Haskell Curry.

    Contrariamente, podemos reinterpretar el tipo [A -> B -> C] como
    [(A * B) -> C].  Esot es llamado _descurryficacion_.  Con una
    funcion binaria descurrificada, ambos argumentos son dados de una
    como un par; no admite aplicacion parcial.  *)

(** Podemos definir currificacion de la siguiente manera: *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(** Como ejercicio, defina su inverso, [prod_uncurry].  Luego
    demuestre el teorma de abajo de que ambas son inversas.  *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  (* FILL IN HERE *) admit.

(** (Ejercicio mental: antes de ejecutar estos comandos, puede
    calcular los tipos de [prod_curry] y [prod_uncurry]?) *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** Filtro *)

(** Aqui hay una funcion de alto-orden muy util, que toma una lista de
    [X]s y un _predicado_ booleano en [X] (una funcion de [X] a
    [bool]) que "filtra" la lista, retornando una nueva lista
    conteniendo solo aquellos elementos para los cuales el predicado
    retorna [true]. *)

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

(** Por ejemplo, si aplicamos [filter] al predicado [evenb] y una
    lista de numeros [l], retorna una lista conteniendo solo los
    numeros pares de [l].  *)

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** Podemos usar [filter] para dar una version concisa de la funcion
    [countoddmembers] del capitulo [Lists]. *)

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Funciones Anonimas *)

(** Es un poco molesto estar obligado a definir una funcion
    [length_is_1] y darle un nombre solo para poder pasarla como
    argumento de [filter], puesto que posiblemente no la volvamos a
    usar de vuelta.  Es mas, esto no es un caso aislado.  Cuando las
    funciones de alto-orden se utilizan continuamente, es comun pasar
    funciones que jamas vamos a usar en otros contextos; tener que dar
    un nombre a cada una de estas funciones es tedioso.

    Por suerte, hay forma de hacer esto mejor.  Es posible construir
    una funcion "al vuelo" sin declararla en el "nivel superior" (top
    level, donde se declaran las funciones) ni darle un nombre. *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

(** Reescribimos el ejemplo motivador de antes, ahora utilizando una
    funcion anonima. *)

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** **** Ejercicio: 2 stars (filter_even_gt7) *)

(** Use [filter] (en vez de [Fixpoint]) para escribir una funcion en
    Coq [filter_even_gt7] que toma una lista de numeros naturales y
    retorna una lista de solo aquellos numeros que son mayores que
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat :=
  (* FILL IN HERE *) admit.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
 (* FILL IN HERE *) Admitted.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 3 stars (partition) *)
(** Use [filter] para escribir una funcion [partition]: partition :
  forall X : Type, (X -> bool) -> list X -> list X * list X Dado un
  conjunto [X], una funcion de tipo [X -> bool] y una [list X],
  [partition] debe retornar un par de listas.  El primer elemento del
  par es la sublista de la lista original conteniendo los elementos
  que satisfagan el test, y el segundo los que no.  El orden de los
  elementos en ambas listas debe respetar el orden que tenian en la
  lista original.  *)

Definition partition {X : Type} (test : X -> bool) (l : list X)
                     : list X * list X :=
(* FILL IN HERE *) admit.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
(* FILL IN HERE *) Admitted.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** Map *)

(** Otra funcion de alto-orden util, [map]. *)

Fixpoint map {X Y:Type} (f:X->Y) (l:list X)
             : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

(** Toma una funcion [f] y una lista [ l = [n1, n2, n3, ...] ] y
    retorna la lista [ [f n1, f n2, f n3,...] ], donde [f] ha sido
    aplicada a cada elemento de [l].  Por ejemplo: *)

Example test_map1: map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** Los tipos de los elementos de las listas de entrada y salida no
    tienen porque ser los mismos ([map] toma _dos_ argumentos de
    tipos, [X] e [Y]).  Esta version de [map] puede ser aplicada
    entonces a una lista de numeros y una funcion de numeros a
    booleanos y retornar una lista de booleanos: *)

Example test_map2: map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity.  Qed.

(** Incluso puede ser aplicada a una lista de numeros y una funcion de
    numeros a _listas_ de booleanos y retornar una lista de listas de
    booleanos: *)

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

(** **** Ejercicio: 3 stars (map_rev) *)
(** Muestre que [map] y [rev] conmuta.  Usted puede necesitar definir
    un lema auxiliar. *)

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 2 stars (flat_map) *)
(** La funcion [map] mapea una [list X] a una [list Y] usando una
    funcion de tipo [X -> Y].  Podemos definir una funcion similar,
    [flat_map], que mapea una [list X] a una [list Y] usando una
    funcion [f] de tipo [X -> list Y].  Su definicion debe funcionar
    'aplastando' ('flattening' en ingles) los resultados de [f], como
    en: [flat_map (fun n => [n;n+1;n+2]) [1;5;10] = [1; 2; 3; 5; 6; 7;
    10; 11; 12]].  *)

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  (* FILL IN HERE *) admit.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** La funcion [map] no es exclisiva de la listas.  Aqui hay una
    definicion para el tipo [option]: *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(** **** Ejercicio: 2 stars, opcional (implicit_args) *)
(** Las definiciones y usos de [filter] y [map] usan argumentos
    implicitos en muchos lugares.  Reemplace las llaves ({}) alrededor
    de los argumentos implicitos por parentesis, y llene los
    parametros explicitamente donde sea necesario.  Verifique con Coq
    que lo haya hecho correctamente.  (Este ejercicio no se debe
    entregar; posiblemente sea mas facil trabajar sobre una _copia_ de
    este archivo que puede descartar una vez terminado el
    ejercicio). *)

(* ###################################################### *)
(** ** Fold *)

(** Una funcion de alto-orden incluso mas poderosa es llamada [fold].
    Esta funcion es la inspiracion de la operacion "[reduce]" que es
    parte central del framework de programacion distribuida de Google
    llamado map/reduce . *)

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

(** Intuitivamente, el comportamiento de la operacion [fold] es
    insertar el operador binario [f] entre cada par de elementos de
    una lista dada.  Por ejemplo, [ fold plus [1;2;3;4] ] significa
    intuitivamente [1+2+3+4].  Para hacer esto mas preciso, tambien
    necesitamos un "elemento de inicio" que sirve como input inicial a
    [f].  De esta forma, por ejemplo, [ fold plus [1;2;3;4] 0 ]
    retorna [1 + (2 + (3 + (4 + 0)))].  Aqui hay mas ejemplos: *)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(** **** Ejercicio: 1 star, avanzado (fold_types_different) *)
(** Observe que el tipo de [fold] esta parametrizado por _dos_
    variables de tipo, [X] e [Y], y que el parametro [f] es un
    operador binario que toma un [X] y un [Y] y retorna un [Y].  Puede
    pensar una situacion donde es util que [X] e [Y] sean diferentes?
    *)

(* ###################################################### *)
(** ** Funciones Para Construir Funciones *)

(** La mayoria de las funciones de alto-orden que hemos mencionado
    hasta ahora toman funciones como _argumentos_.  Ahora veamos
    algunos ejemplos de funciones _retornando_ funciones.

    Para empezar, aqui hay una funcion que toma un valor [x] (de algun
    tipo [X]) y retorna una funcion de [nat] a [X] que retorna [x]
    cuando es invocada, ignorando su argumento de tipo [nat].  *)

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** Similarmente, pero un poco mas interesantemente, aqui hay una
    funcion que toma una funcion [f] de numeros a algun tipo [X], un
    numero [k], y un valor [x], y construye una funcion que se
    comporta exactamente como [f] excepto que, cuando es llamada con
    el argumento [k], retorna [x].  *)

Definition override {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if beq_nat k k' then x else f k'.

(** Por ejemplo, podemos aplicar [override] dos veces para obtener una
    funcion de numeros a booleanos que retorne [false] en [1] y [3]
    y retorne [true] en cualquier otro argumento. *)

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

(** **** Ejercicio: 1 star (override_example) *)
(** Antes de empezar a trabajar en la demostracion a continuacion,
    asegurese que entiende exactamente lo que el teorema esta
    diciendo, y expliquecelo en sus propias palabras.  La prueba en si
    es sencilla. *)

Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Usaremos la funcion [override] significativamente en el resto del
    curso, con lo que necesitaremos saber bastante acerca de sus
    propiedades.  Pero para poder probar estas propiedades, vamos a
    necesitar manejar varias tacticas de Coq.  Aprender estas tacticas
    va a ser el punto principal del capitulo siguiente.  Por ahora,
    vamos a introducir solo una tactica extremadamente util, que nos
    va a ayudar a probar algunas propiedades de las funciones que ya
    vimos en este capitulo. *)

(* ###################################################### *)
(** * La Tactica [unfold] *)

(** A veces, una demostracion puede quedarse trabada porque Coq no
    expande automaticamente una llamada a funcion en su definicion.
    (Esto es una caracteristica deseada de Coq, no un bug: si Coq
    expandiera automaticamente todo, los objetivos de prueba se
    volverian enormes rapidamente -- dificiles de leer y pesados de
    manipular para Coq!)  *)

Theorem unfold_example_bad : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
(* En este punto quisieramos hacer [rewrite -> H], puesto que
     [plus3 n] es definicionalmente igual a [3 + n].  Sin embargo,
     Coq no expande automaticamente [plus3 n] a su definicion. *)
  Abort.

(** La tactica [unfold] puede ser utilizada explicitamente para
    reemplazar un nombre definido por el lado derecho de su
    definicion.  *)

Theorem unfold_example : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.  Qed.

(** Ahora podemos probar la primer propiedad de [override]: Si
    sobreescribimos (override) una funcion en un valor [k] y luego
    miramos [k], obtenemos el valor sobreescrito. *)

Theorem override_eq : forall {X:Type} x k (f:nat->X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.  Qed.

(** Esta prueba fue facil, pero note que requiere [unfold] para
    expandir la definicion de [override]. *)

(** **** Ejercicio: 2 stars (override_neq) *)
Theorem override_neq : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Como la inversa de [unfold], Coq provee tambien una tactica
    [fold], que puede ser utilizada para "desexpandir" una definicion.
    Es utilizada bastante menos frecuentemente.  *)

(* ##################################################### *)
(** * Ejercicios Adicionales *)

(** **** Ejercicio: 2 stars (fold_length) *)
(** Muchas funciones comunes sobre listas pueden ser implementadas en
   terminos de [fold].  Por ejemplo, aqui hay una definicion
   alternativa de [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

(** Demuestre la correctitud de [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 3 stars (fold_map) *)
(** Podemos definir tambien [map] en terminos de [fold].  Complete [fold_map]
    abajo. *)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
(* FILL IN HERE *) admit.

(** Escriba un teorema en Coq estableciendo que [fold_map] es correcto
    y demuestrelo. *)

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

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)


From mathcomp
Require Import all_ssreflect.
Require Import Ascii String.

Definition eq_ascii (a a' : ascii) := nat_of_ascii a == nat_of_ascii a'.

Lemma eq_asciiP : Equality.axiom eq_ascii.
Proof.
move => x y; apply: (iffP idP); last by move =>->; apply/eqP.
move/eqP; rewrite -{2}(ascii_nat_embedding x); move =>->.
by rewrite ascii_nat_embedding.
Qed.

Definition ascii_eqMixin := EqMixin eq_asciiP.
Canonical ascii_eqType := Eval hnf in EqType ascii ascii_eqMixin.

Fixpoint seq_of_string s :=
if s is String c s' then c :: seq_of_string s' else [::].

Fixpoint string_of_seq s :=
if s is c :: s' then String c (string_of_seq s') else EmptyString.

Lemma seq_of_stringK : cancel seq_of_string string_of_seq.
Proof. by elim=> [|c s /= ->]. Qed.

Definition eq_string (s s' : string) := seq_of_string s == seq_of_string s'.

Lemma eq_stringP : Equality.axiom eq_string.
Proof.
move => x y; apply: (iffP idP); last by move =>->; apply/eqP.
move/eqP; rewrite -{2}(seq_of_stringK x); move =>->.
by rewrite seq_of_stringK.
Qed.

Definition string_eqMixin := EqMixin eq_stringP.
Canonical string_eqType := Eval hnf in EqType string string_eqMixin.


Require Import HoTT.Basics HoTT.Types HoTT.Colimits.Pushout.

(** * Pushouts of "dependent spans". *)

Section SpanPushout.
  Context {X Y : Type} (Q : X -> Y -> Type).

  Definition SPushout := @Pushout {xy:X * Y & Q (fst xy) (snd xy)} X Y
                                  (fst o pr1) (snd o pr1).
  Definition spushl : X -> SPushout := pushl.
  Definition spushr : Y -> SPushout := pushr.
  Definition spglue {x:X} {y:Y} : Q x y -> spushl x = spushr y
    := fun q => pglue ((x,y) ; q).

  Definition SPushout_rec (R : Type)
             (spushl' : X -> R) (spushr' : Y -> R)
             (sglue' : forall x y (q : Q x y), spushl' x = spushr' y)
    : SPushout -> R.
  Proof.
    srapply (@Pushout_rec {xy:X * Y & Q (fst xy) (snd xy)} X Y
                          (fst o pr1) (snd o pr1) R spushl' spushr').
    intros [[x y] q]; cbn in *.
    apply sglue'; assumption.
  Defined.

  Definition SPushout_ind (R : SPushout -> Type)
             (spushl' : forall x, R (spushl x))
             (spushr' : forall y, R (spushr y))
             (sglue' : forall x y (q : Q x y),
                 transport R (spglue q) (spushl' x) = (spushr' y))
    : forall p, R p.
  Proof.
    srapply (@Pushout_ind {xy:X * Y & Q (fst xy) (snd xy)} X Y
                          (fst o pr1) (snd o pr1) R spushl' spushr').
    intros [[x y] q]; cbn in *.
    apply sglue'; assumption.
  Defined.

  Definition spushout_ind_beta_sglue (R : SPushout -> Type)
             (spushl' : forall x, R (spushl x))
             (spushr' : forall y, R (spushr y))
             (spglue' : forall x y (q : Q x y),
                 transport R (spglue q) (spushl' x) = (spushr' y))
             (x:X) (y:Y) (q:Q x y)
    : apD (SPushout_ind R spushl' spushr' spglue') (spglue q) = spglue'  x y q
    := Pushout_ind_beta_pglue _ _ _ _ ((x,y);q).

End SpanPushout.


Require Import List.
Import ListNotations.

From Verbatim Require Import ltac.

From Verbatim Require Import regex.

Module ImplFn (Import R : regex.T).

  Fixpoint exp_matchb (s : String) (r : regex) :=
    match s, r with
    | [], _ => nullable r
    | x::xs, _ => exp_matchb xs (derivative x r)
    end.

End ImplFn.

Module LemmasFn (Import R : regex.T).

  Include ImplFn R.
  Import R.Ty.

  { (**)

    Theorem der_matchb : forall(a : Sigma) (s : String) (r : regex),
        true = exp_matchb (a::s) r <-> true = exp_matchb s (derivative a r).
    Proof.
      intros a s r.
      split; generalize dependent r; induction s; intros r H; simpl; simpl in H; apply H.
    Qed.

  }
End LemmasFn.

Module CorrectFn (Import R : regex.T).

  Include LemmasFn R.
  Import R.Ty.

  { (**)

    Theorem der_matchb' : forall(a : Sigma) (s : String) (r : regex),
      exp_matchb (a::s) r = exp_matchb s (derivative a r).
    Proof.
      intros. destruct (exp_matchb (a :: s) r) eqn:E.
      - symmetry in E. rewrite der_matchb in E. auto.
      - symmetry. rewrite false_not_true in *.
        intros C. destruct E.
        symmetry in C. rewrite <- der_matchb in C. auto.
    Qed.

    Theorem match_iff_matchb : forall(s : String) (r : regex),
        true = exp_matchb s r <-> exp_match s r.
    Proof.
      intros s r. split.
      {
        generalize dependent r. induction s; intros r H.
        - simpl in H. apply nullable_bridge. apply H.
        - apply der_match. apply der_matchb in H. apply IHs. apply H.
      }
      {
        generalize dependent r. induction s; intros r H.
        - simpl. apply nullable_bridge. apply H.
        - apply der_match in H. apply der_matchb. apply IHs in H. apply H.
      }
    Qed.

  }

End CorrectFn.

Module MatcherFn (Import R : regex.T).
  Include CorrectFn R.
End MatcherFn.


Set Warnings "-notation-overridden,-parsing".

From LF Require Export Lists.

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.
Module MumbleGrumble.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Arguments nil {X}.
Arguments cons {X} _ _.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity.  Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

Fail Definition mynil := nil.

Definition mynil : list nat := nil.

Check @nil.

Definition mynil' := @nil nat.

Fixpoint repeat {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat x count')
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
intros X l.
induction l as [| n l' IHl'].
- simpl. reflexivity.
- simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
Proof.
intros X l1 l2.
induction l1 as [| n l1' IHl1'].
- (* l1 = nil *)
  reflexivity.
- (* l1 = cons *)
  simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2. induction l1.
  - simpl. rewrite  -> app_nil_r. reflexivity.
  - simpl.
  rewrite -> IHl1.
  rewrite -> app_assoc.
  reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l. induction l.
  - simpl. reflexivity.
  - simpl.
  rewrite -> rev_app_distr.
  rewrite -> IHl.
  simpl.
  reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

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

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t => (x :: (fst (split t)), y :: (snd (split t)))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
reflexivity.
Qed.

Module OptionPlayground.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
match l with
| [] => None
| a :: l' => if n =? O then Some a else nth_error l' (pred n)
end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
reflexivity.
Qed.

Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
reflexivity.
Qed.

Example test_nth_error3 : nth_error [true] 2 = None.
reflexivity.
Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
match l with
| nil => None
| a :: l => Some a
end.

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
reflexivity.
Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
reflexivity.
Qed.

Fixpoint filter {X:Type} (test: X -> bool) (l:list X)
                : (list X) :=
match l with
| [] => []
| h :: t => if test h then h :: (filter test t) else filter test t
end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.

Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (evenb n) (negb (leb n 7))) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. simpl. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. simpl. reflexivity. Qed.

(*
Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : (prod (list X) (list X))
pair (filter test l) (filter (fun x => negb (test x)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity.  Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity.  Qed.

*)

Fixpoint map {X Y: Type} (f:X -> Y) (l:list X) : (list Y) :=
match l with
| [] => []
| h :: t => (f h) :: (map f t)
end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

Theorem map_assoc : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
    map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  intros X Y f l1 l2.
  induction l1.
  - reflexivity.
  - simpl. rewrite -> IHl1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
intros X Y f l.
induction l as [| x l' IHl].
- reflexivity.
- simpl.
  rewrite -> map_assoc.
  rewrite <- IHl.
  reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X) : (list Y) :=
match l with
| nil => nil
| h :: t => f h ++ (flat_map f t)
end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y :=
match xo with
  | None => None
  | Some x => Some (f x)
end.

Fixpoint fold {X Y: Type} (f: X -> Y ->Y) (l: list X) (b: Y) : Y :=
match l with
| nil => b
| h :: t => f h (fold f t b)
end.

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(* Additional Exercises *)
Module Exercises.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
reflexivity.
Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
intros X l.
induction l as [|h l' IHl].
- reflexivity.
- simpl. rewrite <- IHl. reflexivity.
Qed.

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
fold (fun x acc => f x :: acc) l [].

Theorem fold_map_correct : forall X Y (l : list X) (f: X -> Y),
  fold_map f l = map f l.
Proof.
intros X Y l f.
induction l as [| h l' IHl].
- reflexivity.
- simpl. rewrite <- IHl. reflexivity.
Qed.

End Exercises.


Require Import AutoSep.

Definition div4S := SPEC("n") reserving 1
  Al m,
  PRE[V] [| wordToNat (V "n") = m * 4 |]%nat
  POST[R] [| wordToNat R = m |].

Definition m := bmodule "numops" {{
  bfunction "div4"("n", "acc") [div4S]
    "acc" <- 0;;

    [Al m,
      PRE[V] [| wordToNat (V "n") = m * 4 |]%nat
      POST[R] [| R = natToW m ^+ V "acc" |] ]
    While ("n" >= 4) {
      "acc" <- "acc" + 1;;
      "n" <- "n" - 4
    };;

    Return "acc"
  end
}}.

Section ok.
  Lemma use_pred : forall (w : W) n,
    wordToNat w = n * 4
    -> natToW 4 <= w
    -> wordToNat w - 4 = (pred n) * 4.
    intros.
    nomega.
  Qed.

  Hint Immediate use_pred.

  Lemma roundTrip_4 : wordToNat (natToW 4) = 4.
    auto.
  Qed.

  Hint Rewrite roundTrip_4 : N.

  Lemma cancel_pred : forall n m rv acc,
    natToW 4 <= n
    -> wordToNat n = m * 4
    -> rv = natToW (pred m) ^+ (acc ^+ natToW 1)
    -> rv = natToW m ^+ acc.
    intros; subst.
    rewrite Minus.pred_of_minus.
    rewrite natToW_minus by nomega; words.
  Qed.

  Hint Immediate cancel_pred.

  Lemma finish : forall rv acc n m,
    rv = acc
    -> n < natToW 4
    -> wordToNat n = m * 4
    -> rv = natToW m ^+ acc.
    intros; subst.
    assert (m0 = 0) by nomega.
    words.
  Qed.

  Hint Immediate finish.
  Hint Rewrite <- plus_n_O : sepFormula.

  Lemma switch_up : forall (w : W) n rv,
    wordToNat w = n * 4
    -> rv = natToW n
    -> wordToNat rv = n.
    intros; subst.
    apply wordToNat_natToWord_idempotent.
    change (goodSize n).
    eapply goodSize_weaken.
    instantiate (1 := wordToNat w).
    eauto.
    omega.
  Qed.

  Hint Immediate switch_up.

  Theorem ok : moduleOk m.
    vcgen; abstract (sep_auto; eauto).
  Qed.
End ok.