Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.
Require Import Maps.
Require Import Imp.

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall st : state, aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall st : state, beval st b1 = beval st b2.

Theorem aequiv_example :
  aequiv (AMinus (AId X) (AId X)) (ANum 0).
Proof. intros st. apply Nat.sub_diag. Qed.

Theorem bequiv_example :
  bequiv (BEq (AMinus (AId X) (AId X)) (ANum 0)) BTrue.
Proof. intros st. simpl. rewrite Nat.sub_diag. reflexivity. Qed.

Definition cequiv (c1 c2 : com) : Prop :=
  forall st st' : state,
    (c1 / st \\ st') <-> (c2 / st \\ st').

Theorem skip_left : forall c,
    cequiv (SKIP;; c) c.
Proof. intros c st st'. split; intros H.
       -inversion H. subst.
        inversion H2. subst. apply H5.
       -apply E_Seq with (st' := st). apply E_Skip.
        apply H.
Qed.

Theorem skip_right : forall c,
    cequiv (c;; SKIP) c.
Proof. intros c st st'. split; intros H.
       -inversion H. subst.
        inversion H5. subst. assumption.
       -apply E_Seq with (st' := st').
        apply H. apply E_Skip.
Qed.

Theorem IFB_true_simple : forall c1 c2,
    cequiv (IFB BTrue THEN c1 ELSE c2 FI) c1.
Proof. intros c1 c2 st st'. split; intros H.
       -inversion H; subst.
        +apply H5.
        +inversion H6.
       -apply E_IfTrue.
        +apply H.
        +reflexivity.
Qed.

Theorem IFB_true : forall c1 c2 b,
    bequiv b BTrue ->
    cequiv (IFB b THEN c1 ELSE c2 FI) c1.
Proof. intros c1 c2 b H st st'. split; intros H1.
       -inversion H1; subst; [assumption |
        rewrite H in H7; inversion H7].
       -apply E_IfTrue. apply H1. apply H.
Qed.

Theorem IFB_false : forall c1 c2 b,
    bequiv b BFalse ->
    cequiv (IFB b THEN c1 ELSE c2 FI) c2.
Proof. intros c1 c2 b H st st'. split; intros H1.
       -inversion H1; subst. rewrite H in H7. inversion H7.
        assumption.
       -apply E_IfFalse. apply H1. apply H.
Qed.

Theorem swap_if_branches : forall c1 c2 b,
    cequiv (IFB b THEN c1 ELSE c2 FI) (IFB BNot b THEN c2 ELSE c1 FI).
Proof. intros c1 c2 b st st'. split; intros H.
       -inversion H; subst; [apply E_IfFalse | apply E_IfTrue]; try assumption;
        simpl; apply negb_false_iff; try rewrite negb_involutive; assumption.
       -inversion H; subst; simpl in H6; [apply negb_true_iff in H6 | apply negb_false_iff in H6];
        [apply E_IfFalse | apply E_IfTrue]; try apply H5; try apply H6.
Qed.

Theorem WHILE_false : forall c b,
    bequiv b BFalse ->
    cequiv (WHILE b DO c END) SKIP.
Proof. intros c b H st st'. split; intros H1.
       -inversion H1; subst; try apply E_Skip.
        rewrite H in H3. inversion H3.
       -inversion H1. subst. apply E_WhileEnd.
        rewrite H. reflexivity.
Qed.

Lemma WHILE_true_nonterm : forall b c st st',
    bequiv b BTrue ->
    ~( (WHILE b DO c END) / st \\ st' ).
Proof. unfold not. intros b c st st' Hb H. remember (WHILE b DO c END) as cw eqn:HH.
       induction H; try inversion HH. subst. rewrite Hb in H. inversion H.
       subst. apply IHceval_funR2. reflexivity.
Qed.

Theorem WHILE_true : forall b c,
    bequiv b BTrue ->
    cequiv (WHILE b DO c END) (WHILE b DO SKIP END).
Proof. intros b c H. split; intros H1;
       exfalso; [apply WHILE_true_nonterm with (c:=c) (st:=st) (st':=st') in H |
                 apply WHILE_true_nonterm with (c:=SKIP) (st:=st) (st':=st') in H ];
        apply H; apply H1.
Qed.

Theorem loop_unrolling : forall b c,
    cequiv (WHILE b DO c END) (IFB b THEN (c ;; WHILE b DO c END) ELSE SKIP FI).
Proof. intros b c. split; intros H.
       -inversion H; subst.
        +apply E_IfFalse. apply E_Skip. apply H4.
        +apply E_IfTrue. apply E_Seq with (st':=st'0). apply H3. apply H6. apply H2.
       -inversion H; inversion H5. subst.
        +apply E_WhileLoop with (st':=st'1). apply H6. apply H9. apply H12.
        +subst. apply E_WhileEnd. apply H6.
Qed.

(* the way this proof worked, I used replace before inversion, I was able to single
one instance of st' to replace. What if c \ st' / st' were the case instead. Is there
a way to only target the second instance? *)
Theorem identity_assignment : forall X,
    cequiv (X ::= AId X) SKIP.
Proof. intros X. split; intros H.
       -inversion H. subst. simpl. replace (t_update st X (st X)) with st.
        apply E_Skip. symmetry. apply t_update_same.
       -replace st' with (t_update st' X (st' X)). inversion H. subst.
        apply E_Ass. reflexivity. apply t_update_same.
Qed.

Theorem assign_aequiv : forall X e,
    aequiv (AId X) e ->
    cequiv SKIP (X ::= e).
Proof. intros X e H. split; intros H1.
       +unfold aequiv in H. symmetry in H.
        apply E_Ass with (st:=st') (x:=X) in H. simpl in H.
        replace st' with (t_update st' X (st' X)).
        inversion H1. subst. apply H. apply t_update_same.
       +inversion H1. subst. unfold aequiv in H. rewrite <- H.
        simpl. rewrite t_update_same. apply E_Skip.
Qed.

Lemma refl_aequiv : forall a, aequiv a a.
Proof. unfold aequiv. reflexivity.
Qed.

Lemma sym_aequiv : forall a1 a2,
    aequiv a1 a2 -> aequiv a2 a1.
Proof. intros a1 a2 H. unfold aequiv. unfold aequiv in H.
       symmetry. apply H.
Qed.

Lemma trans_aequiv : forall a1 a2 a3,
    aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof. intros a1 a2 a3 H1 H2. unfold aequiv in H1. unfold aequiv in H2.
       unfold aequiv. intros st. rewrite <- H2. apply H1.
Qed.

Lemma refl_bequiv : forall b, bequiv b b.
Proof. unfold bequiv. reflexivity.
Qed.

Lemma sym_bequiv : forall b1 b2,
    bequiv b1 b2 -> bequiv b2 b1.
Proof. intros b1 b2 H. unfold bequiv. unfold bequiv in H.
       symmetry. apply H.
Qed.

Lemma trans_bequiv : forall b1 b2 b3,
    bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof. intros b1 b2 b3 H1 H2. unfold bequiv in H1. unfold bequiv in H2.
       unfold bequiv. intros st. rewrite <- H2. apply H1.
Qed.

Lemma refl_cequiv : forall c, cequiv c c.
Proof. unfold cequiv. reflexivity.
Qed.

Lemma sym_cequiv : forall c1 c2,
    cequiv c1 c2 -> cequiv c2 c1.
Proof. intros c1 c2 H. unfold cequiv. unfold cequiv in H.
       symmetry. apply H.
Qed.

Lemma iff_trans : forall P1 P2 P3 : Prop,
    (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof. intros P1 P2 P3 H1 H2. rewrite <- H2. apply H1.
Qed.

Lemma trans_cequiv : forall c1 c2 c3,
    cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof. intros c1 c2 c3 H1 H2. unfold cequiv in H1. unfold cequiv in H2.
       unfold cequiv. intros st st'. rewrite <- H2. apply H1.
Qed.

Theorem CAss_congruence : forall i a1 a1',
    aequiv a1 a1' ->
    cequiv (i ::= a1) (i ::= a1').
Proof. intros i a1 a1' H. split; intros H1;
       inversion H1; subst; apply E_Ass; unfold aequiv in H;
        rewrite H; reflexivity.
Qed.

Theorem CWhile_congruence : forall b b' c c',
    bequiv b b' ->
    cequiv c c' ->
    cequiv (WHILE b DO c END) (WHILE b' DO c' END).
Proof. intros b b' c c' Hb Hc. split; intros H.
       -remember ((WHILE b DO c END) / st \\ st') as Hw.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import choice fintype.

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

Unset Printing Implicit.  (* Unset: implicitな引数を表示しない。D:しない。 A:する。*)
Unset Printing Coercions. (* Unset: コアーションを表示しない。  D:しない。 A:する。*)
Set Printing Notations.   (* Set: Notation を使って表示する。   D:する。   A:しない。*)
Unset Printing Universe.  (* Unset: 高階のTypeを表示しない。    D:しない。 A:- *)

(**
命題4 関数fにおいて、以下は同値である。
- fは単射
- g,h : Z -> X について、f・g = f・h ならば g = h
 *)

Definition c {Z X : Type} (x : X) (_ : Z) := x.

Lemma P4 : forall (Z X Y : Type) (f : X -> Y),
             (forall (x1 x2 : X), f x1 = f x2 -> x1 = x2)
             <->
             (forall (g h : Z -> X), (f \o g) =1 (f \o h) -> g =1 h).
Proof.
  move=> Z X Y f.
  split=> H.
  - move=> g h H1 z.
    have H' := H (g z) (h z).
    by apply/H'/H1.

  - move=> x1 x2 H1.
    have H' := H (c x1) (c x2).
    rewrite /eqfun //= in H'.               (* この行は、なくてもよい。 *)
    apply: H'.
    + move=> x.
        (* c x1 x ==> x1, c x2 x ==> x2 より Goal は x1 = f x2 *)
      by apply: H1.
    + admit.
      (* H' の後件 forall x : Z, c x1 x = c x2 x の (x : Z) が使えずに残ってしまう。 *)
Qed.

(**
命題6'
X <- Z -> Y の仲介射は、Z = X x Y のとき恒等射(id)である。
*)

Definition product {X Y Z : Type} (f : Z -> X) (g : Z -> Y) :=
  fun (x : Z) => (f x, g x).

Notation "<< f , g >>" := (product f g).

Check <<S, S>> : nat -> nat * nat.
Check product S S.

Check <<S, S>> \o S.
Check <<S \o S, S \o S>>.

Lemma product_dist {X Y Z W : Type} (f : Z -> X) (g : Z -> Y) (h : W -> Z) :
  <<f, g>> \o h =1 <<f \o h, g \o h>>.
Proof.
  done.
Qed.
(* 左分配則はなりたたない。 *)

(* 単位元の一意性の証明 *)
(* f と g が単位元であるとき、f = g である。
   あるいは、左右単位元が同じ、の証明というべきか。
 *)
Lemma id_uniqness' {X : Type} (f g : X -> X) :
  (forall h : X -> X, f \o h =1 h) ->
  (forall h : X -> X, h \o g =1 h) ->
  f =1 g.
Proof.
  move=> Hf Hg.
  Check Hf g.                               (* f \o g =1 g *)
  Check Hg f.                               (* f \o g =1 f *)
  move=> x.
  have Hf' := Hf g x.                       (* (f \o g) x = g x *)
  have Hg' := Hg f x.                       (* (f \o g) x = f x *)
  by rewrite -Hf' -Hg'.
Qed.

(* mono または 左キャンセル可能であることの定義 *)
Definition mono {X Y Z: Type} (f : X -> Y) (g h : Z -> X) :=
  f \o g =1 f \o h -> g =1 h.

Lemma P6' {X Y : Type} (f : X * Y -> X) (g : X * Y -> Y) :
  mono <<f, g>> <<f, g>> id ->
            f \o <<f, g>> =1 f ->
                      g \o <<f, g>> =1 g ->
                                <<f, g>> =1 id.
Proof.
  move=> Hmono HX HY.
  apply: Hmono => x.
  rewrite (product_dist f g <<f, g>> x).
  rewrite /product /=.
  rewrite [f (f x, g x)](HX x).
  rewrite [g (f x, g x)](HY x).
  by [].
Qed.

(**
命題10
Preorder (X, ≦) で圏が定まる。
反射律(Preorder) <---> 単位律(圏)
推移律(Preorder) <---> 結合律(圏)

ただし、
f : y < z として g : x < y とするとき、
f・g : x < y /\ y < z の意味とする。

 *)

(* END *)


Require Import Recdef.

From FormalSystems Require Import Base.

Inductive AExp : Type :=
    | AConst : nat -> AExp
    | Var : Loc -> AExp
    | Add : AExp -> AExp -> AExp
    | Sub : AExp -> AExp -> AExp
    | Mul : AExp -> AExp -> AExp
    | ACond : BExp -> AExp -> AExp -> AExp

with BExp : Type :=
    | BTrue : BExp
    | BFalse : BExp
    | Eq : AExp -> AExp -> BExp
    | Le : AExp -> AExp -> BExp
    | Not : BExp -> BExp
    | And : BExp -> BExp -> BExp
    | Or : BExp -> BExp -> BExp
    | BCond : BExp -> BExp -> BExp -> BExp.

Inductive Com : Type :=
    | Skip : Com
    | Asgn : Loc -> AExp -> Com
    | Seq : Com -> Com -> Com
    | If : BExp -> Com -> Com -> Com
    | While : BExp -> Com -> Com.

Definition State : Type := Loc -> nat.

Definition initialState : State := fun _ => 0.

Definition changeState (s : State) (x : Loc) (n : nat) : State :=
  fun y : Loc => if x =? y then n else s y.

Inductive AEval : AExp -> State -> nat -> Prop :=
    | EvalAConst :
        forall (n : nat) (s : State), AEval (AConst n) s n
    | EvalVar :
        forall (v : Loc) (s : State), AEval (Var v) s (s v)
    | EvalAdd :
        forall (a1 a2 : AExp) (s : State) (n1 n2 : nat),
          AEval a1 s n1 -> AEval a2 s n2 -> AEval (Add a1 a2) s (n1 + n2)
    | EvalSub :
        forall (a1 a2 : AExp) (s : State) (n1 n2 : nat),
          AEval a1 s n1 -> AEval a2 s n2 -> AEval (Sub a1 a2) s (n1 - n2)
    | EvalMul :
        forall (a1 a2 : AExp) (s : State) (n1 n2 : nat),
          AEval a1 s n1 -> AEval a2 s n2 -> AEval (Mul a1 a2) s (n1 * n2)
    | EvalACondTrue :
        forall (b : BExp) (s : State) (a1 a2 : AExp) (n : nat),
          BEval b s true -> AEval a1 s n -> AEval (ACond b a1 a2)s  n
    | EvalACondFalse :
        forall (b : BExp) (s : State) (a1 a2 : AExp) (n : nat),
          BEval b s false -> AEval a2 s n -> AEval (ACond b a1 a2) s n

with BEval : BExp -> State -> bool -> Prop :=
    | EvalTrue :
        forall s : State, BEval BTrue s true
    | EvalFalse :
        forall s : State, BEval BFalse s false
    | EvalEq :
        forall (a1 a2 : AExp) (s : State) (n m : nat),
          AEval a1 s n -> AEval a2 s m -> BEval (Eq a1 a2) s (Nat.eqb n m)
    | EvalLe :
        forall (a1 a2 : AExp) (s : State) (n m : nat),
          AEval a1 s n -> AEval a2 s m -> BEval (Le a1 a2) s (Nat.leb n m)
    | EvalNot :
        forall (e : BExp) (s : State) (b : bool),
          BEval e s b -> BEval (Not e) s (negb b)
    | EvalAnd :
        forall (e1 e2 : BExp) (s : State) (b1 b2 : bool),
          BEval e1 s b1 -> BEval e2 s b2 -> BEval (And e1 e2) s (andb b1 b2)
    | EvalOr :
        forall (e1 e2 : BExp) (s : State) (b1 b2 : bool),
          BEval e1 s b1 -> BEval e2 s b2 -> BEval (Or e1 e2) s (orb b1 b2)
    | EvalBCondTrue :
        forall (e e1 e2 : BExp) (s : State) (b : bool),
          BEval e s true -> BEval e1 s b -> BEval (BCond e e1 e2) s b
    | EvalBCondFalse :
        forall (e e1 e2 : BExp) (s : State) (b : bool),
          BEval e s false -> BEval e2 s b -> BEval (BCond e e1 e2) s b.

#[global] Hint Constructors AEval BEval : core.

Inductive CEval : Com -> State -> State -> Prop :=
    | EvalSkip :
        forall s : State, CEval Skip s s
    | EvalAsgn :
        forall (v : Loc) (a : AExp) (s : State) (n : nat),
          AEval a s n -> CEval (Asgn v a) s (changeState s v n)
    | EvalSeq :
        forall (c1 c2 : Com) (s1 s2 s3 : State),
          CEval c1 s1 s2 -> CEval c2 s2 s3 -> CEval (Seq c1 c2) s1 s3
    | EvalIfFalse :
        forall (b : BExp) (c1 c2 : Com) (s1 s2 : State),
          BEval b s1 false -> CEval c2 s1 s2 -> CEval (If b c1 c2) s1 s2
    | EvalIfTrue :
        forall (b : BExp) (c1 c2 : Com) (s1 s2 : State),
          BEval b s1 true -> CEval c1 s1 s2 -> CEval (If b c1 c2) s1 s2
    | EvalWhileFalse :
        forall (b : BExp) (c : Com) (s : State),
          BEval b s false -> CEval (While b c) s s
    | EvalWhileTrue :
        forall (b : BExp) (c : Com) (s1 s2 s3 : State),
          BEval b s1 true ->
          CEval c s1 s2 -> CEval (While b c) s2 s3 ->
            CEval (While b c) s1 s3.

#[global] Hint Constructors CEval : core.

Function desugara (a : AExp) : AExp :=
match a with
    | AConst n => AConst n
    | Var v => Var v
    | Add a1 a2 =>
        match desugara a1, desugara a2 with
            | ACond b1 a11 a12, ACond b2 a21 a22 =>
                ACond b1 (ACond b2 (Add a11 a21) (Add a11 a22))
                         (ACond b2 (Add a12 a21) (Add a12 a22))
            | ACond b1 a11 a12, a2 =>
                ACond b1 (Add a11 a2) (Add a12 a2)
            | a1, ACond b2 a21 a22 =>
                ACond b2 (Add a1 a21) (Add a1 a22)
            | a1, a2 => Add a1 a2
        end
    | Sub a1 a2 => Sub a1 a2
    | Mul a1 a2 => Mul a1 a2
    | ACond b1 a1 a2 => ACond (desugarb b1) (desugara a1) (desugara a2)
end

with desugarb (b : BExp) : BExp :=
match b with
    | BTrue => BTrue
    | BFalse => BFalse
    | Eq a1 a2 =>
        match desugara a1, desugara a2 with
            | ACond b1 a11 a12, ACond b2 a21 a22 =>
                BCond b1 (BCond b2 (Eq a11 a21) (Eq a11 a22))
                         (BCond b2 (Eq a12 a21) (Eq a12 a22))
            | ACond b1 a11 a12, a2 =>
                BCond b1 (Eq a11 a2) (Eq a12 a2)
            | a1, ACond b2 a21 a22 =>
                BCond b2 (Eq a1 a21) (Eq a1 a22)
            | a1, a2 => Eq a1 a2
        end
    | Le a1 a2 => Le a1 a2
    | Not b' => Not (desugarb b')
    | And b1 b2 => And (desugarb b1) (desugarb b2)
    | Or b1 b2 => Or (desugarb b1) (desugarb b2)
    | BCond b1 b2 b3 => Or (And b1 b2) (And (Not b1) b3)
end.

Lemma AEval_desugara :
  forall (a : AExp) (s : State) (n : nat),
    AEval a s n -> AEval (desugara a) s n

with BEval_desugarb :
  forall (e : BExp) (s : State) (b : bool),
    BEval e s b -> BEval (desugarb e) s b.
Proof.
  intro a. functional induction desugara a; cbn; intros.
    1-2: assumption.
    inv H. specialize (IHa0 _ _ H2). rewrite e0 in IHa0. admit.
    inv H.
    Ltac wut :=
    repeat match goal with
        | IH : forall _ _ , AEval _ _ _ -> _, H : AEval _ _ _ |- _ =>
            specialize (IH _ _ H)
        | H : match ?x with _ => _ end |- _ => destruct x
        | H : AEval (desugara _) _ _, H' : desugara _ = _ |- _ =>
            rewrite H' in H; inv H; auto
    end.
    wut.
    inv H. wut.
    inv H.
    1-2: assumption.
    inv H; auto.
  intro e. functional induction desugarb e; cbn; intros; auto.
    inv H.
    apply AEval_desugara in H2. rewrite e0 in H2.
      apply AEval_desugara in H5. rewrite e1 in H5.
      inv H2; inv H5; auto.
    admit.
    admit.
    inv H. auto.
    inv H. auto.
    inv H. auto.
    inv H. auto.
    inv H. destruct b; auto.

    repeat match goal with
        | H : forall _ _ _ , AEval _ _ _ -> _,
          H' : AEval ?a _ _ |- _ => idtac H; idtac H';
            is_var a; let H'' := fresh "H" in pose (H'' := H _ _ _ H');
            clearbody H''; clear H'
        | H : AEval ?a _ _, H' : ?a = _ |- _ =>
            rewrite H' in H; clear H'; inv H; auto
    end.
Abort.


(*
 * Taken from https://github.com/jwiegley/coq-lattice
 * Requires the quote library
 *)

Require Import Coq.Program.Program.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Bool_nat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Wellfounded.Lexicographic_Product.

Generalizable All Variables.

Reserved Infix "⊓" (at level 40, left associativity).
Reserved Infix "⊔" (at level 36, left associativity).

Class Lattice (A : Type) := {
  meet : A -> A -> A where "x ⊓ y" := (meet x y);
  join : A -> A -> A where "x ⊔ y" := (join x y);

  meet_commutative : forall a b, a ⊓ b = b ⊓ a;
  meet_associative : forall a b c, (a ⊓ b) ⊓ c = a ⊓ (b ⊓ c);
  meet_absorptive  : forall a b, a ⊓ (a ⊔ b) = a;
  meet_idempotent  : forall a, a ⊓ a = a;

  join_commutative : forall a b, a ⊔ b = b ⊔ a;
  join_associative : forall a b c, (a ⊔ b) ⊔ c = a ⊔ (b ⊔ c);
  join_absorptive  : forall a b, a ⊔ (a ⊓ b) = a;
  join_idempotent  : forall a, a ⊔ a = a
}.

Infix "⊓" := meet (at level 40, left associativity).
Infix "⊔" := join (at level 36, left associativity).

Class Order (A : Set) := {
  ord : relation A;

  reflexive :> Reflexive ord;
  antisymmetric : forall {x y}, ord x y -> ord y x -> x = y;
  transitive :> Transitive ord
}.

Infix "≤" := ord (at level 50).

Class LOSet {A : Set} `(@Order A) `(@Lattice A) := {
  meet_consistent : forall a b, a ≤ b <-> a = a ⊓ b;
  join_consistent : forall a b, a ≤ b <-> b = a ⊔ b
}.

Section Lattice.

Context `{O : Order A}.
Context `{L : Lattice A}.
Context `{@LOSet A O L}.

Theorem meet_is_glb : forall a b : A,
  forall x, x ≤ a /\ x ≤ b <-> x ≤ a ⊓ b.
Proof.
  split; intros.
    intuition.
    apply meet_consistent in H1.
    apply meet_consistent in H2.
    apply meet_consistent.
    rewrite <- meet_associative, <- H1.
    assumption.
  apply meet_consistent in H0.
  rewrite H0; clear H0.
  split; apply meet_consistent.
    rewrite meet_associative.
    rewrite (meet_commutative (a ⊓ b) a).
    rewrite <- (meet_associative a).
    rewrite meet_idempotent.
    reflexivity.
  rewrite meet_associative.
  rewrite meet_associative.
  rewrite meet_idempotent.
  reflexivity.
Qed.

Theorem meet_prime : forall a b : A,
  forall x, a ≤ x \/ b ≤ x -> a ⊓ b ≤ x.
Proof.
  intros.
  destruct H0;
  apply meet_consistent in H0;
  apply meet_consistent; [rewrite meet_commutative|];
  rewrite meet_associative;
  rewrite <- H0; reflexivity.
Qed.

Theorem join_is_lub : forall a b : A,
  forall x, a ≤ x /\ b ≤ x <-> a ⊔ b ≤ x.
Proof.
  split; intros.
    intuition.
    apply join_consistent in H1.
    apply join_consistent in H2.
    apply join_consistent.
    rewrite join_associative, <- H2.
    assumption.
  apply join_consistent in H0.
  rewrite H0; clear H0.
  split; apply join_consistent.
    rewrite <- join_associative.
    rewrite <- join_associative.
    rewrite join_idempotent.
    reflexivity.
  rewrite (join_commutative a b).
  rewrite <- join_associative.
  rewrite <- join_associative.
  rewrite join_idempotent.
  reflexivity.
Qed.

Theorem join_prime : forall a b : A,
  forall x, x ≤ a \/ x ≤ b -> x ≤ a ⊔ b.
Proof.
  intros.
  destruct H0;
  apply join_consistent in H0;
  apply join_consistent; [|rewrite join_commutative];
  rewrite <- join_associative;
  rewrite <- H0; reflexivity.
Qed.

Set Decidable Equality Schemes.

Inductive Term : Set :=
  | Var  : nat  -> Term
  | Meet : Term -> Term -> Term
  | Join : Term -> Term -> Term.

Lemma Meet_acc_l x y : Meet x y <> x.
Proof.
  induction x;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Lemma Meet_acc_r x y : Meet x y <> y.
Proof.
  induction y;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Lemma Join_acc_l x y : Join x y <> x.
Proof.
  induction x;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Lemma Join_acc_r x y : Join x y <> y.
Proof.
  induction y;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Fixpoint length (t : Term) : nat :=
  match t with
  | Var n => 1
  | Meet t1 t2 => 1 + length t1 + length t2
  | Join t1 t2 => 1 + length t1 + length t2
  end.

Fixpoint depth (t : Term) : nat :=
  match t with
  | Var n => 0
  | Meet t1 t2 => 1 + max (depth t1) (depth t2)
  | Join t1 t2 => 1 + max (depth t1) (depth t2)
  end.

Inductive Subterm : Term -> Term -> Prop :=
  | Meet1 : forall t1 t2, Subterm t1 (Meet t1 t2)
  | Meet2 : forall t1 t2, Subterm t2 (Meet t1 t2)
  | Join1 : forall t1 t2, Subterm t1 (Join t1 t2)
  | Join2 : forall t1 t2, Subterm t2 (Join t1 t2).

Definition Subterm_inv_t : forall x y, Subterm x y -> Prop.
Proof.
  intros [] [] f;
  match goal with
  | [ H : Subterm ?X (Meet ?Y ?Z) |- Prop ] =>
    destruct (Term_eq_dec X Y); subst;
    [ destruct (Term_eq_dec X Z); subst;
      [ exact (f = Meet1 _ _ \/ f = Meet2 _ _)
      | exact (f = Meet1 _ _) ]
    | destruct (Term_eq_dec X Z); subst;
      [ exact (f = Meet2 _ _)
      | exact False ] ]
  | [ H : Subterm ?X (Join ?Y ?Z) |- Prop ] =>
    destruct (Term_eq_dec X Y); subst;
    [ destruct (Term_eq_dec X Z); subst;
      [ exact (f = Join1 _ _ \/ f = Join2 _ _)
      | exact (f = Join1 _ _) ]
    | destruct (Term_eq_dec X Z); subst;
      [ exact (f = Join2 _ _)
      | exact False ] ]
  | _ => exact False
  end.
Defined.

Corollary Subterm_inv x y f : Subterm_inv_t x y f.
Proof.
  pose proof Term_eq_dec.
  destruct f, t1, t2; simpl;
  repeat destruct (Term_eq_dec _ _); subst;
  try (rewrite e || rewrite <- e);
  try (rewrite e0 || rewrite <- e0);
  try congruence;
  try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition;
  try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition;

  repeat destruct (Term_eq_dec _ _); subst;
  try (rewrite e || rewrite <- e);
  try (rewrite e0 || rewrite <- e0);
  try congruence;
  try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition;
  try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition.
Qed.

Program Instance Subterm_Irreflexive : Irreflexive Subterm.
Next Obligation.
  repeat intro.
  pose proof (Subterm_inv _ _ H0).
  inversion H0; subst; simpl in *.
  - now apply (Meet_acc_l x t2).
  - now apply (Meet_acc_r t1 x).
  - now apply (Join_acc_l x t2).
  - now apply (Join_acc_r t1 x).
Qed.

Lemma Subterm_wf : well_founded Subterm.
Proof.
  constructor; intros.
  inversion H0; subst; simpl in *;
  induction y;
  induction t1 || induction t2;
  simpl in *;
  constructor; intros;
  inversion H1; subst; clear H1;
  try (apply IHy1; constructor);
  try (apply IHy2; constructor).
Defined.

Reserved Notation "〚 t 〛 env" (at level 9).

Fixpoint eval (t : Term) (env : nat -> A) : A :=
  match t with
  | Var n => env n
  | Meet t1 t2 => 〚t1〛env ⊓ 〚t2〛env
  | Join t1 t2 => 〚t1〛env ⊔ 〚t2〛env
  end where "〚 t 〛 env" := (eval t env).

Definition Leq   (s t : Term) : Prop := forall env, 〚s〛env ≤ 〚t〛env.
Arguments Leq _ _ /.

(* Note that Equiv can be computed from Leq. *)
Definition Equiv (s t : Term) : Prop := forall env, 〚s〛env = 〚t〛env.
Arguments Equiv _ _ /.

Reserved Infix "≲" (at level 30).

Definition R := symprod Term Term Subterm Subterm.
Arguments R /.

Open Scope lazy_bool_scope.

Ltac meets_and_joins leq :=
  repeat destruct (leq (_, _) _);
  simpl in *;
  subst;
  repeat match goal with
  | [ H : (_, _) = (_, _) |- _ ] => progress (inversion H; subst)
  | [ H : bool |- _ ] => destruct H
  end;
  try discriminate;
  simpl in *;
  repeat match goal with
  | [ |- _ ⊔ _ ≤ _ ] => apply join_is_lub; split; firstorder idtac
  | [ |- _ ≤ _ ⊔ _ ] => apply join_prime; firstorder idtac
  | [ |- _ ≤ _ ⊓ _ ] => apply meet_is_glb; split; firstorder idtac
  | [ |- _ ⊓ _ ≤ _ ] => apply meet_prime; firstorder idtac
  end.

Local Obligation Tactic :=
  program_simpl; try (constructor; constructor).

Set Transparent Obligations.

(* Whitman's decision procedure. *)
Program Fixpoint leq (p : Term * Term) {wf R p} :
  { b : bool | b = true -> Leq (fst p) (snd p) } :=
  match p with
  (* 1. If s = Var i and t = Var j, then s ≲ t holds iff i = j. *)
  | (Var i, Var j) => nat_eq_bool i j

  (* 2. If s = Join s1 s2, then s ≲ t holds iff s1 ≲ t and s2 ≲ t. *)
  | (Join s1 s2, t) =>
    exist _ (proj1_sig (leq (s1, t)) &&& proj1_sig (leq (s2, t))) _

  (* 3. If t = Meet t1 t2, then s ≲ t holds iff s ≲ t1 and s ≲ t2. *)
  | (s, Meet t1 t2) =>
    exist _ (proj1_sig (leq (s, t1)) &&& proj1_sig (leq (s, t2))) _

  (* 4. If s = Var i and t = Join t1 t2, then s ≲ t holds iff s ≲ t1 or s ≲ t2. *)
  | (Var i, Join t1 t2) =>
    exist _ (proj1_sig (leq (Var i, t1)) ||| proj1_sig (leq (Var i, t2))) _

  (* 5. If s = Meet s1 s2 and t = Var i, then s ≲ t holds iff s1 ≲ t or s2 ≲ t. *)
  | (Meet s1 s2, Var i) =>
    exist _ (proj1_sig (leq (s1, Var i)) ||| proj1_sig (leq (s2, Var i))) _

  (* 6. If s = Meet s1 s2 and t = Join t1 t2, then s ≲ t holds iff s1 ≲ t or
        s2 ≲ t or s ≲ t1 or s ≲ t2. *)
  | (Meet s1 s2, Join t1 t2) =>
    exist _ (proj1_sig (leq (s1, Join t1 t2)) |||
             proj1_sig (leq (s2, Join t1 t2)) |||
             proj1_sig (leq (Meet s1 s2, t1)) |||
             proj1_sig (leq (Meet s1 s2, t2))) _
  end.
Next Obligation.
  destruct (nat_eq_bool i j); simpl in *; subst.
  rewrite y; reflexivity.
Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation.
  repeat destruct (leq (_, _)); simpl in *.
  destruct x.  apply meet_prime; left;  apply o;  reflexivity.
  destruct x0. apply meet_prime; right; apply o0; reflexivity.
  destruct x1. apply join_prime; left;  apply o1; reflexivity.
  destruct x2. apply join_prime; right; apply o2; reflexivity.
  discriminate.
Defined.
Next Obligation.
  apply wf_symprod;
  apply Subterm_wf.
Defined.

Notation "s ≲ t" := (leq (s, t)) (at level 30).

Definition leq_correct {t u : Term} (Heq : ` (t ≲ u) = true) :
  forall env, 〚t〛env ≤ 〚u〛env := proj2_sig (t ≲ u) Heq.

Inductive Logic : Set :=
  | LLe   : Term  -> Term  -> Logic
  | LAnd  : Logic -> Logic -> Logic
  | LOr   : Logic -> Logic -> Logic
  | LImpl : Logic -> Logic -> Logic.

Fixpoint logicDenote (t : Logic) (env : nat -> A) : Prop :=
  match t with
  | LLe   x y => 〚x〛env ≤ 〚y〛env
  | LAnd  x y => logicDenote x env /\ logicDenote y env
  | LOr   x y => logicDenote x env \/ logicDenote y env
  | LImpl x y => logicDenote x env -> logicDenote y env
  end.

Inductive AndOr {A B : Type} : Type :=
  | AO_Terms : A -> B    -> AndOr
  | AO_And   : AndOr -> AndOr -> AndOr
  | AO_Or    : AndOr -> AndOr -> AndOr.

Program Fixpoint normLe (p : Term * Term) {wf (R) p} : @AndOr Term Term :=
  match p with
  | (Meet a b, c) => AO_Or  (normLe (a, c)) (normLe (b, c))
  | (Join a b, c) => AO_And (normLe (a, c)) (normLe (b, c))
  | (c, Meet a b) => AO_And (normLe (c, a)) (normLe (c, b))
  | (c, Join a b) => AO_Or  (normLe (c, a)) (normLe (c, b))
  | (a, b) => AO_Terms a b
  end.
Next Obligation. intuition; inversion H2. Defined.
Next Obligation. intuition; inversion H2. Defined.
Next Obligation. intuition; inversion H2. Defined.
Next Obligation.
  apply measure_wf.
  apply wf_symprod;
  apply Subterm_wf.
Defined.

Fixpoint denoteAndOr (t : @AndOr Term Term) : Logic :=
  match t with
  | AO_Terms x y => LLe x y
  | AO_And   x y => LAnd (denoteAndOr x) (denoteAndOr y)
  | AO_Or    x y => LOr (denoteAndOr x) (denoteAndOr y)
  end.

Program Fixpoint logicNorm (t : Logic) : Logic :=
  match t with
  | LLe a b => denoteAndOr (normLe (a, b))

  | LAnd  x y => LAnd (logicNorm x) (logicNorm y)
  | LOr   x y => LOr  (logicNorm x) (logicNorm y)

  | LImpl x y =>
    match logicNorm y with
    | LImpl y z => LImpl (LAnd (logicNorm x) y) z
    | y => LImpl (logicNorm x) y
    end
  end.

Theorem logicNorm_sound : forall x env,
  logicDenote x env <->
  logicDenote (logicNorm x) env.
Proof.
Admitted.

(*
Definition markVars (t : Term) (env : nat -> A) (f : nat -> bool) :
  nat -> bool :=
  let fix go t f :=
      match t with
      | Var x    => fun n => (x =? n) ||| f n
      | Meet x y => go x (go y f) (* jww (2017-06-18): correct? *)
      | Join x y => go x (go y f)
      end in
  go t (fun _ => false).

Fixpoint markLogic (t : Logic) (env : nat -> A) : Prop :=
  match t with
  | LLe   x y => 〚x〛env ≤ 〚y〛env
  | LAnd  x y => logicDenote x env /\ logicDenote y env
  | LOr   x y => logicDenote x env \/ logicDenote y env
  | LImpl x y => logicDenote x env -> logicDenote y env
  end.

Fixpoint logicCheck (t : Logic) (env : nat -> A) : Prop :=
  match t with
  | LLe   x y => 〚x〛env ≤ 〚y〛env
  | LAnd  x y => logicDenote x env /\ logicDenote y env
  | LOr   x y => logicDenote x env \/ logicDenote y env
  | LImpl x y => logicDenote x env -> logicDenote y env
  end.

Program Fixpoint determine_truth (t : Logic) {struct t} :
  { b : bool | b = true -> forall env, logicDenote t env } :=
  match t with
  | LLe   x y => leq (x, y)
  | LAnd  x y => exist _ (` (determine_truth x) &&& ` (determine_truth y)) _
  | LOr   x y => exist _ (` (determine_truth x) ||| ` (determine_truth y)) _
  | LImpl x y => exist _ (if ` (determine_truth x)
                          then ` (determine_truth y)
                          else false) _
  end.
Next Obligation. destruct x0; intuition. Defined.
Next Obligation. destruct x0; intuition. Defined.
Next Obligation. destruct x0; intuition. Defined.
*)

End Lattice.

Notation "〚 t 〛 env" := (@eval _ _ t env) (at level 9).
Notation "s ≲ t" := (@leq _ _ _ _ (s, t)) (at level 30).

Import ListNotations.

Ltac inList x xs :=
  match xs with
  | tt => false
  | (x, _) => true
  | (_, ?xs') => inList x xs'
  end.

Ltac addToList x xs :=
  let b := inList x xs in
  match b with
  | true => xs
  | false => constr:((x, xs))
  end.

Ltac allVars xs e :=
  match e with
  | ?e1 ⊓ ?e2 =>
    let xs := allVars xs e1 in
    allVars xs e2
  | ?e1 ⊔ ?e2 =>
    let xs := allVars xs e1 in
    allVars xs e2
  | _ => addToList e xs
  end.

Ltac lookup x xs :=
  match xs with
  | (x, _) => O
  | (_, ?xs') =>
    let n := lookup x xs' in
    constr:(S n)
  end.

Ltac reifyTerm env t :=
  match t with
  | ?X1 ⊓ ?X2 =>
    let r1 := reifyTerm env X1 in
    let r2 := reifyTerm env X2 in
    constr:(Meet r1 r2)
  | ?X1 ⊔ ?X2 =>
    let r1 := reifyTerm env X1 in
    let r2 := reifyTerm env X2 in
    constr:(Join r1 r2)
  | ?X =>
    let n := lookup X env in
    constr:(Var n)
  end.

Ltac functionalize xs :=
  let rec loop n xs' :=
    match xs' with
    | (?x, tt) => constr:(fun _ : nat => x)
    | (?x, ?xs'') =>
      let f := loop (S n) xs'' in
      constr:(fun m : nat => if m =? n then x else f m)
    end in
  loop 0 xs.

Ltac reify :=
  match goal with
  | [ |- ?S ≤ ?T ] =>
    let xs  := allVars tt S in
    let xs' := allVars xs T in
    let r1  := reifyTerm xs' S in
    let r2  := reifyTerm xs' T in
    let env := functionalize xs' in
    (* pose xs'; *)
    (* pose env; *)
    (* pose r1; *)
    (* pose r2; *)
    change (〚r1〛env ≤ 〚r2〛env)
  end.

Ltac lattice := reify; apply leq_correct; vm_compute; auto.

Example sample_1 `{LOSet A} : forall a b : A,
  a ≤ a ⊔ b.
Proof. intros; lattice. Qed.

Lemma running_example `{LOSet A} : forall a b : A,
  a ⊓ b ≤ a ⊔ b.
Proof.
  intros a b.
  rewrite meet_consistent.
  rewrite meet_associative.
  rewrite join_commutative.
  rewrite meet_absorptive.
  reflexivity.
Qed.

Lemma running_example' `{LOSet A} : forall a b : A,
  a ⊓ b ≤ a ⊔ b.
Proof. intros; lattice. Qed.

Lemma median_inequality `{LOSet A} : forall x y z : A,
  (x ⊓ y) ⊔ (y ⊓ z) ⊔ (z ⊓ x) ≤ (x ⊔ y) ⊓ (y ⊔ z) ⊓ (z ⊔ x).
Proof. intros; lattice. Qed.

Ltac allVarsLogic xs e :=
  match e with
  | ?X1 ≤ ?X2 =>
    let xs := allVars xs X1 in
    allVars xs X2
  | ?X1 /\ ?X2 =>
    let xs := allVarsLogic xs X1 in
    allVarsLogic xs X2
  | ?X1 \/ ?X2 =>
    let xs := allVarsLogic xs X1 in
    allVarsLogic xs X2
  | ~ ?X1 =>
    allVarsLogic xs X1
  | ?X1 -> ?X2 =>
    let xs := allVarsLogic xs X1 in
    allVarsLogic xs X2
  end.

Ltac reifyLogic env t :=
  match t with
  | ?X1 ≤ ?X2 =>
    let r1 := reifyTerm env X1 in
    let r2 := reifyTerm env X2 in
    constr:(LLe r1 r2)
  | ?X1 /\ ?X2 =>
    let r1 := reifyLogic env X1 in
    let r2 := reifyLogic env X2 in
    constr:(LAnd r1 r2)
  | ?X1 \/ ?X2 =>
    let r1 := reifyLogic env X1 in
    let r2 := reifyLogic env X2 in
    constr:(LOr r1 r2)
  | ?X1 -> ?X2 =>
    let r1 := reifyLogic env X1 in
    let r2 := reifyLogic env X2 in
    constr:(LImpl r1 r2)
  end.

Ltac lattice' :=
  match goal with
  | [ |- ?P ] =>
    let xs := allVarsLogic tt P in
    let r1 := reifyLogic xs P in
    let env := functionalize xs in
    (* pose xs; *)
    (* pose r1; *)
    (* pose env; *)
    change (logicDenote r1 env);
    apply logicNorm_sound;
    let p := fresh "p" in
    let Heqp := fresh "Heqp" in
    remember (logicNorm _) as p eqn:Heqp;
    vm_compute in Heqp;
    rewrite Heqp; clear Heqp p
    (* vm_compute; *)
    (* intuition idtac *)
  end.

Lemma example_3 `{LOSet A} : forall a b c : A,
  b ≤ a ⊔ b ->
  a ⊓ c ≤ a ->
  a ⊓ b ≤ c ->
  a ⊓ c ≤ b.
Proof.
  intros a b c.
  lattice'.
  simpl.
  intuition.
Admitted.

Lemma median_inequality' `{LOSet A} : forall x y z : A,
  (x ⊓ y) ⊔ (y ⊓ z) ⊔ (z ⊓ x) ≤ (x ⊔ y) ⊓ (y ⊔ z) ⊓ (z ⊔ x).
Proof.
  intros.
  lattice'.
  simpl.
  intuition.
Abort.


Goal forall (X : Type) (x y : X),
(forall p : X -> Prop, p x -> p y) -> x = y.

Proof.
  intros X x y A.

  apply (A (fun z => x = z)).
  reflexivity.
Qed.


(** 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.

Definition synth (x : natural) (y : natural) : natural := plus x (Succ y).


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.

Definition beq_char (a:ascii) (b:ascii) : bool :=
  beq_nat (nat_of_ascii a) (nat_of_ascii b).

Fixpoint beq_string (str1:string) (str2:string) : bool :=
  match str1,str2 with
  | String h1 t1, String h2 t2 => if beq_char h1 h2 then beq_string t1 t2 else false
  | EmptyString, EmptyString => true
  | _, _ => false
  end.

Example beg_string_test1 : (beq_string "123123" "123123") = true.
Proof.
  simpl. reflexivity.
Qed.

Example beg_string_test2 : (beq_string "123123" "abcabc") = false.
Proof.
  simpl. reflexivity.
Qed.

Lemma string_eq_ref : forall s1 s2, beq_string s1 s2 = true -> s1 = s2.
Proof.
  intros. Admitted.

Lemma string_neq_ref : forall s1 s2, beq_string s1 s2 = false -> s1 <> s2.
Proof.
  intros. Admitted.


Require Export Arith.
Require Export ArithRing.
Require Export Lia.
Require Export log2_it.

Inductive log_domain : nat ->  Prop :=
 | log_domain_1: log_domain 1
 | log_domain_2:
     forall (p : nat), log_domain (S (div2 p)) ->  log_domain (S (S p)) .

Theorem log_domain_non_O: forall (x : nat), log_domain x ->  (x <> 0).
Proof.
 intros x H; case H;  discriminate.
Qed.

Theorem log_domain_inv:
 forall (x p : nat), log_domain x -> x = S (S p) ->  log_domain (S (div2 p)).
Proof.
intros x p H; case H; (try (intros H'; discriminate H')).
 intros p' H1 H2; injection H2; intros H3; rewrite <- H3; assumption.
Defined.

Fixpoint exp2 (n : nat) : nat :=
 match n with O => 1 | S p => 2 * exp2 p end.

Theorem spec_1:  exp2 0 <= 1 < 2 * exp2 0 .
Proof.
simpl; auto with arith.
Qed.

Theorem spec_2:
 forall p v',
 ( exp2 v' <= div2 (S (S p)) < 2 * exp2 v' ) ->
  ( exp2 (S v') <= S (S p) < 2 * exp2 (S v') ).
Proof.
intros p v' H; (cbv zeta iota beta delta [exp2]; fold exp2).
elim (div2_eq (S (S p))); intros; lia.
Qed.

Definition log_well_spec:
 forall x (h : log_domain x),
  ({v : nat |  exp2 v <= x < 2 * exp2 v }).
refine (fix
        log_well_spec (x : nat) (h : log_domain x) {struct h} :
          {v : nat |  exp2 v <= x < 2 * exp2 v } :=
           match x as y
           return x = y ->  ({v : nat |  exp2 v <= y < 2 * exp2 v })
           with
              0 =>
                fun h' =>
                False_rec
                 ({v : nat |  exp2 v <= 0 < 2 * exp2 v })
                 (log_domain_non_O x h h')
             | 1 =>
                 fun h' =>
                 exist (fun v =>  exp2 v <= 1 < 2 * exp2 v ) 0 spec_1
             | S (S p) =>
                 fun h' =>
                    match log_well_spec (S (div2 p)) (log_domain_inv x p h h')
                     with
                      exist _ v' Hv' =>
                        exist
                         (fun v =>  exp2 v <= S (S p) < 2 * exp2 v )
                         (S v') (spec_2 p v' Hv')
                    end
           end (refl_equal x)).
Qed.


Require Import mathcomp.ssreflect.ssreflect.

Set Ltac Profiling.

Lemma plus_O : forall n m: nat, n + m = m + n.
Proof.
  induction n; try done; simpl; intro.
  rewrite IHn.
  done.
Qed.

Show Ltac Profile.


Require Import List.

Inductive Perm (a:Type) : list a -> list a -> Prop :=
| pRefl   : forall (xs:list a), Perm a xs xs
| pCons   : forall (x:a)(xs ys:list a), Perm a xs ys -> Perm a (x :: xs) (x :: ys)
| pAppend : forall (x:a)(xs:list a), Perm a (x :: xs) (xs ++ x :: nil)
| pTrans  : forall (xs ys zs:list a), Perm a xs ys -> Perm a ys zs -> Perm a xs zs
.

Ltac perm_aux n :=
    match goal with
    | |- (Perm _ ?l ?l) => apply pRefl
    | |- (Perm _ (?x :: ?l1) (?x :: ?l2)) =>
        let newn := eval compute in (length l1) in
            (apply pCons; perm_aux newn)
    | |- (Perm ?a (?x :: ?l1) ?l2) =>
        match eval compute in n with
        | 1 => fail
        | _ =>
            let l1' := constr:(l1 ++ x :: nil) in
                (apply (pTrans a (x :: l1) l1' l2);
                [ apply pAppend | compute; perm_aux (pred n) ])
        end
    end.

Ltac solve_perm :=
    match goal with
    | |- (Perm _ ?l1 ?l2) =>
        match eval compute in (length l1 = length l2) with
        | (?n = ?n) => perm_aux n
        end
    end.

Lemma L1 : Perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil).
Proof. solve_perm. Qed.

Lemma L2 : Perm nat
    (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil)
    (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil).
Proof. solve_perm. Qed.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)

Set Default Goal Selector "!".

Require Import Turing.Turing.
Require Import Turing.LangRed.
Require Import Turing.LangDec.
Require Import Turing.Problems.
Require Import Coq.Logic.FunctionalExtensionality.

(* ---------------------------------------------------------------------------*)

(* ------------------------ BEGIN UTILITY RESULTS ---------------------- *)
Ltac invc H := inversion H; subst; clear H.

Lemma a_tm_rw:
  forall M i,
  A_tm <[ M, i ]> <->
  Run (Call M i) true.
Proof.
  unfold A_tm.
  intros.
  run_simpl_all.
  reflexivity.
Qed.

(* -------------------------- END OF UTILITY RESULTS ---------------------- *)

(**

=== Background information on map-reducibility ===

First recall the definition of <=m .

  Notation "<=m".

outputs:

  Notation "x <=m y" := (Reducible x y) (default interpretation)

So, what is reducible:

  Print Reducible.

Which says:

  Reducible =
  fun A B : lang => exists f : input -> input, Reduction f A B
      : lang -> lang -> Prop

  Arguments Reducible A B

The important bit here is

    exists f, Reduction f A B

After `Print Reduction.` we recall that a reduction relates any input i
in A whenever f(i) is in B.

    forall w, A w <-> B (f w)

=== Actual proof ===

We will follow the proof of Theorem 5.28 (which redirects to
the proof of 5.22).

This kind of result needs to be proved directly (without the
aid of any theorem, so let us open up both definitions:

    unfold Reducible, Reduction in *.

At this point, our proof state is as follows:

  H : exists f, forall w : input, A w <-> B (f w)
  H0 : Recognizable B
  ______________________________________(1/1)
  Recognizable A

Let us access the function that maps from A to B with `destruct H as (f, H)`,
and the program that recognizes B `destruct H0 as (M, H0)`.

The pen & paper proof says the following:

  On input w:
  1. Compute f(w).
  2. Run M on input f(w) and output whatever M outputs

Our next tactics must be as follows to state that `(fun w => M (f w))`
recognizes A.

  exists (fun w => M (f w)).

In Coq, the high-level description can be state as `(fun w => M (f w))`,
since `M` is a program parameterized by an input and
"running M on input f(w)" amounts to calling `M` with argument `f(w)`,
written as `M (f w)`.

Now we apply the theorem `recognizes_def` to show that our program
recognizes language `A`. Following we introduce the input as `i`.

Our goal is now to show:

  Run (M (f i)) true <-> A i

Recall that `M` recognizes `B` (assumption `H0`) and
since `M (f i)` returns `true`, then we have `B (f i)`;
using `rewrite (recognizes_rw H0)` to obtain that fact in the goal
--- if we use `recognizes_rw` without a parameter Coq will complain
that it requires more information.

Finally, we can get rid of `A i` on the right-hand side of the equivalence
by using our map-reducibly assumption, with `rewrite H`.

 *)
Theorem red1:
  forall A B,
  A <=m B ->
  Recognizable B ->
  Recognizable A.
Proof.
        intros.
        unfold Reducible, Reduction in *.
        destruct H as (f, H).
        destruct H0 as (M, H0).
        exists (fun w => M (f w)).
        apply recognizes_def.
        intros.
        rewrite (recognizes_rw H0).
        rewrite <- H.
        reflexivity.
Qed.

(**

We will follow the proof of Theorem 5.22.

First, we simplify `Decidable B` as in HW7 and we simplify our
remaining assumptions as suggested in `red1` until we get the following
proof state:

  H : forall w, A w <-> B (f w)
  H0 : Recognizes M B
  H1 : Decider M
  ______________________________________(1/1)
  Decidable A

We use the same program to decide `A` than we do in exercise `red1`.
Our proof state is now as follows

  Decides (fun w : input => M (f w)) A

We use theorem `decides_def` to continue. The first sub-goal proceeds
exactly like in exercise `red1`.

The second sub-goal we have the following relevant proof state:

  H1: Decider M
  ______________________________________(1/1)
  Decider (fun w : input => M (f w))

Recall that a decider halts for all inputs, `f w` is an arbitrary
input, thus `M` halts for `f w`. To conclude this goal,
write `unfold Decider in *` and use `H1` to conclude.

 *)
Theorem red2:
  forall A B,
  A <=m B ->
  Decidable B ->
  Decidable A.
Proof.
        intros.
        unfold Reducible, Reduction in H.
        destruct H as (f, H).
        destruct H0 as (M, H0).
        destruct H0.
        exists (fun w => M (f w)).
        apply decides_def.
        1: apply recognizes_def.
        1: intros.
        1: rewrite (recognizes_rw H0); rewrite <- H; reflexivity.
        unfold Decider. intros. apply H1.
Qed.

(**

We will follow Prof. Peter Fejer's proof of problem 5.22:

  https://www.cs.umb.edu/~fejer/cs420/hw11s.pdf

Since our goal is an equivalence, we should start with

  split; intros.

Prof. Fejer's proof starts with:

1. "Let M be a Turing machine that recognizes A."

The first goal, first obtain the parameterized program `p` and
assumption `H` from `H: Recognizable A`.

We can convert a parametric program, such as `p`, into an abstract
Turing machine with

    destruct (code_of p) as (M, Hp).

This tactics yields an abstract Turing machine `M` and an
assumption `Hp : CodeOf p M` which establishes the equivalence
between the parametric function `p` and the abstract Turing machine `M`.

We now have all of the ingredient's to continue Prof. Fejer's proof:

2. "The function f defined by f (w) =〈M, w〉is a reduction from A to A_tm"

We can state that with the tactics:

  apply reducible_iff with (f:=fun i => <[ M, i ]>).

Finally, the last step of Prof. Fejer's proof is as follows:

3. "because it is obviously computable and we have"

    "w ∈ A iff M accepts w iff〈M, w〉 ∈ A_tm iff f (w) ∈ A_tm"
We can show that "〈M, w〉 ∈ A_tm iff M accepts w" with rewriting
with `a_tm_rw`, since "M accepts w" is represented in
Coq by `Run (Call M w) true`.

We know that `M` represents function `p`; we replace `Run (Call M w) true`
by `Run (p w) true` by rewriting with `(code_of_run_rw Hp)`.

Finally, since `p` recognizes `A` we can replace `Run (p w) true` by
`A w` using `(recognizes_rw H)`.

The second case is trivial knowing what we proved so far, if you recall
that `A_tm` is recognizable, given by a_tm_recognizable. Read Prof. Fejer's
proof to get the remaining details.

 *)
Theorem red3:
  forall A, Recognizable A <-> A <=m A_tm.
Proof.
        intros.
        split.
        all:intros.
        1: destruct H as (p, H).
        1: destruct (code_of p) as (M, Hp).
        1: apply reducible_iff with (f:=fun i => <[ M, i ]>).
        1: intros.
        1: rewrite a_tm_rw.
        1: rewrite (code_of_run_rw Hp).
        1: rewrite (recognizes_rw H); reflexivity.
        Search ( Recognizable).
        apply red1 with (B:= A_tm) in H.
        1: assumption.
        apply a_tm_recognizable.
Qed.
(**

Prove Corollary 5.29.

 *)
Theorem red4:
  forall A B,
  A <=m B ->
  ~ Recognizable A ->
  ~ Recognizable B.
Proof.
        intros.
        intros N.
        contradict H0.
        apply red1 in H.
        1,2: assumption.
Qed.

(**

Let us solve Exercise 5.6 (solution in pp 242).

First, we simplify our assumptions to obtain.

  Hab : Reduction f A B
  Hbc : Reduction g B C
  ______________________________________(1/1)
  A <=m C

Now apply reducible_iff and with function `fun w => g (f w))`.

Next, we `unfold Reduction in *`.

The remainder should be trivial.

 *)
Theorem red5:
  forall A B C,
  A <=m B ->
  B <=m C ->
  A <=m C.
Proof.
        intros.
        unfold Reducible, Reduction in *.
        invc H; invc H0.
        exists (fun i => x0 (x i)).
        intros.
        rewrite <- H.
        rewrite <- H1.
        reflexivity.
Qed.

(**

Use theorem `co_red_co_1`, which states

  If A <=m B, then compl A <=m compl B.

and what we have learned so far to prove the following statement.

 *)
Theorem red6:
  forall A B,
  A <=m B ->
  Recognizable (compl B) ->
  Recognizable (compl A).
Proof.
        intros.
        apply co_red_co_1 in H.
        apply red1 in H.
        all: assumption.
Qed.

(**

Use the theorem `co_red_2`, which states:

  If A <=m compl B, then compl A <=m B

and what we have learned so far to prove the following statement.

 *)
Theorem red7:
  forall A B C,
  A <=m compl B ->
  compl B <=m C ->
  compl A <=m compl C.
Proof.
        intros.
        apply co_red_2 in H.
        apply co_red_co_1 in H0.
        rewrite co_co_rw in H0.
        apply red5 with (B:= B).
        1,2: assumption.
Qed.

(**

Use theorem dec_rec_co_rec which we learned in class and two other
theorems we established in this assignment to conclude this proof.

 *)
Theorem red8:
  forall A,
  Decidable A ->
  A <=m compl A_tm.
Proof.
        intros.
        apply dec_rec_co_rec in H.
        destruct H.
        apply red3 in H0.
        apply co_red_co_1 in H0.
        rewrite co_co_rw in H0.
        auto.
Qed.

(**

Recall that A_tm is not recognizable (co_a_tm_not_recognizable).
Show that if A_tm is map-reducible to A, then the complement of A is not
recognizable. Hint use: co_red_co_1.

 *)
Theorem red9:
  forall A,
  A_tm <=m A ->
  ~ Recognizable (compl A).
Proof.
        intros.
        intros N.
        apply co_red_co_1 in H.
        apply red4 in H.
        1: contradiction.
        Search A_tm.
        apply co_a_tm_not_recognizable.
Qed.

(**

Show A_tm is *not* map-reducible to decidable languages.

Start the proof by assuming that A_tm <= A and then reach a contradiction,
which is obtained because we can show that compl A is recognizable and
compl A is unrecognizable.

1. We can prove that compl A is recognizable from A decidable.
2. We can prove that compl A is unrecognizable as follows:
   We have `compl A_tm <=m compl A_tm` and that `compl A_tm` is unrecognizable,
   so `compl A` is unrecognizable (which is one of the exercises prove here).
   The proof is similar to red9.

 *)
Theorem red10:
  forall A,
  Decidable A ->
  ~ (A_tm <=m A).
Proof.
        intros.
        intros I.
        apply red9 in I.
        Search Decidable.
        apply decidable_to_co_recognizable with (L:= A) in H.
        contradiction.
Qed.

(**

Show the following trivial statement.

 *)
Theorem red11:
  forall A,
  Decidable A ->
  A <=m A_tm.
Proof.
        intros.
        Search Decidable.
        apply decidable_to_recognizable with (L:= A) in H.
        apply red3 in H.
        1: assumption.
Qed.

Theorem red12:
  forall A B,
  Recognizable A ->
  A_tm <=m B ->
  A <=m B.
Proof.
        intros.
        apply red3 in H.
        apply red5 with (A:= A) (B:= A_tm) (C:= B) in H.
        all: auto.
Qed.

(**

Which language satisfies the following statement?
Ask for a hint if you are unsure.

 *)
Theorem red13:
  exists A, (A_tm <=m A) /\ Recognizable A.
Proof.
        exists A_tm.
        split.
        1: unfold Reducible, Reduction.
        1: exists (fun i=> i).
        1: intros.
        1: reflexivity.
        apply a_tm_recognizable.
Qed.

(**

Solve Exercise 5.7 of the book. The solution given in pp 242 is as follows:

1. Suppose that A <=m compl A. Then compl A <=m A via co_red_2.
2. Because A is Turing-recognizable, red3 implies that compl A is
   Turing-recognizable, and then dec_rec_co_rec implies that A is decidable.

 *)
Theorem red14:
  forall A,
  Recognizable A ->
  A <=m compl A ->
  Decidable A.
Proof.
        intros.
        apply dec_rec_co_rec.
        split.
        1: auto.
        apply co_red_2 in H0.
        apply red1 in H0.
        all: intuition.
Qed.


Inductive bool : Type :=
    | true
    | false.

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.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.


(**
プログラミング Coq 証明駆動開発入門(1)
http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt8.html

をSSReflectに書き直した。
Permutation は SSReflect の相当の補題を使っているため、
証明の詳細は原著と異なることに注意してください。
*)

(* ************************************************** *)
(* nat と ≦ より一般的な、eqType と R で証明を試みる。 *)
(* ************************************************** *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Section isort.
  Variables T : eqType.
  Variables R R' : rel T.
  Hypothesis complete_conv : forall n m : T, ~ R m n -> R n m.

  (* Permutation, seq.v *)
  Check perm_eq (1::2::3::nil) (2::1::3::nil).
  Eval compute in perm_eq (1::2::3::nil) (2::1::3::nil). (* true *)
  Eval compute in perm_eq nil nil.                       (* true *)

  (* ソート処理の定義 *)
  Fixpoint insert (a : T) (l : seq T) : seq T :=
    match l with
      | nil => a :: nil
      | x :: xs => if R a x then a :: l else x :: insert a xs
    end.

  Fixpoint insertion_sort (l : seq T) : seq T :=
    match l with
      | nil => nil
      | x :: xs => insert x (insertion_sort xs)
    end.

  (* 証明 *)
  Lemma perm_iff (m n : seq T) :
    (forall l, perm_eq m l = perm_eq n l) <-> perm_eq m n.
  Proof.
    split=> H.
    - by rewrite H.
    - by apply/perm_eqlP.
  Qed.

  Lemma perm_swap : forall (l l' : seq T) (x a : T),
                      perm_eq [:: x, a & l] l' = perm_eq [:: a, x & l] l'.
  Proof.
    move=> l l' x a.
    apply/perm_iff : l' => //.              (* l' は、perm_iff の左辺の∀のため。 *)
    rewrite -[[:: x, a & l]]cat1s -[[:: a & l]]cat1s.
    apply/perm_eqlP.
      by apply: (perm_catCA [:: x] [:: a] l).
  Qed.

  Lemma insert_perm : forall (l : seq T) (x : T),
                        perm_eq (x::l) (insert x l).
  Proof.
    elim=> [_ // | a l H x //=].
    case: (R x a) => [//= |].
    apply/perm_iff => // l'.
    rewrite perm_swap => //.
    apply/perm_iff : l'.
    by rewrite perm_cons.
  Qed.

  Theorem isort_permutation : forall (l : seq T),
                                perm_eq l (insertion_sort l).
  Proof.
    elim=> [// | a l H //=].
    apply: (@perm_eq_trans T (a :: insertion_sort l)).
(*  apply perm_eq_trans with (y := a :: insertion_sort l). *)
    + by rewrite perm_cons.
    + by apply: insert_perm.
  Qed.

  Inductive LocallySorted : seq T -> Prop :=
  | LSorted_nil : LocallySorted nil
  | LSorted_cons1 : forall a : T, LocallySorted (a :: nil)
  | LSorted_consn : forall (a b : T) (l : seq T),
                      LocallySorted (b :: l) ->
                      R a b -> LocallySorted (a :: b :: l).

  Lemma insert_sorted : forall (a : T) (l : seq T),
                          LocallySorted l -> LocallySorted (insert a l).
  Proof.
    move=> a.
    elim=> [H //= | a0 l IHl H //=].
    - by apply: LSorted_cons1.
    - case Heqb : (R a a0).                 (* remember *)
      + apply: LSorted_consn.
        * by [].
        * by rewrite Heqb.
(*    + elim: l IHl H => [_ _ |b l0 H1 IHl H]. *)
      + inversion H.
        * apply: LSorted_consn.
          apply: LSorted_cons1.
          by move: Heqb => /negP /complete_conv.
        * rewrite -H1 in IHl, H.            (* subst *)
          rewrite /= in IHl => /=.          (* simpl in IHl; simpl. *)
          elim H' : (R a b).
          - apply: LSorted_consn.
            + by rewrite H' in IHl; apply: IHl. (* apply H2. *)
            + by move: Heqb => /negP /complete_conv.
          - apply: LSorted_consn.
            + by rewrite H' in IHl; apply: IHl. (* apply H2. *)
            + by [].                            (* apply H3. *)
  Qed.

  Theorem isort_sorted : forall (l : seq T),
                           LocallySorted (insertion_sort l).
  Proof.
    elim=> [| a l H //=].
    - by apply: LSorted_nil.
    - by apply: insert_sorted.
  Qed.

End isort.

Lemma leq_complete_conv : forall n m : nat, ~ (m <= n) -> n <= m.
Proof.
  move=> n m /negP.
  rewrite -ltnNge.
  by apply: ltnW.
Qed.

Definition nat_isort_sorted := isort_sorted leq_complete_conv.
Check nat_isort_sorted :
  forall l : seq nat, LocallySorted leq (insertion_sort leq l).

(* 以下、参考 *)
Eval compute in insert leq 1 nil.                      (* [:: 1] *)
Eval compute in insert leq 5 [:: 1; 4; 2; 9; 3].       (* [:: 1; 4; 2; 5; 9; 3] *)
Eval compute in insertion_sort leq [:: 2; 4; 1; 5; 3]. (* [:: 1; 2; 3; 4; 5] *)

Check leq : nat -> nat -> bool.
Check leq : nat -> nat -> Prop.
Check leq : rel nat : Type.
Check le : nat -> nat -> Prop.
Fail Check le : nat -> nat -> bool.
Fail Check le : rel nat.                    (* rel : Type -> Type *)
Check LocallySorted leq (1::2::3::nil) : Prop.
Fail Check LocallySorted le (1::2::3::nil) : Prop.

Require Import path.

(* Sorted, path.v *)
Check sorted : forall T : eqType, rel T -> seq T -> bool.
Check leq : nat -> nat -> bool.
Check leq : nat -> nat -> Prop.
Check leq : rel nat : Type.
Check le : nat -> nat -> Prop.
Fail Check le : nat -> nat -> bool.
Fail Check le : rel nat.                    (* rel : Type -> Type *)

Check sorted ltn (1::2::3::nil).
Check sorted leq (1::2::3::nil).
Eval compute in sorted leq (1::2::3::nil). (* true *)
Eval compute in sorted leq (3::nil).       (* true *)
Eval compute in sorted leq nil.            (* true *)
Eval compute in sorted leq (2::1::3::nil). (* false *)

(* END *)


Require Import HoTT.
(*Require Import Coq.Program.Tactics.*)

Section Book_1_4.
Variable C:Type.

(*Defining the iterator.*)
Fixpoint iter (C:Type) (c0:C) (cs:C->C) (n:nat) : C :=
	match n with
		|O=>c0
		|S p => cs (iter C c0 cs p)
end.

(*Make an iterative step function N*C->N*C from the recursive step function cs.*)
Definition iter_step (c0:C) (cs : nat->C->C) (p:nat*C) : nat*C :=
	match p with
		|(n,c) => (S n, cs n c)
end.

(*Define recursion in terms of the iterator.*)
Definition Rec (c0:C) (cs : nat->C->C) (n:nat) : C :=
	snd (iter (nat*C) (O,c0)  (iter_step c0 cs) n).

Lemma iter_formula : forall (n:nat) (c0:C) (cs : nat->C->C),
  iter (nat*C) (O,c0) (iter_step c0 cs) n = (n, Rec c0 cs n).
Proof.
  intros n c0 cs.
  apply equiv_path_prod.
  simpl.
  split.
  * (* First projection *)
		induction n.
		** (*Base case*)
			reflexivity.
		** (*Induction step*)
			simpl.
			rewrite IHn.
			reflexivity.

  * (*Second projection*)
		induction n.
		** (*Base case*)
			reflexivity.
		** (*Induction step*)
			unfold Rec.
			reflexivity.
Qed.

(*
	induction n.
	* (*base case*) reflexivity.

	* (*step case*)
	unfold Rec.
	simpl.
	rewrite IHn.
	simpl.
	unfold iter_step.
	reflexivity.
Qed.
 *)
Proposition Rec_equals_natrec : forall (c0:C)(cs : nat->C->C)(n:nat),
  	Rec c0 cs n = nat_rec C c0 cs n.
	intros c0 cs.
	intro n.

	induction n.
	* reflexivity.

	*
	simpl.
	rewrite <- IHn.
	unfold Rec at 1.
	simpl.
	rewrite iter_formula.
	simpl.
	reflexivity.
Qed.

(*Alternative way to do it:*)
Lemma step_equation_satisfied : forall (c0:C)(cs : nat->C->C)(n:nat),
	Rec c0 cs (n.+1) = cs n (Rec c0 cs n).
	intros c0 cs n.
	unfold Rec at 1.

	simpl.
	rewrite (iter_formula).
	simpl.
	reflexivity.
Qed.

Proposition Rec_equals_natrec2 : forall (c0:C)(cs : nat->C->C)(n:nat),
  	Rec c0 cs n = nat_rec C c0 cs n.
  	intros c0 cs n.
  	induction n.
  	* reflexivity.
  	*
  	rewrite step_equation_satisfied.
  	rewrite IHn.
  	reflexivity.
Qed.

End Book_1_4.


(* T1: Programación funcional y métodos elementales de demostración en Coq *)

(* El contenido de la teoría es
1. Datos y funciones
   1. Tipos enumerados
   2. Booleanos
   3. Tipos de las funciones
   4. Tipos compuestos
   5. Módulos
   6. Números naturales
2. Métodos elementales de demostración
   1. Demostraciones por simplificación
   2. Demostraciones por reescritura
   3. Demostraciones por análisis de casos *)

(* =====================================================================
   § 1. Datos y funciones
   ================================================================== *)

(* =====================================================================
   §§ 1.1. Tipos enumerados
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.1.1. Definir el tipo dia cuyos constructores sean los días
   de la semana.
   ------------------------------------------------------------------ *)

Inductive dia: Type :=
  | lunes     : dia
  | martes    : dia
  | miercoles : dia
  | jueves    : dia
  | viernes   : dia
  | sabado    : dia
  | domingo   : dia.

(* ---------------------------------------------------------------------
   Ejemplo 1.1.2. Definir la función
      siguiente_laborable : dia -> dia
   tal que (siguiente_laborable d) es el día laboral siguiente a d.
   ------------------------------------------------------------------ *)

Definition siguiente_laborable (d:dia) : dia:=
  match d with
  | lunes     => martes
  | martes    => miercoles
  | miercoles => jueves
  | jueves    => viernes
  | viernes   => lunes
  | sabado    => lunes
  | domingo   => lunes
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.1.3. Calcular el valor de las siguientes expresiones
      + siguiente_laborable jueves
      + siguiente_laborable viernes
      + siguiente_laborable (siguiente_laborable sabado)
   ------------------------------------------------------------------ *)

Compute (siguiente_laborable jueves).
(* ==> viernes : dia *)

Compute (siguiente_laborable viernes).
(* ==> lunes : dia *)

Compute (siguiente_laborable (siguiente_laborable sabado)).
(* ==> martes : dia *)

(* ---------------------------------------------------------------------
   Ejemplo 1.1.4. Demostrar que
      siguiente_laborable (siguiente_laborable sabado) = martes
   ------------------------------------------------------------------ *)

Example siguiente_laborable1:
  siguiente_laborable (siguiente_laborable sabado) = martes.
Proof.
  simpl.       (* ⊢ martes = martes *)
  reflexivity. (* ⊢ *)
Qed.

(* =====================================================================
   §§ 1.2. Booleanos
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.2.1. Definir el tipo bool (𝔹) cuyos constructores son true
   y false.
   ------------------------------------------------------------------ *)

Inductive bool : Type :=
  | true  : bool
  | false : bool.

(* ---------------------------------------------------------------------
   Ejemplo 1.2.2. Definir la función
      negacion : bool -> bool
   tal que (negacion b) es la negacion de b.
   ------------------------------------------------------------------ *)

Definition negacion (b:bool) : bool :=
  match b with
  | true  => false
  | false => true
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.2.3. Definir la función
      conjuncion : bool -> bool -> bool
   tal que (conjuncion b1 b2) es la conjuncion de b1 y b2.
   ------------------------------------------------------------------ *)

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

(* ---------------------------------------------------------------------
   Ejemplo 1.2.4. Definir la función
      disyuncion : bool -> bool -> bool
   tal que (disyuncion b1 b2) es la disyunción de b1 y b2.
   ------------------------------------------------------------------ *)

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

(* ---------------------------------------------------------------------
   Ejemplo 1.2.5. Demostrar las siguientes propiedades
      disyuncion true  false = true.
      disyuncion false false = false.
      disyuncion false true  = true.
      disyuncion true  true  = true.
   ------------------------------------------------------------------ *)

Example disyuncion1: disyuncion true false = true.
Proof. simpl. reflexivity.  Qed.

Example disyuncion2: disyuncion false false = false.
Proof. simpl. reflexivity.  Qed.

Example disyuncion3: disyuncion false true = true.
Proof. simpl. reflexivity.  Qed.

Example disyuncion4: disyuncion true true = true.
Proof. simpl. reflexivity.  Qed.

(* ---------------------------------------------------------------------
   Ejemplo 1.2.6. Definir los operadores (&&) y (||) como abreviaturas
   de las funciones conjuncion y disyuncion.
   ------------------------------------------------------------------ *)

Notation "x && y" := (conjuncion x y).
Notation "x || y" := (disyuncion x y).

(* ---------------------------------------------------------------------
   Ejemplo 1.2.7. Demostrar que
      false || false || true = true.
   ------------------------------------------------------------------ *)

Example disyuncion5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.2.1. Definir la función
      nand : bool -> bool -> bool
   tal que (nanb x y) se verifica si x e y no son verdaderos.

   Demostrar las siguientes propiedades de nand
      nand true  false = true.
      nand false false = true.
      nand false true  = true.
      nand true  true  = false.
   ------------------------------------------------------------------ *)

Definition nand (b1:bool) (b2:bool) : bool :=
  negacion (b1 && b2).

Example nand1: nand true false = true.
Proof. simpl. reflexivity. Qed.

Example nand2: nand false false = true.
Proof. simpl. reflexivity. Qed.

Example nand3: nand false true = true.
Proof. simpl. reflexivity. Qed.

Example nand4: nand true true = false.
Proof. simpl. reflexivity. Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.2.2. Definir la función
      conjuncion3 : bool -> bool -> bool -> bool
   tal que (conjuncion3 x y z) se verifica si x, y y z son verdaderos.

   Demostrar las siguientes propiedades de conjuncion3
      conjuncion3 true  true  true  = true.
      conjuncion3 false true  true  = false.
      conjuncion3 true  false true  = false.
      conjuncion3 true  true  false = false.
   ------------------------------------------------------------------ *)

Definition conjuncion3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  b1 && b2 && b3.

Example conjuncion3a: conjuncion3 true true true = true.
Proof. simpl. reflexivity. Qed.

Example conjuncion3b: conjuncion3 false true true = false.
Proof. simpl. reflexivity. Qed.

Example conjuncion3c: conjuncion3 true false true = false.
Proof. simpl. reflexivity. Qed.

Example conjuncion3d: conjuncion3 true true false = false.
Proof. simpl. reflexivity. Qed.

(* =====================================================================
   §§ 1.3. Tipos de las funciones
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.3.1. Calcular el tipo de las siguientes expresiones
      + true
      + (negacion true)
      + negacion
   ------------------------------------------------------------------ *)

Check true.
(* ===> true : bool *)

Check (negacion true).
(* ===> negacion true : bool *)

Check negacion.
(* ===> negacion : bool -> bool *)

(* =====================================================================
   §§ 1.4. Tipos compuestos
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.4.1. Definir el tipo rva cuyos constructores son rojo, verde
   y azul.
   ------------------------------------------------------------------ *)

Inductive rva : Type :=
  | rojo  : rva
  | verde : rva
  | azul  : rva.

(* ---------------------------------------------------------------------
   Ejemplo 1.4.2. Definir el tipo color cuyos constructores son negro,
   blanco y primario, donde primario es una función de rva en color.
   ------------------------------------------------------------------ *)

Inductive color : Type :=
  | negro    : color
  | blanco   : color
  | primario : rva -> color.

(* ---------------------------------------------------------------------
   Ejemplo 1.4.3. Definir la función
      monocromático : color -> bool
   tal que (monocromático c) se verifica si c es monocromático.
   ------------------------------------------------------------------ *)

Definition monocromático (c : color) : bool :=
  match c with
  | negro      => true
  | blanco     => true
  | primario p => false
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.4.4. Definir la función
      esRojo : color -> bool
   tal que (esRojo c) se verifica si c es rojo.
   ------------------------------------------------------------------ *)

Definition esRojo (c : color) : bool :=
  match c with
  | negro         => false
  | blanco        => false
  | primario rojo => true
  | primario _    => false
  end.

(* =====================================================================
   §§ 1.5. Módulos
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.5.1. Iniciar el módulo Naturales.
   ------------------------------------------------------------------ *)

Module Naturales.

(* =====================================================================
   §§ 1.6. Números naturales
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.1. Definir el tipo nat de los números naturales con los
   constructores 0 (para el 0) y S (para el siguiente).
   ------------------------------------------------------------------ *)

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

(* ---------------------------------------------------------------------
   Ejemplo 1.6.2. Definir la función
      pred : nat -> nat
   tal que (pred n) es el predecesor de n.
   ------------------------------------------------------------------ *)

Definition pred (n : nat) : nat :=
  match n with
    | O    => O
    | S n' => n'
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.3. Finalizar el módulo Naturales.
   ------------------------------------------------------------------ *)

End Naturales.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.4. Calcular el tipo y valor de la expresión
   (S (S (S (S O)))).
   ------------------------------------------------------------------ *)

Check (S (S (S (S O)))).
(* ===> 4 : nat *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.5. Definir la función
      menosDos : nat -> nat
   tal que (menosDos n) es n-2.
   ------------------------------------------------------------------ *)

Definition menosDos (n : nat) : nat :=
  match n with
    | O        => O
    | S O      => O
    | S (S n') => n'
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.6. Evaluar la expresión (menosDos 4).
   ------------------------------------------------------------------ *)

Compute (menosDos 4).
(* ===> 2 : nat *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.7. Calcular et tipo de las funcionse S, pred y menosDos.
   ------------------------------------------------------------------ *)

Check S.
(* ===>  S : nat -> nat *)

Check pred.
(* ===> pred : nat -> nat *)

Check menosDos.
(* ===> menosDos : nat -> nat *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.8. Definir la función
      esPar : nat -> bool
   tal que (esPar n) se verifica si n es par.
   ------------------------------------------------------------------ *)

Fixpoint esPar (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => esPar n'
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.9. Definir la función
      esImpar : nat -> bool
   tal que (esImpar n) se verifica si n es impar.
   ------------------------------------------------------------------ *)

Definition esImpar (n:nat) : bool :=
  negacion (esPar n).

(* ---------------------------------------------------------------------
   Ejemplo 1.6.10. Demostrar que
      + esImpar 1 = true.
      + esImpar 4 = false.
   ------------------------------------------------------------------ *)

Example esImpar1: esImpar 1 = true.
Proof. simpl. reflexivity.  Qed.

Example esImpar2: esImpar 4 = false.
Proof. simpl. reflexivity.  Qed.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.12. Iniciar el módulo Naturales2.
   ------------------------------------------------------------------ *)

(* Module Naturales2. *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.13. Definir la función
      suma : nat -> nat -> nat
   tal que (suma n m) es la suma de n y m. Por ejemplo,
      suma 3 2 = 5

   Nota: Es equivalente a la predefinida plus
   ------------------------------------------------------------------ *)

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

Compute (suma 3 2).
(* ===> 5: nat *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.14. Definir la función
      producto : nat -> nat -> nat
   tal que (producto n m) es el producto de n y m. Por ejemplo,
      producto 3 2 = 6

   Nota: Es equivalente a la predefinida mult.
   ------------------------------------------------------------------ *)

Fixpoint producto (n m : nat) : nat :=
  match n with
    | O    => O
    | S n' => suma m (producto n' m)
  end.

Example producto1: (producto 2 3) = 6.
Proof. simpl. reflexivity.  Qed.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.15. Definir la función
      resta : nat -> nat -> nat
   tal que (resta n m) es la diferencia de n y m. Por ejemplo,
      resta 3 2 = 1

   Nota: Es equivalente a la predefinida minus.
   ------------------------------------------------------------------ *)

Fixpoint resta (n m:nat) : nat :=
  match (n, m) with
  | (O   , _)    => O
  | (S _ , O)    => n
  | (S n', S m') => resta n' m'
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.16. Cerrar el módulo Naturales2.
   ------------------------------------------------------------------ *)

(* End Naturales2. *)

(* ---------------------------------------------------------------------
   Ejemplo 1.6.17. Definir la función
      potencia : nat ->  nat -> nat
   tal que (potencia x n) es la potencia n-ésima de x. Por ejemplo,
      potencia 2 3 = 8

   Nota: En lugar de producto, usar la predefinida mult.
   ------------------------------------------------------------------ *)

Fixpoint potencia (x n : nat) : nat :=
  match n with
    | O   => S O
    | S m => mult x (potencia x m)
  end.

Compute (potencia 2 3).
(* ===> 8 : nat *)

(* ---------------------------------------------------------------------
   Ejercicio 1.6.1. Definir la función
      factorial : nat -> nat1
   tal que (factorial n) es el factorial de n.
      factorial 3 = 6.
      factorial 5 = mult 10 12
   ------------------------------------------------------------------ *)

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O    => 1
  | S n' =>  S n' * factorial n'
  end.

Example prop_factorial1: factorial 3 = 6.
Proof. simpl. reflexivity.  Qed.

Example prop_factorial2: factorial 5 = mult 10 12.
Proof. simpl. reflexivity.  Qed.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.18. Definir los operadores +, - y * como abreviaturas de
   las funciones plus, rminus y mult.
   ------------------------------------------------------------------ *)

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.19. Definir la función
      iguales_nat : nat -> nat -> bool
   tal que (iguales_nat n m) se verifica si n y me son iguales.
   ------------------------------------------------------------------ *)

Fixpoint iguales_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O    => true
         | S m' => false
         end
  | S n' => match m with
            | O    => false
            | S m' => iguales_nat n' m'
            end
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.20. Definir la función
      menor_o_igual : nat -> nat -> bool
   tal que (menor_o_igual n m) se verifica si n es menor o igual que m.
   ------------------------------------------------------------------ *)

Fixpoint menor_o_igual (n m : nat) : bool :=
  match n with
  | O    => true
  | S n' => match m with
            | O    => false
            | S m' => menor_o_igual n' m'
            end
  end.

(* ---------------------------------------------------------------------
   Ejemplo 1.6.21. Demostrar las siguientes propiedades
      + menor_o_igual 2 2 = true.
      + menor_o_igual 2 4 = true.
      + menor_o_igual 4 2 = false.
   ------------------------------------------------------------------ *)

Example menor_o_igual1: menor_o_igual 2 2 = true.
Proof. simpl. reflexivity.  Qed.

Example menor_o_igual2: menor_o_igual 2 4 = true.
Proof. simpl. reflexivity.  Qed.

Example menor_o_igual3: menor_o_igual 4 2 = false.
Proof. simpl. reflexivity.  Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.6.2. Definir la función
      menor_nat : nat -> nat -> bool
   tal que (menor_nat n m) se verifica si n es menor que m.

   Demostrar las siguientes propiedades
      menor_nat 2 2 = false.
      menor_nat 2 4 = true.
      menor_nat 4 2 = false.
   ------------------------------------------------------------------ *)

Definition menor_nat (n m : nat) : bool :=
  negacion (iguales_nat (m-n) 0).

Example menor_nat1: (menor_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.

Example menor_nat2: (menor_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.

Example menor_nat3: (menor_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* =====================================================================
   § 2. Métodos elementales de demostración
   ================================================================== *)

(* =====================================================================
   § 2.1. Demostraciones por simplificación
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 2.1.1. Demostrar que el 0 es el elemento neutro por la
   izquierda de la suma de los números naturales.
   ------------------------------------------------------------------ *)

(* 1ª demostración *)
Theorem suma_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n.    (* n : nat
                  ============================
                   0 + n = n *)
  simpl.       (*  n = n *)
  reflexivity.
Qed.

(* 2ª demostración *)
Theorem suma_O_n' : forall n : nat, 0 + n = n.
Proof.
  intros n.    (* n : nat
                  ============================
                  0 + n = n *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.1.2. Demostrar que la suma de 1 y n es el siguiente de n.
   ------------------------------------------------------------------ *)

Theorem suma_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n.     (* n : nat
                   ============================
                   1 + n = S n *)
  simpl.        (* S n = S n *)
  reflexivity.
Qed.

Theorem suma_1_l' : forall n:nat, 1 + n = S n.
Proof.
  intros n.
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.1.3. Demostrar que el producto de 0 por n es 0.
   ------------------------------------------------------------------ *)

Theorem producto_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n.    (* n : nat
                  ============================
                  0 * n = 0 *)
  simpl.       (* 0 = 0 *)
  reflexivity.
Qed.

(* =====================================================================
   § 2.2. Demostraciones por reescritura
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 2.2.1. Demostrar que si n = m, entonces n + n = m + m.
   ------------------------------------------------------------------ *)

Theorem suma_iguales : forall n m:nat,
  n = m ->
  n + n = m + m.

Proof.
  intros n m.   (* n : nat
                   m : nat
                   ============================
                   n = m -> n + n = m + m *)
  intros H.     (* n : nat
                   m : nat
                   H : n = m
                   ============================
                   n + n = m + m *)
  rewrite H.    (* m + m = m + m *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 2.2.1. Demostrar que si n = m y m = o, entonces
   n + m = m + o.
   ------------------------------------------------------------------ *)

Theorem suma_iguales_ejercicio : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o H1 H2. (* n : nat
                         m : nat
                         o : nat
                         H1 : n = m
                         H2 : m = o
                         ============================
                         n + m = m + o *)
  rewrite H1.         (* m + m = m + o *)
  rewrite H2.         (* o + o = o + o *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.2.2. Demostrar que (0 + n) * m = n * m.
   ------------------------------------------------------------------ *)

Theorem producto_0_mas : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.          (* n : nat
                          m : nat
                          ============================
                         (0 + n) * m = n * m *)
  rewrite suma_O_n.   (* n * m = n * m *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 2.2.2. Demostrar que si m = S n, entonces m * (1 + n) = m * m.
   ------------------------------------------------------------------ *)

Theorem producto_S_1 : forall n m : nat,
  m = S n -> m * (1 + n) = m * m.
Proof.
  intros n m H. (* n : nat
                   m : nat
                   H : m = S n
                   ============================
                   m * (1 + n) = m * m *)
  simpl.        (* m * S n = m * m *)
  rewrite H.    (* S n * S n = S n * S n *)
  reflexivity.
Qed.

(* =====================================================================
   § 2.3. Demostraciones por análisis de casos
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 2.3.1. Demostrar que n + 1 es distinto de 0.
   ------------------------------------------------------------------ *)

(* 1º intento *)
Theorem siguiente_distinto_cero_primer_intento : forall n : nat,
  iguales_nat (n + 1) 0 = false.
Proof.
  intros n. (* n : nat
               ============================
                iguales_nat (n + 1) 0 = false *)
  simpl.    (* n : nat
               ============================
                iguales_nat (n + 1) 0 = false *)
Abort.

(* 2º intento *)
Theorem siguiente_distinto_cero : forall n : nat,
  iguales_nat (n + 1) 0 = false.
Proof.
  intros n.             (* n : nat
                           ============================
                            iguales_nat (n + 1) 0 = false *)
  destruct n as [| n'].
  -                     (*
                           ============================
                            iguales_nat (0 + 1) 0 = false *)
    reflexivity.
  -                     (* n' : nat
                           ============================
                            iguales_nat (S n' + 1) 0 = false *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.3.2. Demostrar que la negacion es involutiva; es decir, la
   negacion de la negacion de b es b.
   ------------------------------------------------------------------ *)

Theorem negacion_involutiva : forall b : bool,
  negacion (negacion b) = b.
Proof.
  intros b.      (*
                    ============================
                     negacion (negacion b) = b *)
  destruct b.
  -              (*
                     ============================
                     negacion (negacion true) = true *)
    reflexivity.
  -              (*
                    ============================
                     negacion (negacion false) = false *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.3.3. Demostrar que la conjuncion es conmutativa.
   ------------------------------------------------------------------ *)

(* 1ª demostración *)
Theorem conjuncion_commutativa : forall b c,
    conjuncion b c = conjuncion c b.
Proof.
  intros b c.      (* b : bool
                      c : bool
                      ============================
                       b && c = c && b *)
  destruct b.
  -                (* c : bool
                      ============================
                       true && c = c && true *)
    destruct c.
    +              (* ============================
                       true && true = true && true *)
      reflexivity.
    +              (*
                      ============================
                       true && false = false && true *)
      reflexivity.
  -                (* c : bool
                      ============================
                       false && c = c && false *)
    destruct c.
    +              (*
                       ============================
                       false && true = true && false *)
      reflexivity.
    +              (*
                      ============================
                       false && false = false && false *)
      reflexivity.
Qed.

(* 2ª demostración *)
Theorem conjuncion_commutativa2 : forall b c,
    conjuncion b c = conjuncion c b.
Proof.
  intros b c.
  destruct b.
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.3.4. Demostrar que
     conjuncion (conjuncion b c) d = conjuncion (conjuncion b d) c.
   ------------------------------------------------------------------ *)

Theorem conjuncion_intercambio : forall b c d,
    conjuncion (conjuncion b c) d = conjuncion (conjuncion b d) c.
Proof.
  intros b c d.
  destruct b.
  - destruct c.
    { destruct d.
      - reflexivity.   (* (true && true) && true = (true && true) && true *)
      - reflexivity. } (* (true && true) && false  = (true && false) && true *)
    { destruct d.
      - reflexivity.   (* (true && false) && true = (true && true) && false *)
      - reflexivity. } (* (true && false) && false = (true && false) && false *)
  - destruct c.
    { destruct d.
      - reflexivity.   (* (false && true) && true = (false && true) && true *)
      - reflexivity. } (* (false && true) && false = (false && false) && true *)
    { destruct d.
      - reflexivity.   (* (false && false) && true = (false && true) && false *)
      - reflexivity. } (* (false && false) && false = (false && false) && false *)
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.3.5. Demostrar que n + 1 es distinto de 0.
   ------------------------------------------------------------------ *)

Theorem siguiente_distinto_cero' : forall n : nat,
  iguales_nat (n + 1) 0 = false.
Proof.
  intros [|n].
  - reflexivity. (* iguales_nat (0 + 1) 0 = false *)
  - reflexivity. (* iguales_nat (S n + 1) 0 = false *)
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.3.6. Demostrar que la conjuncion es conmutativa.
   ------------------------------------------------------------------ *)

Theorem conjuncion_commutativa'' : forall b c,
    conjuncion b c = conjuncion c b.
Proof.
  intros [] [].
  - reflexivity. (* true  && true  = true  && true *)
  - reflexivity. (* true  && false = false && true *)
  - reflexivity. (* false && true  = true  && false *)
  - reflexivity. (* false && false = false && false *)
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 2.2.3. Demostrar que si
      conjuncion b c = true, entonces c = true.
   ------------------------------------------------------------------ *)

Theorem conjuncion_true_elim : forall b c : bool,
  conjuncion b c = true -> c = true.
Proof.
  intros b c.      (* b : bool
                      c : bool
                      ============================
                       b && c = true -> c = true *)
  destruct c.
  -                (* b : bool
                      ============================
                       b && true = true -> true = true *)
    reflexivity.
  -                (* b : bool
                      ============================
                       b && false = true -> false = true *)
    destruct b.
    +              (*
                      ============================
                       true && false = true -> false = true *)
      simpl.       (*
                      ============================
                       false = true -> false = true *)
      intros H.    (* H : false = true
                      ============================
                       false = true *)
      rewrite H.   (* H : false = true
                      ============================
                       true = true *)
      reflexivity.
    +              (*
                      ============================
                       false && false = true -> false = true *)
      simpl.       (*
                      ============================
                       false = true -> false = true *)
      intros H.    (* H : false = true
                      ============================
                       false = true *)
      rewrite H.   (* H : false = true
                      ============================
                       true = true *)
      reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 2.2.4. Demostrar que 0 es distinto de n + 1.
   ------------------------------------------------------------------ *)

Theorem cero_distinto_mas_uno: forall n : nat,
  iguales_nat 0 (n + 1) = false.
Proof.
  intros [| n'].
  - reflexivity. (* iguales_nat 0 (0 + 1) = false *)
  - reflexivity. (* iguales_nat 0 (S n' + 1) = false *)
Qed.

(* =====================================================================
   § 3. Ejercicios complementarios
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio 3.1. Demostrar que
      forall (f : bool -> bool),
        (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b.
   ------------------------------------------------------------------ *)

Theorem aplica_dos_veces_la_identidad : forall (f : bool -> bool),
  (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b.
Proof.
  intros f H b. (* f : bool -> bool
                   H : forall x : bool, f x = x
                   b : bool
                   ============================
                    f (f b) = b *)
  rewrite H.    (* f b = b *)
  rewrite H.    (* b = b *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 3.2. Demostrar que
      forall (b c : bool),
        (conjuncion b c = disyuncion b c) -> b = c.
   ------------------------------------------------------------------ *)

Theorem conjuncion_igual_disyuncion: forall (b c : bool),
  (conjuncion b c = disyuncion b c) -> b = c.
Proof.
  intros [] c.
  -              (* c : bool
                    ============================
                     true && c = true || c -> true = c *)
    simpl.       (* c : bool
                    ============================
                     c = true -> true = c *)
    intros H.    (* c : bool
                    H : c = true
                    ============================
                     true = c *)
    rewrite H.   (* c : bool
                    H : c = true
                    ============================
                     true = true *)
    reflexivity.
  -              (* c : bool
                    ============================
                     false && c = false || c -> false = c *)
    simpl.       (* c : bool
                    ============================
                     false = c -> false = c *)
    intros H.    (* c : bool
                    H : false = c
                    ============================
                     false = c *)
    rewrite H.   (* c : bool
                    H : false = c
                    ============================
                     c = c *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 3.3. En este ejercicio se considera la siguiente
   representación de los números naturales
      Inductive nat2 : Type :=
        | C  : nat2
        | D  : nat2 -> nat2
        | SD : nat2 -> nat2.
   donde C representa el cero, D el doble y SD el siguiente del doble.

   Definir la función
      nat2Anat : nat2 -> nat
   tal que (nat2Anat x) es el número natural representado por x.

   Demostrar que
      nat2Anat (SD (SD C))     = 3
      nat2Anat (D (SD (SD C))) = 6.
   ------------------------------------------------------------------ *)

Inductive nat2 : Type :=
  | C  : nat2
  | D  : nat2 -> nat2
  | SD : nat2 -> nat2.

Fixpoint nat2Anat (x:nat2) : nat :=
  match x with
  | C    => O
  | D n  => 2 * nat2Anat n
  | SD n => (2 * nat2Anat n) + 1
  end.

Example prop_nat2Anat1: (nat2Anat (SD (SD C))) = 3.
Proof. reflexivity. Qed.

Example prop_nat2Anat2: (nat2Anat (D (SD (SD C)))) = 6.
Proof. reflexivity. Qed.

(* =====================================================================
   § Bibliografía
   ================================================================== *)

(*
 + "Functional programming in Coq" de Peirce et als. http://bit.ly/2zRCL6t
 *)


Require Export Iron.Language.SystemF2Effect.Type.Exp.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LowerTT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.WfT.

(********************************************************************)
(* Substitution of Types in Types. *)
Fixpoint substTT (d: nat) (u: ty) (tt: ty) : ty
 := match tt with
    | TVar ix
    => match nat_compare ix d with
       | Eq          => u
       | Gt          => TVar (ix - 1)
       | _           => TVar  ix
       end

    |  TForall k t   => TForall k (substTT (S d) (liftTT 1 0 u) t)
    |  TApp t1 t2    => TApp      (substTT d u t1) (substTT d u t2)
    |  TSum t1 t2    => TSum      (substTT d u t1) (substTT d u t2)
    |  TBot k        => TBot k

    | TCon0 tc       => TCon0 tc
    | TCon1 tc t1    => TCon1 tc  (substTT d u t1)
    | TCon2 tc t1 t2 => TCon2 tc  (substTT d u t1) (substTT d u t2)
    | TCap _         => tt
  end.

(********************************************************************)
(* What might happen when we substitute for a variable.
   This can be easier use than the raw substTT definition. *)
Lemma substTT_TVar_cases
 :  forall n1 n2 t1
 ,  (substTT n1 t1 (TVar n2) = t1            /\ n1 = n2)
 \/ (substTT n1 t1 (TVar n2) = TVar (n2 - 1) /\ n1 < n2)
 \/ (substTT n1 t1 (TVar n2) = TVar n2       /\ n1 > n2).
Proof.
 intros.
 unfold substTT.
  lift_cases; burn.
Qed.

Lemma substTT_wfT_above
 :  forall d ix t t2
 ,  WfT d t
 -> substTT (d + ix) t2 t = t.
Proof.
 intros. gen d ix t2.
 induction t; rip; inverts H; simpl; f_equal; burn.

 Case "TVar".
  norm; omega.
  lets D: IHt H1. burn.
Qed.
Hint Resolve substTT_wfT_above.

Lemma substTT_wfT
 :  forall d ix t1 t2
 ,  ix <= d
 -> WfT (S d) t1
 -> WfT d     t2
 -> WfT d (substTT ix t2 t1).
Proof.
 intros. gen d ix t2.
 induction t1; rip; inverts H0; simpl; snorm.
Qed.
Hint Resolve substTT_wfT.

(* Closing substitution of types in types *)
Lemma substTT_closing
 :  forall t1 t2
 ,  WfT 1 t1
 -> ClosedT t2
 -> ClosedT (substTT 0 t2 t1).
Proof. eauto. Qed.
Hint Resolve substTT_closing.

Lemma substTT_closedT_id
 :  forall d t t2
 ,  ClosedT t
 -> substTT d t2 t = t.
Proof.
 intros. rrwrite (d = d + 0). eauto.
Qed.
Hint Resolve substTT_closedT_id.

Lemma substTT_liftTT_wfT1
 :  forall t1 t2
 ,  WfT 1 t1
 -> ClosedT t2
 -> substTT 0 t2 t1 = liftTT 1 0 (substTT 0 t2 t1).
Proof.
 intros.
 have    (ClosedT (substTT 0 t2 t1)).
 rrwrite (liftTT 1 0 (substTT 0 t2 t1) = substTT 0 t2 t1).
 trivial.
Qed.
Hint Resolve substTT_liftTT_wfT1.

(* Substituting into TBot is still TBot. *)
Lemma substTT_TBot
 : forall d t2 k
 , substTT d t2 (TBot k) = TBot k.
Proof. burn. Qed.
Hint Resolve substTT_TBot.
Hint Rewrite substTT_TBot : global.