Require Import Bool Arith Omega List Coq.Program.Equality.
Require Import Maps Imp.
Require Import Sequences Semantics.
Require Import List.
Import ListNotations.
Require Import Machine MachineStackLimited.
Require Import LanguageModel TraceModel ChainModel.
Require Import TraceCriterion.
Require Import Compiler.
Require Import Stream.
Require Import ClassicalExtras.
Require Import ResourceExhaustion.
Require Import Logic.Classical.
Require Import Logic.IndefiniteDescription.

Set Bullet Behavior "Strict Subproofs".

(** * 3. Semantic preservation *)

(** ** Correctness of generated code for expressions. *)

(** Remember the informal specification we gave for the code generated
  for an arithmetic expression [a].  It should
- execute in sequence (no branches)
- deposit the value of [a] at the top of the stack
- preserve the variable state.

We now prove that the code [compile_aexp a] fulfills this contract.
The proof is a nice induction on the structure of [a]. *)
Ltac choose_side stk :=
  destruct (stack_limit <=? length stk) eqn:Hstk;
  [right; rewrite Nat.leb_le in Hstk
  | left; rewrite leb_iff_conv in Hstk].

Ltac compile_aexp_correct_simpl_t trans_thm :=
  apply star_one;
  econstructor; last eassumption;
  apply trans_thm; eauto with codeseq.

Ltac compile_aexp_correct_compl_t IHa2' trans_thm :=
  eapply starans; first eauto;
  replace [] with ([] ++ [] : list nat); last reflexivity;
  eapply starans;
  [eapply IHa2' |
   apply star_one; normalize; econstructor;
   [apply trans_thm; eauto with codeseq | eassumption]].

Lemma compile_aexp_correct:
  forall C st a pc stk,
    codeseq_at C pc (compile_aexp a) ->
    star (transition_limited C)
            (Some (pc, stk, st)) nil
            (Some (pc + length (compile_aexp a), aeval st a :: stk, st)) \/
      star (transition_limited C) (Some (pc, stk, st)) nil None.
Proof.
  intros C st a.
  (* rewrite <- Nat.leb_le. *)
  (* destruct (stack_limit <=? length stk) eqn:Hlt. *)
  (* now left. *)
  (* right. *)
  (* rewrite leb_iff_conv in Hlt. *)
  (* revert pc stk H Hlt. *)
  induction a; simpl; intros.
  - (* ANum *)
    choose_side (n :: stk);
      compile_aexp_correct_simpl_t trans_const.
  - (* AId *)
    choose_side (st i :: stk);
      compile_aexp_correct_simpl_t trans_var.
  - (* APlus *)
    replace ([] : list nat) with ([] ++ []: list nat); last reflexivity.
    replace (aeval st a1 + aeval st a2 :: stk) with ([aeval st a1 + aeval st a2] ++ stk); last reflexivity.
    edestruct IHa1 as [IHa1' | IHstk1]; edestruct IHa2 as [IHa2' | IHstk2]; eauto with codeseq.
    + choose_side ([aeval st a1 + aeval st a2] ++ stk).
      * compile_aexp_correct_compl_t IHa2' trans_add.
      * compile_aexp_correct_compl_t IHa2' trans_add.
    + right. eapply starans. eauto.
      assumption.
  - (* AMinus *)
    replace ([] : list nat) with ([] ++ []: list nat); last reflexivity.
    replace (aeval st a1 + aeval st a2 :: stk) with ([aeval st a1 + aeval st a2] ++ stk); last reflexivity.
    edestruct IHa1 as [IHa1' | IHstk1]; edestruct IHa2 as [IHa2' | IHstk2]; eauto with codeseq.
    + choose_side ([aeval st a1 + aeval st a2] ++ stk).
      * compile_aexp_correct_compl_t IHa2' trans_sub.
      * compile_aexp_correct_compl_t IHa2' trans_sub.
    + right. eapply starans. eauto.
      assumption.
  - (* APlus *)
    replace ([] : list nat) with ([] ++ []: list nat); last reflexivity.
    replace (aeval st a1 + aeval st a2 :: stk) with ([aeval st a1 + aeval st a2] ++ stk); last reflexivity.
    edestruct IHa1 as [IHa1' | IHstk1]; edestruct IHa2 as [IHa2' | IHstk2]; eauto with codeseq.
    + choose_side ([aeval st a1 + aeval st a2] ++ stk).
      * compile_aexp_correct_compl_t IHa2' trans_mul.
      * compile_aexp_correct_compl_t IHa2' trans_mul.
    + right. eapply starans. eauto.
      assumption.
      Unshelve.
      all: exact stk.
Qed.

(** Here is a similar proof for the compilation of boolean expressions. *)
Ltac compile_bexp_correct_simpl_t trans_thm ofs :=
  apply star_one;
  econstructor; last eassumption;
  apply trans_thm with ofs; eauto with codeseq.

Ltac compile_bexp_correct_compl_t st a a0 ofs trans_thm:=
  destruct (beq_nat (aeval st a) (aeval st a0)) eqn:Heq;
          simpl;
          (replace [] with ([] ++ [] : list nat); last reflexivity);
          eapply starans; eauto with codeseq;
            (replace [] with ([] ++ [] : list nat); last reflexivity);
            eapply starans; eauto with codeseq;
              apply star_one;
              econstructor; eauto;
                [eapply trans_thm with ofs | eapply trans_thm with ofs];
                eauto with codeseq.

Lemma compile_bexp_correct:
  forall C st b cond ofs pc stk,
  codeseq_at C pc (compile_bexp b cond ofs) ->
  star (transition_limited C)
          (Some (pc, stk, st)) nil
          (Some (pc + length (compile_bexp b cond ofs) + if eqb (beval st b) cond then ofs else 0, stk, st)) \/
  star (transition_limited C)
          (Some (pc, stk, st)) nil
          None.
