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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros. simpl. rewrite <- append_assoc. simpl.
   rewrite lem. rewrite IHx. rewrite <- append_assoc. reflexivity.
 - intros. simpl. rewrite lem2. lfind. Admitted.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.time prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.arrival_sequence.
Require Import prosa.classic.model.schedule.uni.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module ScheduleOfTask.

  Export SporadicTaskset UniprocessorSchedule.

  (* In this section, we define properties about schedules of tasks. *)
  Section ScheduleProperties.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any uniprocessor schedule. *)
    Variable sched: schedule Job.

    Section TaskProperties.

      (* Let tsk be any task. *)
      Variable tsk: Task.

      (* Next we define whether a task is scheduled at time t, ... *)
      Definition task_scheduled_at (t: time) :=
        if sched t is Some j then
          job_task j == tsk
        else false.

      (* ...which also corresponds to the instantaneous service it receives. *)
      Definition task_service_at (t: time) : time := task_scheduled_at t.

      (* Based on the notion of instantaneous service, we define the
         cumulative service received by tsk during any interval [t1, t2)... *)
      Definition task_service_during (t1 t2: time) :=
        \sum_(t1 <= t < t2) task_service_at t.

      (* ...and the cumulative service received by tsk up to time t2,
         i.e., in the interval [0, t2). *)
      Definition task_service (t2: time) := task_service_during 0 t2.

    End TaskProperties.

  End ScheduleProperties.

End ScheduleOfTask.


Require Import List EqdepClass.
Require Export EquivDec.
Require Import Decidables.

Set Implicit Arguments.
Set Strict Implicit.

Section fin.
  Variable A : Type.

  Inductive fin : list A -> Type :=
  | FO : forall x ls, fin (x :: ls)
  | FS : forall x ls, fin ls -> fin (x :: ls).

  Fixpoint lift (ls : list A) e : fin ls -> fin (e ++ ls) :=
    match e as e return fin ls -> fin (e ++ ls) with
      | nil => fun x => x
      | a :: b => fun x => FS a (@lift ls b x)
    end.

  Definition finOut ls (f : fin ls) : match ls return fin ls -> Type with
                                        | nil => fun _ => Empty_set
                                        | _ => fun f => {f' : _ & f = FS _ f'} + {f = FO _ _}
                                      end f :=
  match f with
    | FO _ _ => inright _ (refl_equal _)
    | FS _ _ f' => inleft _ (existT _ f' (refl_equal _))
  end.

  Definition finIfz t (ls : list A) (d : fin (t :: ls))
    : forall (R : fin (t :: ls) -> Type) (h : R (@FO _ _)) (n : forall c, R (@FS _ _ c)),
    R d :=
    match d as d' in fin ls' return match ls' return fin ls' -> Type with
                                | nil => fun _ => Empty_set
                                | a :: b => fun d =>
                                  forall (R : fin (a :: b) -> Type) (h : R (@FO _ _)) (n : forall c, R (@FS _ _ c)), R d
                              end d'
      with
      | FO _ _ => fun _ h _ => h
      | FS _ _ x => fun _ _ f => f x
    end.

  Definition finArg ls (f : fin ls) : option (fin (tl ls)) :=
    match f with
      | FO _ _ => None
      | FS _ _ f' => Some f'
    end.

  Lemma fin_inj : forall z ls (x y : fin ls),
    x <> y
    -> FS z x <> FS z y.
    red; intros.
    assert (finArg (FS z x) = finArg (FS z y)) by congruence.
    simpl in *; congruence.
  Qed.

  Hint Immediate fin_inj.

  Definition finEq : forall ls (x y : fin ls), {x = y} + {x <> y}.
    refine (fix finEq ls : forall x y : fin ls, {x = y} + {x <> y} :=
      match ls return forall x y : fin ls, {x = y} + {x <> y} with
        | nil => fun x _ => match finOut x with end
        | _ :: _ => fun x y => match finOut x, finOut y with
                                 | inleft (existT x' _), inleft (existT y' _) => if finEq _ x' y' then left _ _ else right _ _
                                 | inright _, inright _ => left _ _
                                 | _, _ => right _ _
                               end
      end); clear finEq; (subst; auto; try congruence;
        match goal with
          | [ H : sigT _ |- _ ] => destruct H
        end; subst; discriminate).
  Defined.

  Global Instance EquivDec_fin ls : EqDec (fin ls) (@eq _) :=
  { equiv_dec := @finEq ls }.

  Definition dcomp_option T (a b : T) (d : dcomp a b) : option (a = b) :=
    match d with
      | Eq pf => Some pf
      | _ => None
    end.

  Global Instance Comparable_fin ls : Comparable (fin ls).
  constructor.
  refine ((fix finCmp ls (x : fin ls) : forall y : fin ls, dcomp x y :=
    match x in fin ls return forall y : fin ls, dcomp x y with
      | FO a b => fun y : fin (a :: b) =>
        @finIfz _ _ y (dcomp (FO a b)) (Eq (refl_equal _)) (fun _ => Lt _ _)
      | FS a ls r => fun y : fin (a :: ls) =>
        @finIfz _ _ y (dcomp (FS a r)) (Gt _ _)
          (fun r' => match finCmp _ r r' with
                       | Eq pf => Eq (match pf in _ = t return FS a r = FS a t with
                                        | refl_equal => refl_equal _
                                      end)

                       | Gt => Gt _ _
                       | Lt => Lt _ _
                     end)
    end) ls).
  Defined.

  Fixpoint get (ls : list A) : fin ls -> A :=
    match ls return fin ls -> A with
      | nil => fun f => match f in fin N return match N with
                                                  | nil => A
                                                  | _ => unit
                                                end with
                          | FO _ _ => tt
                          | FS _ _ _ => tt
                        end
      | x :: ls' => fun f => match f in fin N return match N with
                                                       | nil => Empty_set
                                                       | _ :: ls' => (fin ls' -> A) -> A
                                                     end with
                               | FO _ _ => fun _ => x
                               | FS _ _ f' => fun get_ls' => get_ls' f'
                             end (@get ls')
    end.

  Fixpoint liftD (ls : list A) e : forall i : fin ls, { x : fin (e ++ ls) & get x = get i } :=
    match e as e return forall i : fin ls, { x : fin (e ++ ls) & get x = get i } with
      | nil => fun x => existT _ x (refl_equal _)
      | a :: b => fun x =>
        match @liftD ls b x with
          | existT x pf =>
            existT _ (FS a x) (match pf in _ = t
                                 return get (FS a x) = t with
                                 | refl_equal => refl_equal _
                               end)
        end
    end.

  Fixpoint pf_list_simpl A b c (a : list A) : (a ++ b :: nil) ++ c = a ++ b :: c :=
    match a as a return (a ++ b :: nil) ++ c = a ++ b :: c with
      | nil => refl_equal (nil ++ b :: nil ++ c)
      | a' :: b' => match eq_sym (@pf_list_simpl A b c b') in _ = t return a' :: t = a' :: b' ++ b :: c
                      with
                      | refl_equal => refl_equal _
                    end
    end.

  Fixpoint fin_remove (U : Type) ls t ls' : forall (f : fin (ls ++ t :: ls')),
    (t = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U :=
    match ls as ls
      return forall f : fin (ls ++ t :: ls'), (t = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U
      with
      | nil => fun (f : fin (t :: ls')) =>
        match f in fin z
          return match z with
                   | nil => unit
                   | a :: b => (a = get f -> U) -> (forall f' : fin b, get f' = get f -> U) -> U
                 end
          with
          | FO _ _ => fun D _ => D refl_equal
          | FS _ _ f => fun _ F => F _ refl_equal
        end
      | a :: b => fun (f : fin (a :: b ++ t :: ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove _ _ _ _ (projT1 s)
              (match eq_sym (projT2 s) in _ = t' return (t = get t' -> U) -> (t = get (projT1 s)) -> U with
                 | refl_equal => fun x => x
               end D)
              (fun x' pf => F (FS _ x')
                match eq_sym (projT2 s) in _ = t return get (FS a x') = get t with
                  | refl_equal => pf
                end)
          | inright l => F (FO _ _) match eq_sym l in _ = t return get (FO _ _) = get t with
                                      | refl_equal => refl_equal
                                    end
        end
    end.

  Fixpoint fin_remove_range' (U : Type) ls'' ls' : forall (f : fin (ls'' ++ ls')),
    (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls'), get f' = get f -> U) -> U :=
    match ls'' as ls''
      return forall f : fin (ls'' ++ ls'), (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin ls', get f' = get f -> U) -> U
      with
      | nil => fun (f : fin ls') => fun _ z => z f refl_equal
      | a :: b => fun (f : fin (a :: b ++  ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove_range' _ b ls' (projT1 s)
              (fun x' pf => D (FS _ x') match eq_sym (projT2 s) in _ = t return get (FS a x') = get t with
                                          | refl_equal => pf
                                        end)
              (fun x' pf => F x' match eq_sym (projT2 s) in _ = t return get x' = get t with
                                   | refl_equal => pf
                                 end)
          | inright l => D (FO _ _) match eq_sym l in _ = t return get (FO a b) = get t with
                                      | refl_equal => refl_equal
                                    end
        end
    end.

  Fixpoint fin_remove_range (U : Type) ls ls'' ls' : forall (f : fin (ls ++ ls'' ++ ls')),
    (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U :=
    match ls as ls
      return forall f : fin (ls ++ ls'' ++ ls'), (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U
      with
      | nil => fun (f : fin (ls'' ++ ls')) => @fin_remove_range' U ls'' ls' f
      | a :: b => fun (f : fin (a :: b ++ ls'' ++  ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove_range _ _ _ _ (projT1 s)
              (fun x' pf => D x' match eq_sym (projT2 s) in _ = t return get x' = get t with
                                   | refl_equal => pf
                                 end)
              (fun x' pf => F (FS _ x') match eq_sym (projT2 s) in _ = t return get (FS _ x') = get t with
                                          | refl_equal => pf
                                        end)
          | inright l => F (FO _ _)
              match eq_sym l in _ = t return get (FO _ _) = get t with
                | refl_equal => refl_equal
              end
        end
    end.

  Fixpoint liftDmid (ls ls' : list A) e : forall (i : fin (ls' ++ ls)),
    { x : fin (ls' ++ e ++ ls) & get x = get i }.
  refine (
    match ls' as ls' return forall (i : fin (ls' ++ ls)),
      { x : fin (ls' ++ e ++ ls) & get x = get i } with
      | nil => fun i => liftD e i
      | a :: b => fun i : fin (a :: b ++ ls) =>
        match finOut i with
          | inleft (existT r pf) =>
            match liftDmid ls b e r with
              | existT rr pf' =>
                @existT _ _ (FS a rr) _
            end
          | inright pf => @existT _ _ (FO _ _) _
        end
    end).
  rewrite pf; simpl; assumption.
  rewrite pf; reflexivity.
  Defined.

  Fixpoint liftDend (ls : list A) e (i : fin ls) :
    { x : fin (ls ++ e) & get x = get i } :=
    match i as i in fin ls return { x : fin (ls ++ e) & get x = get i } with
      | FO _ _ => existT _ (FO _ _) refl_equal
      | FS _ _ f =>
        match liftDend e f with
         | existT _ e => existT _ (FS _ _) e
        end
    end.

  Section liftD_Proofs.
    Variable EQ : EqDec A (@eq A).

    Lemma liftD_liftD_app : forall (a z y : list A) x0,
      projT1 (liftD y (projT1 (liftD a x0))) =
      match app_assoc_reverse y a z in (_ = t) return (fin t) with
        | eq_refl => projT1 (liftD (y ++ a) x0)
      end.
    Proof.
      induction y; simpl in *; uip_all.
        simpl in *. uip_all. reflexivity.
        simpl in *. case_eq (liftD y (projT1 (liftD a x0))).
        simpl. intros. assert (projT1 (liftD y (projT1 (liftD a x0))) = x).
        rewrite H; auto.
        rewrite IHy in H0. subst.
        destruct (liftD (y ++ a) x0). simpl. uip_all.
        generalize e e2. rewrite <- e2. uip_all. reflexivity.
    Qed.

    Lemma liftDmid_lift_nil : forall (a b : list A) x0,
      projT1 (liftDmid a b nil x0) = x0.
    Proof.
      induction b; simpl; intros; auto.
      destruct (finOut x0). destruct s. subst.
      specialize (IHb x). destruct (liftDmid a b nil x). simpl in *. subst; auto.

      subst. simpl. reflexivity.
    Qed.

    Lemma liftDmid_liftDmid_app : forall x y z a x0,
      projT1 (liftDmid (a ++ z) x y (projT1 (liftDmid z x a x0)))
      = match app_ass _ _ _ in _ = t return fin (_ ++ t) with
          | refl_equal => projT1 (liftDmid z x (y ++ a) x0)
        end.
    Proof.
      induction x.
        simpl; intros; apply liftD_liftD_app.
        intros. simpl in x0. destruct (finOut x0).

        destruct s. specialize (IHx y z a0 x1). subst. simpl in *.
        destruct (liftDmid z x a0 x1); simpl in *. destruct (liftDmid (a0 ++ z) x y x0); simpl in *.
        subst. destruct (liftDmid z x (y ++ a0) x1). simpl. uip_all. generalize e2 x2. rewrite e2.
        intros. rewrite (UIP_refl e3). reflexivity.

        subst; simpl. uip_all. generalize e. rewrite e. uip_all. reflexivity.
    Qed.
  End liftD_Proofs.

  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall x ls, B x -> hlist ls -> hlist (x :: ls).

  Definition hlist_hd (T : A) (ls : list A) (v : hlist (T :: ls)) : B T :=
    match v in hlist ls return match ls with
                                 | nil => unit
                                 | a :: _ => B a
                               end with
      | HNil => tt
      | HCons _ _ x _ => x
    end.

  Definition hlist_tl (T : A) (ls : list A) (v : hlist (T :: ls)) : hlist ls :=
    match v in hlist ls return match ls with
                                 | nil => unit
                                 | _ :: ls => hlist ls
                               end with
      | HNil => tt
      | HCons _ _ _ x => x
    end.

  Fixpoint hlist_app ll lr : hlist ll -> hlist lr -> hlist (ll ++ lr) :=
    match ll with
      | nil => fun _ x => x
      | _ :: _ => fun l r => HCons (hlist_hd l) (hlist_app (hlist_tl l) r)
    end.

  Fixpoint hlist_All ls (P : forall t, B t -> Prop) (h : hlist ls) {struct h} : Prop :=
    match h with
      | HNil => True
      | HCons _ _ a b => P _ a /\ hlist_All P b
    end.

  Variable dec : forall x (y z : B x), option (y = z).

  Definition hlistEq : forall x (y z : hlist x), option (y = z).
    refine (fix hlistEq x (y : hlist x) : forall z : hlist x, option (y = z) :=
      match y in hlist x return forall z : hlist x, option (y = z) with
        | HNil => fun z => match z in hlist x return match x return hlist x -> Type with
                                                       | nil => fun z => option (HNil = z)
                                                       | _ => fun _ => unit
                                                     end z with
                             | HNil => Some _
                             | _ => tt
                           end
        | HCons _ _ v1 y' => fun z => match z in hlist x return match x return hlist x -> Type with
                                                                  | nil => fun _ => unit
                                                                  | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                                                    (forall v2, option (v1 = v2))
                                                                    -> (forall z', option (y' = z'))
                                                                    -> option (HCons v1 y' = z)
                                                                end z with
                                        | HNil => tt
                                        | HCons _ _ v2 z' => fun v1 _ dec' self => if dec' v2 then if self z' then Some _ else None else None
                                      end v1 y' (dec v1) (hlistEq _ y')
      end); clear hlistEq; abstract congruence.
  Defined.

  Variable cmp : forall x (y z : B x), dcomp y z.
  Definition hlistCmp : forall x (y z : hlist x), dcomp y z.
    refine (fix hlistCmp x (y : hlist x) : forall z : hlist x, dcomp y z :=
      match y in hlist x return forall z : hlist x, dcomp y z with
        | HNil => fun z => match z in hlist x return match x return hlist x -> Type with
                                                       | nil => fun z => dcomp HNil z
                                                       | _ => fun _ => unit
                                                     end z with
                             | HNil => Eq _
                             | _ => tt
                           end
        | HCons _ _ v1 y' => fun z => match z in hlist x return match x return hlist x -> Type with
                                                                  | nil => fun _ => unit
                                                                  | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                                                    (forall v2, dcomp v1 v2)
                                                                    -> (forall z', dcomp y' z')
                                                                    -> dcomp (HCons v1 y') z
                                                                end z with
                                        | HNil => tt
                                        | HCons _ _ v2 z' => fun v1 _ cmp' self =>
                                          match cmp' v2 with
                                            | Eq _ =>
                                              match self z' with
                                                | Gt => Gt _ _
                                                | Lt => Lt _ _
                                                | Eq _ => Eq _
                                              end
                                            | Gt => Gt _ _
                                            | Lt => Lt _ _
                                          end
                                      end v1 y' (cmp v1) (hlistCmp _ y')
      end); clear hlistCmp; abstract congruence.
  Defined.

  Variable ocmp : forall x (y z : B x), option (dcomp y z).
  Fixpoint hlistOCmp x (y : hlist x) : forall (z : hlist x), option (dcomp y z).
    refine (
      match y as y in hlist x return forall z : hlist x, option (dcomp y z) with
        | HNil => fun z =>
          match z in hlist x return match x return hlist x -> Type with
                                      | nil => fun z => option (dcomp HNil z)
                                      | _ => fun _ => unit
                                    end z with
            | HNil => Some (Eq _)
            | _ => tt
          end
        | HCons _ _ v1 y' => fun z =>
          match z in hlist x return match x return hlist x -> Type with
                                      | nil => fun _ => unit
                                      | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                        (forall v2, option (dcomp v1 v2))
                                        -> (forall z', option (dcomp y' z'))
                                        -> option (dcomp (HCons v1 y') z)
                                    end z with
            | HNil => tt
            | HCons _ _ v2 z' => fun v1 _ cmp' self =>
              match cmp' v2 with
                | None =>
                  match self z' with
                    | None => None
                    | Some Gt => Some (Gt _ _)
                    | Some Lt => Some (Lt _ _)
                    | Some (Eq _) => None
                  end
                | Some (Eq _) =>
                  match self z' with
                    | None => None
                    | Some Gt => Some (Gt _ _)
                    | Some Lt => Some (Lt _ _)
                    | Some (Eq _) => Some (Eq _)
                  end
                | Some Gt => Some (Gt _ _)
                | Some Lt => Some (Lt _ _)
              end
          end v1 y' (ocmp v1) (hlistOCmp _ y')
      end); clear hlistOCmp; abstract congruence.
  Defined.

  Fixpoint hlist_get (ls : list A) (i : fin ls) : hlist ls -> B (get i) :=
    match i in fin ls return hlist ls -> B (get i) with
      | FO _ _ => fun hl => hlist_hd hl
      | FS _ _ f' => fun hl => hlist_get f' (hlist_tl hl)
    end.

  Section hlist_Proofs.
    Variable EQ : EqDec A (@eq A).
    Lemma hlist_nil_only : forall (h : hlist nil),
      h = HNil.
    Proof.
      intros.
      change h with (match refl_equal in _ = t return hlist t with
                       | refl_equal => h
                     end).
      generalize (refl_equal (@nil A)). generalize h.
      assert (forall k (h : hlist k) (e : k = nil),
        match e in (_ = t) return (hlist t) with
          | eq_refl => h
        end = HNil).
      destruct h0.
      uip_all. reflexivity.
      congruence.
      eauto.
    Qed.

    Lemma hlist_eta : forall a b (h : hlist (a :: b)),
      h = HCons (hlist_hd h) (hlist_tl h).
    Proof.
      intros.
      assert (forall k (h : hlist k) (e : k = a :: b),
        match e in (_ = t) return (hlist t) with
          | eq_refl => h
        end = HCons (hlist_hd match e in _ = t return hlist t with
                                | eq_refl => h
                              end)
        (hlist_tl match e in _ = t return  hlist t with
                    | eq_refl => h
                  end)).
      destruct h0. congruence.
      intros. inversion e. subst.
      generalize e. uip_all. reflexivity.

      specialize (H _ h (refl_equal _)). assumption.
    Qed.

    Theorem hlist_get_lift : forall ls ls' ls'' (f : fin (ls ++ ls'')) G G' G'',
      hlist_get f (hlist_app G G'') =
      match liftDmid ls'' ls ls' f with
        | existT f' pf =>
          match pf in _ = t return B t with
            | refl_equal =>
              hlist_get f' (hlist_app G (hlist_app G' G''))
          end
      end.
    Proof.
      induction ls. simpl. intros. unfold liftDmid; simpl.
        Focus.
        generalize dependent ls'. induction ls'; simpl; auto.
          intros. specialize (IHls' (hlist_tl G')). rewrite IHls'. destruct (liftD ls' f).
          simpl. generalize (hlist_get x (hlist_app (hlist_tl G') G'')). generalize e. rewrite e.
          intros. rewrite (UIP_refl e0). reflexivity.

        intros. simpl in f. destruct (finOut f). destruct s; subst. simpl.
        specialize (@IHls ls' _ x (hlist_tl G) G' G''). rewrite IHls. clear IHls.
        destruct (liftDmid ls'' ls ls' x). reflexivity.
        subst. reflexivity.
    Qed.

    Theorem hlist_get_lift_end : forall ls' G' ls (f : fin ls) G,
      hlist_get f G =
      match liftDend ls' f with
        | existT f' pf =>
          match pf in _ = t return B t with
            | refl_equal =>
              hlist_get f' (hlist_app G G')
          end
      end.
    Proof.
      clear dec cmp ocmp.
      induction f; simpl; auto.
      destruct f; simpl in *. auto.
      intros. rewrite IHf. clear IHf. destruct (liftDend ls' f).
      generalize e. rewrite <- e. uip_all. auto.
    Qed.

    Lemma hlist_get_remove_range' : forall U a b (A : hlist a) (B' : hlist b) x P
      (D : forall x' : fin a, get x' = get x -> U) F,
      (forall x' (pf : get x' = get x),
        hlist_get x (hlist_app A B') =
          match pf in _ = z return B z with
            | refl_equal => hlist_get x' A
          end ->
        P (D x' pf)) ->
      (forall x' pf,
        hlist_get x (hlist_app A B') =
          match pf in _ = t return B t with
            | refl_equal => hlist_get x' B'
          end ->
        P (F x' pf)) ->
      P (@fin_remove_range' U a b x D F).
    Proof.
      clear dec cmp ocmp.
      induction a; simpl; intros; eauto.
      destruct (finOut x) as [ [ ? ? ] | ? ]; subst; simpl; eauto.
      eapply IHa; eauto.
    Qed.

    Theorem hlist_get_remove_range : forall U a b c (A : hlist a) (B' : hlist b) (C : hlist c) x P (D : forall x' : fin b, get x' = get x -> U) F,
      (forall x' (pf : get x' = get x),
        hlist_get x (hlist_app A (hlist_app B' C)) =
          match pf in _ = z return B z with
            | refl_equal => hlist_get x' B'
          end ->
        P (D x' pf)) ->
      (forall x' pf,
        hlist_get x (hlist_app A (hlist_app B' C)) =
          match pf in _ = t return B t with
            | refl_equal => hlist_get x' (hlist_app A C)
          end ->
        P (F x' pf)) ->
      P (@fin_remove_range U a b c x D F).
    Proof.
      clear dec cmp ocmp.
      induction a; simpl; intros.
      eapply hlist_get_remove_range'; eauto.
      destruct (finOut x); subst; simpl.
        destruct s; subst; simpl. eapply IHa; eauto.
        eapply X0. auto.
    Qed.

  End hlist_Proofs.

  Fixpoint absAll (ls : list A) :
    (hlist ls -> Type) -> Type :=
    match ls return (hlist ls -> Type) -> Type with
      | nil => fun R => R (HNil)
      | a :: b => fun R =>
        forall x : B a, absAll (fun y => R (HCons x y))
    end.

  Fixpoint hlistDestruct (ls : list A) (args : hlist ls) {struct args}
    : forall K : hlist ls -> Type, absAll K -> K args :=
      match
        args as args0 in hlist ls0
          return (forall K : hlist ls0 -> Type, absAll K -> K args0)
        with
        | HNil =>
          fun (K : hlist nil -> Type) (cc : absAll K) => cc
        | HCons x0 ls0 x args =>
          fun (K : hlist (x0 :: ls0) -> Type) (cc : absAll K) =>
            hlistDestruct args
            (fun y : hlist ls0 => K (HCons x y))
            (cc x)
      end.

  Variable a : A.
  Variable b : B a.
  Fixpoint hlistIn (ls : list A) : hlist ls -> Prop :=
    match ls as ls return hlist ls -> Prop with
      | nil => fun _ => False
      | hd :: tl => fun hl =>
        (exists pf : a = hd, hlist_hd hl = match pf in _ = t return B t with
                                             | refl_equal => b
                                           end)
        \/ hlistIn (hlist_tl hl)
    end.

End fin.

Implicit Arguments FO [A x ls].
Implicit Arguments FS [A x ls].
Implicit Arguments finIfz [A t ls].

Implicit Arguments get [A].
Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].

Section hlist_map.
  Variable A : Type.
  Variable F : A -> Type.
  Variable G : A -> Type.
  Variable ff : forall x, F x -> G x.

  Fixpoint hlist_map (ls : list A) (hl : hlist F ls) {struct hl} : hlist G ls :=
    match hl in @hlist _ _ ls return hlist G ls with
      | HNil => HNil
      | HCons _ _ hd tl =>
        HCons (ff hd) (hlist_map tl)
    end.
End hlist_map.

Section hlist_fold2.
  Variables T U V : Type.
  Variables F G : T -> Type.
  Variable f : U -> forall t : T, F t -> G t -> U.

  Fixpoint hlist_fold2 ls (l : hlist F ls) {struct l} : hlist G ls -> U -> U :=
    match l in hlist _ ls
      return hlist G ls -> U -> U
      with
      | HNil => fun _ acc => acc
      | HCons _ _ fr hr => fun r acc =>
        hlist_fold2 hr (hlist_tl r) (f acc fr (hlist_hd r))
    end.
End hlist_fold2.

Export Decidables.


Require Export List.

Require Import term.
Require Import rpo.

Require Export utils.
Require Export coccinelle_utils.

(** Translation of the specification *)
Module Specif.

  Inductive symb : Set :=
  | id_0
  | id_S
  | id_Nil
  | id_Cons
  | id_true
  | id_false
  | id_sorted
  | id_leq
  | id_length
  | id_insert
  | id_isort
  | id_eq_nat
  .

  Definition arity (f:symb) :=
    match f with
    | id_0 => term_spec.Free 0
    | id_S => term_spec.Free 1
    | id_Nil => term_spec.Free 0
    | id_Cons => term_spec.Free 2
    | id_true => term_spec.Free 0
    | id_false => term_spec.Free 0
    | id_sorted => term_spec.Free 1
    | id_leq => term_spec.Free 2
    | id_length => term_spec.Free 1
    | id_insert => term_spec.Free 2
    | id_isort => term_spec.Free 1
    | id_eq_nat => term_spec.Free 2
    end.

Definition status (f:symb) :=
     match f with
    | id_0 => rpo.Mul
    | id_S => rpo.Mul
    | id_Nil => rpo.Mul
    | id_Cons => rpo.Mul
    | id_true => rpo.Mul
    | id_false => rpo.Mul
    | id_sorted => rpo.Mul
    | id_leq => rpo.Mul
    | id_length => rpo.Mul
    | id_insert => rpo.Mul
    | id_isort => rpo.Mul
    | id_eq_nat => rpo.Mul

    end.
  Definition index (f:symb) :=
     match f with
    | id_0 => 2
    | id_S => 3
    | id_Nil => 4
    | id_Cons => 5
    | id_true => 6
    | id_false => 7
    | id_sorted => 16
    | id_leq => 11
    | id_length => 12
    | id_insert => 17
    | id_isort => 18
    | id_eq_nat => 13
    end.

  Definition max_size := 100.

End Specif.

(* Nat and comparisons *)
Module Nat <: decidable_set.S.

  Definition A:=nat.
  Definition eq_bool := utils.beq_nat.
  Definition eq_bool_ok := utils.beq_nat_ok.

End Nat. (*: decidable_set.S*)

(** Initialisation of Coccinelle *)
Module Symbols <: term_spec.Signature.

  Module Symb <: decidable_set.S.

    Definition A:=Specif.symb.

    Theorem symb_eq_dec: forall x y:A, {x=y}+{x<>y}.
    Proof.
    decide equality.
    Defined.

    Definition eq_bool := utils.eq_bool A symb_eq_dec.
    Definition eq_bool_ok := utils.eq_bool_ok A symb_eq_dec.

  End Symb. (* Symb : decidable_set.S *)

  Definition arity := Specif.arity.

End Symbols. (* Symbols : term_spec.Signature *)

Module Terms <: term_spec.Term := term.Make' Symbols Nat.
Module Rpo := coccinelle_utils.Make Terms.

Export Specif.
Export Rpo.

Theorem prec_eq_status : forall f g, utils.prec_eq symb index f g -> status f = status g.
Proof.
intros f g; case f; case g; reflexivity.
Qed.

Definition P := rpo.Build_Precedence status
    (utils.prec_bool symb index) (utils.prec_bool_ok symb index)  (utils.prec_antisym symb index) (utils.prec_transitive symb index) (utils.prec_eq_bool symb index) (utils.prec_eq_transitive symb index) (utils.prec_eq_refl symb index) (utils.prec_eq_bool_ok symb index) (utils.prec_eq_prec1 symb index) (utils.prec_eq_prec2 symb index) (utils.prec_eq_sym symb index) (utils.prec_not_prec_eq symb index) (prec_eq_status).

Notation less := (rpo_mul P (bb (empty_rpo_infos P max_size))).

(* Coq version of the specification. *) (* TODO: should be in Spec module but model_* *)

Fixpoint model_nat (v: nat): term :=
match v with
| O => (Term id_0 nil)
| (S x) => let x' := model_nat x in   (Term id_S (x'::nil))
 end.

Fixpoint model_bool (v: bool): term :=
match v with
|true => (Term id_true nil)
|false => (Term id_false nil)
end.

Inductive list : Set :=
|Nil : list
|Cons : nat -> list -> list.

Fixpoint model_list (v:list) : term :=
match v with
| Nil => (Term id_Nil nil)
| (Cons x l) => let x' := model_nat x in let l' := model_list l in
(Term id_Cons (x' :: l' :: nil))
end.

Fixpoint eq_nat (n1:nat) (n2:nat): bool :=
match n1, n2 with
| O, O => true
| O, _ => false
| _, O => false
| (S x), (S y) => eq_nat x y
end.

Fixpoint leq (n1:nat) (n2: nat) : bool :=
match n1, n2 with
|O, _ => true
| _, 0 => false
| (S x), (S y) => leq x y
end.

Fixpoint length (l:list): nat :=
match l with
| Nil => O
| Cons _ y => S (length y)
end.

Fixpoint insert (x:nat) (l:list): list :=
match l with
|Nil => Cons x Nil
|Cons h tl => match leq x h with |true => Cons x l |false => Cons h (insert x tl) end
end.

Fixpoint isort (l:list): list:=
match l with
|Nil => Nil
|Cons h tl =>insert h (isort tl)
end.

Definition head_sorted (l : list) : bool := match l with
Cons a (Cons b _) => leq a b | _ => true end.

Fixpoint sorted (l : list) : bool := match l with
Cons a tl => if head_sorted (Cons a tl) then sorted tl else false | Nil => true end.

(** Initialisation of proof process *)
Lemma model_nat_0: model_nat 0 = (Term id_0 nil).
Proof.
auto.
Qed.

Lemma model_nat_S: forall (u1: nat), model_nat (S u1) = (Term id_S ((model_nat u1)::nil)).
Proof.
auto.
Qed.

Lemma model_list_Nil: model_list Nil = (Term id_Nil nil).
Proof.
auto.
Qed.

Lemma model_list_Cons: forall (u1: nat), forall (u2: list), model_list (Cons u1 u2) = (Term id_Cons ((model_nat u1):: (model_list u2)::nil)).
Proof.
auto.
Qed.

Lemma model_bool_true: model_bool true = (Term id_true nil).
Proof.
auto.
Qed.

Lemma model_bool_false: model_bool false = (Term id_false nil).
Proof.
auto.
Qed.

Hint Rewrite model_list_Nil model_list_Cons : model_list.
Hint Rewrite model_nat_0 model_nat_S : model_nat.
Hint Rewrite model_bool_true model_bool_false : model_bool.

Ltac rewrite_model := autorewrite with model_list model_nat model_bool.


(** * Hoare_J: ホーア論理 *)
(* * Hoare: Hoare Logic *)

Require Export ImpList_J.

(** ** 表明 *)
Definition Assertion := state -> Prop.

(** ** ホーアの三つ組 *)
Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c" :=          (hoare_triple P c (fun st => True)) (at level 90)
                                  : hoare_spec_scope.
Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q) (at level 90, c at next level)
                                  : hoare_spec_scope.
Open Scope hoare_spec_scope.

Definition assn_sub V a Q : Assertion :=
  fun (st : state) =>
    Q (update st V (aeval st a)).

(* ####################################################### *)
(** *** 代入 *)
Theorem hoare_asgn : forall Q V a,
  {{assn_sub V a Q}} (V ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q V a st st' HE HQ.
(*
   補足説明：
   [V::=a] を実行すると、
   V=aを加えるとQの成立する(もとの)状態(st)から、
   (V=aを加えなくても)Qの成立する状態(st')に、移行する。

  HQ : assn_sub V a Q st
  HE : (V ::= a) / st || st'
  ============================
   Q st'
*)
  inversion HE. subst.
(*
   補足説明：
   [V::=a] を実行すると、
   stから、
   stにV=aを加えた状態[update st V (aeval st a)]に、移行する。
   (この書き方のほうが解りやすいが、その分、表している意味が少ない、のか）

  HQ : assn_sub V a Q st
  HE : (V ::= a) / st || update st V (aeval st a)
  ============================
   Q (update st V (aeval st a))
*)
  unfold assn_sub in HQ. assumption.
Qed.

(* Here's a first formal proof using this rule. *)
(** この規則を使った最初の形式的証明が次のものです。*)

Theorem hoare_asgn_eq : forall Q Q' V a,
     Q' = assn_sub V a Q ->
     {{Q'}} (V ::= a) {{Q}}.
Proof.
  intros Q Q' V a H.
  rewrite H.
(*
   補足説明
   V=aを加えるとQの成立する(もとの)状態(st)では、Q'が成立する。
   (V=aを加えなくても)Qの成立する状態(st')では、Qが成立する。あたりまえ。
   [V::=a] を実行すると、st' から st に移行する。

   感覚的にいうと、
   Q' st で、Q st' のとき、stはst'からV=aを取り去ったもの。
   このQ'とQの関係を以下で示す。
   Q' = assn_sub V a Q
   取り去るというより、不問にする、というべきだろうか。
   より重要なのは、取り去られているのはV=aという、Vとaeval(a)の関係であって、
   aeval(a)を実行するための状態は、取り去られていないことである、だろうか。

   H : Q' = assn_sub V a Q
   ============================
   {{assn_sub V a Q}} V ::= a {{Q}}
*)
  apply hoare_asgn.
Qed.

(* 事前条件を強め、事後条件を弱める。 *)
Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  (forall st, P st -> P' st) ->
  (forall st, Q' st -> Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  intros st st' Hc HP.
  apply HQ'Q.  apply (Hht st st'). assumption.
  apply HPP'. assumption.  Qed.

(* 事前条件を強める。 *)
Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  (forall st, P st -> P' st) ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  apply hoare_consequence with (P' := P') (Q' := Q);
    try assumption.
  intros st H. apply H.  Qed.

(* 事後条件を弱める。 *)
Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  (forall st, Q' st -> Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  apply hoare_consequence with (P' := P) (Q' := Q');
    try assumption.
  intros st H. apply H.  Qed.

(* ####################################################### *)
(** *** Skip *)
(** [SKIP]は状態を変えないことから、任意の性質 P を保存します:
[[
      --------------------  (hoare_skip)
      {{ P }} SKIP {{ P }}
]]
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* ####################################################### *)
(** *** コマンド合成 *)
(** より興味深いことに、コマンド[c1]が、[P]が成立する任意の状態を[Q]が成立する状態にし、
    [c2]が、[Q]が成立する任意の状態を[R]が成立する状態にするとき、
    [c1]に続いて[c2]を行うことは、[P]が成立する任意の状態を[R]が成立する状態にします:
[[
        {{ P }} c1 {{ Q }}
        {{ Q }} c2 {{ R }}
       ---------------------  (hoare_seq)
       {{ P }} c1;c2 {{ R }}
]]
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); try assumption. Qed.

(** 形式的規則[hoare_seq]においては、
    前提部分が「逆順」である([c1]の前に[c2]が来る)ことに注意してください。
    この順は、規則を使用する多くの場面で情報の自然な流れにマッチするのです。*)

(** 非形式的には、この規則を利用した証明を記録する良い方法は、
    [c1]と[c2]の間に中間表明[Q]を記述する"修飾付きプログラム"の様にすることです:
[[
      {{ a = n }}
    X ::= a;
      {{ X = n }}      <---- 修飾 Q
    SKIP
      {{ X = n }}
]]
*)

(* ####################################################### *)
(** *** 条件分岐 *)

(** しかし、実際には、より詳しいことを言うことができます。
   "then"の枝では、ブール式[b]の評価結果が[true]になることがわかっています。
   また"else"の枝では、それが[false]になることがわかっています。
   この情報を補題の前提部分で利用できるようにすることで、
   [c1]と[c2]の振舞いについて(つまり事後条件[Q]が成立する理由について)推論するときに、
   より多くの情報を使うことができるようになります。
[[
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
]]
*)

(** この規則を形式的に解釈するために、もう少しやることがあります。

    厳密には、上述の表明において、表明とブール式の連言[P /\ b]は、型チェックを通りません。
    これを修正するために、ブール式[b]を形式的に「持ち上げ」て、表明にしなければなりません。
    このために[bassn b]と書きます。
    これは"ブール式[b]の評価結果が(任意の状態で)[true]になる"という表明です。*)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

(** [bassn]についての2つの便利な事実です: *)

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(** いよいよ条件分岐についてのホーア証明規則を形式化し、正しいことを証明できます。*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* ####################################################### *)
(** *** ループ *)

(** 最後に、ループについての推論規則が必要です。
    次のループを考えます:
[[
      WHILE b DO c END
]]
    そして、次の三つ組が正しくなる事前条件[P]と事後条件[Q]を探します:
[[
      {{P}} WHILE b DO c END {{Q}}
]]
    まず、[b]が最初から偽であるときを考えましょう。
    このときループの本体はまったく実行されません。
    この場合は、ループは[SKIP]と同様の振舞いをしますので、
    次のように書いても良いかもしれません。
[[
      {{P}} WHILE b DO c END {{P}}.
]]
    しかし、条件分岐について議論したのと同様に、最後でわかっていることはもう少し多いのです。
    最終状態では[P]であるだけではなく[b]が偽になっているのです。
    そこで、事後条件にちょっと付け足すことができます:
[[
      {{P}} WHILE b DO c END {{P /\ ~b}}
]]
    それでは、ループの本体が実行されるときはどうなるでしょう？
    ループを最後に抜けるときには[P]が成立することを確実にするために、
    コマンド[c]の終了時点で常に[P]が成立することを確認する必要があるのは確かでしょう。
    さらに、[P]が[c]の最初の実行の前に成立しており、[c]を実行するたびに、
    終了時点で[P]の成立が再度確立されることから、
    [P]が[c]の実行前に常に成立していると仮定することができます。
    このことから次の規則が得られます:
[[
                   {{P}} c {{P}}
        -----------------------------------
        {{P}} WHILE b DO c END {{P /\ ~b}}
]]
    命題[P]は不変条件(_invariant_)と呼ばれます。ループ不変式

    これで求める規則にかなり近付いたのですが、もうちょっとだけ改良できます。
    ループ本体の開始時点で、[P]が成立しているだけでなく、
    ガード[b]が現在の状態で真であるということも言えます。
    このことは、[c]についての推論の際にいくらかの情報を与えてくれます。
    結局、規則の最終バージョンはこうなります:
[[
               {{P /\ b}} c {{P}}
        -----------------------------------  [hoare_while]
        {{P}} WHILE b DO c END {{P /\ ~b}}
]]
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember (WHILE b DO c END) as wcom.
  induction He;                             (* wcom / st || st' に対する帰納法。 *)
    inversion Heqwcom; subst.

  (* "E_WhileEnd". *)
  (*
     HP : P st
     H : beval st b = false
     ============================
     P st /\ ~ bassn b st
 *)
  split.
  apply HP.
  apply bexp_eval_false. apply H.

  (* "E_WhileLoop". *)
  (*
     HP : P st
     He1 : c / st || st'
     IHHe1 : c = (WHILE b DO c END) -> P st -> P st' /\ ~ bassn b st'
     H : beval st b = true
     He2 : (WHILE b DO c END) / st' || st''
     IHHe2 : (WHILE b DO c END) = (WHILE b DO c END) ->
     P st' -> P st'' /\ ~ bassn b st''
     ============================
     P st'' /\ ~ bassn b st''
     *)
  apply IHHe2.  reflexivity.
  apply (Hhoare st st').
  apply He1.
  (* P st /\ bassn b st *)
  split.
  apply HP.
  apply bexp_eval_true. apply H.
Qed.

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  unfold hoare_triple. intros P Q st st' contra.
  apply loop_never_stops in contra.  inversion contra.
Qed.

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Exercise: Reduce to Zero *)
(** ** 練習問題: ゼロへの簡約 *)

(** 次の while ループは、非常にシンプルなため、不変条件が必要ありません:
[[
          {{ True }}
        WHILE X <> 0 DO
            {{ True /\ X <> 0 }} =>
            {{ True }}
          X ::= X - 1
            {{ True }}
        END
          {{ True /\ X = 0 }} =>
          {{ X = 0 }}
]]
   この証明を Coq に変換しなさい。[slow_subtraction]の証明がアイデアの参考になるでしょう。
*)

(* **** Exercise: 2 stars (reduce_to_zero_correct) *)
(** **** 練習問題: ★★ (reduce_to_zero_correct) *)
Definition reduce_to_zero : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    X ::= AMinus (AId X) (ANum 1)
  END.

Theorem reduce_to_zero_correct :
  {{fun st => True}}
  reduce_to_zero
  {{fun st => asnat (st X) = 0}}.
Proof.
  unfold reduce_to_zero.
  (*
     {{ True }}
     WHILE X <> 0 DO
     X ::= X - 1
     END
     {{ X = 0 }}
 *)
  eapply hoare_consequence_post.            (* (1) *)
  (*
     {{ True }}
     WHILE X <> 0 DO
     X ::= X - 1
     END
     {{ True /\ X = 0 }}
 *)
  apply hoare_while.
  (*
     {{ True /\ X <> 0 }}
     X ::= X - 1
     {{ True }}
 *)
  eapply hoare_consequence_pre.             (* (2) *)
  (*
     {{ True }}
     X ::= X - 1
     {{ True }}
     *)
  apply hoare_asgn.
  (* (2)の後始末。
     {{True /\ X <> 0}} => {{True}}
     *)
  intros st H. apply H.
  (* (1)の後始末。
     {{True /\ X = 0}} => {{X=0}}
     *)
  intros st H. simpl in H.
  destruct H.
  unfold bassn, beval in H0. simpl in H0.
  apply eq_true_not_negb in H0.
  rewrite negb_involutive in H0.
  apply beq_nat_true in H0.
  apply H0.
Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Exercise: Slow Addition *)
(** ** 練習問題: 遅い足し算 *)

(** 次のプログラムは変数Xを変数Zに足します。
    そのために、Xを減らしてZを増やすということを繰り返します。*)

Definition add_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    Z ::= APlus (AId Z) (ANum 1);
    X ::= AMinus (AId X) (ANum 1)
  END.

(* **** Exercise: 3 stars (add_slowly_decoration) *)
(** **** 練習問題: ★★★ (add_slowly_decoration) *)
(*
   [[
   {{ X = x /\ Z = z }} => (1)
   {{ Z + X = z + x }}        ：ループ不変式
   WHILE X <> 0 DO
   {{ Z + X = z + x /\ X <> 0 }} => (2)
   {{ (Z + 1) + (X - 1) = z + x }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
   X ::= X - 1
   {{ Z + X = z + x }}
   END
   {{ Z + X = z + x /\ ~ (X <> 0) }} => (3)
   {{ Z = z + x }}
   ]]
*)
(** [] *)

(* **** Exercise: 3 stars (add_slowly_formal) *)
(** **** 練習問題: ★★★ (add_slowly_formal) *)
(* Now write down your specification of [add_slowly] formally, as a
    Coq [Hoare_triple], and prove it valid. *)
(** Coq の [Hoare_triple]のように、[add_slowly]の仕様を形式的に記述しなさい。
    そして正しさを証明しなさい。*)

Definition add_slowly_invariant x z :=
  fun st => (asnat (st Z)) + (asnat (st X)) = z + x.

Theorem add_slowly_correct : forall x z,
  {{fun st => asnat (st X) = x /\ asnat (st Z) = z}}
  add_slowly
  {{fun st => asnat (st Z) = z + x}}.
Proof.
  (* subtract_slowly を add_slowly に書き換えただけ。 *)
  intros x z. unfold add_slowly.
(*
   {{ X = x /\ Z = z }}
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z = z + x }}
]]
*)
  eapply hoare_consequence with (P' := add_slowly_invariant x z). (* pre:(1)、 post:(2) *)
(*
   {{ X + Z = x + z }} (1)
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z + X = z + x /\ ~ (X <> 0) }} (2)
]]
*)
  apply hoare_while.
(*
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  eapply hoare_seq.
(*
   SEQの後の文。
   {{ Z + (X - 1) = z + x }}
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  apply hoare_asgn.
(*
   SEQの前の文。
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  eapply hoare_consequence_pre.             (* (3) *)
(*
   {{ (Z + 1) + (X - 1) = z + x }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  apply hoare_asgn.

(* (3)の後始末。
   {{ Z + X = z + x /\ X <> 0 }} => {{ (Z + 1) + (X - 1) = z + x }}
*)
  unfold add_slowly_invariant, assn_sub, update, bassn. simpl.
  intros st [Inv GuardTrue].
  remember (beq_nat (asnat (st X)) 0) as Q; destruct Q.
  inversion GuardTrue.
  symmetry in HeqQ.  apply beq_nat_false in HeqQ.
  omega.

(* (1)の後始末。
   {{ X = x /\ Z = z }} => {{ Z + X = z + x }}
   *)
  unfold add_slowly_invariant.
  intros st [HX HZ]. omega.

(* (2)の後始末。
   {{ Z + X = z + x /\ ~ (X <> 0) }} => {{ Z = z + x }}
 *)
  intros st [Inv GuardFalse].
  unfold add_slowly_invariant in Inv.
  unfold add_slowly_invariant.
  unfold bassn in GuardFalse. simpl in GuardFalse.
  destruct (asnat (st X)).
  omega.
  apply ex_falso_quodlibet.   apply GuardFalse. reflexivity.
Qed.

(* hoare_consequence_pre とhoare_consequence_postに分けてみた。
   後始末のゴールの順番が変わることに注意するだけ。
*)
Theorem add_slowly_correct' : forall x z,
  {{fun st => asnat (st X) = x /\ asnat (st Z) = z}}
  add_slowly
  {{fun st => asnat (st Z) = z + x}}.
Proof.
  intros x z. unfold add_slowly.
(*
   {{ X = x /\ Z = z }}
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z = z + x }}
]]
*)
   eapply hoare_consequence_pre.            (* (1) *)
(*  with (P' := add_slowly_invariant x z). *)
(*
   {{ X + Z = x + z }}
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z = z + x }}
]]
*)
   eapply hoare_consequence_post.           (* (2) *)
(*    with (Q' :=
      fun st : state =>                     (* (2) *)
        add_slowly_invariant x z st /\ ~ bassn (BNot (BEq (AId X) (ANum 0))) st).*)
(*
   {{ X + Z = x + z }} (1)
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z + X = z + x /\ ~ (X <> 0) }} (2)
]]
*)
  apply hoare_while
    with (P := add_slowly_invariant x z).
  (* whileの分解にループ不変式を使うのが、筋だと思う。 *)
(*
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  eapply hoare_seq.
(*
   SEQの後の文。
   {{ Z + (X - 1) = z + x }}
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  apply hoare_asgn.
(*
   SEQの前の文。
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  eapply hoare_consequence_pre.             (* (3) *)
(*
   {{ (Z + 1) + (X - 1) = z + x }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  apply hoare_asgn.

(* (3)の後始末。
   {{ Z + X = z + x /\ X <> 0 }} => {{ (Z + 1) + (X - 1) = z + x }}
*)
  unfold add_slowly_invariant, assn_sub, update, bassn. simpl.
  intros st [Inv GuardTrue].
  remember (beq_nat (asnat (st X)) 0) as Q; destruct Q.
  inversion GuardTrue.
  symmetry in HeqQ. apply beq_nat_false in HeqQ.
  omega.

(* (2)の後始末。
   {{ Z + X = z + x /\ ~ (X <> 0) }} => {{ Z = z + x }}
 *)
  intros st [Inv GuardFalse].
  unfold add_slowly_invariant in Inv.
  unfold add_slowly_invariant.
  unfold bassn in GuardFalse. simpl in GuardFalse.
  destruct (asnat (st X)).
  omega.
  apply ex_falso_quodlibet. apply GuardFalse. reflexivity.

(* (1)の後始末。
   {{ X = x /\ Z = z }} => {{ Z + X = z + x }}
   *)
  unfold add_slowly_invariant.
  intros st [HX HZ]. omega.
Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Example: Parity *)
(** ** 例: パリティ *)
(**
[[
    {{ X = x }} =>
    {{ X = x /\ 0 = 0 }}
  Y ::= 0;
    {{ X = x /\ Y = 0 }} =>
    {{ (Y=0 <-> ev (x-X)) /\ X<=x }}
  WHILE X <> 0 DO
      {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }} =>
      {{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    Y ::= 1 - Y;
      {{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    X ::= X - 1
      {{ Y=0 <-> ev (x-X) /\ X<=x }}
  END
    {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }} =>
    {{ Y=0 <-> ev x }}
]]
*)

Definition find_parity : com :=
  Y ::= (ANum 0);
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    Y ::= AMinus (ANum 1) (AId Y);
    X ::= AMinus (AId X) (ANum 1)
  END.

Definition find_parity_invariant x :=
  fun st =>
       asnat (st X) <= x
    /\ (asnat (st Y) = 0 /\ ev (x - asnat (st X)) \/ asnat (st Y) = 1 /\ ~ev (x - asnat (st X))).

Lemma not_ev_ev_S_gen: forall n,
  (~ ev n -> ev (S n)) /\
  (~ ev (S n) -> ev (S (S n))).
Proof.
  induction n as [| n'].
  Case "n = 0".
    split; intros H.
    SCase "->".
      apply ex_falso_quodlibet. apply H. apply ev_0.
    SCase "<-".
      apply ev_SS. apply ev_0.
  Case "n = S n'".
    inversion IHn' as [Hn HSn]. split; intros H.
    SCase "->".
      apply HSn. apply H.
    SCase "<-".
      apply ev_SS. apply Hn. intros contra.
      apply H. apply ev_SS. apply contra.  Qed.

Lemma not_ev_ev_S : forall n,
  ~ ev n -> ev (S n).
Proof.
  intros n.
  destruct (not_ev_ev_S_gen n) as [H _].
  apply H.
Qed.

(* より修飾に忠実な判 *)
(*
[[
    {{ X = x }} =>                                (1)
    {{ X = x /\ 0 = 0 }}
  Y ::= 0;
    {{ X = x /\ Y = 0 }} =>                       (2)
    {{ (Y=0 <-> ev (x-X)) /\ X<=x }}
  WHILE X <> 0 DO
      {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }} => (3)
      {{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    Y ::= 1 - Y;
      {{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    X ::= X - 1
      {{ Y=0 <-> ev (x-X) /\ X<=x }}
  END
    {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }} => (4)
    {{ Y=0 <-> ev x }}
]]
*)
Theorem find_parity_correct'' : forall x,
  {{fun st => asnat (st X) = x}}
  find_parity
  {{fun st => asnat (st Y) = 0 <-> ev x}}.
Proof.
  intros x. unfold find_parity.
(*
[[
{{ X = x }}
  Y ::= 0;
  WHILE X <> 0 DO
    Y ::= 1 - Y;
    X ::= X - 1
  END
  {{ Y=0 <-> ev x }}
]]
*)
 eapply hoare_consequence_post.             (* (4) *)
(*
[[
{{ X = x }}
  Y ::= 0;
  WHILE X <> 0 DO
    Y ::= 1 - Y;
    X ::= X - 1
  END
    {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }}
]]
*)
  apply hoare_seq with (Q := find_parity_invariant x). (* (2) *)
  (* 修飾の証明は増えない。つまり(2)の修飾の証明はいらない。 *)
(*
[[
{{ (Y=0 <-> ev (x-X)) /\ X<=x }} ： ループ不変式
  WHILE X <> 0 DO
    Y ::= 1 - Y;
    X ::= X - 1
  END
  {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }}
]]
*)
  apply hoare_while with (P := find_parity_invariant x). (* ゴールは増えない。 *)
(*
[[
{{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }}
Y ::= 1 - Y;
X ::= X - 1
{{ Y=0 <-> ev (x-X) /\ X<=x }}
]]
*)
    eapply hoare_seq.
(*
[[
{{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
X ::= X - 1
{{ Y=0 <-> ev (x-X) /\ X<=x }}
]]
*)
    apply hoare_asgn.                       (* X ::= X - 1 *)
(*
[[
{{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }}
Y ::= 1 - Y;
{{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
]]
*)
    eapply hoare_consequence_pre.           (* (3) *)
(*
[[
{{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
Y ::= 1 - Y;
{{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
]]
*)
    apply hoare_asgn.                       (* Y ::= 1 - Y *)
(* (3)の修飾の証明。
   {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }} =>
   {{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
   *)
    intros st [[Inv1 Inv2] GuardTrue].
    unfold find_parity_invariant, bassn, assn_sub, aeval in *. (* GoalとGuardTrue *)
    rewrite update_eq.
    rewrite (update_neq Y X); auto.
    rewrite (update_neq X Y); auto.
    rewrite update_eq.
    simpl in GuardTrue. destruct (asnat (st X)).
      inversion GuardTrue. simpl.
    split. omega.
    inversion Inv2 as [[H1 H2] | [H1 H2]]; rewrite H1;
                     [right|left]; (split; simpl; [omega |]).
    apply ev_not_ev_S in H2.
    replace (S (x - S n)) with (x-n) in H2 by omega.
    rewrite <- minus_n_O. assumption.
    apply not_ev_ev_S in H2.
    replace (S (x - S n)) with (x - n) in H2 by omega.
    rewrite <- minus_n_O. assumption.
(*
[[
{{ X = x }}
Y ::= 0;
{{ (Y=0 <-> ev (x-X)) /\ X<=x }}
]]
*)
    eapply hoare_consequence_pre.           (* (1) *)
(*
[[
{{ X = x /\ 0 = 0 }}
Y ::= 0;
{{ (Y=0 <-> ev (x-X)) /\ X<=x }}
]]
*)
    apply hoare_asgn.                       (* Y ::= 0 *)
(* (1) の修飾の証明
   {{ X = x }} => {{ X = x /\ 0 = 0 }}
*)
    intros st H.
    unfold assn_sub, find_parity_invariant, update. simpl.
    subst.
    split.
    omega.
    replace (asnat (st X) - asnat (st X)) with 0 by omega.
    left. split. reflexivity.
    apply ev_0.

(* (4) の修飾の証明。
   {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }} => {{ Y=0 <-> ev x }}
*)
    unfold bassn, find_parity_invariant. simpl.
    intros st [[Inv1 Inv2] GuardFalse].
    destruct (asnat (st X)).
      split; intro.
        inversion Inv2.
           inversion H0 as [_ H1]. replace (x-0) with x in H1 by omega.
           assumption.
           inversion H0 as [H0' _]. rewrite H in H0'. inversion H0'.
        inversion Inv2.
           inversion H0. assumption.
           inversion H0 as [_ H1]. replace (x-0) with x in H1 by omega.
           apply ex_falso_quodlibet. apply H1. assumption.
      apply ex_falso_quodlibet. apply GuardFalse. reflexivity.
Qed.

(* ####################################################### *)
(* ####################################################### *)
(* ** Example: Finding Square Roots *)
(** ** 例: 平方根の探索 *)
(*
{{Treu}} => {{x = x}}              修飾(0)
  X ::= ANum x;
{{X = x}} => {{X = x /\ 0 = 0}}    修飾(1)
  Z ::= ANum 0;
{{X = x /\ Z = 0}}                 修飾(2)
=> {{X = x /\ Z * Z <= x}}         ループ不変式
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) <= x}}  ループ不変式かつループ実行条件
=> {{X = x /\ (Z+1)*(Z+1) <= x}}   修飾(3)
    Z ::= APlus (ANum 1) (AId Z)
{{X = x /\ Z * Z <= x}}            ループ不変式
END
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) > x}}   ループ不変式かつ終了条件
=> {{Z * Z <= x /\ (Z+1)*(Z+1) > x}}  要求仕様、 修飾(4)
*)

Definition sqrt_loop : com :=
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
  END.

Definition sqrt_com : com :=
  Z ::= ANum 0;
  sqrt_loop.

Definition sqrt_spec (x : nat) : Assertion :=
  fun st =>
       ((asnat (st Z)) * (asnat (st Z))) <= x
    /\ ~ (((S (asnat (st Z))) * (S (asnat (st Z)))) <= x).

Definition sqrt_inv (x : nat) : Assertion :=
  fun st =>
       asnat (st X) = x
    /\ ((asnat (st Z)) * (asnat (st Z))) <= x.

Theorem random_fact_1 : forall st,
     (S (asnat (st Z))) * (S (asnat (st Z))) <= asnat (st X) ->
     bassn (BLe (AMult (APlus (ANum 1) (AId Z))
                       (APlus (ANum 1) (AId Z)))
                (AId X)) st.
Proof.
  intros st Hle.  unfold bassn. simpl.
  destruct (asnat (st X)) as [|x'].
  Case "asnat (st X) = 0".
    inversion Hle.
  Case "asnat (st X) = S x'".
    simpl in Hle. apply le_S_n in Hle.
    remember (ble_nat (plus (asnat (st Z))
                      ((asnat (st Z)) * (S (asnat (st Z))))) x')
      as ble.
    destruct ble. reflexivity.
    symmetry in Heqble. apply ble_nat_false in Heqble.
    unfold not in Heqble. apply Heqble in Hle. inversion Hle.
Qed.

Theorem random_fact_2 : forall st,
     bassn (BLe (AMult (APlus (ANum 1) (AId Z))
                       (APlus (ANum 1) (AId Z)))
                (AId X)) st ->
       asnat (aeval st (APlus (ANum 1) (AId Z)))
     * asnat (aeval st (APlus (ANum 1) (AId Z)))
     <= asnat (st X).
Proof.
  intros st Hble. unfold bassn in Hble. simpl in *.
  destruct (asnat (st X)) as [| x'].
  Case "asnat (st X) = 0".
    inversion Hble.
  Case "asnat (st X) = S x'".
    apply ble_nat_true in Hble. omega. Qed.

(* 修飾を注釈版 *)
Theorem sqrt_com_correct' : forall x,
  {{fun st => True}} (X ::= ANum x; sqrt_com) {{sqrt_spec x}}.
Proof.
  intros x.
(*
{{Treu}}
  X ::= ANum x;
  Z ::= ANum 0;
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{Z * Z <= x /\ (Z+1)*(Z+1) > x}} 要求仕様
*)
  apply hoare_seq with (Q := fun st => asnat (st X) = x).
(*
{{X = x}}
  Z ::= ANum 0;
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{Z * Z <= x /\ (Z+1)*(Z+1) > x}} 要求仕様
*)
  Case "sqrt_com".
    unfold sqrt_com.
    apply hoare_seq with (Q := fun st => asnat (st X) = x
                                      /\ asnat (st Z) = 0).

(*
{{X = x /\ Z = 0}}
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{Z * Z <= x /\ (Z+1)*(Z+1) > x}} 要求仕様
*)
    SCase "sqrt_loop".
      unfold sqrt_loop.
      eapply hoare_consequence.
(*
{{X = x /\ Z * Z <= x}}         ループ不変式
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) > x}}   ループ不変式かつ終了条件
*)
      apply hoare_while with (P := sqrt_inv x).
(*
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) <= x}}  ループ不変式かつループ実行条件
    Z ::= APlus (ANum 1) (AId Z)
{{X = x /\ Z * Z <= x}}            ループ不変式
*)
      SSCase "loop preserves invariant".
        eapply hoare_consequence_pre.
(*
{{X = x /\ (Z+1)*(Z+1) <= x}}   修飾(3)
    Z ::= APlus (ANum 1) (AId Z)
{{X = x /\ Z * Z <= x}}            ループ不変式
*)
        apply hoare_asgn.                   (* Z := 1 + Z *)
(*
   修飾(3)の証明
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) <= x}}  ループ不変式かつループ実行条件
=> {{X = x /\ (Z+1)*(Z+1) <= x}}
*)
        intros st H.
        unfold assn_sub. unfold sqrt_inv in *.
        inversion H as [[HX HZ] HP]. split.
        SSSCase "X is preserved".
          rewrite update_neq; auto.
        SSSCase "Z is updated correctly".
          rewrite (update_eq (aeval st (APlus (ANum 1) (AId Z))) Z st).
          subst. apply random_fact_2. assumption.
(*  修飾(3)終わり *)
(*
   修飾(2)の証明
{{X = x /\ Z = 0}} => {{X = x /\ Z * Z <= x}}   ループ不変式
*)
      SSCase "invariant is true initially".
        intros st H. inversion H as [HX HZ].
        unfold sqrt_inv. split. assumption.
        rewrite HZ. simpl. omega.
(*  修飾(2)終わり *)
(*
   修飾(4)の証明
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) > x}}   ループ不変式かつ終了条件
=> {{Z * Z <= x /\ (Z+1)*(Z+1) > x}}         要求仕様
*)
      SSCase "after loop, spec is satisfied".
        intros st H. unfold sqrt_spec.
        inversion H as [HX HP].
        unfold sqrt_inv in HX.  inversion HX as [HX' Harith].
        split. assumption.
        intros contra. apply HP. clear HP.
        simpl. simpl in contra.
        apply random_fact_1. subst x. assumption.
(*  修飾(4)終わり *)
(*
{{X = x}}
  Z ::= ANum 0;
{{X = x /\ Z = 0}}
*)
    SCase "Z set to 0".
      eapply hoare_consequence_pre.
(*
{{X = x /\ 0 = 0}}
  Z ::= ANum 0;
{{X = x /\ Z = 0}}
*)
(*
   修飾(1)の証明
{{X = x}} => {{X = x /\ 0 = 0}}
 *)
      apply hoare_asgn.                     (* Z := 0 *)
      intros st HX.
      unfold assn_sub. split.
      rewrite update_neq; auto.
      rewrite update_eq; auto.
(*  修飾(1)終わり *)
(*
{{Treu}}
  X ::= ANum x;
{{X = x}}
*)
  Case "assignment of X".
    eapply hoare_consequence_pre.
(*
{{x = x}}
  X ::= ANum x;
{{X = x}}
*)
    apply hoare_asgn.                       (* X := x *)
(*
   修飾(0)の証明
{{Treu}} => {{x = x}}
*)
    intros st H.
    unfold assn_sub. rewrite update_eq; auto.
(*  修飾(0)終わり *)
  Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Exercise: Factorial *)
(** ** 練習問題: 階乗 *)

Module Factorial.

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

(* Recall the factorial Imp program: *)
(** 階乗を計算する Imp プログラムを思い出してください: *)

Definition fact_body : com :=
  Y ::= AMult (AId Y) (AId Z);
  Z ::= AMinus (AId Z) (ANum 1).

Definition fact_loop : com :=
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    fact_body
  END.

Definition fact_com : com :=
  Z ::= (AId X);
  Y ::= ANum 1;
  fact_loop.

(* **** Exercise: 3 stars, optional (fact_informal) *)
(** **** 練習問題: ★★★, optional (fact_informal) *)
(* Decorate the [fact_com] program to show that it satisfies the
    specification given by the pre and postconditions below.  Just as
    we have done above, you may elide the algebraic reasoning about
    arithmetic, the less-than relation, etc., that is (formally)
    required by the rule of consequence:

(* FILL IN HERE *)
[[
    {{ X = x }}
  Z ::= X;
  Y ::= 1;
  WHILE Z <> 0 DO
    Y ::= Y * Z;
    Z ::= Z - 1
  END
    {{ Y = real_fact x }}
]]
*)
(** [fact_com]を修飾して、以下の事前条件、事後条件として与えられる仕様を満たすことを示しなさい。
    帰結規則のために(形式的には)算術式や不等号などについての推論が必要になりますが、
    ここまでと同様、それらは省略して構いません。

回答：
[[
{{True}} => {{ X = x }}  修飾(1)
  Z ::= X;
{{Z = x}} => {{Z = x /\ 1 = 1}} 修飾(2)
  Y ::= 1;
{{Z = x /\ Y = 1}} =>  修飾(3)
{{Y*real_fact(Z) = real_fact(x)}} ループ不変式
  WHILE Z <> 0 DO
{{Y * real_fact(Z) = real_fact(x) /\ Z <> 0}} ループ不変式、かつ、ループ実行条件
=> {{Y * Z * real_fact(Z - 1) = real_fact(x)}} 修飾(4)
    Y ::= Y * Z;
{{Y * real_fact(Z - 1) = real_fact(x)}}
    Z ::= Z - 1
{{Y * real_fact(Z) = real_fact(x)}} ループ不変式
  END
{{Y * real_fact(Z) = real_fact(x) /\ Z = 0}} ループ不変式、かつ、終了条件
=> {{ Y = real_fact x }} 要求仕様、修飾(5)
]]
*)
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* **** Exercise: 4 stars, optional (fact_formal) *)
(** **** 練習問題: ★★★★, optional (fact_formal) *)
(* Prove formally that fact_com satisfies this specification,
    using your informal proof as a guide.  You may want to state
    the loop invariant separately (as we did in the examples). *)
(** fact_com がこの仕様を満たすことを、形式的に証明しなさい。
    その際、自分の非形式的な証明をガイドとして使いなさい。
    (例で行ったように)ループ不変条件を分離して主張しても構いません。*)

(* 要求仕様 使ってない *)
Definition fact_spec (x : nat) : Assertion :=
  fun st =>
       asnat (st Z) = real_fact x.

Definition fact_inv (x : nat) : Assertion :=
  fun st =>
       asnat (st Y) * real_fact (asnat (st Z)) = real_fact x.

Theorem fact_com_correct : forall x,
  {{fun st => asnat (st X) = x}} fact_com
  {{fun st => asnat (st Y) = real_fact x}}.
Proof.
  unfold fact_com, fact_loop, fact_body.
  intros x.
  eapply hoare_consequence_post.            (* 修飾(5) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  apply hoare_seq with (Q := fun st => asnat (st Z) = x).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_seq with (Q := fun st => asnat (st Z) = x /\ asnat (st Y) = 1).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  apply hoare_while with (P := fact_inv x).
  eapply hoare_consequence_pre.             (* 修飾(4) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* Z := Z - 1 *)
  apply hoare_asgn.                         (* Y := Y * Z *)
(*
   修飾(4)の証明
   {{Y * real_fact(Z) = real_fact(x) /\ Z <> 0}} ループ不変式、かつ、ループ実行条件
   => {{Y * Z * real_fact(Z - 1) = real_fact(x)}}
 *)
  unfold assn_sub, bassn, fact_inv, update.
  intros st H. simpl.
  destruct H as [H1 H2].
  simpl in H2.
  (* ここの証明は、Imp_J.vの fact_body_preserves_invariant とおなじ。 *)
  destruct (asnat (st Z)) as [| z'].
  apply ex_falso_quodlibet. inversion H2.
  rewrite <- H1. rewrite <- mult_assoc.
  replace (S z' - 1) with z' by omega.
  reflexivity.
(* 修飾(4)の証明、終わり *)

(*
   修飾(3)の証明
   {{Z = x /\ Y = 1}} => {{Y*real_fact(Z) = real_fact(x)}} ループ不変式
*)
  intros st H.
  unfold fact_inv.
  destruct H as [H1 H2].
  rewrite H1. rewrite H2. omega.
(* 修飾(3)の証明、終わり *)

  apply hoare_asgn.                         (* Y := 1 *)
(*
   修飾(2)の証明
   {{Z = x}} => {{Z = x /\ 1 = 1}}
*)
  unfold assn_sub, update.
  intros st H.
  split; try(rewrite <- H); simpl; reflexivity.
(* 修飾(2)の証明、終わり *)

  apply hoare_asgn.                         (* Z := X *)
(*
   修飾(1)の証明
   {{True}} => {{ X = x }}
*)
  unfold assn_sub, update. simpl.
  intros st H.
  apply H.
(* 修飾(1)の証明、終わり *)

(*
   修飾(5)の証明
   {{Y * real_fact(Z) = real_fact(x) /\ Z = 0}}
   ループ不変式、かつ、終了条件
   => {{ Y = real_fact x }} 要求仕様
   *)
  unfold assn_sub, bassn, fact_inv, update.
  intros st H. simpl.
  destruct H as [H1 H2].
  simpl in H2.
  destruct (asnat (st Z)) as [| z'].
  rewrite <- H1. simpl. omega.
  apply ex_falso_quodlibet. apply H2.
  reflexivity.
Qed.
(** [] *)

End Factorial.

(* ####################################################### *)
(* ####################################################### *)
(* ** Reasoning About Programs with Lists *)
(** ** リストを扱うプログラムについての推論 *)

(* **** Exercise: 3 stars (list_sum) *)
(** **** 練習問題: ★★★ (list_sum) *)
(* Here is a direct definition of the sum of the elements of a list,
    and an Imp program that computes the sum. *)
(** 以下は、リストの要素の合計の直接的定義と、その合計を計算するImpプログラムです *)

Definition sum l := fold_right plus 0 l.

Definition sum_program :=
  Y ::= ANum 0;
  WHILE (BIsCons (AId X)) DO
    Y ::= APlus (AId Y) (AHead (AId X)) ;
    X ::= ATail (AId X)
  END.

(* ループ不変式 *)
Definition sum_program_inv l : Assertion :=
  fun st =>
    asnat (st Y) + sum (aslist (st X)) = sum l.

(* Provide an _informal_ proof of the following specification of
    [sum_program] in the form of a decorated version of the
    program. *)
(** [sum_program]の以下の仕様の「非形式的な」証明を、
    修飾を付けたバージョンのプログラムの形で与えなさい。*)

Definition sum_program_spec := forall l,
  {{ fun st => aslist (st X) = l }}
  sum_program
  {{ fun st => asnat (st Y) = sum l }}.

(*
[[
{X = 1} => {X = 1 /\ 0 = 0}              修飾(1)
Y := 0;
{X = 1 /\ Y = 0} => {Y + sum X = sum l}  修飾(2)、ループ不変式
WHILE (isCons X) DO
{Y + sum X = sum l /\ isCons X}          ループ不変式かつループ実行条件
=> {Y + head X + sum (tail X) = sum l}   修飾(3)
  Y := Y + head X;
{Y + sum (tail X) = sum l}
  X := tail X;
{Y + sum X = sum l}                      ループ不変式
END
{Y + sum X = sum l /\ ~isCons X}         ループ不変式かつループ終了条件
=> {Y = sum l}                           修飾(4)、要求仕様
]]
*)

Lemma sum_head_tail : forall l,
  head l + sum (tail l) = sum l.
Proof.
  intros l.
  induction l; simpl; reflexivity.
Qed.

Theorem sum_program_correct :
  sum_program_spec.
Proof.
  unfold sum_program_spec.
  intros l.
  eapply hoare_consequence_post.            (* 修飾(4) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  eapply hoare_seq
    with (Q := fun st => aslist (st X) = l /\ asnat (st Y) = 0).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_while with (P := sum_program_inv l).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* X := tail X *)
  apply hoare_asgn.                         (* Y := Y + head X *)
(*
   修飾(3)
   {Y + sum X = sum l /\ isCons X}
   => {Y + head X + sum (tail X) = sum l}
   *)
  unfold sum_program_inv, assn_sub. simpl.
  intros st [H1 H2].
  unfold bassn in H2.
  unfold update. simpl.
  rewrite plus_assoc_reverse.
  rewrite (sum_head_tail (aslist (st X))).
  apply H1.

(*
   修飾(2)
   {X = 1 /\ Y = 0} => {Y + sum X = sum l}
   *)
  unfold sum_program_inv. simpl.
  intros st [H1 H2].
  rewrite H2. rewrite H1. reflexivity.

  apply hoare_asgn.                         (* Y := 0 *)
(*
   修飾(1)
   {X = l} => {X = l /\ 0 = 0}
   *)
  unfold assn_sub, update. simpl.
  intros st H.
  split. apply H. reflexivity.

(*
   修飾(4)
   {Y + sum X = sum l /\ ~(isCons X)} => {Y = sum l}
   *)
  unfold sum_program_inv, bassn, update.
  intros st [H1 H2].
  remember (aslist (st X)) as x'.
  destruct x'.
  (* X = [] のとき。 *)
  rewrite <- H1. simpl. omega.
  (* X = n :: x' のとき。 *)
  apply ex_falso_quodlibet.
  apply H2. simpl.
  rewrite <- Heqx'.
  reflexivity.
Qed.
(** [] **)

(* **** Exercise: 4 stars, optional (list_reverse) *)
(** **** 練習問題: ★★★★, optional (list_reverse) *)
(* Recall the function [rev] from Poly.v, for reversing lists. *)
(** Poly_J.vの[rev]を思い出してください。リストを逆順にするものです。*)

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

Lemma snoc_equation : forall (A : Type) (h:A) (x y : list A),
  snoc x h ++ y = x ++ h :: y.
Proof.
  intros A h x y.
  induction x.
    Case "x = []". reflexivity.
    Case "x = cons". simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_nil : forall (A : Type) (l : list A),
  l ++ [] = l.
Proof.
  induction l.
    reflexivity.
    simpl. rewrite IHl. reflexivity.
Qed.

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

Lemma rev_equation : forall (A : Type) (h : A) (x y : list A),
  rev (h :: x) ++ y = rev x ++ h :: y.
Proof.
  intros. simpl. apply snoc_equation.
Qed.

Definition rev_program :=
  Y ::= ANil;
  WHILE BIsCons (AId X) DO
    Y ::= ACons (AHead (AId X)) (AId Y);
    X ::= ATail (AId X)
  END.

Definition rev_program_inv l : Assertion :=
  fun st =>
    rev (aslist (st X)) ++ aslist (st Y) = rev l.

Definition rev_program_spec := forall l,
  {{fun st => aslist (st X) = l}}
  rev_program
  {{fun st => aslist (st Y) = rev l}}.

(*
[[
{X = l} => {X = l /\ nil = nil}             修飾(1)
  Y ::= ANil;
{X = l /\ Y = nil} => {rev X ++ Y = rev l}  修飾(2)、ループ不変式
  WHILE BsCons (AId X) DO
{rev X ++ Y = rev l /\ BsCons (AId X)}      ループ不変式かつループ実行条件
=> {rev (tail X) ++ ((head X) :: Y) = rev l}  修飾(3)
    Y ::= ACons (AHead (AId X)) (AId Y);
{rev (tail X) ++ Y = rev l}
    X ::= ATail (AId X)
{rev X ++ Y = rev l}                        ループ不変式
  END.
{rev X ++ Y = rev l /\ ~(isCons X)}         ループ不変式かつループ終了条件
=> {Y = rev l}                              修飾(4)、要求仕様
]]
*)

Theorem rev_program_correct :
  rev_program_spec.
Proof.
  unfold rev_program_spec, rev_program.
  intros l.
  eapply hoare_consequence_post.            (* 修飾(4) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  apply hoare_seq
    with (Q := fun st => aslist (st X) = l /\ aslist (st Y) = []).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_while
    with (P := rev_program_inv l).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* Y := tail X *)
  apply hoare_asgn.                         (* Y := (head X) :: Y *)
(*
   修飾(3)
   {rev X ++ Y = rev l /\ BsCons (AId X)}
   => {rev (tail X) ++ ((head X) :: Y) = rev l}
   *)
  unfold rev_program_inv, assn_sub, bassn, update. simpl.
  intros st [H1 H2].
  rewrite <- (rev_equation nat
    (head (aslist (st X)))                  (* h *)
    (tail (aslist (st X)))                  (* x *)
    (aslist (st Y))).                       (* y *)
   (* (head X) :: (tail X) = X にならない。
      （(head []) :: (tail []) = 0 :: [] = [0] だから。）
      だから、Xをnilとconsに分けて証明する。
      *)
   remember (aslist (st X)) as x'.
   destruct x'.
(* X = [] *)
   simpl.
   (* 0 :: aslist (st Y) = rev l 、、、これは変 *)
   apply ex_falso_quodlibet.
   inversion H2.
(* X = n :: x' *)
   rewrite <- H1.
   simpl.
   reflexivity.

(*
   修飾(2)
   {X = l /\ Y = nil} => {rev X ++ Y = rev l}
   *)
   unfold rev_program_inv.
   intros st [H1 H2].
   rewrite H1. rewrite H2.
   apply append_nil.

   apply hoare_asgn.                        (* Y := nil *)
(*
   修飾(1)
   {X = l} => {X = l /\ nil = nil}
   *)
   unfold assn_sub, update. simpl.
   intros st H.
   split. apply H. reflexivity.

(*
   修飾(4)
   {rev X ++ Y = rev l /\ ~(isCons X)} => {Y = rev l}
   *)
   unfold rev_program_inv, bassn, update.
   intros st [H1 H2].
   rewrite <- H1.
   remember (aslist (st X)) as x'.
   destruct x'.
(* X = [] のとき。 *)
   simpl. reflexivity.
(* X = n :: x' のとき *)
   apply ex_falso_quodlibet.
   apply H2. simpl. rewrite <- Heqx'.
   reflexivity.
Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* 次節の問題だが、ここ方法で解いて見る。 *)
(** [X]に現在設定されている値を変数[Y]に代入する遠回りの方法は、
    [Y]を[0]から始め、
    [X]を[0]になるまで減らしていきながら、その各ステップで[Y]を増やしていくことです。
    com の方法で解いてみる *)
(*
[[
      {{ X = x }} => {0 = 0}                                   (1)
    Y ::= 0;
      {{ X = x /\ Y = 0 }} => {{ X + Y = x }}      ループ不変式 (2)
    WHILE X <> 0 DO
        {{ X + Y = x /\ X > 0 }}
        => {{ (X - 1) + (Y + 1) = x }}                         (3)
      X ::= X - 1;
        {{ X + Y + 1 = x }}
      Y ::= Y + 1;
        {{ X + Y = x }}
    END
      {{ X + Y = x /\ X = 0 }} => {{ Y = x }}                   (4)
]]
*)

Definition slow_asgn_prog :=
  Y ::= (ANum 0);
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    X ::= AMinus (AId X) (ANum 1);
    Y ::= APlus (AId Y) (ANum 1)
  END.

Definition slow_asgn_prog_inv x : Assertion :=
  fun st =>
    asnat (st X) + asnat (st Y) = x.

Definition slow_asgn_prog_spec := forall x,
  {{ fun st => asnat (st X) = x }}
  slow_asgn_prog
  {{ fun st => asnat (st Y) = x }}.

Lemma negb_not_true_iff : forall b, negb b <> true <-> b = true.
Proof.
  intros b.
  split.
  intros H.
  apply eq_true_negb_classical.             (* XXX *)
  apply H.
  intros H.

  rewrite H. simpl.
  unfold not.
  intros. inversion H0.
Qed.

Lemma x_plus_y__x_m1_plus_y_p1 : forall x y,
             x <> 0 -> x + y = (x - 1) + (y + 1).
Proof.
  intros x y H.
  induction x as [| x'].
  Case "x = 0".
    apply ex_falso_quodlibet.               (* 単にomegaでもよい *)
    apply H. reflexivity.
  Case "x = Sx'".
    omega.
Qed.

Theorem slow_asgn_prog_correct :
  slow_asgn_prog_spec.
Proof.
  unfold slow_asgn_prog_spec.
  intros x.
  eapply hoare_consequence_post.            (* 修飾(4) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  eapply hoare_seq
    with (Q := fun st => asnat (st X) = x /\ asnat (st Y) = 0).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_while with (P := slow_asgn_prog_inv x).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* Y := Y + 1 *)
  apply hoare_asgn.                         (* X := X - 1 *)
(*
   修飾(3)
   {{ X + Y = x /\ X > 0 }}
   => {{ (X - 1) + (Y + 1) = x }}                         (3)
*)
  unfold slow_asgn_prog_inv, assn_sub. simpl.
  intros st [H1 H2].
  unfold bassn in H2.
  unfold update. simpl.
  rewrite <- x_plus_y__x_m1_plus_y_p1.
  rewrite H1.
  reflexivity.
  (* X <> 0 の証明をする。 *)
  apply beq_nat_false.
  unfold bassn in H2.
  apply negb_true_iff in H2.
  apply H2.
(*
   修飾(2)
   {{ X = x /\ Y = 0 }} => {{ X + Y = x }}
   *)
  unfold slow_asgn_prog_inv.
  intros st [H1 H2].
  rewrite H2. rewrite H1. omega.

  apply hoare_asgn.                         (* X := x *)
(*
   修飾(1)
   {{ X = x }} => {0 = 0}                                   (1)
   *)
  unfold assn_sub, update. simpl.
  intros st H.
  split. apply H. reflexivity.

(*
   修飾(4)
   {{ X + Y = x /\ X = 0 }} => {{ Y = x }}                  (4)
   *)
  unfold slow_asgn_prog_inv, bassn. simpl.
  intros st [H1 H2].
  apply negb_not_true_iff in H2.
  apply beq_nat_true in H2.
  rewrite H2 in H1.
  rewrite plus_O_n in H1.
  apply H1.
Qed.

(* END *)


(*|
######################################################
Trouble writing my notation for natural numbers in Coq
######################################################

:Link: https://stackoverflow.com/q/11714415
|*)

(*|
Question
********

Why does Coq not accept this?

.. coq:: none
|*)

Definition addition a b := a + b.
Definition multiply a b := a * b.
Definition ten := 10.

(*||*)

Fail Notation "[ d1 , .. , d2 ]" := (addition (multiply ( .. d1 .. ) ten) d2). (* .fails *)

(*|
Answer
******

`Recursive notations
<http://coq.inria.fr/doc/Reference-Manual015.html#RecursiveNotations>`__
need to obey fairly strict rules. The pattern to repeat must appear
twice (that's how Coq knows what is to be repeated): once using ``d2``
around the hole, and once using ``d1`` around a *terminating
expression*. You've only used your pattern once, using ``d2`` around
the hole. You need another iteration, around some ``zero`` (like
``nil`` in the notation for lists).
|*)

Definition zero := 0. (* .none *)
Notation "[ d1 , .. , d2 ]" :=
  (addition (multiply .. (addition (multiply zero ten) d1) .. ten) d2).

(*|
If you don't wish to introduce a zero, you can require at least two
digits inside the brackets (instead of just one as above), and use
that as the terminating expression. This is like the notation for
pairs (in ``Init/Notations.v``, also presented in the manual). You
could complement this with a notation for ``[d0]`` with lower
priority, but as this is just ``d0`` there isn't much point.
|*)

Notation "[ d0 , d1 , .. , d2 ]" :=
  (addition (multiply .. (addition (multiply d0 ten) d1) .. ten) d2).


Require Import IFOL.Syntax.Signature.
Require Import IFOL.Syntax.Theory.

Require Import IFOL.Semantics.Signature.
Require Import IFOL.Semantics.Formula.

Definition theory_dom {S} (eval_S : sort_dom S) (sg : sig S)
  (eval_sig : sig_dom eval_S sg) (th : Theory sg) : Type :=
  forall i : carrier sg th, eval_Formula eval_S sg eval_sig nil tt
    (formula sg th i).


Require Import String List.
Require Import ExtLib.Data.HList.

Set Implicit Arguments.
Set Strict Implicit.

Inductive data T : (T -> Type) -> Type :=
| Inj   : forall X, Type -> data X
| Get   : forall X, T -> data X
| Prod  : forall X, data X -> data X -> data X
| Sigma : forall X (S : Type), (S -> data X) -> data X
| Pi    : forall X (S : Type), (S -> data X) -> data X.

Fixpoint dataD (T : Type) (X : T -> Type) (d : data X) : Type :=
  match d with
    | Inj _X x => x
    | Get X i => X i
    | Prod l r => prod (dataD l) (dataD r)
    | @Sigma _ _ i s => @sigT i (fun v => dataD (s v))
    | @Pi _ _ i s => forall v : i, dataD (s v)
  end.

(** Example of lists as data **)
Definition dataList (a : Type) : @data unit (fun _ => list a) :=
  @Sigma _ _ bool (fun x => match x with
                              | true => @Inj _ _ unit
                              | false => @Prod _ _ (Inj _ a) (Get _ tt)
                            end).

Theorem dataList_to_list : forall T (x : dataD (dataList T)), list T.
  simpl. intros.
  destruct x. destruct x.
  apply nil.
  simpl in *.
  apply (fst d :: snd d).
Defined.

Theorem list_to_dataList : forall T (ls : list T), dataD (dataList T).
  simpl. destruct 1.
  exists true. apply tt.
  exists false. apply (t, ls).
Defined.

Fixpoint dataP (T : Type) (X : T -> Type) (d : data X) (R : Type) : Type :=
  match d with
    | Inj _X x => x -> R
    | Get X x => X x -> R
    | @Prod _ _ l r => dataP l (dataP r R)
    | @Sigma _ _ i s => forall i, dataP (s i) R
    | @Pi _ _ i s => (forall i, dataD (s i)) -> R
  end.

Fixpoint dataMatch (T : Type) (X : T -> Type) (d : data X) {struct d}
  : forall (R : Type), dataP d R -> dataD d -> R :=
    match d as d return forall (R : Type), dataP d R -> dataD d -> R with
      | Inj _ _ => fun _ p => p
      | Get X x => fun _ p => p
      | @Prod _ _ l r => fun _ p v =>
        dataMatch r _ (dataMatch l _ p (fst v)) (snd v)
      | @Sigma _ _ i d => fun _ p v =>
        match v with
        | existT _ x y => dataMatch (d x) _ (p _) y
        end
      | @Pi _ _ i d => fun _ p v => p v
    end.

(* This used to work
(** You really need a fold! **)
Fixpoint dataLength {x} (l : list x) Z {struct l} : nat :=
  dataMatch (dataList x) _ (fun tag => match tag with
                                       | true => fun _ => 0
                                       | false => fun h t => S (Z t) (* (dataLength t) *)
                                       end) (list_to_dataList l).
*)


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import finfun bigop prime binomial ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import Reals_ext ssr_ext ssralg_ext log2 ln_facts Rssr Rbigop arg_rmax.
Require Import num_occ proba entropy types jtypes divergence conditional_divergence.
Require Import error_exponent channel_code channel success_decode_bound.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope channel_code_scope.
Local Open Scope channel_scope.
Local Open Scope entropy_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope reals_ext_scope.
Local Open Scope proba_scope.
Local Open Scope types_scope.

Section channel_coding_converse_intermediate_lemma.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable cap : R.
Hypothesis Hc : capacity W cap.

Variable minRate : R.
Hypothesis HminRate : minRate > cap.

Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof.
case/card_gt0P : Anot0 => a _; exact (dist_support_not_empty (W a)).
Qed.

Lemma channel_coding_converse_gen : exists Delta, 0 < Delta /\ forall n',
  let n := n'.+1 in forall (M : finType) (c : code A B M n), (0 < #|M|)%nat ->
    minRate <= CodeRate c ->
      scha(W, c) <= INR (n.+1)^(#|A| + #|A| * #|B|) * exp2 (- INR n * Delta).
Proof.
move: error_exponent_bound => /(_ _ _ Bnot0 W _ Hc _ HminRate); case => Delta [Delta_pos HDelta].
exists Delta; split => // n' n M c Mnot0 H.
apply (Rle_trans _ _ _ (success_bound W Mnot0 c)).
set Pmax := arg_rmax _ _ _.
set tc :=  _.-typed_code _.
rewrite pow_add -mulRA.
apply Rmult_le_compat_l; first by apply pow_le, pos_INR.
apply (Rle_trans _ _ _ (typed_success_bound W Mnot0 (Pmax.-typed_code c))).
apply Rmult_le_compat_l; first by apply pow_le, pos_INR.
set Vmax := arg_rmax _ _ _.
rewrite /success_factor_bound /exp_cdiv.
case : ifP => Hcase; last first.
  rewrite mul0R; by apply Rlt_le, exp2_pos.
rewrite -exp2_plus.
apply exp2_le_increasing.
rewrite -mulRDr 2!Ropp_mult_distr_l_reverse.
apply Ropp_le_contravar, Rmult_le_compat_l; first by apply pos_INR.
have {Hcase}Hcase : Vmax << W | Pmax.
  move=> a Hp b /eqP Hw.
  move/forallP : Hcase.
  by move/(_ a)/implyP/(_ Hp)/forallP/(_ b)/implyP/(_ Hw)/eqP.
apply (Rle_trans _ _ _ (HDelta Pmax Vmax Hcase)) => /=.
by apply Rplus_le_compat_l, Rle_max_compat_l, Rplus_le_compat_r.
Qed.

End channel_coding_converse_intermediate_lemma.

Section channel_coding_converse.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable cap : R.
Hypothesis w_cap : capacity W cap.

Variable epsilon : R.
Hypothesis eps_gt0 : 0 < epsilon.

Variable minRate : R.
Hypothesis minRate_cap : minRate > cap.

(** * Converse of the Channel Coding Theorem #<a name="label_channel_coding_converse"> </a># *)

Theorem channel_coding_converse : exists n0,
  forall n M (c : code A B M n),
    (0 < #|M|)%nat -> n0 < INR n -> minRate <= CodeRate c -> scha(W, c) < epsilon.
Proof.
case: (channel_coding_converse_gen w_cap minRate_cap) => Delta [Delta_pos HDelta].
pose K := (#|A| + #|A| * #|B|)%nat.
pose n0 := 2 ^ K * INR K.+1`! / ((Delta * ln 2) ^ K.+1) / epsilon.
exists n0 => n M c HM n0_n HminRate.
have Rlt0n : 0 < INR n.
  apply: (Rlt_trans _ _ _ _ n0_n).
  rewrite /n0.
  apply Rmult_lt_0_compat; last by apply Rinv_0_lt_compat.
  rewrite /Rdiv -mulRA.
  apply Rmult_lt_0_compat; first by apply pow_gt0; fourier.
  apply Rmult_lt_0_compat; first by apply lt_0_INR; apply /ltP; apply fact_gt0.
  apply Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
destruct n as [|n'].
  by apply Rlt_irrefl in Rlt0n.
set n := n'.+1.
apply (Rle_lt_trans _ (INR n.+1 ^ K * exp2 (- INR n * Delta))).
  by apply HDelta.
move: (n0_n) => /(Rmult_lt_compat_l (/ INR n) _) => /(_ (Rinv_0_lt_compat (INR n) Rlt0n)).
rewrite Rinv_l; last by apply not_eq_sym, Rlt_not_eq.
move/(Rmult_lt_compat_l epsilon _) => /(_ eps_gt0); rewrite mulR1 => H1'.
apply: (Rle_lt_trans _ _ _ _ H1') => {H1'}.
rewrite /n0 [in X in _ <= X]mulRC -2![in X in _ <= X]mulRA.
rewrite Rinv_l; last by apply not_eq_sym, Rlt_not_eq.
rewrite mulR1.
apply Rge_le; rewrite mulRC -2!mulRA; apply Rle_ge.
set aux := INR _ * (_ * _).
have aux_gt0 : 0 < aux.
  apply Rmult_lt_0_compat.
    apply lt_0_INR; apply/ltP; by apply fact_gt0.
  apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
  by apply Rinv_0_lt_compat.
apply (Rle_trans _ ((INR n.+1 / INR n) ^ K * aux)); last first.
  apply Rmult_le_compat => //.
  - apply pow_ge0, Rle_mult_inv_pos => //; by apply pos_INR.
  - by apply Rlt_le.
  - apply pow_incr; split.
    + apply Rle_mult_inv_pos => //; by apply pos_INR.
    + apply Rmult_le_reg_r with (INR n) => //.
      rewrite /Rdiv -mulRA -Rinv_l_sym; last by apply not_eq_sym, Rlt_not_eq.
      rewrite mulR1 (_ : 2 = INR 2) // -mult_INR; apply le_INR.
      rewrite (_ : 0 = INR 0) // in Rlt0n.
      apply INR_lt in Rlt0n.
      rewrite multE mul2n -addnn -addn1.
      apply/leP.
      by rewrite leq_add2l.
  - by apply Rle_refl.
rewrite pow_mult -mulRA.
apply Rmult_le_compat.
- apply pow_ge0, Rlt_le, lt_0_INR; by apply/ltP.
- by apply Rlt_le, exp2_pos.
- by apply Rle_refl.
- apply Rle_inv_conv.
  + by apply exp2_pos.
  + apply Rmult_lt_0_compat; last by exact aux_gt0.
    rewrite pow_inv; last by apply not_eq_sym, Rlt_not_eq.
    by apply Rinv_0_lt_compat, pow_gt0.
  + rewrite -exp2_Ropp Ropp_mult_distr_l_reverse Ropp_involutive /exp2.
    have nDeltaln2 : 0 <= INR n * Delta * ln 2.
      apply Rmult_le_pos; last by apply Rlt_le, ln_2_pos.
      apply Rmult_le_pos; last by apply Rlt_le.
      by apply pos_INR.
    apply: (Rle_trans _ _ _ _ (exp_lb (K.+1) nDeltaln2)) => {nDeltaln2}.
    apply Req_le.
    rewrite Rinv_mult_distr; last 2 first.
      by apply not_eq_sym, Rlt_not_eq, pow_gt0, Rinv_0_lt_compat.
      by apply not_eq_sym, Rlt_not_eq.
    rewrite mulRC Rinv_mult_distr; last 2 first.
      apply not_eq_sym, Rlt_not_eq, lt_0_INR; apply/ltP; by apply fact_gt0.
      apply not_eq_sym, Rlt_not_eq, Rmult_lt_0_compat.
        apply Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
      by apply Rinv_0_lt_compat.
    rewrite -mulRA mulRC.
    rewrite Rinv_mult_distr; last 2 first.
    - apply not_eq_sym, Rlt_not_eq, Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
    - by apply not_eq_sym, Rlt_not_eq, Rinv_0_lt_compat.
    - rewrite Rinv_involutive ; last first.
        apply not_eq_sym, Rlt_not_eq, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
      rewrite Rinv_involutive; last by apply not_eq_sym, Rlt_not_eq.
      rewrite (_ : / (/ INR n) ^ K = (INR n) ^ K); last first.
        rewrite -pow_inv; last first.
          by apply Rinv_neq_0_compat, not_eq_sym, Rlt_not_eq.
        rewrite Rinv_involutive //.
        by apply not_eq_sym, Rlt_not_eq.
      rewrite /Rdiv; f_equal.
      rewrite !Rpow_mult_distr -(tech_pow_Rmult (INR n)).
      field.
Qed.

End channel_coding_converse.

Check channel_coding_converse.


(*** Coq coding by choukh, Aug 2022 ***)

Require Import Lib.
From Category.Instance Require Import Poset Ens Sets Zero One.
From Category.Algebra Require Import Monoid.
From Category.Construction Require Import Opposite.

(** 3 Important Kinds Of Categories **)
Section Ch3.

(** 3.1 Preorders **)
Import Relation_Definitions RelationClasses.

(* preorder *)
Check (@Proset : ∀ A (R : relation A), PreOrder R → Category).

(* partial order *)
Check (@Poset : ∀ C (R : relation obj[C]), PreOrder R → Asymmetric R → Category).

(** 3.2 The Category Of Sets **)

(* cat of setoids *)
Check (Sets : Category).

(* cat of coq types *)
Check (Coq : Category).

(** 3.4 The Category Of Graphs **)

(* Directed multigraphs with loops *)
(* kind of like 'categories' without id and comp. *)
Record Graph := {
  vertex :> Type;
  edge : Type;
  endpoint : bool → edge → vertex;
  source := endpoint true;
  target := endpoint false
}.
Arguments source {_}.
Arguments target {_}.

Record Graph_Morph (A B : Graph) := {
  αᵥ :> A → B;
  αₑ : edge A → edge B;
  source_morph e : source (αₑ e) = αᵥ (source e);
  target_morph e : target (αₑ e) = αᵥ (target e)
}.

Global Instance Graph_Morph_Setoid {A B} : Setoid (Graph_Morph A B).
Proof. construct.
  - intros F G. exact ((∀ x, F x = G x) ∧ ∀ e, F.(αₑ) e = G.(αₑ) e).
  - firstorder congruence.
Defined.

Import Setoid Category.

Program Definition Gph : Category := {|
  obj := Graph;
  hom := Graph_Morph;
  homset := @Graph_Morph_Setoid;
  id X := {| αᵥ x := x |};
  compose X Y Z f g := {| αᵥ := Basics.compose f g |};
|}.
Next Obligation. destruct f, g; auto. Defined.
Next Obligation. destruct f, g; simpl; congruence. Defined.
Next Obligation. destruct f, g; simpl; congruence. Defined.
Next Obligation.
  proper. congruence.
  destruct x0, y0, x1, y1. simpl in *. congruence.
Defined.
Next Obligation. destruct f; auto. Defined.
Next Obligation. destruct f; auto. Defined.
Next Obligation. destruct f, g, h; auto. Defined.
Next Obligation. destruct f, g, h; auto. Defined.

(** 3.5 Monoids **)

(* empty cat *)
Check (_0 : Category).

(* one object one arrow cat *)
Check (_1 : Category).

(* one object many arrows cat *)

Variable A : Type.
Hypothesis setoid_A : Setoid A.
Hypothesis monoid_A : @Monoid A setoid_A.

Definition monoid : Category := {|
  obj := unit;
  hom _ _ := A;
  homset _ _ := setoid_A;
  id _ := mempty;
  compose _ _ _ := mappend;
  compose_respects _ _ _ := mappend_respects;
  id_left _ _ := mempty_left;
  id_right _ _ := mempty_right;
  comp_assoc _ _ _ _ f g h := symmetry (mon_assoc f g h);
  comp_assoc_sym _ _ _ _ := mon_assoc;
|}.

(** 3.6 Duality **)

Check (Opposite : Category → Category).

(* opposite involution *)
Check (@op_invol : ∀ C : Category, C^op^op = C).

End Ch3.


From stdpp Require Import base gmultiset fin_sets.
From Coq Require Import ssreflect.

(* 공집합이 아닌 집합은 크기가 0보다 크다는 보조정리  *)
Lemma non_empty_pos (X : gmultiset nat) n :
  n ∈ X → size X > 0.
Proof.
  intros. assert (size X ≠ 0); [|lia].
  apply gmultiset_size_non_empty_iff. multiset_solver.
Qed.

Lemma gm_size_singleton_inv (X : gmultiset nat) n m :
  size X = 1 →
  n ∈ X → m ∈ X  →
  n = m.
Proof.
  intros HX n_in m_in.
  apply (gmultiset_disj_union_difference' m),(f_equal size) in m_in.
  rewrite HX gmultiset_size_disj_union gmultiset_size_singleton in m_in.
  assert (X ∖ {[+ m +]} = ∅) as Hm_empty.
  { apply gmultiset_size_empty_iff. lia. }
  assert (X = {[+ m +]}) as -> by multiset_solver.
  by apply gmultiset_elem_of_singleton.
Qed.

Lemma one_gmultiset_not_empty (X : gmultiset nat) n :
  size X > 1 → n ∈ X → X ∖ {[+ n +]} ≠ ∅.
Proof.
  intros.
  rewrite -gmultiset_size_empty_iff gmultiset_size_difference; [multiset_solver|].
  rewrite gmultiset_size_singleton. lia.
Qed.

Lemma apply_induction (P : gmultiset nat) p s P' :
  (∀ (m n : nat) (P : gmultiset nat),
    P ≠ ∅ → m ∈ P → n ∈ P → s = size P → n = m) →
  s > 0 →
  S s = size P →
  p ∈ P →
  P' = P ∖ {[+ p +]} →
  ∃ m, ∀ (n : nat), n ∈ P' → n = m.
Proof.
  intros IHs' ?? p_in HP'.
  assert (s = size P').
  { apply (f_equal size) in HP'. rewrite gmultiset_size_difference in HP'; [multiset_solver|].
    rewrite gmultiset_size_singleton in HP'. lia.
  }
  destruct (gmultiset_choose P') as [m m_in].
  { apply gmultiset_size_non_empty_iff. lia. }
  exists m. intros n n_in. apply (IHs' m n P'); [multiset_solver|done..].
Qed.

Lemma fake_set_eq (P : gmultiset nat) n :
    P ≠ ∅ → ∃ m, n ∈ P → n = m.
Proof.
  intros NotEmpty.
  destruct (gmultiset_choose P) as [m m_in]; [done|].
  exists m.
  (* n ∈ X라는 사실과 귀납변수가 될 집합의 크기 m을 소개. *)
  intro n_in. remember (size P) as N eqn:HN.
  (* 보조정리로 크기가 0보다 크다는 사실을 암. *)
  assert (N > 0) as N_pos by (subst N; by apply (non_empty_pos P n)).
  (* 올바른 induction hypothesis을 얻기 위한 작업. *)
  generalize dependent P. generalize dependent n. generalize dependent m.
  (* 귀납 시작. *)
  induction N as [|N' IHN'].
  - (* Base Case. Vacuously true. *)
    inversion N_pos.
  - (* Inductive Case. *)
    (* 우선 N = 1일때를 해결하자. *)
    destruct (decide (N' = 0)) as [->|Gt]; intros m n P NotEmpy m_in n_in HN'.
    { apply (gm_size_singleton_inv P n m); [lia|done..]. }
    (* 그럼 N > 1이다. *)
    assert (N' > 0) as Pos by lia;
    specialize (IHN' Pos). clear Pos N_pos.

    (* 우선 p1을 얻기 위해 공집합이 아님을 보임 *)
    assert (P ≠ ∅) as NotEmpty.
    { (* 자명함. *) multiset_solver. }
    (* p1 얻기 성공! *)
    apply gmultiset_choose in NotEmpty;
    destruct NotEmpty as [p1 p1_in].
    (* [P ∖ {[+ p1 +]}]에 대해 IHs' 적용. *)
    remember (P ∖ {[+ p1 +]}) as P1 eqn:HP1.
    assert (∃ m1, ∀ (n1 : nat), n1 ∈ P1 → n1 = m1) as P1_all_same.
    { apply (apply_induction P p1 N'); auto with lia. }

    (* 이제 다른 원소 p2를 얻어야함 *)
    assert (P ∖ {[+ p1 +]} ≠ ∅) as NotEmpty.
    { (* 크기가 1보다 크니 자명함. *) apply (one_gmultiset_not_empty P p1); [lia|done]. }
    (* p2 얻기 성공! *)
    apply gmultiset_choose in NotEmpty;
    destruct NotEmpty as [p2 p2_in].

    (* [P ∖ {[+ p2 +]}]에 대해 IHs' 적용. *)
    remember (P ∖ {[+ p2 +]}) as P2 eqn:HP2.
    assert (∃ m2, ∀ (n2 : nat), n2 ∈ P2 → n2 = m2) as P2_all_same.
    { apply (apply_induction P p2 N'); auto with lia. multiset_solver. }

    (* 교집합에서 원소가 있음을 보이기 위해, 교집합이 공집합이 아님을 증명해보자... *)
    assert (P1 ∩ P2 ≠ ∅) as NonEmpty.
    { subst.
      (* 여태까지와 같이 크기를 사용하자. *)
      apply gmultiset_size_non_empty_iff.
      (* 크기가... 0일수가 있네...? *)
      admit.
    }
Abort.


(* This file defines nat_cast, an alternative to eq_rect which works only for type nat instead
   of any type A.
   The motivation behind nat_cast is that it only matches on proofs in contradictory cases,
   so functions using nat_cast can always be run inside Coq using cbv, whereas function using
   eq_rect cannot. *)

Arguments id {A} x.

(* Transport equality, only matching on eq_refl in contradictory cases, to make sure
   terms using this function reduce *)
Fixpoint nat_cast (P : nat -> Type) {n m} : n = m -> P n -> P m.
  refine match n, m return n = m -> P n -> P m with
         | O, O => fun _ => id
         | S n, S m => fun pf => @nat_cast (fun n => P (S n)) n m (f_equal pred pf)
         | _, _ => fun pf => match _ pf : False with end
         end;
    clear; abstract congruence.
Defined. (* thx Jason *)

Lemma nat_cast_eq_rect: forall (P : nat -> Type),
  forall (n m : nat)  (e: n = m) (pn: P n),
  nat_cast P e pn = eq_rect n P pn m e.
Proof.
  destruct e.
  revert dependent P; induction n; simpl; intros.
  - reflexivity.
  - rewrite IHn. reflexivity.
Qed. (* thx Clement *)

Lemma nat_cast_proof_irrel: forall (P : nat -> Type),
  forall (n m : nat)  (e1 e2: n = m) (pn: P n),
  nat_cast P e1 pn = nat_cast P e2 pn.
Proof.
  destruct e1.
  revert dependent P; induction n; simpl; intros.
  - reflexivity.
  - erewrite IHn. reflexivity.
Qed.

Lemma nat_cast_same: forall (P: nat -> Type) (s: nat) (n: P s),
  nat_cast P eq_refl n = n.
Proof.
  intros. rewrite nat_cast_eq_rect. reflexivity.
Qed.

Lemma nat_cast_fuse: forall (P: nat -> Type) (n1 n2 n3: nat) (e12: n1 = n2) (e23: n2 = n3) (x: P n1),
  nat_cast P e23 (nat_cast P e12 x) = nat_cast P (eq_trans e12 e23) x.
Proof.
  destruct e12.
  destruct e23.
  intros.
  rewrite nat_cast_same.
  reflexivity.
Qed.

Lemma nat_cast_cast ni no (pf: ni = no) (P: nat -> Type) (x : P ni):
  nat_cast P pf x = match pf in _ = Y return P Y with
                    | eq_refl => x
                    end.
Proof.
  destruct pf.
  rewrite nat_cast_same.
  auto.
Qed.