Proof.
  induction b; simpl; intros.
  - (* BTrue *)
    destruct cond; simpl;
      [| left; repeat rewrite plus_0_r; apply star_refl].
    destruct (stack_limit <=? length stk) eqn:Hstk;
      [ rewrite Nat.leb_le in Hstk
      | rewrite leb_iff_conv in Hstk].
    + right. compile_bexp_correct_simpl_t trans_branch_forward ofs.
    + left. compile_bexp_correct_simpl_t trans_branch_forward ofs.
  - (* BFalse *)
    destruct cond; simpl;
      [left; repeat rewrite plus_0_r; apply star_refl|].
    destruct (stack_limit <=? length stk) eqn:Hstk;
      [ rewrite Nat.leb_le in Hstk
      | rewrite leb_iff_conv in Hstk].
    + right. compile_bexp_correct_simpl_t trans_branch_forward ofs.
    + left. compile_bexp_correct_simpl_t trans_branch_forward ofs.
  - (* BEq *)
    edestruct compile_aexp_correct with (a := a); first eauto with codeseq;
      edestruct compile_aexp_correct with (a := a0); first eauto with codeseq;
        (destruct (stack_limit <=? length stk) eqn:Hstk;
        [ rewrite Nat.leb_le in Hstk
        | rewrite leb_iff_conv in Hstk]);
        try (right;
             replace [] with ([] ++ [] : list nat); last reflexivity;
             eapply starans; now eauto);
        eauto with codeseq.
    + destruct cond; right;
        [ compile_bexp_correct_compl_t st a a0 ofs trans_beq
        | compile_bexp_correct_compl_t st a a0 ofs trans_bne].
    + destruct cond; left;
        try (compile_bexp_correct_compl_t st a a0 ofs trans_beq; normalize; rewrite Heq; omega);
        try (compile_bexp_correct_compl_t st a a0 ofs trans_bne; normalize; rewrite Heq; omega).
  - (* BLe *)
    edestruct compile_aexp_correct with (a := a); first eauto with codeseq;
      edestruct compile_aexp_correct with (a := a0); first eauto with codeseq;
        (destruct (stack_limit <=? length stk) eqn:Hstk;
        [ rewrite Nat.leb_le in Hstk
        | rewrite leb_iff_conv in Hstk]);
        try (right;
             replace [] with ([] ++ [] : list nat); last reflexivity;
             eapply starans; now eauto);
        eauto with codeseq.
    + destruct cond; right;
        [ compile_bexp_correct_compl_t st a a0 ofs trans_ble
        | compile_bexp_correct_compl_t st a a0 ofs trans_bgt].
    + destruct cond; left;
        try (compile_bexp_correct_compl_t st a a0 ofs trans_ble; normalize; rewrite Heq; omega);
        try (compile_bexp_correct_compl_t st a a0 ofs trans_bgt; normalize; rewrite Heq; omega).
      try (destruct (aeval st a <=? aeval st a0) eqn:Hle; eauto;
           compile_bexp_correct_compl_t st a a0 ofs trans_ble; normalize; rewrite Hle; omega).
      try (destruct (aeval st a <=? aeval st a0) eqn:Hle; eauto;
           compile_bexp_correct_compl_t st a a0 ofs trans_bgt; normalize; rewrite Hle; omega).
      (* very ugly *)
  - (* BNot *)
    replace (eqb (negb (beval st b)) cond)
    with (eqb (beval st b) (negb cond)).
    apply IHb; auto.
    destruct (beval st b); destruct cond; auto.

  - (*BAnd *)
    replace ([] : list nat) with ([] ++ []: list nat); last reflexivity.
    edestruct IHb1 as [IHb1' | IHstk1]; edestruct IHb2 as [IHb2' | IHstk2]; eauto with codeseq;
      (destruct (stack_limit <=? length stk) eqn:Hstk;
       [ rewrite Nat.leb_le in Hstk
       | rewrite leb_iff_conv in Hstk]).
    + destruct cond; left.
      * eapply starans; eauto;
          destruct (beval st b1); destruct (beval st b2); simpl in *;
            normalize; eauto;
              eapply star_refl.
      * destruct (beval st b1); destruct (beval st b2); simpl in *;
          normalize; eauto;
        (replace [] with ([] ++ [] : list nat); last reflexivity);
        eapply starans; eauto;
        rewrite <- plus_assoc; rewrite (plus_comm ofs); rewrite plus_assoc;
          apply star_refl.
    + destruct cond; left.
      * eapply starans; eauto;
          destruct (beval st b1); destruct (beval st b2); simpl in *;
            normalize; eauto;
              eapply star_refl.
      * destruct (beval st b1); destruct (beval st b2); simpl in *;
          normalize; eauto;
        (replace [] with ([] ++ [] : list nat); last reflexivity);
        eapply starans; eauto;
        rewrite <- plus_assoc; rewrite (plus_comm ofs); rewrite plus_assoc;
          apply star_refl.
    + set (code_b2 := compile_bexp b2 cond ofs) in *.
      set (ofs' := if cond then length code_b2 else ofs + length code_b2) in *.
      set (code_b1 := compile_bexp b1 false ofs').
      destruct cond, (beval st b1), (beval st b2);
        try (now right; eapply starans; eauto; simpl; rewrite plus_0_r; eauto);
        try (now left; normalize; eauto);
        try (now left; subst ofs'; normalize; rewrite <- plus_assoc; rewrite <- (plus_comm ofs); eauto).
    + set (code_b2 := compile_bexp b2 cond ofs) in *.
      set (ofs' := if cond then length code_b2 else ofs + length code_b2) in *.
      set (code_b1 := compile_bexp b1 false ofs').
      destruct cond, (beval st b1), (beval st b2);
        try (now right; eapply starans; eauto; simpl; rewrite plus_0_r; eauto);
        try (now left; normalize; eauto);
        try (now left; subst ofs'; normalize; rewrite <- plus_assoc; rewrite <- (plus_comm ofs); eauto).
      Unshelve.
      all: exact nil.
      Grab Existential Variables.
      all: eauto.
Qed.

(** ** Correctness of generated code for commands: terminating case. *)

Lemma compile_com_correct_terminating:
  forall C st c st' l,
  c / st \\ st' --> l ->
  forall stk pc,
  codeseq_at C pc (compile_com c) ->
  star (transition_limited C)
       (Some (pc, stk, st)) l
       (Some (pc + length (compile_com c), stk, st')) \/
  exists l', list_list_prefix l' l /\
  star (transition_limited C)
          (Some (pc, stk, st)) l'
          None.
Proof.
  induction 1; intros stk pc AT.

- (* SKIP *)
  simpl in *. rewrite plus_0_r. left. apply star_refl.

- (* := *)
  simpl in *. subst n.
  replace ([] : list nat) with ([] ++ []: list nat); try reflexivity.
  edestruct compile_aexp_correct; eauto with codeseq.
  + choose_side stk;
      [exists ([] ++ []); split; [now simpl |] |];
      eapply starans; try eassumption;
        eapply star_one;
        [eapply transition_OOM | eapply transition_some]; eauto;
          normalize; eapply trans_setvar; eauto with codeseq.
  + right.
    exists [].
    split; first now simpl.
    eassumption.

- (* sequence *)
  edestruct IHceval1; edestruct IHceval2;
    eauto with codeseq.
  + left.
    eapply starans; eauto.
    destruct c1; repeat (normalize; eauto).
  + right.
    destruct H2 as [l'0 [H3 H2]].
    exists (l ++ l'0); split; eauto.

    now apply list_list_prefix_app. (* trivial *)
    eapply starans; eauto.
  + right.
    destruct H1 as [l1' [H3 H1]].
    exists l1'. split; eauto.
    eapply list_list_prefix_trans. eauto.
    replace l with (l ++ []); last apply app_nil_r. rewrite <- app_assoc.
    now apply list_list_prefix_app.
  + destruct H1 as [l1' [H3 H1]].
    right.
    exists l1'. split; eauto.
    eapply list_list_prefix_trans; eauto.
    replace l with (l ++ []); last apply app_nil_r. rewrite <- app_assoc.
    now apply list_list_prefix_app.

- (* if true *)
  simpl in *.
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  replace l with ([] ++ l); last reflexivity.
  edestruct compile_bexp_correct with (b := b); edestruct IHceval;
    eauto with codeseq.
  + rewrite H in *;
      choose_side stk; [exists l; split; first (simpl; apply list_list_prefix_ref);
                          try replace l with ([] ++ l); last reflexivity |];
        eapply starans;
        try eassumption;
        simpl; fold codeb; normalize;
          replace l with (l ++ []); try apply app_nil_r;
            eapply starans; try eassumption;
              apply star_one;
              econstructor; try eassumption;
                eapply trans_branch_forward; eauto with codeseq; omega.
  + destruct H2 as [l' [Hpref Hstar]].
    right; exists l'; split; eauto.
    fold codeb in H1; rewrite H in *; normalize.
    replace l' with ([] ++ l'); last reflexivity.
    eapply starans; eauto.
  + right; exists []; split; now eauto.
  + right; exists []; split; now eauto.

- (* if false *)
  simpl in *.
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  replace l with ([] ++ l); last reflexivity.
  edestruct compile_bexp_correct with (b := b) (cond := false); edestruct IHceval;
    eauto with codeseq.
  + rewrite H in *;
     left;
     eapply starans;
     try eassumption;
     simpl; fold codeb; normalize;
       replace (pc + length codeb + length code1 + S(length code2))
         with (pc + length codeb + length code1 + 1 + length code2);
       eauto; omega.
  + destruct H2 as [l' [Hpref Hstar]].
    right; exists l'; split; eauto.
    fold codeb in H1; rewrite H in *; normalize.
    replace l' with ([] ++ l'); last reflexivity.
    eapply starans; normalize; eauto.
  + right; exists []; split; now eauto.
  + right; exists []; split; now eauto.

- (* while false *)
  simpl in *.
  replace ([] : list nat) with ([] ++ []: list nat); try reflexivity.
  edestruct compile_bexp_correct; eauto with codeseq.
  + left; eapply starans; eauto; rewrite H; simpl; normalize;
    apply star_refl.
  + right; exists []; now split.

- (* while true *)
  edestruct compile_bexp_correct; eauto with codeseq.
  + rewrite H in *; simpl in *.
    edestruct IHceval1; eauto with codeseq.
    * edestruct IHceval2; eauto with codeseq.
      -- choose_side stk.
         ++ exists (l ++ []). split; last first.
            eapply starans.
            replace l with ([] ++ l); try reflexivity.
            eapply starans; eauto.
            replace l with (l ++ []); last apply app_nil_r.
            rewrite plus_0_r.
            eapply starans. eauto.
            eapply star_one.
            econstructor. eapply trans_branch_backward.
            eauto with codeseq; omega. reflexivity. eauto. eapply star_refl.
            now apply list_list_prefix_app.
         ++ eapply starans.
            replace l with ([] ++ l); try reflexivity.
            eapply starans; eauto.
            replace l with (l ++ []); last apply app_nil_r.
            rewrite plus_0_r.
            eapply starans. eauto.
            eapply star_one.
            eapply transition_some.
            eapply trans_branch_backward.
            eauto with codeseq; omega. reflexivity. eauto.
            normalize.
            replace (pc +
                     length (compile_bexp b false (length (compile_com c) + 1)) + length (compile_com c) + 1 -
                     (length (compile_bexp b false (length (compile_com c) + 1)) + length (compile_com c) + 1))
              with pc; last omega.
            eauto.
      -- destruct H4 as [l'0 [Hpref Hstar]].
         destruct (stack_limit <=? length stk) eqn:Hstk;
           [rewrite Nat.leb_le in Hstk | rewrite leb_iff_conv in Hstk].
         ++ right.
            exists (l ++ []); split; first now apply list_list_prefix_app.
            eapply starans.
            replace l with ([] ++ l); try reflexivity.
            eapply starans; eauto.
            replace l with (l ++ []); last apply app_nil_r.
            rewrite plus_0_r.
            eapply starans. eauto.
            eapply star_one.
            econstructor.
            eapply trans_branch_backward.
            eauto with codeseq; omega. reflexivity. eauto.
            eapply star_refl.
         ++ right.
            exists (l ++ l'0); split; first now apply list_list_prefix_app.
            eapply starans.
            replace l with ([] ++ l); try reflexivity.
            eapply starans; eauto.
            replace l with (l ++ []); last apply app_nil_r.
            rewrite plus_0_r.
            eapply starans. eauto.
            eapply star_one.
            eapply transition_some.
            eapply trans_branch_backward.
            eauto with codeseq; omega. reflexivity. eauto.
            normalize.
            replace (pc +
                     length (compile_bexp b false (length (compile_com c) + 1)) + length (compile_com c) + 1 -
                     (length (compile_bexp b false (length (compile_com c) + 1)) + length (compile_com c) + 1))
              with pc; last omega.
            eauto.
    * destruct H3 as [l'0 [Hpref Hstar]].
      right; exists ([] ++ l'0); split.
      simpl. eapply list_list_prefix_trans; eauto.
      replace l with (l ++ []); last apply app_nil_r. rewrite <- app_assoc.
      now apply list_list_prefix_app.
      eapply starans. eauto. rewrite plus_0_r; eauto.
  + right; exists []; split; now eauto.

- (* output *)
  simpl in *. subst n.
  edestruct compile_aexp_correct; eauto with codeseq.
  + choose_side stk.
    * exists [].
      replace [] with ([] ++ [] : list nat); last reflexivity.
      split; first now auto.
      eapply starans. eauto.
      apply star_one.
      eapply transition_OOM; eauto.
      econstructor; eauto with codeseq.
    * replace [aeval st a] with ([] ++ [aeval st a]); last reflexivity.
      eapply starans; eauto.
      apply star_one.
      econstructor; eauto.
      normalize; eapply trans_out; eauto with codeseq.
  + right; eexists; split; now eauto.
    Unshelve.
    all: eauto.
Qed.

Theorem compile_program_correct_terminating:
  forall c st st' l,
  c / st \\ st' --> l ->
  mach_terminates (compile_program c) st st' l \/
  exists l', list_list_prefix l' l /\ mach_OOM (compile_program c) st l'.
Proof.
  intros. unfold compile_program.
  edestruct compile_com_correct_terminating with (pc := 0);
    eauto.
  eapply codeseq_at_intro with (C1 := nil); eauto.
  left. red.
    exists (length (compile_com c)); split.
    apply code_at_app. auto.
    eauto.
Qed.

(** ** Correctness of generated code for commands: general case. *)

(** We would like to strengthen the correctness result above so that it
  is not restricted to terminating source programs, but also applies to
  source program that diverge.  To this end, we abandon the big-step
  semantics for commands and switch to the small-step semantics with continuations.
  We then show a simulation theorem, establishing that every transition_limited
  of the small-step semantics in the source program is simulated (in a sense
  to be made precise below) by zero, one or several transition_limiteds of the
  machine executing the compiled code for the source program. *)

(** Our first task is to relate configuration_limiteds [(c, k, st)] of the small-step
  semantics with configuration_limiteds [(C, pc, stk, st)] of the machine.
  We already know how to relate a command [c] with the machine code,
  using the [codeseq_at] predicate.  What needs to be defined is a relation
  between the continuation [k] and the machine code.

  Intuitively, when the machine finishes executing the generated code for
  command [c], that is, when it reaches the program point
  [pc + length(compile_com c)], the machine should continue by executing
  instructions that perform the pending computations described by
  continuation [k], then reach an [Ihalt] instruction to stop cleanly.

  We formalize this intution by the following inductive predicate
  [compile_cont C k pc], which states that, starting at program point [pc],
  there are instructions that perform the computations described in [k]
  and reach an [Ihalt] instruction. *)

Inductive compile_cont (C: code): cont -> nat -> Prop :=
  | ccont_stop: forall pc,
      code_at C pc = Some Ihalt ->
      compile_cont C Kstop pc
  | ccont_seq: forall c k pc pc',
      codeseq_at C pc (compile_com c) ->
      pc' = pc + length (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (Kseq c k) pc
  | ccont_while: forall b c k pc ofs pc' pc'',
      code_at C pc = Some(Ibranch_backward ofs) ->
      pc' = pc + 1 - ofs ->
      codeseq_at C pc' (compile_com (WHILE b DO c END)) ->
      pc'' = pc' + length (compile_com (WHILE b DO c END)) ->
      compile_cont C k pc'' ->
      compile_cont C (Kwhile b c k) pc
  | ccont_branch: forall ofs k pc pc',
      code_at C pc = Some(Ibranch_forward ofs) ->
      pc' = pc + 1 + ofs ->
      compile_cont C k pc' ->
      compile_cont C k pc.

(** Then, a configuration_limited [(c,k,st)] of the small-step semantics matches
  a configuration_limited [(C, pc, stk, st')] of the machine if the following conditions hold:
- The memory states are identical: [st' = st].
- The machine stack is empty: [stk = nil].
- The machine code at point [pc] is the compiled code for [c]:
  [codeseq_at C pc (compile_com c)].
- The machine code at point [pc + length (compile_com c)] matches continuation
  [k], in the sense of [compile_cont] above.
*)

Inductive match_config_lim (C : code) : com * cont * state -> configuration_limited -> Prop :=
| match_config_lim_intro : forall c k st pc,
      codeseq_at C pc (compile_com c) ->
      compile_cont C k (pc + length (compile_com c)) ->
      match_config_lim C (c, k, st) (Some (pc, nil, st)).

(** Finding an appropriate "anti-stuttering" measure is a bit of a black art.
After trial and error, we find that the following measure works.  It is
the sum of the sizes of the command [c] under focus and all the commands
appearing in the continuation [k]. *)

(** A few technical lemmas to help with the simulation proof. *)

Lemma compile_cont_Kstop_inv:
  forall C pc m,
  compile_cont C Kstop pc ->
  exists pc',
    star (transition_limited C) (Some (pc, nil, m)) [] (Some (pc', nil, m))
  /\ code_at C pc' = Some Ihalt.
Proof.
  intros. dependent induction H.
- exists pc; split. apply star_refl. auto.
- destruct IHcompile_cont as [pc'' [A B]]; auto.
  exists pc''; split; auto.
  replace (star (transition_limited C) (Some (pc, [], m)) [] (Some (pc'', [], m)))
          with (star (transition_limited C) (Some (pc, [], m)) ([] ++ []) (Some (pc'', [], m))).
  eapply star_step; eauto. econstructor.  eapply trans_branch_forward; eauto.
  unfold stack_limit. simpl; omega.
  reflexivity.
Qed.

Lemma compile_cont_Kseq_inv:
  forall C c k pc m,
  compile_cont C (Kseq c k) pc ->
  exists pc',
    star (transition_limited C) (Some (pc, nil, m)) [] (Some (pc', nil, m))
  /\ codeseq_at C pc' (compile_com c)
  /\ compile_cont C k (pc' + length(compile_com c)).
Proof.
  intros. dependent induction H.
  exists pc; split. apply star_refl. split; congruence.
  destruct (IHcompile_cont _ _ eq_refl) as [pc'' [A [B D]]].
  exists pc''; split; auto.
  replace (star (transition_limited C) (Some (pc, [], m)) [] (Some (pc'', [], m)))
          with (star (transition_limited C) (Some (pc, [], m)) ([] ++ []) (Some (pc'', [], m))).
  eapply star_step; eauto.
  econstructor.
  eapply trans_branch_forward; eauto.
  unfold stack_limit; simpl; omega.
  reflexivity.
Qed.

Lemma compile_cont_Kwhile_inv:
  forall C b c k pc m,
  compile_cont C (Kwhile b c k) pc ->
  exists pc',
  plus (transition_limited C) (Some (pc, nil, m)) [] (Some (pc', nil, m))
  /\ codeseq_at C pc' (compile_com (WHILE b DO c END))
  /\ compile_cont C k (pc' + length(compile_com (WHILE b DO c END))).
Proof.
  intros. dependent induction H.
- exists (pc + 1 - ofs); split.
  apply plus_one. econstructor.
  eapply trans_branch_backward; eauto.
  unfold stack_limit; simpl; omega.
  split; congruence.
- destruct (IHcompile_cont _ _ _ (refl_equal _)) as [pc'' [A [B D]]].
  exists pc''; split; auto.
  replace (plus (transition_limited C) (Some (pc, [], m)) [] (Some (pc'', [], m))) with
      (plus (transition_limited C) (Some (pc, [], m)) ([] ++ []) (Some (pc'', [], m))).

  eapply plus_left. eapply transition_some. eapply trans_branch_forward; eauto.
  unfold stack_limit; simpl; omega.
  apply plus_star; eauto.
  reflexivity.
Qed.

Lemma match_config_lim_skip:
  forall C k m pc,
  compile_cont C k pc ->
  match_config_lim C (SKIP, k, m) (Some (pc, nil, m)).
Proof.
  intros C.
  assert (forall k pc, compile_cont C k pc -> codeseq_at C pc nil).
    induction 1.
    eapply code_at_codeseq; eauto.
    change (compile_com c) with (nil ++ compile_com c) in H. eauto with codeseq.
    eapply code_at_codeseq; eauto.
    eapply code_at_codeseq; eauto.
  intros. constructor. simpl. eauto. simpl. rewrite plus_0_r; auto.
Qed.

(** At long last, we can state and prove the right simulation diagram. *)

Lemma simulation_step:
  forall C impstate1 impstate2 machstate1 l,
  kstep impstate1 l impstate2 ->
  match_config_lim C impstate1 machstate1 ->
  exists machstate2 l',
      (plus (transition_limited C) machstate1 l' machstate2
       \/ (star (transition_limited C) machstate1 l' machstate2 /\ measure impstate2 < measure impstate1))
   /\ ((match_config_lim C impstate2 machstate2 /\ l = l') \/ (machstate2 = None /\ list_list_prefix l' l)).
Proof.
  intros until l; intros KSTEP MATCH.
  inversion KSTEP; clear KSTEP; subst; inversion MATCH; clear MATCH; subst; simpl in *.

- (* assign *)
  edestruct compile_aexp_correct; eauto with codeseq.
  + eexists; eexists; split. left.
    replace [] with ([] ++ [] : list nat); last reflexivity.
    eapply plus_right. eauto.
    eapply transition_some.
    eapply trans_setvar; eauto with codeseq.
    unfold stack_limit; simpl; omega.
    left; split; eauto.
    normalize. apply match_config_lim_skip. auto.
  + eexists; eexists; split. left.
    replace [] with ([] ++ [] : list nat); eauto.
    inversion H; subst.
    assert (l1 = []) by now induction l1. subst. simpl in *.
    econstructor; eauto; subst; eauto.
    now right.

- (* seq *)
  econstructor; eexists; split.
  right; split. apply star_refl. omega.
  normalize. left; split; auto. constructor. eauto with codeseq.
  eapply ccont_seq; eauto with codeseq.

- (* if true *)
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  edestruct compile_bexp_correct with (b := b) (cond := false) (ofs := length code1 + 1);
    eauto with codeseq.
  + eexists; eexists; split.
    right; split; eauto; omega.
    left. rewrite H; simpl; fold codeb; normalize.
    split; auto.
    constructor; eauto with codeseq.
    eapply ccont_branch; eauto with codeseq.
    change (S (length code2)) with (1 + length code2) in *; normalize; auto.
  + exists None; eexists. split.
    right; split; eauto; omega.
    now right.

- (* if false *)
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  edestruct compile_bexp_correct with (b := b) (cond := false) (ofs := length code1 + 1);
    eauto with codeseq.
  + eexists; eexists; split.
    right; split; eauto; omega.
    left; split; auto. rewrite H; simpl; fold codeb; normalize.
    constructor; eauto with codeseq.
    change (S (length code2)) with (1 + length code2) in H5; normalize; auto.
  + exists None; eexists. split.
    right; split; eauto; omega.
    now right.

- (* while true *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b false (length codec + 1)) in *.
  edestruct compile_bexp_correct with (b := b) (cond := false) (ofs := length codec + 1);
    eauto with codeseq.
  + eexists; eexists; split.
    right; split; eauto; omega.
    left. rewrite H; simpl; fold codeb; normalize.
    split; auto.
    constructor; eauto with codeseq.
    fold codec.
    assert (PC: pc + length codeb + length codec + 1 - (length codeb + length codec + 1) = pc)
      by omega.
    eapply ccont_while; eauto with codeseq. rewrite PC; auto.
    rewrite PC; simpl; normalize; auto.
  + exists None; eexists. split; eauto.
    right; split; eauto; omega.
    now right.

- (* while false *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b false (length codec + 1)) in *.
  edestruct compile_bexp_correct with (b := b) (cond := false) (ofs := length codec + 1);
    eauto with codeseq.
  + eexists; eexists; split.
    right; split.
    eauto.
    generalize (com_size_nonzero c). omega.
    rewrite H; simpl; fold codeb; normalize; left; split; auto; apply match_config_lim_skip; auto.
  + exists None; eexists; split.
    right; split; eauto.
    generalize (com_size_nonzero c). omega.
    now right.

- (* skip seq *)
  normalize.
  destruct (compile_cont_Kseq_inv _ _ _ _ st H4) as [pc' [X [Y Z]]].
  econstructor; eexists; split.
  right; split. eexact X. omega.
  left; split; auto; constructor; auto.

- (* skip while *)
  normalize.
  destruct (compile_cont_Kwhile_inv _ _ _ _ _ st H4) as [pc' [X [Y Z]]].
  econstructor; eexists; split.
  left. eexact X.
  left; split; auto; constructor; auto.

- (* out *)
  edestruct compile_aexp_correct; eauto with codeseq.
  + eexists; eexists; split. left.
    replace [aeval st a] with ([] ++ [aeval st a] : list nat); last reflexivity.
    eapply plus_right. eauto.
    eapply transition_some.
    eapply trans_out; eauto with codeseq.
    unfold stack_limit; simpl; omega.
    left.
    normalize. split; auto. apply match_config_lim_skip. auto.
  + eexists; eexists; split. left.
    replace [] with ([] ++ [] : list nat); eauto.
    inversion H; subst.
    assert (l1 = []) by now induction l1. subst. simpl in *; subst.
    econstructor; eauto; subst; eauto.
    now right.
Qed.

(** Simulation diagrams such as [simulation_step] above imply semantic preservation
  for terminating programs and for diverging programs.  We now develop a generic
  proof of this fact that we can reuse later for other program transformations. *)

Section SIMULATION_DIAGRAM.

(** The generic proof is parameterized over the small-step semantics for the
  source and target languages, and over an invariant between their states. *)

  Variable event : Type.

  Variable state1: Type.	     (**r the type of configuration_limiteds for the source language *)
  Variable step1: state1 -> list event -> state1 -> Prop.   (**r the small-step semantics for the source language *)

  Variable state2': Type.	     (**r the type of configuration_limiteds for the target language *)
  Definition state2 := option state2'.
Variable step2: state2 -> list event -> state2 -> Prop.   (**r the small-step semantics for the target language *)

Variable match_states: state1 -> state2 -> Prop.  (**r the invariant *)

Variable measure: state1 -> nat.                  (**r the anti-stuttering measure *)

(*

Lemma simulation_step:
  forall C impstate1 impstate2 machstate1 l,
  kstep impstate1 l impstate2 ->
  match_config_lim C impstate1 machstate1 ->
  exists machstate2 l',
      (plus (transition_limited C) machstate1 l' machstate2
       \/ (star (transition_limited C) machstate1 l' machstate2 /\ measure impstate2 < measure impstate1))
   /\ ((match_config_lim C impstate2 machstate2 /\ l = l') \/ (machstate2 = None /\ list_list_prefix l' l)).
 *)
Hypothesis simulation :
  forall S1 S1' S2 l,
    step1 S1 l S1' -> match_states S1 S2 ->
    exists S2' l',
      (plus step2 S2 l' S2' \/ (star step2 S2 l' S2' /\ measure S1' < measure S1))
      /\ ((match_states S1' S2' /\ l = l') \/ (S2' = None /\ list_list_prefix l' l))
.

(** We first extend the simulation to finite sequences of source transition_limiteds.
  This will show semantic preservation for terminating programs. *)

Lemma simulation_star:
  forall S1 S1' l,
    star step1 S1 l S1' ->
    forall S2, match_states S1 S2 ->
          exists S2' l', star step2 S2 l' S2' /\( (match_states S1' S2' /\ l = l') \/ (S2' = None /\ list_list_prefix l' l)).
Proof.
  induction 1; intros.
- (* zero transition_limited *)
  exists S2, []; split. apply star_refl. auto.
- (* one or more transition_limiteds *)
  destruct (simulation _ _ _ _ H H1) as [S2' [l [P Q]]].
  destruct Q as [[Q1 Q2] | [Q1 Q2]].
  + destruct (IHstar _ Q1) as [S2'' [l' [U V]]].
    subst.
    destruct V as [[V1 V2] | [V1 V2]].
    * subst.
      exists S2''; exists (l ++ l'); split.
      eapply starans; eauto. destruct P. apply plus_star; auto. destruct H2; auto.
      auto.
    * subst.
      exists None. exists (l++l'); split.
      eapply starans; eauto. destruct P. apply plus_star; auto. destruct H2; auto.
      right. split; auto.
      clear -V2.
      induction l. eauto.
      simpl. now split.
  + exists S2'. exists l. subst.
    split. destruct P; try now apply plus_star. destruct H2; auto.
    right. split; auto.
    eapply list_list_prefix_trans; eauto.
    clear.
    induction l1; now simpl.
Qed.

(** Turning to infinite sequences, we first show that the target program
  can always make progress, while preserving the [match_states] relation,
  if the source diverges.  The proof is an induction on the maximal number
  [N] of stutterings the target can make before performing at least one transition_limited. *)

(** It follows that the target performs infinitely many transition_limiteds if
  started in a configuration_limited that matches a diverging source configuration_limited. *)

Lemma simulation_infseq:
  forall S1 S2 s,
  infseq step1 s S1 ->
  match_states S1 S2 ->
  (forall l, list_stream_prefix l s -> not (star step2 S2 l None)) ->
  infseq step2 s S2.
Proof.
  assert (forall S1 S2 s,
             infseq step1 s S1 ->
             match_states S1 S2 ->
             (forall l, list_stream_prefix l s -> not (star step2 S2 l None)) ->
             infseq_N step2 s (measure S1) S2).
  {
    clear -simulation.
    cofix Hfix; intros S1 S2 s H H0 H1.
    inversion H; subst; clear H.
    destruct (simulation _ _ _ _ H2 H0) as [S2' [l' [[Hplus | [Hstar Hmeas]] Hmatch]]].
    - destruct Hmatch as [[Hmatch1 Match2] | [Hmatch1 Hmatch2]]; subst.
      + eapply infseq_N_plus; eauto.
        eapply Hfix. eauto. eauto.
        intros l H Hn.
        apply (H1 (l' ++ l)).
               now apply list_stream_prefix_app.
        eapply starans; eauto. eapply plus_star; eauto.
      + eapply plus_star in Hplus.
        assert (H: list_stream_prefix l' (app_list_stream l s0)) by now apply list_list_prefix_stream_app.
        specialize (H1 l' H).
        now auto.
    - destruct Hmatch as [[Hmatch1 Hmatch2] | [Hmatch1 Hmatch2]]; subst.
      + eapply infseq_N_star; eauto.
        eapply Hfix. eauto. eauto.
        intros l H Hn.
        apply (H1 (l' ++ l)).
        now apply list_stream_prefix_app.
        eapply starans; eauto.
      + assert (H: list_stream_prefix l' (app_list_stream l s0)) by now apply list_list_prefix_stream_app.
        specialize (H1 l' H).
        now auto.
  }
  intros S1 S2 s H0 H1 H2.
  eapply infseq_N_infseq. eauto.
Qed.

Lemma simulation_infseq' :
  forall S1 S2 s,
    infseq step1 s S1 ->
    match_states S1 S2 ->
    infseq step2 s S2 \/ (exists l, list_stream_prefix l s /\ star step2 S2 l None).
Proof.
  intros S1 S2 s H H0.
  pose proof simulation_infseq S1 S2 s H H0 as H'.
  setoid_rewrite imp_equiv in H';
    setoid_rewrite not_forall_ex_not in H';
    setoid_rewrite not_imp in H';
    setoid_rewrite <- dne in H';
    setoid_rewrite or_comm in H'.
  now apply H'.
Qed.

Lemma simulation_infseq_prod:
  forall S1 S2 s,
    infseq_prod step1 s S1 ->
    match_states S1 S2 ->
    infseq_prod step2 s S2 \/ (exists l, list_stream_prefix l s /\ star step2 S2 l None).
Proof.
  assert (H: forall S1 S2 s,
             infseq_prod step1 s S1 ->
             match_states S1 S2 ->
             (forall l, list_stream_prefix l s -> not (star step2 S2 l None)) ->
             infseq_prod step2 s S2).
  {
    cofix Hfix; intros S1 S2 s H H0 Hnot.
    inversion H; subst; clear H.
    edestruct simulation_star
      as [S2' [l' [Hstar [[Hmatch1 Hmatch2] | [Hmatch1 Hmatch2]]]]];
      eauto; subst.
    - econstructor; eauto.
      eapply Hfix; eauto.
      intros l Hl Hn.
      eapply (Hnot (l' ++ l)); try eapply starans; eauto.
      now apply list_stream_prefix_app.
    - exfalso. (* eapply (Hnot _ _ Hstar). *)
      eapply Hnot. eapply list_list_prefix_stream_app; eauto.
      eauto.
  }
  intros S1 S2 s H0 H1.
  specialize (H S1 S2 s H0 H1).
  setoid_rewrite imp_equiv in H;
    setoid_rewrite not_forall_ex_not in H;
    setoid_rewrite not_imp in H;
    setoid_rewrite <- dne in H;
    setoid_rewrite or_comm in H.
  now assumption.
Qed.

Lemma simulation_infseq_silent :
  forall S1 S2,
    infseq_silent step1 S1 ->
    match_states S1 S2 ->
    (forall l, l = [] -> not (star step2 S2 l None)) ->
    infseq_silent step2 S2.
Proof.
  assert (forall S1 S2,
             infseq_silent step1 S1 ->
             match_states S1 S2 ->
             (forall l, l = [] -> not (star step2 S2 l None)) ->
             infseq_silent_N step2 (measure S1) S2).
  {
    clear -simulation.
    cofix Hfix; intros S1 S2 H H0 H1.
    inversion H; subst; clear H.
    destruct (simulation _ _ _ _ H2 H0) as [S2' [l' [[Hplus | [Hstar Hmeas]] [[Hmatch1 Hmatch2] | [Hmatch1 Hmatch2]]]]];
      subst.
    - eapply infseq_silent_N_plus; eauto.
      eapply Hfix; eauto. intros l H Hn; subst.
      eapply plus_star in Hplus.
      apply (H1 ([] ++ []) eq_refl).
      eapply starans; eauto.
    - assert (l' = []) by now destruct l'. subst.
      eapply plus_star in Hplus; specialize (H1 [] eq_refl).
      now auto.
    - eapply infseq_silent_N_star; eauto.
      eapply Hfix; eauto.
      intros l Heq Hn; subst.
      eapply (H1 ([] ++ []) eq_refl); eapply starans; eauto.
    - assert (l' = []) by now destruct l'.
      subst.
      now specialize (H1 [] eq_refl).
  }
  intros S1 S2 H0 H1 H2.
  eapply infseq_silent_N_infseq_silent. eauto.
Qed.

Lemma simulation_infseq_silent' :
  forall S1 S2,
  infseq_silent step1 S1 ->
  match_states S1 S2 ->
  infseq_silent step2 S2 \/ exists l, l = [] /\ star step2 S2 l None.
Proof.
  intros S1 S2 s H.
  pose proof simulation_infseq_silent S1 S2 s H as H'.
  setoid_rewrite imp_equiv in H';
    setoid_rewrite not_forall_ex_not in H';
    setoid_rewrite not_imp in H';
    setoid_rewrite <- dne in H';
    setoid_rewrite or_comm in H'.
  now apply H'.
Qed.

End SIMULATION_DIAGRAM.
(** We now apply these results to the Imp compiler.  We first obtain
  an alternate proof of semantic preservation for terminating Imp programs. *)

Lemma match_config_lim_initial:
  forall c st,
  match_config_lim (compile_program c) (c, Kstop, st) (Some (0, nil, st)).
Proof.
  intros. constructor.
  change (compile_program c) with (nil ++ compile_com c ++ Ihalt :: nil). constructor. auto.
  simpl. unfold compile_program. constructor. apply code_at_app. auto.
Qed.

Theorem compile_program_correct_terminating_2:
  forall c st st' l,
  kterminates c st st' l ->
  mach_terminates (compile_program c) st st' l \/ exists l', list_list_prefix l' l /\ mach_OOM (compile_program c) st l'.
Proof.
  intros.
  assert (exists machconf2 l',
           star (transition_limited (compile_program c)) (Some (0, nil, st)) l' machconf2
           /\ ((match_config_lim (compile_program c) (SKIP, Kstop, st') machconf2 /\ l = l') \/
             (machconf2 = None /\ list_list_prefix l' l))).
  eapply simulation_star; eauto. eapply simulation_step. apply match_config_lim_initial.
  destruct H0 as [machconf2 [l' [STAR [[MS EQ] | [EQ PREF]]]]].
  + inversion MS; subst. simpl in *. normalize.
    destruct (compile_cont_Kstop_inv _ _ st' H5) as [pc' [A B]].
    left. red. exists pc'; split. auto.
    replace l' with (l' ++ [] : list (ev event)); last apply app_nil_r.
    eapply starans; eauto.
  + subst. right.
    exists l'; now split.
Qed.

(** More interestingly, we also prove semantic preservation for diverging
  Imp programs. *)

Theorem compile_program_correct_diverging:
  forall c st s,
  kdiverges c st s ->
  mach_diverges (compile_program c) st s \/ exists l', list_stream_prefix l' s /\ mach_OOM (compile_program c) st l'.
Proof.
  intros c st s H.
  edestruct simulation_infseq' with (match_states := match_config_lim (compile_program c));
    eauto using simulation_step, match_config_lim_initial.
Qed.

Theorem compile_program_correct_silent:
  forall c st st' l,
    ksilent c st st' l ->
    mach_silent (compile_program c) st st' l \/ exists l', list_list_prefix l' l /\ mach_OOM (compile_program c) st l'.
Proof.
  intros.
  destruct H as [c' [k' [H1 H2]]].
  assert (exists machconf2 l', star (transition_limited (compile_program c)) (Some (0, nil, st)) l' machconf2
                          /\ ((match_config_lim (compile_program c) (c',k', st') machconf2 /\ l = l') \/
                             machconf2 = None /\ list_list_prefix l' l)).
  eapply simulation_star; eauto. eapply simulation_step. apply match_config_lim_initial.
  destruct H as [machconf2 [l' [STAR [[MS1 MS2] | [MS1 MS2]]]]]; subst.
  - inversion MS1; subst. simpl in *.
    edestruct simulation_infseq_silent' with (match_states := match_config_lim (compile_program c)); eauto.
    eapply simulation_step.
    + left. red.
      exists pc, nil.
      now split.
    + destruct H as [l [? Hstar]]; subst.
      right.
      exists (l' ++ []).
      split. rewrite app_nil_r; now apply list_list_prefix_ref.
      unfold mach_OOM.
      eapply starans; eauto.
  - right.
    now (exists l').
Qed.

Theorem compile_program_correct_reacting:
  forall c st s,
    kreacts c st s ->
    mach_reacts (compile_program c) st s \/ exists l, list_stream_prefix l s /\ mach_OOM (compile_program c) st l.
Proof.
  intros.
  unfold mach_reacts, mach_OOM.
  eapply simulation_infseq_prod with (match_states := match_config_lim (compile_program c)); eauto using simulation_step, match_config_lim_initial.
Qed.

Section Traces.
  Definition event := Imp.event.
  Definition endstate := {| es := unit; an_es := tt |}.
  Definition trace := @TraceModel.trace event endstate.
End Traces.

Section Source.

  Definition traceS := @ResourceExhaustion.traceS event endstate.

  Definition sprg := com.
  Definition spar := sprg.
  Definition sctx := unit.
  Definition splug (p : spar) (c : sctx) := p.

  Definition source := {| prg := sprg; par := spar; ctx := sctx; plug := splug |}.

  Definition semS (p : sprg) (t : traceS) : Prop :=
    match t with
    | tstop l e => exists st', kterminates p empty_state st' l
    | tsilent l => exists st', ksilent p empty_state st' l
    | tstream s => kreacts p empty_state s
    end.
Definition trace_app (t1 t2 : trace) : trace :=
    match t1 with
    | tstop l e =>
      match t2 with
      | tstop l' e' => tstop (l ++ l') e'
      | tsilent l' => tsilent (l ++ l')
      | tstream s => tstream (Stream.app_list_stream l s)
      end
    | tsilent l => tsilent l
    | tstream s => tstream s
    end.

  Section Reacts.
    Variable s0 : (com * cont * state).
    Hypothesis reacts:
      forall s1 t1, star kstep s0 t1 s1 ->
               exists s2, exists t2, star kstep s1 t2 s2 /\ t2 <> [].

    Lemma reacts':
      forall s1 t1, star kstep s0 t1 s1 ->
               { s2 & { t2 : list (ev Imp.event) | star kstep s1 t2 s2 /\ t2 <> [] } }.
    Proof.
      intros.
      destruct (constructive_indefinite_description _ (reacts _ _ H)) as [s2 A].
      destruct (constructive_indefinite_description _ A) as [t2 [B C]].
      exists s2; exists t2; auto.
    Qed.

    CoFixpoint build_stream' s1 (t1: list (ev Imp.event)) (ST: star kstep s0 t1 s1) : @stream' (ev Imp.event) :=
      match (reacts' _ _ ST) with
      | existT s2 (exist t2 (conj A B)) =>
        @scons' _ t2 (build_stream' _ _ (starans ST A)) B
      end.

    Lemma reacts_forever_reactive_rec:
      forall s1 t1 (ST: star kstep s0 t1 s1),
        infseq_prod kstep (stream_of_stream' (build_stream' _ _ ST)) s1.
    Proof.
      cofix COINDHYP; intros.
      rewrite (unroll_stream' (build_stream' _ _ ST)).
      simpl.
      destruct (reacts' _ _ ST) as [s2 [t2 [A B]]].
      rewrite stream_stream'_app.
      econstructor. eassumption. auto. apply COINDHYP.
    Qed.

    Lemma reacts_forever_reactive:
      exists s, infseq_prod kstep s s0.
    Proof.
      exists (stream_of_stream' (build_stream' _ _ (star_refl _ _))).
      apply reacts_forever_reactive_rec.
    Qed.
  End Reacts.

  Lemma non_empty_semS : forall W, exists t, semS W t.
  Proof.
    intros W.
    unfold semS.
    destruct (classic (forall s1 t1, star kstep (W, Kstop, empty_state) t1 s1 -> exists s2, exists t2, kstep s1 t2 s2)).
    - (* Divergence *)
      destruct (classic (exists s1, exists t1, star kstep (W, Kstop, empty_state) t1 s1 /\
                                     (forall s2 t2, star kstep s1 t2 s2 -> exists s3,
                                           kstep s2 [] s3))).
      + (* Silent divergence *)
        destruct H0 as [[[]] [t1 [A B]]].
        exists (tsilent t1); econstructor; eauto.
        unfold ksilent. subst.
        eexists; eexists; split; eauto.
        now apply diverges_infseq_silent.
      + (*reactive divergence *)
        destruct (@reacts_forever_reactive (W, Kstop, empty_state)) as [T FR].
        intros.
        generalize (not_ex_all_not _ _ H0 s1). intro A; clear H0.
        generalize (not_ex_all_not _ _ A t1). intro B; clear A.
        destruct (not_and_or _ _ B). contradiction.
        destruct (not_all_ex_not _ _ H0) as [s2 C]; clear H0.
        destruct (not_all_ex_not _ _ C) as [t2 D]; clear C.
        destruct (imply_to_and _ _ D) as [E F]; clear D.
        destruct (H s2 (List.app t1 t2)) as [s3 [t3 G]]. eapply starans; eauto.
        exists s3; exists (List.app t2 t3); split.
        eapply plus_star; eapply plus_right; eauto.
        (* eapply star_step_right; eauto. *)
        red; intros. destruct (app_eq_nil t2 t3 H0). subst. elim F. exists s3; auto.
        exists (tstream T). assumption.
    - (* Termination *)
      destruct (not_all_ex_not _ _ H) as [[[]] A]; clear H.
      destruct (not_all_ex_not _ _ A) as [t1 B]; clear A.
      destruct (imply_to_and _ _ B) as [C D]; clear B.
      assert (c = SKIP /\ c0 = Kstop).
      {
        destruct c;
          try now (exfalso; apply D; eexists; eexists; econstructor; eauto).
        - split; first reflexivity.
          destruct c0; first reflexivity;
            try now (exfalso; apply D;
                     eexists; eexists; econstructor; eauto).
        - exfalso; apply D.
          destruct (beval s b) eqn:Heq.
          + eexists; eexists; now apply KS_IfTrue.
          + eexists; eexists; now apply KS_IfFalse.
        - exfalso; apply D.
          destruct (beval s b) eqn:Heq.
          + eexists; eexists; now apply KS_WhileTrue.
          + eexists; eexists; now apply KS_WhileFalse.
      }
      exists (tstop t1 (tt : es endstate)).
      econstructor; eauto.
      unfold kterminates.
      destruct H; subst; eauto.
  Qed.

  Definition semanticsS : Semantics source trace :=
    {| sem := semS : prg source -> trace -> Prop;
       non_empty_sem := non_empty_semS |}.

End Source.

Section Target.

  Definition traceT := @ResourceExhaustion.traceT event endstate.

  Definition tprg := code.
  Definition tpar := tprg.
  Definition tctx := unit.
  Definition tplug (p : tpar) (c : tctx) := p.

  Definition target := {| prg := tprg; par := tpar; ctx := tctx; plug := tplug |}.

  Definition semT (p : tprg) (t : traceT) : Prop :=
    match t with
    | tstop l (inl e) => exists st', mach_terminates p (empty_state) st' l \/ mach_goes_wrong p empty_state l
    | tstop l (inr e) => mach_OOM p (empty_state) l
    | tsilent l => exists st', mach_silent p empty_state st' l
    | tstream s => mach_reacts p empty_state s
    end.

  Section Reacts.
    Variable s0 : configuration_limited.
    Variable C : code.
    Hypothesis reacts:
      forall s1 t1, star (transition_limited C) s0 t1 s1 ->
               exists s2, exists t2, star (transition_limited C) s1 t2 s2 /\ t2 <> [].

    Lemma reacts'_mach:
      forall s1 t1, star (transition_limited C) s0 t1 s1 ->
               { s2 & { t2 : list (ev Imp.event) | star (transition_limited C) s1 t2 s2 /\ t2 <> [] } }.
    Proof.
      intros.
      destruct (constructive_indefinite_description _ (reacts _ _ H)) as [s2 A].
      destruct (constructive_indefinite_description _ A) as [t2 [B C']].
      exists s2; exists t2; auto.
    Qed.

    CoFixpoint build_stream'_mach s1 (t1: list (ev Imp.event)) (ST: star (transition_limited C) s0 t1 s1) : @stream' (ev Imp.event) :=
      match (reacts'_mach _ _ ST) with
      | existT s2 (exist t2 (conj A B)) =>
        @scons' _ t2 (build_stream'_mach _ _ (starans ST A)) B
      end.

    Lemma reacts_forever_reactive_rec_mach:
      forall s1 t1 (ST: star (transition_limited C) s0 t1 s1),
        infseq_prod (transition_limited C) (stream_of_stream' (build_stream'_mach _ _ ST)) s1.
    Proof.
      cofix COINDHYP; intros.
      rewrite (unroll_stream' (build_stream'_mach _ _ ST)).
      simpl.
      destruct (reacts'_mach _ _ ST) as [s2 [t2 [A B]]].
      rewrite stream_stream'_app.
      econstructor. eassumption. auto. apply COINDHYP.
    Qed.

    Lemma reacts_forever_reactive_mach:
      exists s, infseq_prod (transition_limited C) s s0.
    Proof.
      exists (stream_of_stream' (build_stream'_mach _ _ (star_refl _ _))).
      apply reacts_forever_reactive_rec_mach.
    Qed.
  End Reacts.

  Lemma non_empty_semT : forall W, exists t, semT W t.
  Proof.
    intros W.
    unfold semT.
    destruct (classic (forall s1 t1, star (transition_limited W) (Some (0, [], empty_state)) t1 s1 -> exists s2, exists t2, (transition_limited W) s1 t2 s2)).
    - (* Divergence *)
      destruct (classic (exists s1, exists t1, star (transition_limited W) (Some (0, [], empty_state)) t1 s1 /\
                                     (forall s2 t2, star (transition_limited W) s1 t2 s2 -> exists s3,
                                           (transition_limited W) s2 [] s3))).
      + (* Silent divergence *)
        destruct H0 as [[[[]]|] [t1 [A B]]].
        exists (tsilent (t1 : list (ev Imp.event))); econstructor; eauto.
        eexists; eexists; split; eauto.
        now apply diverges_infseq_silent.
        exists (tstop (t1 : list (ev Imp.event)) (inr tt : es (endstateT endstate))).
        eauto.
      + (*reactive divergence *)
        destruct (@reacts_forever_reactive_mach (Some (0, [], empty_state))) with (C := W) as [T FR].
        intros.
        generalize (not_ex_all_not _ _ H0 s1). intro A; clear H0.
        generalize (not_ex_all_not _ _ A t1). intro B; clear A.
        destruct (not_and_or _ _ B). contradiction.
        destruct (not_all_ex_not _ _ H0) as [s2 C]; clear H0.
        destruct (not_all_ex_not _ _ C) as [t2 D]; clear C.
        destruct (imply_to_and _ _ D) as [E F]; clear D.
        destruct (H s2 (List.app t1 t2)) as [s3 [t3 G]]. eapply starans; eauto.
        exists s3; exists (List.app t2 t3); split.
        eapply plus_star; eapply plus_right; eauto.
        (* eapply star_step_right; eauto. *)
        red; intros. destruct (app_eq_nil t2 t3 H0). subst. elim F. exists s3; auto.
        exists (tstream (T : @Stream.stream (ev Imp.event))). assumption.
    - (* Termination *)
      destruct (not_all_ex_not _ _ H) as [[[[]]|] A]; clear H.
      destruct (not_all_ex_not _ _ A) as [t1 B]; clear A.
      destruct (imply_to_and _ _ B) as [C D]; clear B.
      exists (tstop (t1 : list (ev Imp.event)) (inl tt : es (endstateT endstate))).
      exists s0.
      destruct (code_at W n) as [[]|] eqn:Heq;
        destruct s as [| i s'] eqn:Heq';
      match goal with
      | Hcode : code_at W n = Some Ihalt,  Hstk : s = [] |- _ => left
      | _ => right; econstructor; exists s; exists s0; split; subst; try eassumption;
              split;
              try (now intros b e; apply not_ex_all_not with (n := b) in D;
                   apply not_ex_all_not with (n := e) in D; assumption);
              match goal with
              | |- _ \/ [] = [] => now right
              | |- _ \/ (_ :: _) <> [] => now right
                         | _ => idtac
              end;
              left
      end;
      try now rewrite Heq.
      econstructor; eauto.
      destruct (not_all_ex_not _ _ A) as [t1 B]; clear A.
      destruct (imply_to_and _ _ B) as [C D]; clear B.
      exists (tstop (t1 : list (ev Imp.event)) (inr tt : es (endstateT endstate))).
      auto.
  Qed.

  Definition semanticsT : Semantics target traceT :=
    {| sem := semT : prg target -> traceT -> Prop;
       non_empty_sem := non_empty_semT |}.

End Target.

Section CompilationChain.

  Definition compile : prg source -> prg target := compile_program.
  Hint Unfold compile.

  Definition compiler : CompilationChain source target :=
    {| compile_whole := compile;
       compile_par := compile;
       compile_ctx := fun x => x |}.

End CompilationChain.

Definition rel' := ResourceExhaustion.rel event endstate.
Hint Unfold rel'.

Definition rel (t1 : traceS) (t2 : traceT) :=
  match t1, t2 with
  | tstream s1, tstream s2 => Stream.stream_eq s1 s2
  | _, _ => rel' t1 t2
  end.

Definition trace_eq (t1 t2 : traceT) :=
  match t1, t2 with
  | tstream s1, tstream s2 => Stream.stream_eq s1 s2
  | _, _ => t1 = t2
  end.

Definition rel_TC := TraceCriterion.rel_TC compiler semanticsS semanticsT rel.

Definition rel_TC_fwd := forall W s, semS W s -> exists t, rel s t /\ semT (compile W) t.

Lemma target_determinism : forall W s1 s2,
    semT W s1 ->
    semT W s2 ->
    trace_eq s1 s2.
Proof.
  intros W s1 s2 H1 H2. unfold rel.
  unfold semT in *.
  destruct s1 as [ l1 [[] | []] | l1 | s1 ];
    destruct s2 as [ l2 [[] | []] | l2 | s2];
    repeat
      match goal with
      | Hor : exists _ : state, _ \/ _ |- _ => destruct Hor as [? []]
      | Hsile: exists _ : state, mach_silent _ _ _ _ |- _ => destruct Hsile
      end;
    try (now exfalso; eapply terminates_goeswrong_exclusive; eassumption);
    try (now exfalso; eapply terminates_silent_exclusive; eassumption);
    try (now exfalso; eapply terminates_diverges_exclusive; eassumption);
    try (now exfalso; eapply terminates_reacts_exclusive; eassumption);
    try (now exfalso; eapply terminates_OOM_exclusive; eassumption);
    try (now exfalso; eapply goeswrong_silent_exclusive; eassumption);
    try (now exfalso; eapply goeswrong_diverges_exclusive; eassumption);
    try (now exfalso; eapply goeswrong_reacts_exclusive; eassumption);
    try (now exfalso; eapply goeswrong_OOM_exclusive; eassumption);
    try (now exfalso; eapply silent_diverges_exclusive; eassumption);
    try (now exfalso; eapply silent_reacts_exclusive; eassumption);
    try (now exfalso; eapply silent_OOM_exclusive; eassumption);
    try (now exfalso; eapply reacts_OOM_exclusive; eassumption).
  - match goal with
    | Ht1 : mach_terminates _ _ _ _, Ht2 : mach_terminates _ _ _ _ |- _ =>
      destruct (terminates_unique _ _ _ _ _ _ Ht1 Ht2)
    end; now subst.
  - match goal with
    | Ht1 : mach_goes_wrong _ _ _, Ht2 : mach_goes_wrong _ _ _ |- _ =>
      destruct (goeswrong_unique _ _ _ _ Ht1 Ht2)
    end; now subst.
  - match goal with
    | Ht1 : mach_OOM _ _ _, Ht2 : mach_OOM _ _ _ |- _ =>
      destruct (OOM_unique _ _ _ _ Ht1 Ht2)
    end; now subst.
  - match goal with
    | Ht1 : mach_silent _ _ _ _, Ht2 : mach_silent _ _ _ _ |- _ =>
      destruct (silent_unique _ _ _ _ _ _ Ht1 Ht2)
    end; now subst.
  - match goal with
    | Ht1 : mach_reacts _ _ _, Ht2 : mach_reacts _ _ _ |- _ =>
      destruct (reacts_unique _ _ _ _ Ht1 Ht2)
    end; now econstructor.
Qed.

Lemma rel_TC_fwd_rel_TC : rel_TC_fwd -> rel_TC.
Proof.
  unfold rel_TC_fwd, rel_TC, TraceCriterion.rel_TC.
  intros H W t H0.
  destruct (non_empty_semS W) as [s Hs].
  specialize (H W s Hs).
  destruct H as [t' [H1 H2]].
  simpl in H0.
  assert (trace_eq t t') by
      now apply target_determinism with (W := compile W).
  subst.
  exists s. split; eauto.
  destruct s, t, t'; try now rewrite H.
  - simpl in *.
    inversion H1.
    inversion H3.
    destruct H3 as [m [H31 H32]].
    inversion H31.
  - simpl in *. inversion H1.
    inversion H3.
    destruct H3 as [m [H31 H32]].
    inversion H31.
  - simpl in *. eapply stream_eq_trans. eauto. eapply stream_eq_sym. eauto.
Qed.

Theorem correctness : rel_TC.
Proof.
  apply rel_TC_fwd_rel_TC.
  unfold rel_TC_fwd.
  intros W t H; simpl in H.
  destruct t as [l e | l | s].
  - simpl in *.
    destruct H as [st' Hterm].
    apply compile_program_correct_terminating_2 in Hterm.
    destruct Hterm as [H | H].
    + exists (tstop (l : list (ev event)) (inl e : es (endstateT endstate))).
      split.
      repeat constructor.
      now (exists st'; left).
    + destruct H as [l' [H1 H2]].
      exists (tstop (l' : list (ev event)) (OOM (endstate))).
      split.
      right. eexists; split; eauto.
      eauto.
  - simpl in *.
    destruct H as [st' Hsil].
    apply compile_program_correct_silent in Hsil.
    destruct Hsil as [H | H].
    + exists (tsilent (l : list (ev event))).
      split.
      repeat constructor.
      now (exists st').
    + destruct H as [l' [H1 H2]].
      exists (tstop (l' : list (ev event)) (OOM (endstate))).
      split.
      right. eexists; split; simpl; eauto.
      eauto.
  - simpl in *.
    apply compile_program_correct_reacting in H.
    destruct H as [H | H].
    + exists (tstream (s : @stream (ev event))).
      split.
      repeat constructor; eauto.
      eauto.
    + destruct H as [l' [H1 H2]].
      exists (tstop (l' : list (ev event)) (OOM (endstate))).
      split.
      right. eexists; split; eauto.
      eauto.
Qed.


From PlutusCert Require Import
  Language.PlutusIR
  Analysis.BoundVars.
Import NamedTerm.

Require Import
  Strings.String
  Lists.List
.

Import ListNotations.

Definition ctx := list string.

Definition tvd_name (tvd : tvdecl tyname) : tyname :=
  match tvd with
  | TyVarDecl v K => v
  end.

Reserved Notation "Δ '|-*' T" (at level 40, T at level 0).
Inductive well_scoped_Ty (Δ : ctx) : Ty -> Prop :=
  | WST_Var : forall X,
      In X Δ ->
      Δ |-* (Ty_Var X)
  | WST_Fun : forall T1 T2,
      Δ |-* T1 ->
      Δ |-* T2 ->
      Δ |-* (Ty_Fun T1 T2)
  | WST_IFix  : forall F T,
      Δ |-* T ->
      Δ |-* F ->
      Δ |-* (Ty_IFix F T)
  | WST_Forall : forall X K T,
      (X :: Δ) |-* T ->
      Δ |-* (Ty_Forall X K T)
  | WST_Builtin : forall u,
      Δ |-* (Ty_Builtin (Some (TypeIn u)))
  | WST_Lam : forall X K1 T,
      (X :: Δ) |-* T ->
      Δ |-* (Ty_Lam X K1 T)
  | WST_App : forall T1 T2,
      Δ |-* T1 ->
      Δ |-* T2 ->
      Δ |-* (Ty_App T1 T2)
where "Δ '|-*' T " := (well_scoped_Ty Δ T).

Reserved Notation "Δ ',,' Γ '|-+' t " (at level 101, t at level 0, no associativity).
Reserved Notation "Δ '|-ok_c' c " (at level 101, c at level 0).
Reserved Notation "Δ ',,' Γ  '|-oks_nr' bs" (at level 101, bs at level 0, no associativity).
Reserved Notation "Δ ',,' Γ '|-oks_r' bs" (at level 101, bs at level 0, no associativity).
Reserved Notation "Δ ',,' Γ '|-ok_b' b" (at level 101, b at level 0, no associativity).

Inductive constructor_well_formed (Δ : ctx) : constructor -> Prop :=
  | W_Con : forall x T ar,
      Δ |-* T ->
      Δ |-ok_c (Constructor (VarDecl x T) ar)
  where
    "Δ '|-ok_c' c" := (constructor_well_formed Δ c)
.

Inductive well_scoped (Δ Γ: ctx) : Term -> Prop :=
  | WS_Var : forall x,
      In x Γ ->
      Δ ,, Γ |-+ (Var x)
  | WS_LamAbs : forall x T t,
      Δ |-* T ->
      Δ ,, (x :: Γ) |-+ t ->
      Δ ,, Γ |-+ (LamAbs x T t)
  | WS_Apply : forall t1 t2,
      Δ ,, Γ |-+ t1 ->
      Δ ,, Γ |-+ t2 ->
      Δ ,, Γ |-+ (Apply t1 t2)
  (* Universal types *)
  | WS_TyAbs : forall X K t,
      (X :: Δ) ,, Γ |-+ t ->
      Δ ,, Γ |-+ (TyAbs X K t)
  | WS_TyInst : forall t T,
      Δ ,, Γ |-+ t ->
      Δ |-* T ->
      Δ ,, Γ |-+ (TyInst t T)
  | WS_IWrap : forall F T M,
      Δ |-* F ->
      Δ |-* T ->
      Δ ,, Γ |-+ M ->
      Δ ,, Γ |-+ (IWrap F T M)
  | WS_Unwrap : forall M,
      Δ ,, Γ |-+ M ->
      Δ ,, Γ |-+ (Unwrap M)
  | WS_Constant : forall u a,
      Δ ,, Γ |-+ (Constant (Some (ValueOf u a)))
  | WS_Builtin : forall f,
      Δ ,, Γ |-+ (Builtin f)
  | WS_Error : forall S,
      Δ |-* S ->
      Δ ,, Γ |-+ (Error S)
  | WS_Let : forall bs t Δ' Γ',
      Δ' = rev (btvbs bs) ++ Δ ->
      Γ' = rev (bvbs bs) ++ Γ ->
      Δ ,, Γ |-oks_nr bs ->
      Δ' ,, Γ' |-+ t ->
      Δ ,, Γ |-+ (Let NonRec bs t)
  | WS_LetRec : forall bs t Δ' Γ',
      Δ' = rev (btvbs bs) ++ Δ ->
      Γ' = rev (bvbs bs) ++ Γ ->
      Δ' ,, Γ' |-oks_r bs ->
      Δ' ,, Γ' |-+ t ->
      Δ ,, Γ |-+ (Let Rec bs t)

with bindings_well_formed_nonrec (Δ Γ : ctx) : list Binding -> Prop :=

  | W_NilB_NonRec :
    Δ ,, Γ |-oks_nr nil

  | W_ConsB_NonRec : forall b bs,
      Δ ,, Γ |-ok_b b ->
      (btvb b ++ Δ) ,, (bvb b ++ Γ) |-oks_nr bs ->
      Δ ,, Γ |-oks_nr (b :: bs)

with bindings_well_formed_rec (Δ Γ : ctx) : list Binding -> Prop :=

  | W_NilB_Rec :
      Δ ,, Γ |-oks_r nil
  | W_ConsB_Rec : forall b bs,
      Δ ,, Γ |-ok_b b ->
      Δ ,, Γ |-oks_r bs ->
      Δ ,, Γ |-oks_r (b :: bs)

with binding_well_formed (Δ Γ : ctx) : Binding -> Prop :=
  | W_Term : forall s x T t,
      Δ |-* T ->
      Δ ,, Γ |-+ t ->
      Δ ,, Γ |-ok_b (TermBind s (VarDecl x T) t)
  | W_Type : forall X K T,
      Δ |-* T ->
      Δ ,, Γ |-ok_b (TypeBind (TyVarDecl X K) T)
  | W_Data : forall X YKs cs matchFunc Δ',
      Δ' = rev (map tvd_name YKs) ++ Δ  ->
      (forall c, In c cs -> Δ' |-ok_c c) ->
      Δ ,, Γ |-ok_b (DatatypeBind (Datatype X YKs matchFunc cs))

  where "Δ ',,' Γ '|-+' t" := (well_scoped Δ Γ t)
  and "Δ ',,' Γ '|-oks_nr' bs" := (bindings_well_formed_nonrec Δ Γ bs)
  and "Δ ',,' Γ '|-oks_r' bs" := (bindings_well_formed_rec Δ Γ bs)
  and "Δ ',,' Γ '|-ok_b' b" := (binding_well_formed Δ Γ b)
.

Definition closed := well_scoped [] [].


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*									     *)
(*	                       Setoid Product               		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Map.

Set Implicit Arguments.
Unset Strict Implicit.

(* Produit de deux Setoid *)

Section s_prod.

Variable A B : Setoid.

Structure Sprod : Type :=  {Sprod_l : A; Sprod_r : B}.

Definition Equal_Sprod (a1xb1 a2xb2 : Sprod) :=
  Sprod_l a1xb1 =_S Sprod_l a2xb2 /\ Sprod_r a1xb1 =_S Sprod_r a2xb2.

Lemma Equal_Sprod_equiv : Equivalence Equal_Sprod.
Proof.
apply Build_Equivalence.
unfold Reflexive in |- *; simple induction x; intros a b;
 unfold Equal_Sprod in |- *; simpl in |- *.
split.
apply Refl.
apply Refl.
apply Build_Partial_equivalence.
unfold Transitive in |- *.
simple induction x; intros a b; simple induction y; intros a' b';
 simple induction z; intros a'' b''.
unfold Equal_Sprod in |- *; simpl in |- *.
intros H H0; elim H; intros H1 H2; elim H0; intros H3 H4.
split.
apply Trans with a'; trivial.
apply Trans with b'; trivial.
unfold Symmetric in |- *; simple induction x; intros a b; simple induction y;
 intros a' b'.
unfold Equal_Sprod in |- *; simpl in |- *.
intros H; elim H; intros H1 H2.
split.
apply Sym; trivial.
apply Sym; trivial.
Qed.

Canonical Structure SPROD : Setoid := Equal_Sprod_equiv.

(* AxB = (S_PROD A B) *)
(* Sprod_l et Sprod_r sont en fait des Map *)

Lemma Proj1_SPROD_map_law : Map_law (Sprod_l:SPROD -> A).
Proof.
unfold Map_law in |- *; simpl in |- *.
simple induction x; intros a b; simple induction y; intros a' b'.
simpl in |- *; unfold Equal_Sprod in |- *; simpl in |- *.
simple induction 1; trivial.
Qed.

Canonical Structure Proj1_SPROD : Map SPROD A := Proj1_SPROD_map_law.

Lemma Proj2_SPROD_map_law : Map_law (Sprod_r:SPROD -> B).
Proof.
unfold Map_law in |- *; simpl in |- *.
simple induction x; intros a b; simple induction y; intros a' b'.
simpl in |- *; unfold Equal_Sprod in |- *; simpl in |- *.
simple induction 1; trivial.
Qed.

Canonical Structure Proj2_SPROD : Map SPROD B := Proj2_SPROD_map_law.

End s_prod.


(** * Z1: Reguły indukcji i indukcja funkcyjna [TODO] *)

Require Import Coq.Program.Wf Arith NPeano Div2 Lia List.
Import ListNotations.

(** * Customowe reguły indukcji *)

Fixpoint nat_ind_2
  (P : nat -> Prop)
  (H0 : P 0) (H1 : P 1)
  (H : forall n : nat, P n -> P (S (S n)))
  (n : nat) : P n :=
match n with
| 0 => H0
| 1 => H1
| S (S n') => H n' (nat_ind_2 P H0 H1 H n')
end.

Lemma expand :
  forall (P : nat -> Prop) (n k : nat),
    ~ n <= k -> P (k + (n - k)) -> P n.
Proof.
  intros. replace n with (k + (n - k)).
    assumption.
    lia.
Defined.

Program Fixpoint nat_ind_k
  (k : nat) (P : nat -> Prop)
  (H : forall k' : nat, k' <= k -> P k')
  (H' : forall n : nat, P n -> P (S k + n))
  (n : nat) {measure n} : P n :=
match le_dec n k with
| left n_le_k => H n n_le_k
| right n_gt_k =>
    expand P n k n_gt_k (H' (n - S k) (nat_ind_k k P H H' (n - S k)))
end.
Next Obligation. lia. Defined.
Next Obligation. lia. Defined.

Inductive even : nat -> Prop :=
| even0 : even 0
| evenSS : forall n : nat, even n -> even (S (S n)).

Fixpoint even_ind'
  (P : nat -> Prop)
  (H0 : P 0)
  (HSS : forall n : nat, even n -> P n -> P (S (S n)))
  (n : nat) (Heven : even n) : P n.
Proof.
  destruct n as [| [| n']].
    assumption.
    inversion Heven.
    inversion Heven; subst. apply HSS.
      assumption.
      apply (even_ind' P H0 HSS n' H1).
Defined.

Program Fixpoint nat_ind_k'
  (k : nat) (Hk : k <> 0) (P : nat -> Prop)
  (H : forall k' : nat, k' <= k -> P k')
  (H' : forall n : nat, P n -> P (k + n))
  (n : nat) {measure n} : P n :=
match le_dec n k with
| left n_le_k => H n n_le_k
| right n_gt_k =>
    expand P n k n_gt_k (H' (n - k) (nat_ind_k' k Hk P H H' (n - k)))
end.
Next Obligation. lia. Defined.

Fixpoint nat_ind_8
  {P : nat -> Type}
  (P0 : P 0)
  (P1 : P 1)
  (P2 : P 2)
  (P3 : P 3)
  (P4 : P 4)
  (P5 : P 5)
  (P6 : P 6)
  (P7 : P 7)
  (P8plus : forall n : nat, P n -> P (8 + n))
  (n : nat) : P n :=
match n with
| 0 => P0
| 1 => P1
| 2 => P2
| 3 => P3
| 4 => P4
| 5 => P5
| 6 => P6
| 7 => P7
| S (S (S (S (S (S (S (S n'))))))) =>
    P8plus n' (nat_ind_8 P0 P1 P2 P3 P4 P5 P6 P7 P8plus n')
end.

Lemma above_7 : forall n : nat,
    exists i j : nat, 8 + n = 3 * i + 5 * j.
Proof.
  apply nat_ind_8.
    exists 1, 1. cbn. reflexivity.
    exists 3, 0. cbn. reflexivity.
    exists 0, 2. cbn. reflexivity.
    exists 2, 1. cbn. reflexivity.
    exists 4, 0. cbn. reflexivity.
    exists 1, 2. cbn. reflexivity.
    exists 3, 1. cbn. reflexivity.
    exists 0, 3. cbn. reflexivity.
    intros n' (i & j & IH). exists (S i), (S j). lia.
Qed.

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

Fixpoint f (n : nat) : nat :=
match n with
| 0 => 0 * fac 0
| S n' => f n' + n * fac n
end.

Lemma pred_lemma :
  forall n m : nat,
    1 <= n -> pred (n + m) = pred n + m.
Proof.
  induction 1; cbn; trivial.
Qed.

Lemma fact_ge_1 :
  forall n : nat, 1 <= fac n.
Proof.
  induction n as [| n']; cbn.
    trivial.
    eapply Nat.le_trans. eauto. apply Nat.le_add_r.
Qed.

Lemma f_fac :
  forall n : nat, f n = pred (fac (1 + n)).
Proof.
  induction n as [| n'].
    cbn. trivial.
    cbn in *. rewrite pred_lemma. rewrite IHn'. trivial.
    eapply Nat.le_trans.
      apply fact_ge_1.
      apply Nat.le_add_r.
Qed.

Inductive pos : Set :=
| HJ : pos
| Z : pos -> pos
| J : pos -> pos.

Inductive bin : Set :=
| HZ : bin
| HP : pos -> bin.

Definition five : bin := HP (J (Z HJ)).
Definition answer : bin := HP (Z (J (Z (J (Z HJ))))).

Fixpoint pos_to_nat (p : pos) : nat :=
match p with
| HJ => 1
| Z p' => 2 * pos_to_nat p'
| J p' => 1 + 2 * pos_to_nat p'
end.

Definition bin_to_nat (b : bin) : nat :=
match b with
| HZ => 0
| HP p => pos_to_nat p
end.

Program Fixpoint divmod
  (n k : nat) (H : k <> 0) {measure n} : nat * nat :=
match n with
| 0 => (0, 0)
| _ =>
  if Nat.leb n k
  then (0, n)
  else let (d, m) := divmod (n - k) k H in (S d, m)
end.
Next Obligation. lia. Qed.

Lemma two_not_0 : 2 <> 0.
Proof. inversion 1. Qed.

Fixpoint divmod2 (n : nat) : nat * nat :=
match n with
| 0 => (0, 0)
| 1 => (0, 1)
| S (S n') => let (a, b) := divmod2 n' in (S a, b)
end.

Compute divmod2 155.

Compute bin_to_nat answer.
Compute bin_to_nat (HP (Z (J (Z (J (Z HJ)))))).

Definition injective {A B : Type} (f : A -> B) : Prop :=
  forall x x' : A, f x = f x' -> x = x'.

Definition surjective {A B : Type} (f : A -> B) : Prop :=
  forall b : B, exists a : A, f a = b.

Definition bijective {A B : Type} (f : A -> B) : Prop :=
  injective f /\ surjective f.

Lemma pos_to_nat_neq_0 :
  forall p : pos,
    pos_to_nat p <> 0.
Proof.
  induction p as [| p' | p']; cbn; inversion 1.
  apply IHp'. destruct (pos_to_nat p').
    trivial.
    inversion H.
Qed.

Lemma pos_to_nat_inj :
  injective pos_to_nat.
Proof.
  red. induction x as [| p1 | p1]; induction x' as [| p2 | p2]; cbn in *.
    reflexivity.
    lia.
    inversion 1. assert (pos_to_nat p2 = 0). lia.
      destruct (pos_to_nat_neq_0 _ H0).
    lia.
    intros. f_equal. apply IHp1. lia.
    intros. cut False; lia.
    inversion 1. assert (pos_to_nat p1 = 0). lia.
      destruct (pos_to_nat_neq_0 _ H0).
    lia.
    inversion 1. f_equal. apply IHp1. lia.
Qed.

#[global] Hint Resolve pos_to_nat_inj : core.

Lemma bin_to_nat_inj : injective bin_to_nat.
Proof.
  red. destruct x, x'; cbn; intro.
    trivial.
    cut False. inversion 1. eapply pos_to_nat_neq_0. eauto.
    cut False. inversion 1. eapply pos_to_nat_neq_0. eauto.
    f_equal. apply pos_to_nat_inj. assumption.
Qed.

Fixpoint succ (p : pos) : pos :=
match p with
| HJ => Z HJ
| J p' => Z (succ p')
| Z p' => J p'
end.

Lemma pos_to_nat_S :
  forall (p : pos),
    pos_to_nat (succ p) = S (pos_to_nat p).
Proof.
  induction p as [| p' | p']; cbn; trivial.
    rewrite IHp'. cbn. rewrite <- plus_n_Sm. reflexivity.
Qed.

Lemma bin_to_nat_sur :
  surjective bin_to_nat.
Proof.
  red. intro n. induction n as [| n'].
    exists HZ. cbn. trivial.
    destruct IHn' as [b H]. destruct b; cbn in H.
      exists (HP HJ). cbn. rewrite H. trivial.
      destruct p; cbn in H.
        exists (HP (Z HJ)). cbn. rewrite H. trivial.
        exists (HP (succ (Z p))). cbn. rewrite H. trivial.
        exists (HP (succ (J p))). cbn. rewrite pos_to_nat_S.
          cbn. f_equal. rewrite <- plus_n_Sm. assumption.
Qed.

Lemma bin_to_nat_bij :
  bijective bin_to_nat.
Proof.
  unfold bijective. split.
    apply bin_to_nat_inj.
    apply bin_to_nat_sur.
Qed.

Lemma div2_even_inv :
  forall n m : nat,
    n + n = m -> n = Nat.div2 m.
Proof.
  intros n m. generalize dependent n.
  induction m using nat_ind_2; cbn; intros.
    destruct n; inversion H. trivial.
    destruct n; inversion H.
      rewrite <- plus_n_Sm in H1. inversion H1.
    rewrite <- (IHm (pred n)); destruct n; inversion H; cbn; trivial.
      rewrite <- plus_n_Sm in H. inversion H. trivial.
Qed.

Lemma div2_odd_inv :
  forall n m : nat,
    S (n + n) = m -> n = Nat.div2 m.
Proof.
  intros n m. generalize dependent n.
  induction m using nat_ind_2; cbn; intros.
    inversion H.
    inversion H. destruct n; inversion H1; trivial.
    rewrite <- (IHm (pred n)).
      destruct n.
        inversion H.
        cbn. trivial.
      destruct n.
        inversion H.
        cbn in *. rewrite <- plus_n_Sm in H. inversion H. trivial.
Qed.

Lemma nat_ind_bin
  (P : nat -> Prop) (H0 : P 0)
  (Hx2 : forall n : nat, P n -> P (2 * n))
  (Hx2p1 : forall n : nat, P n -> P (1 + 2 * n))
  (n : nat) : P n.
Proof.
  pose proof bin_to_nat_sur. red in H. destruct (H n) as [b H'].
  rewrite <- H'. destruct b as [| p].
    cbn. apply H0.
    generalize dependent n. induction p as [| p' | p']; intros.
      cbn. change 1 with (1 + 2 * 0). apply Hx2p1. assumption.
      cbn in *. apply Hx2. apply (IHp' (Nat.div2 n)).
        apply div2_even_inv. rewrite <- plus_n_O in H'. assumption.
      cbn in *. apply Hx2p1. apply (IHp' (Nat.div2 n)).
        apply div2_odd_inv. rewrite <- plus_n_O in H'. assumption.
Qed.

Lemma even_dec :
  forall n : nat,
    {k : nat & {n = 2 * k} + {n = 1 + 2 * k}}.
Proof.
  induction n as [| n'].
    exists 0. left. trivial.
    destruct IHn' as [k [H | H]].
      exists k. right. rewrite H. trivial.
      exists (S k). left. rewrite H. cbn. lia.
Defined.

Inductive Tree (A : Type) : Type :=
| Empty : Tree A
| Node : A -> list (Tree A) -> Tree A.

Arguments Empty {A}.
Arguments Node {A} _ _.

Print Tree_ind.

Fixpoint Tree_ind_full
  (A : Type) (P : Tree A -> Prop) (Q : list (Tree A) -> Prop)
  (HPQ : forall ltr : list (Tree A), Q ltr -> forall x : A, P (Node x ltr))
  (HPEmpty : P Empty)
  (HQNil : Q nil)
  (HQCons : forall (h : Tree A) (t : list (Tree A)),
      P h -> Q t -> Q (cons h t))
  (t : Tree A) : P t.
Proof.
  destruct t as [| v forest].
    apply HPEmpty.
    apply HPQ. induction forest as [| t' forest'].
      apply HQNil; auto.
      apply HQCons; auto. apply Tree_ind_full with Q; eauto.
Defined.

Fixpoint size {A : Type} (t : Tree A) : nat :=
match t with
| Empty => 0
| Node v forest => 1 +
  (fix size' {A : Type} (forest : list (Tree A)) : nat :=
  match forest with
  | nil => 0
  | cons t forest' => size t + size' forest'
  end) _ forest
end.

Fixpoint size_f {A : Type} (t : Tree A) : nat :=
match t with
| Empty => 0
| Node _ forest => S (fold_right (fun t' s => size_f t' + s) 0 forest)
end.

Fixpoint flatten' {A : Type} (t : Tree A) : list A :=
match t with
| Empty => []
| Node v forest => v :: fold_right (fun h t => flatten' h ++ t) [] forest
end.

Lemma flatten_preserves_size :
    forall (A : Type) (t : Tree A), size t = length (flatten' t).
Proof.
  intro.
  induction t using Tree_ind_full with
      (Q := fun (ltr : list (Tree A)) =>
          forall v : A, size (Node v ltr) =
          S (length (fold_right (fun h t => flatten' h ++ t) [] ltr))).
    rewrite IHt. cbn. reflexivity.
    cbn. reflexivity.
    cbn. reflexivity.
    cbn. intro. f_equal. rewrite app_length.
      specialize (IHt0 v). inversion IHt0. rewrite H0.
      rewrite IHt. reflexivity.
Qed.

Section nat_ind_dbl_pred.

Variable P : nat -> Prop.

Hypothesis H1 : P 1.
Hypothesis Hdbl : forall n : nat, P n -> P (n + n).
Hypothesis Hpred : forall n : nat, P (S n) -> P n.

Lemma H0 : P 0.
Proof. apply Hpred. assumption. Qed.

Lemma Hplus : forall n m : nat, P (n + m) -> P m.
Proof.
  induction n as [| n']; cbn.
    trivial.
    intros. apply IHn'. apply Hpred. assumption.
Qed.

Lemma HS : forall n : nat, P n -> P (S n).
Proof.
  induction n as [| n']; intro.
    assumption.
    apply Hplus with n'. replace (n' + S (S n')) with (S n' + S n').
      apply Hdbl. assumption.
      rewrite (Nat.add_comm n'). cbn. f_equal. rewrite Nat.add_comm. trivial.
Qed.

Lemma nat_ind_dbl_pred : forall n : nat, P n.
Proof.
  induction n as [| n'].
    apply H0.
    apply HS. assumption.
Qed.

End nat_ind_dbl_pred.

Goal forall n : nat, 2 * n <= Nat.pow 2 n.
Proof.
  induction n as [| n'].
    cbn. lia.
    cbn [Nat.pow]. destruct n'; cbn in *; lia.
Qed.

Lemma pow2_lin :
  forall n : nat,
    n < Nat.pow 2 n.
Proof.
  induction n as [| n']; cbn.
    constructor.
    lia.
Qed.

Goal forall n : nat, 2 * n < Nat.pow 2 (S n).
Proof.
  intros. cbn [Nat.pow].
  apply Nat.mul_lt_mono_pos_l.
  - apply Nat.lt_0_succ.
  - apply pow2_lin.
Qed.

Definition maxL := fold_right max 0.
Definition sumL := fold_right plus 0.

Lemma whatt : forall l : list nat, sumL l <= length l * maxL l.
Proof.
  induction l as [| h t]; cbn.
    trivial.
    apply Nat.add_le_mono.
      apply Nat.le_max_l.
      apply Nat.le_trans with (length t * maxL t).
        assumption.
        apply Nat.mul_le_mono.
          apply le_n.
          apply Nat.le_max_r.
Qed.

Fixpoint nat_ind_4
  (P : nat -> Type)
  (P0 : P 0)
  (P1 : P 1)
  (P2 : P 2)
  (P3 : P 3)
  (P4 : forall n : nat, P n -> P (4 + n))
  (n : nat) : P n :=
match n with
| 0 => P0
| 1 => P1
| 2 => P2
| 3 => P3
| S (S (S (S n'))) => P4 n' (nat_ind_4 P P0 P1 P2 P3 P4 n')
end.

Lemma two_and_five :
  forall n : nat,
    exists i j : nat, 4 + n = 2 * i + 5 * j.
Proof.
  induction n using nat_ind_4.
    exists 2, 0. cbn. reflexivity.
    exists 0, 1. cbn. reflexivity.
    exists 3, 0. cbn. reflexivity.
    exists 1, 1. cbn. reflexivity.
    destruct IHn as (i & j & IH).
      exists (2 + i), j. rewrite IH. lia.
Qed.

(** * Reguły indukcji dla typów zagnieżdżonych *)

Inductive RoseTree (A : Type) : Type :=
| E : RoseTree A
| N : A -> list (RoseTree A) -> RoseTree A.

Arguments E {A}.
Arguments N {A} _ _.

(** Rzućmy okiem na powyższy typ drzew różanych. Elementy tego typu są albo
    puste, albo są węzłami, które trzymają element typu [A] i listę poddrzew.

    A jak się ma reguła indukcji, którą Coq wygenerował nam dla tego typu?
    Mogłoby się wydawać, że jest najzwyczajniejsza w świecie, ale nic bardziej
    mylnego. *)

Check RoseTree_ind.
(* ===>
  RoseTree_ind :
    forall (A : Type) (P : RoseTree A -> Prop),
      P E ->
      (forall (a : A) (l : list (RoseTree A)), P (N a l)) ->
        forall r : RoseTree A, P r
*)

(** Jeśli dobrze się przyjrzeć tej regule, to widać od razu, że nie ma w niej
    żadnej ale to żadnej indukcji. Są tylko dwa przypadki bazowe: jeden dla
    drzewa pustego, a drugi dla węzła z dowolną wartością i dowolną listą
    poddrzew.

    Dzieje się tak dlatego, że induktywne wystąpienie typu [RoseTree A] jest
    zawinięte w [list], a Coq nie potrafi sam z siebie wygenerować czegoś w
    stylu "jedna hipoteza indukcyjna dla każdego drzewa t z listy ts". Musimy
    mu w tym pomóc!
*)

Print Forall.
(* ===>
Inductive Forall (A : Type) (P : A -> Prop) : list A -> Prop :=
| Forall_nil : Forall P [[]]
| Forall_cons :
    forall (x : A) (l : list A),
      P x -> Forall P l -> Forall P (x :: l).
*)

(** W tym celu przyda nam się induktywnie zdefiniowany predykat [Forall].
    Jeżeli [Forall P l] zachodzi, to każdy element listy [l] spełnia predykat
    [P]. Definicja jest prosta: każdy element pustej listy spełnia [P], a jeżeli
    głowa spełnia [P] i każdy element ogona spełnia [P], to każdy element całej
    listy spełnia [P].

    Dzięki [Forall] możemy już bez trudu wyrazić myśl "dla każdego elementu
    listy mamy hipotezę indukcyjną". Nie pozostaje nic innego, jak sformułować
    i udowodnić porządną regułę indukcji.
*)

Fixpoint RoseTree_ind'
  {A : Type} (P : RoseTree A -> Prop)
  (P_E : P E)
  (P_N : forall (v : A) (ts : list (RoseTree A)), Forall P ts -> P (N v ts))
  (t : RoseTree A) : P t.
Proof.
  destruct t as [| v ts].
  - exact P_E.
  - apply P_N.
    induction ts as [| t ts' IH].
    + constructor.
    + constructor.
      * exact (RoseTree_ind' A P P_E P_N t).
      * exact IH.
Defined.

(** Nasza reguła ma się następująco. Będziemy jej używać do dowodzenia, że każde
    drzewo różane [t] spełnia predykat [P : RoseTree A -> Prop] pod warunkiem, że:
    - drzewo puste spełnia [P]
    - jeżeli każde drzewo z listy [ts] spełnia [P], to dla dowolnego [v : A]
      drzewo [N v ts] również spełnia [P] *)

(** Dowód jest dość prosty. Zauważmy, że zaczyna się on od komendy [Fixpoint],
    ale mimo tego nie piszemy termu, ale odpalamy tryb dowodzenia. Wobec tego
    [RoseeTree_ind'] pojawia się w naszym kontekście jako hipoteza indukcyjna.

    Zaczynamy od rozbicia [t]. Gdy jest puste, kończymy hipotezą [P_E]. Gdy
    jest węzłem, używamy hipotezy [P_N]. Teraz trzeba udowodnić [Forall P ts],
    ale trochę nie ma jak - nasza hipoteza indukcyjna nam w tym nie pomoże, a
    [P_E] i [P_N] też nie za bardzo.

    Kluczową obserwacją w tym momencie jest, że [Forall P ts] jest zdefiniowany
    induktywnie i ma taki sam kształt, jak lista [ts] ([Forall P ts] to w sumie
    "udekorowanie" listy [ts] dowodami [P] dla poszczególnych elementów), więc
    powinniśmy rozumować przez indukcję po [ts].

    W obu przypadkach używamy konstruktora. Pierwszy jest banalny, zaś drugi
    generuje dwa kolejne podcele. W pierwszym używamy naszej "oryginalnej"
    hipotezy induktywnej [RoseTree_ind'], a w drugim hipotezy indukcyjnej
    pochodzącej z indukcji po liście [ts], którą nazwaliśmy [IH]. To kończy
    dowód.
*)

Fixpoint map {A B : Type} (f : A -> B) (t : RoseTree A) : RoseTree B :=
match t with
| E => E
| N v ts => N (f v) (List.map (map f) ts)
end.

(** Zobaczmy jeszcze tylko, jak użyć naszej nowitukiej reguły indukcji. W tym
    celu zdefiniujemy funkcję [map], analogiczną do tej dla list i innych rodzajów
    drzew, która są ci znane, oraz udowodnimy, że mapowanie identyczności to
    to samo co identyczność.
*)

Lemma map_id :
  forall {A : Type} (t : RoseTree A),
    map (fun x => x) t = t.
Proof.
  induction t using @RoseTree_ind'; cbn; [easy |].
  f_equal.
  induction H; cbn; [easy |].
  now rewrite H, IHForall.
Qed.

(** Dowód jest bardzo prosty. Zaczynamy przez indukcję po [t], używając naszej
    nowiutkiej reguły indukcji. Żeby użyć reguły indukcji innej niż domyślna,
    podajemy jej nazwę w klauzuli [using]. Zauważmy też, że musimy poprzedzić
    nazwę reguły indukcji symbolem [@], który sprawia, że argumenty domyślne
    przestają być domyślne. Jeżeli tego nie zrobimy, to Coq powie nam, że nie
    wie, skąd ma wziąć argument [A] (który nie został jeszcze wprowadzony do
    kontekstu).

    Przypadek bazowy jest łatwy, co ilustruje użycie taktyki [easy]. Ponieważ
    [id v = v], to wystarczy teraz pokazać, że twierdzenie zachodzi dla każdego
    drzewa z listy drzew [ts]. Chcemy w tym celu użyć hipotezy indukcyjnej [H],
    ale nie załatwia ona sprawy bezpośrednio: głosi ona, że zmapowanie [id] po
    każdym drzewie z [ts] daje oryginalne drzewo, ale nasz cel jest postaci
    [List.map (map id) ts = ts].

    Jako, że nie ma nigdzie w bibliotece standardowej odpowiedniego lematu,
    musimy znów wykonać indukcję, tym razem po [H]. Bazowy przypadek indukcji
    znów jest łatwy (taktyka [easy]), zaś w przypadku [cons]owym przepisujemy
    [map] w głowie i [List.map (map id)] w ogonie (to jest hipoteza indukcyjna
    z naszej drugiej indukcji) i jest po sprawie.
*)

Lemma map_id' :
  forall {A : Type} (t : RoseTree A),
    map (fun x => x) t = t.
Proof.
  induction t as [| v ts]; cbn; [easy |].
  f_equal.
  induction ts; cbn; [easy |].
  rewrite IHts.
Abort.

(** Zerknijmy jeszcze, co się stanie, jeżeli spróbujemy użyć autogenerowanej
    reguły indukcji. Początek dowodu przebiega tak samo, ale nie mamy do
    dyspozycji żadnych hipotez indukcyjnych, więc drugą indukcję robimy po
    [ts]. Jednak hipoteza indukcyjna z tej drugiej indukcji wystarcza nam
    jedynie do przepisania w ogonie, ale w głowie pozostaje [map id a],
    którego nie mamy czym przepisać. A zatem reguła wygenerowana przez Coqa
    faktycznie jest za mało ogólna.
*)

(** ** Podsumowanie *)

(** Podsumowując: Coq nie radzi sobie z generowaniem reguł indukcji dla
    zagnieżdżonych typów induktywnych, czyli takich, w których definiowany
    typ występuje jako argument innego typu, jak np. [list] w przypadku
    [RoseTree].

    Żeby rozwiązać ten problem, musimy sami sformułować i udowodnić sobie
    bardziej adekwatną regułę indukcji. W tym celu musimy dla zagnieżdżającego
    typu (czyli tego, w którym występuje definiowany przez nas typ, np. [list]
    dla [RoseTree]) zdefiniować predykat [Forall], który pozwoli nam wyrazić,
    że chcemy mieć hipotezę indukcją dla każdego jego elementu. Dowód reguły
    indukcji jest dość prosty i przebiega przez zagnieżdżoną indukcję - na
    zewnątrz w postaci komendy [Fixpoint], a wewnątrz w postaci indukcji po
    dowodzie [Forall].

    Powstałej w ten sposób reguły indukcji możemy używać za pomocą komendy
    [induction ... using ...], przy czym zazwyczaj i tak będziemy musieli
    użyć jeszcze jednej zagnieżdżonej indukcji, żeby cokolwiek osiągnąć.
*)

(** ** Papiery *)

(** Generowanie reguł indukcji dla zagnieżdżonych typów induktywnych:
    #
    Generating Induction Principles for Nested Inductive Types in MetaCoq#

    Patrz też: #
    Deriving proved equality tests in Coq-elpi: Stronger induction principles for
    containers in Coq# (unarna translacja parametryczna)
*)

(** * Głęboka indukcja (TODO) *)

(** Zacznijmy od krótkiego podsumowania naszej dotychczasowej podróży przez
    świat reguł indukcji.

    Standardowe reguły indukcji dla danego typu to te, które kształtem
    odpowiadają dokładnie kształtowi tego typu. Dla [nat] jest to reguła
    z przypadkiem bazowym zero oraz przypadkiem indukcyjnym (czyli "krokiem")
    następnikowym. Dla list jest to reguły z przypadkiem bazowym [nil] i
    "krokiem" [cons]. Zazwyczaj dostajemy je od Coqa za darmo po zdefiniowaniu
    typu, ale dla typów zagnieżdżonych musimy zdefiniować je sobie sami.

    Niestandardowe reguły indukcji to te, których kształt różni się od kształtu
    typu - w zależności od potrzeb i problemu, który próbujemy rozwiązać. Dla
    [nat] może to być np. reguła z bazowymi przypadkami 0 i 1 oraz krokiem
    "co 2". Definiujemy je ręcznie, przez dopasowanie do wzorca i rekursję
    strukturalną.

    Proste, prawda? Otóż nie do końca.
*)

Inductive ForallT {A : Type} (P : A -> Type) : list A -> Type :=
| ForallT_nil  : ForallT P []
| ForallT_cons :
    forall {h : A} {t : list A},
      P h -> ForallT P t -> ForallT P (h :: t).

Fixpoint list_ind_deep
  {A : Type} (P : list A -> Type) (Q : A -> Type)
  (nil : P [])
  (cons : forall {h : A} {t : list A}, Q h -> P t -> P (h :: t))
  (l : list A) (l' : ForallT Q l) {struct l'} : P l.
Proof.
  destruct l' as [| h t Qh FQh].
  - exact nil.
  - apply cons.
    + exact Qh.
    + apply (list_ind_deep _ P Q); assumption.
Defined.

Module RecursiveDeepInd.

Fixpoint ForallT' {A : Type} (P : A -> Type) (l : list A) : Type :=
match l with
| [] => unit
| h :: t => P h * ForallT' P t
end.

Fixpoint list_ind_deep'
  {A : Type} (P : list A -> Type) (Q : A -> Type)
  (nil : P [])
  (cons : forall (h : A) (t : list A),
            Q h -> P t -> P (h :: t))
  (l : list A) (l' : ForallT' Q l) {struct l} : P l.
Proof.
  destruct l as [| h t].
  - exact nil.
  - destruct l' as [Qh FQh].
    apply cons.
    + exact Qh.
    + apply (list_ind_deep' _ P Q); assumption.
Defined.

End RecursiveDeepInd.

(** Dla drzewek różanych. *)

Inductive RoseTree' {A : Type} (P : A -> Type) : RoseTree A -> Type :=
| E' : RoseTree' P E
| N' : forall (x : A) (ts : list (RoseTree A)),
         P x -> ForallT (RoseTree' P) ts -> RoseTree' P (N x ts).

Arguments E' {A P}.
Arguments N' {A P x ts} _ _.

Fixpoint RoseTree_ind_deep'
  {A : Type} (P : RoseTree A -> Type) (Q : A -> Type)
  (e : P E)
  (n : forall (x : A) (ts : list (RoseTree A)),
         Q x -> ForallT P ts -> P (N x ts))
  {t : RoseTree A} (t' : RoseTree' Q t) {struct t'} : P t.
Proof.
  destruct t' as [| x l Qx FQt].
    exact e.
    apply n.
      exact Qx.
      induction FQt as [| hFQt tFQt]; constructor.
        apply (RoseTree_ind_deep' _ P Q); assumption.
        apply IHFQt.
Defined.