From Complexity.Complexity Require Import NP.
From Undecidability.TM Require TM ProgrammingTools CaseList.
From Undecidability.TM Require Import TM_facts SizeBounds.

From Complexity.NP.TM  Require Import TMGenNP_fixed_mTM.
From Undecidability.TM.Single Require EncodeTapes StepTM.
From Complexity.TM.Single Require DecodeTapes.

From Undecidability Require Import TM.Util.VectorPrelim.
From Complexity.Libs Require Import PSLCompat.

Unset Printing Coercions.

From Coq Require Import Lia Ring Arith.

Module MultiToMono.
  Section multiToMono.

    (** We can simulate any machine while first testing that we indeed work on a valid n-tape encoding *)
    Import EncodeTapes DecodeTapes Single.StepTM ProgrammingTools Combinators Decode.
    Context (sig F:finType) (n:nat) (M__multi : pTM sig F n).

    Definition M : pTM ((sigList (sigTape sig)) ^+) (option F) 1 :=
      If (CheckTapeContains.M (CheckEncodesTapes.M n))
         (Move Lmove;;If (Relabel ReadChar (Option.apply (fun _ => false) true))
                     (Move Rmove;;Relabel (ToSingleTape M__multi) Some)
                     (Return Nop None))
         (Return Nop None).

    Definition Rel : pRel ((sigList (sigTape sig)) ^+) (option F) 1 :=
      fun t '(y,t') => match y with
                      None => ~ exists (v : tapes sig n), StepTM.contains_tapes t[@Fin0] v
                    | Some y => exists (v v': tapes sig n), StepTM.contains_tapes t[@Fin0] v
                                                      /\ StepTM.contains_tapes t'[@Fin0] v'
                                                      /\ Canonical_Rel M__multi v (y,v')
                    end.

    Lemma Realise : M ⊨ Rel .
    Proof.
      intros H__multi.
      eapply Realise_monotone.
      {unfold M. TM_Correct.
       -refine (CheckTapeContains.Realise _ _). now apply CheckEncodesTapes.Realise. now apply tapes_encode_prefixInjective.
       -eapply ToSingleTape_Realise', Canonical_Realise.
      }
      intros t (y,t'). cbn in *.
      intros [H|H];unfold Rel;cbn.
      2:{ destruct H as (?&([Henc]&_)&->&_&<-). intros (v&Hv). hnf in Hv. inversion Henc. apply H.
          exists v,[]. rewrite Hv. now rewrite Encode_map_id. }
      destruct H as (?&[[Henc] <-]&_&t1&Ht1&H). 2:easy.
      destruct H as [H|H].
      2:{ destruct H as (?&(?&?&->&<-)&->&_&<-). rewrite Ht1 in H. intros (v&Ht). hnf in Ht.
          rewrite Ht in H. now cbn in H. }
      destruct H as (?&(?&Hc1&->&->)&(_&t2&Ht2&y'&->&Hm)).
      rewrite Ht1 in Ht2. destruct (current t1[@Fin0]) eqn:Hc1';inv Hc1.
      inv Henc. rename H into Henc. destruct Henc as (x'&t__L&Henc). rewrite Encode_map_id in Henc.
      erewrite tape_move_left_right in Ht2. 2:now rewrite Henc.
      rewrite Ht2 in *. clear Ht2 t2. rewrite Ht1 in *. clear Ht1 t1.
      destruct t__L. 2:now rewrite Henc in Hc1'.
      specialize Hm with (1:=Henc) as (?&(?&?&?&<-&<-)&?).
      do 3 eexists. exact Henc. split. eauto.
      unfold Canonical_T;eauto.
    Qed.

    Context (T__multi : tRel sig n).

    Definition Ter : tRel ((sigList (sigTape sig)) ^+) 1 :=
      fun t k  => exists (k' k__sim: nat), (forall (v : tapes sig n),
                                   StepTM.contains_tapes t[@Fin0] v
                                   -> T__multi v k__sim
                                     /\ Loop_steps (start (projT1 M__multi)) v k__sim <= k')
                               /\ (S (| right t[@Fin0] |)*4*(n+1) + n*16 + 27 + k') <= k .
    Lemma Terminates  : projT1 M__multi ↓ T__multi -> projT1 M ↓ Ter.
    Proof.
      intros H__multi.
      eapply TerminatesIn_monotone.
      {unfold M. TM_Correct.
       -eapply CheckTapeContains.Realise. now apply CheckEncodesTapes.Realise. now apply tapes_encode_prefixInjective.
       -eapply CheckTapeContains.Terminates. now apply CheckEncodesTapes.Realise. apply CheckEncodesTapes.Terminates.
       -eapply ToSingleTape_Terminates'. eassumption.
      }
      intros t k (k'&k__sim&Hk__sim&Hk). infTer 2. infTer 2. hnf. reflexivity.
      split. shelve.
      intros ? b [Henc Hbeq]. destruct b. 2:now apply Nat.le_0_l.
      infTer 4. intros t1 [] Ht1. cbn in Ht1.
      infTer 4. cbn. intros t2 b (?&Hb&->&->).
      destruct b. 2:now apply Nat.le_0_l.
      infTer 4. intros t2 _ Ht2. hnf.
      destruct Henc. inv H. rename H0 into Henc. destruct Henc as (v&t__L&Heq).
      rewrite Ht1 in Ht2. specialize (Hbeq eq_refl). subst tout. cbn in *.
      rewrite Heq in Ht1. rewrite Ht1 in Hb. destruct t__L;inv Hb. rewrite Heq in Ht2. cbn in Ht2.
      rewrite Ht2. clear Ht2 Ht1 t1 t2.
      edestruct Hk__sim as (H__k&Hk__sim').  1:{ hnf. rewrite Heq. now rewrite map_id. }
      eexists v,_. split. 1:{ hnf. now rewrite map_id. }
      split. eassumption. eassumption.
      Unshelve. cbn - [plus mult]. rewrite CheckEncodesTapes.length_right_tape_move_right. cbn - [plus mult].
      ring_simplify.
      transitivity (S (| right t[@Fin0] |)*4*(n+1) + n*16 + 27 + k'). cbn - [plus mult].
      abstract nia. exact Hk.
    Qed.
  End multiToMono.
End MultiToMono.
Arguments MultiToMono.Rel : simpl never.
Arguments MultiToMono.Ter : simpl never.

Section putFirst.
  (** putting the first element at the end of an vector *)

  Definition putFirstAtEnd n: Vector.t (Fin.t (S n)) (S n):=
    Vectors.tabulate (fun i => match lt_dec (S (proj1_sig (Fin.to_nat i))) (S n) with
                      Specif.left H => Fin.of_nat_lt H
                    | _ => Fin.F1
                    end).
  Arguments putFirstAtEnd : simpl never.

  Definition putEndAtFirst n': Vector.t (Fin.t (S n')) (S n').
    refine (Vectors.tabulate (fun i => match Fin.to_nat i with
                            | exist 0 H => Fin.of_nat_lt (Nat.lt_succ_diag_r n')
                            | exist n' H => Fin.of_nat_lt (p:=n'-1) _
                            end )). abstract nia.
  Defined.
  Arguments putEndAtFirst : simpl never.

  Section printFin.
    Local Arguments Fin.t : clear implicits.
    Local Arguments Fin.FS : clear implicits.
    Local Arguments Fin.F1 : clear implicits.
    Local Arguments Vector.cast : clear implicits.

    Lemma putFirstAtEnd_dupfree m: VectorDupfree.dupfree (putFirstAtEnd m).
    Proof.
      clear_all. apply dupfree_tabulate_injective.
      intros i j. destruct (Fin.to_nat i) as [i' Hi] eqn:eqi. destruct (Fin.to_nat j) as [j' Hj] eqn:eqj .
      cbn. 1:do 2 destruct lt_dec. 2,3:easy.
      2:{ intros _. apply Fin.to_nat_inj. rewrite eqi. rewrite eqj. cbn. clear eqi eqj. nia. }
      intros H%Fin.FS_inj. apply Fin.to_nat_inj.
      rewrite eqi,eqj. cbn.
      assert (H1 : i' < m) by now apply Nat.succ_lt_mono.
      assert (H2 : j' < m) by now apply Nat.succ_lt_mono.
      erewrite <- (Fin.of_nat_ext H1), <- (Fin.of_nat_ext H2) in H.
      apply(f_equal Fin.to_nat) in H. rewrite !Fin.to_nat_of_nat in H.
      now inv H.
    Qed.

    Lemma putEndAtFirst_dupfree m: VectorDupfree.dupfree (putEndAtFirst m).
    Proof.
      clear_all. apply dupfree_tabulate_injective.
      intros i j.
      destruct (Fin.to_nat i) eqn:?;destruct (Fin.to_nat j) eqn:?; cbn in *.
      eassert (H'1:=Heqs). assert (H'2:=Heqs0).
      erewrite <- (Fin.of_nat_to_nat_inv i) in Heqs. erewrite <- (Fin.of_nat_to_nat_inv j) in Heqs0.
      rewrite Fin.to_nat_of_nat in Heqs. rewrite Fin.to_nat_of_nat in Heqs0. inversion Heqs; inversion Heqs0.
            destruct (fin_destruct_S i) as [ (i'&->) | ->]; destruct (fin_destruct_S j) as [ (j'&->) | ->].
            all:try change (Fin.FS m i') with (Fin.R 1 i') in *; try change (Fin.FS m j') with (Fin.R 1 j') in *.
            all:change (S m) with (1+m) in *.
            all: rewrite ?Fin.R_sanity in H0;rewrite ?Fin.R_sanity in H1. all: subst;cbn.
            all:intros Heq%(f_equal Fin.to_nat).
            all:rewrite !Fin.to_nat_of_nat in Heq.
            all:inversion Heq as [H2]. all:try rewrite ?Nat.sub_0_r in H2.
            all:try apply Fin.to_nat_inj in H2. all:try easy.
    Qed.

  End printFin.

  Import LiftTapes.

  Lemma putFirstAtEnd_to_list X n' (x:X) xs:
    (Vector.to_list (select (putFirstAtEnd n') (x ::: xs))) = Vector.to_list xs ++ [x].
  Proof.
    apply nth_error_inj. intros i.
    rewrite !vector_nth_error_nat. destruct lt_dec.
    { rewrite select_nth. unfold putFirstAtEnd. rewrite nth_tabulate,Fin.to_nat_of_nat;cbn.
      destruct lt_dec.
      -erewrite nth_error_app1. 2:now erewrite Vector.length_to_list.
       cbn. rewrite vector_nth_error_nat. destruct lt_dec. 2:exfalso;nia.
       erewrite Fin.of_nat_ext. reflexivity.
      -cbn. rewrite nth_error_app2. all:rewrite Vector.length_to_list. 2:nia. replace (i-n') with 0 by nia. easy.
    }
    symmetry. apply nth_error_None. erewrite app_length, Vector.length_to_list. cbn;nia.
  Qed.

  Lemma putEnd_invL X n' (v : Vector.t X _) :
    select (putEndAtFirst n') (select (putFirstAtEnd n') v) = v.
  Proof.
    apply Vector.eq_nth_iff. intros i ? <-. rewrite !select_nth.
    f_equal.
    unfold putEndAtFirst,putFirstAtEnd. rewrite !nth_tabulate.
    destruct (fin_destruct_S i) as  [(i'&->) | ->].
    2:{ cbn. rewrite Fin.to_nat_of_nat. cbn. destruct lt_dec. now exfalso;nia. easy. }
    eapply Fin.to_nat_inj.
    remember (Fin.to_nat (Fin.FS i')) as i0 eqn:H. set (tmp:=proj1_sig i0).
    rewrite (sig_eta i0). subst tmp i0. cbn.
    destruct (Fin.to_nat i') eqn:H.
    cbn. rewrite Fin.to_nat_of_nat;cbn. destruct lt_dec;cbn.
    -rewrite (sig_eta (Fin.to_nat _)). cbn. rewrite Fin.to_nat_of_nat. cbn. nia.
    -clear H. nia.
  Qed.

  Lemma putEndAtFirst_to_list X n' v (ts:X) v0:
    Vector.to_list v ++ [ts] = Vector.to_list v0 ->
    select (putEndAtFirst n') v0 = ts ::: v.
  Proof using.
    intros H. rewrite <- putFirstAtEnd_to_list in H. apply vector_to_list_inj in H.
    subst v0. now setoid_rewrite putEnd_invL.
  Qed.

End putFirst.

From Undecidability Require Import Datatypes.Lists LBool.
From Complexity Require Import L.TM.CompCode.

Section lemmas_for_LMGenNP_to_TMGenNP_mTM.
  Import EncodeTapes DecodeTapes Single.StepTM ProgrammingTools Combinators Decode.
  Import LVector.
  Import TM.

  Context (sig:finType) (n:nat)  (M : TM sig (S n)).

  Definition M__mono : pTM ((sigList (sigTape sig)) ^+) unit 1 :=
    If (Move Rmove ;; Relabel (MultiToMono.M (LiftTapes (M;(fun _ => tt)) (putEndAtFirst n) )) (Option.apply (fun _ => true) false))
       Nop
       Diverge.

  Local Arguments Canonical_Rel : simpl never.
  Lemma Realises__mono:
    M__mono ⊨(fun tin '(_,tout) =>
              exists v v' : tapes sig (S n),
                contains_tapes (tape_move_right tin[@Fin0]) v /\
                contains_tapes tout[@Fin0] v' /\
                Canonical_Rel (LiftTapes (existT (fun x : TM sig (S n) => state x -> unit) M (fun _ : state M => tt)) (putEndAtFirst n)) v
                              (tt, v')).
  Proof.
    eapply Realise_monotone.
    { unfold M__mono. TM_Correct. apply MultiToMono.Realise. } cbn.
    intros tin ([],tout). cbn. intros [H|H].
    2:now decompose record H.
    destruct H as (?&([]&t1&Ht1&b&Hb&H__mono)&<-). destruct b as [ [] | ] ;inv Hb.
    hnf in H__mono. cbn - [Canonical_Rel]in *|-*. rewrite Ht1 in *|-*. easy.
  Qed.

    Lemma Terminates_False sig' n' (M' : TM sig' n'): M' ↓ (fun _ _ => False).
  Proof.
    easy.
  Qed.

  Lemma Terminates__mono:
    projT1 M__mono ↓ (fun t k => exists (v : tapes _ (S n)) k',
                        contains_tapes (tape_move_right t[@Fin0]) v
                        /\ MultiToMono.Ter (LiftTapes (existT _ M (fun _  => tt)) (putEndAtFirst n))
                                          (LiftTapes_T (putEndAtFirst n) (Canonical_T M))
                                          [|(tape_move_right t[@Fin0])|] k'
                        /\ k' + 3 <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold M__mono. TM_Correct.
      -apply MultiToMono.Realise.
      -eapply MultiToMono.Terminates. apply LiftTapes_Terminates. apply putEndAtFirst_dupfree. eapply Canonical_TerminatesIn.
      -apply Terminates_False.
    }
    intros tin k (v&k'&Hv&HT&Hk). cbn.
    infTer 7. intros t1 _ Ht1. unfold tapes in *. destruct_vector;cbn in *. subst h. apply HT. shelve.
    intros tout b (?&t1&Ht1&[[]| ]&->&Hr). all:cbn. 2:{ apply Hr. cbn in *. rewrite <- Ht1 in *. easy. } reflexivity.
    Unshelve.
    { rewrite <- Hk. nia. }
  Qed.

  Lemma concat_eq_inv_borderL X isBorder xs R__L ys b (R__R : list X):
    (forall x, x el xs -> exists hd tl, x = hd::tl /\ isBorder hd /\ forall c, c el tl -> ~isBorder c) ->
    (forall x, x el ys -> exists hd tl, x = hd::tl /\ isBorder hd /\ forall c, c el tl -> ~isBorder c) ->
    (forall x, x el R__R -> ~isBorder x) ->
    isBorder b ->
    concat xs ++ b::R__L = concat ys++R__R ->
    (forall i, i < length xs -> nth_error xs i = nth_error ys i) /\ b::R__L = concat (skipn (length xs) ys) ++ R__R.
  Proof.
    clear. induction xs as [ | x xs] in ys|-*;intros HL HR HRR Hb Heq.
    { cbn in *. easy. }
    destruct ys as [ |y ys].
    { exfalso. cbn in Heq. subst R__R.
      destruct (HL x) as (?&?&->&?&?). easy. eapply HRR. 2:easy. cbn;easy. }
    cbn in Heq. autorewrite with list in Heq.
    destruct (HL x) as (x__hd&x__tl&->&Hxhd&Hxtl). easy.
    destruct (HR y) as (y__hd&y__tl&->&_&Hytl). easy.
    cbn in *.
    revert Heq. intros [= <- Heq].
    replace y__tl with x__tl in *.
    2:{ induction x__tl as [ | x' xtl] in y__tl,Heq,HL,HR,Hytl,Hxtl|-*.
        -destruct y__tl. easy. cbn in Heq. destruct xs.
         +now edestruct (Hytl x);inv Heq.
         +edestruct (HL l) as (?&?&->&?&?). easy. inv Heq. now edestruct Hytl.
        -destruct y__tl.
         2:{ inv Heq. f_equal. eapply IHxtl. 3-5:cbn;intros;auto.
             all:intros z [<-| ].  all:now eauto 7.
         }
         exfalso. destruct ys. 2:{ edestruct (HR l) as (?&?&->&?&?). easy. inv Heq. cbn in *. now eapply Hxtl. }
         cbn in Heq.
         inv Heq. eapply HRR. 2:exact Hb. eauto 10.
    }
    apply app_inv_head in Heq. apply IHxs in Heq.  2-5:now eauto 7.
    destruct Heq as (IH&->). split. 2:easy.
    intros [] ?. easy. cbn. apply IH. nia.
  Qed.

  Lemma contains_tapes_inj (sig' : finType) n' t (v v' : tapes sig' n'):
    contains_tapes t v -> contains_tapes t v' -> v = v'.
  Proof.
    unfold contains_tapes. intros -> [= eq]. apply app_inv_tail in eq. apply map_injective in eq. 2:congruence.
    eassert (H':=tapes_encode_prefixInjective (t:=[]) (t':=[])). rewrite !app_nil_r in H'. apply H' in eq. easy.
  Qed.

End lemmas_for_LMGenNP_to_TMGenNP_mTM.

Arguments putFirstAtEnd : simpl never.
Arguments putEndAtFirst : simpl never.


(* This file contains tactics that are similar to ssreflect tactics.
 * The tactics here use numbers to refer to hypotheses to the right
 * of the entailment.
 *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Tactics.Tactics.

Section indexed.
  Context {L : Type}
          {ILO : ILogicOps L}
          {IL : ILogic L}.

  (* Destruct *)
  Theorem destruct_top
  : forall A B C D : L,
      A |-- B -->> C -->> D ->
      A |-- B //\\ C -->> D.
  Proof. intros. rewrite H. charge_tauto. Qed.

  (* Split *)
  Theorem split_top
  : forall A B C D : L,
      A |-- B -->> D ->
      A |-- C -->> D ->
      A |-- B \\// C -->> D.
  Proof.
    intros. charge_intros.
    charge_cases.
    - charge_apply H; charge_tauto.
    - charge_apply H0; charge_tauto.
  Qed.

  (* Move *)
  Theorem move_top
  : forall A B C D : L,
      A //\\ C |-- B -->> D ->
      (A //\\ B) //\\ C |-- D.
  Proof.
    intros. charge_apply H.
    charge_tauto.
  Qed.

  (* Copy *)
  Theorem copy_top
  : forall A B C : L,
      A |-- B -->> B -->> C ->
      A |-- B -->> C.
  Proof.
    intros. rewrite H. charge_tauto.
  Qed.

  (* Copy *)
  Theorem clear_top
  : forall A B C : L,
      A |-- C ->
      A |-- B -->> C.
  Proof.
    intros. rewrite H. charge_tauto.
  Qed.

  Theorem skip_top : forall A B C D : L,
      (A //\\ B) //\\ C |-- D ->
      A //\\ C |-- B -->> D.
  Proof.
    intros. charge_intros. charge_apply H.
    charge_tauto.
  Qed.

  Lemma apply_ctx : forall A B C : L,
      C |-- A ->
      C //\\ (A -->> B) |-- B.
  Proof.
    intros. rewrite H. charge_tauto.
  Qed.

  Lemma apply_ctx' : forall A B C D : L,
      C //\\ B |-- D ->
      C |-- A ->
      C //\\ (A -->> B) |-- D.
  Proof.
    intros. charge_apply H. rewrite <- H0 at 1.
    charge_tauto.
  Qed.
End indexed.

Ltac charge_destruct_n n :=
  match n with
  | 0 => apply destruct_top
  | S ?n => charge_intro; charge_destruct_n n ; charge_revert
  end.

Ltac charge_split_n n :=
  match n with
  | 0 => apply split_top
  | S ?n => charge_intro; charge_split_n n; charge_revert
  end.

Ltac charge_move_n n :=
  let rec move_n n :=
      match n with
      | 0 => apply limplAdj
      | S ?n => apply limplAdj ; move_n n ; apply move_top
      end
  in
  move_n n ; charge_revert.

Ltac charge_copy_n n :=
  match n with
  | 0 => apply copy_top
  | S ?n => charge_intro ; charge_copy_n n ; charge_revert
  end.

Ltac charge_clear_n n :=
  match n with
  | 0 => apply clear_top
  | S ?n => charge_intro ; charge_copy_n n ; charge_revert
  end.

Ltac charge_apply_n n :=
  charge_move_n n ; apply limplAdj ;
  let rec try_apply k :=
      first [ apply apply_ctx ; k
            | apply apply_ctx'; [ try_apply k | k ] ]
  in
  let rec try_each k :=
      first [ try_apply k
            | apply skip_top ;
              let k' := (charge_revert; k) in
              try_each k' ]
  in
  try_each idtac.

Tactic Notation "charge" "apply" constr(n) := charge_apply_n n.
Tactic Notation "charge" "move" constr(n) := charge_move_n n.
Tactic Notation "charge" "clear" constr(n) := charge_clear_n n.
Tactic Notation "charge" "destruct" constr(n) := charge_destruct_n n.
Tactic Notation "charge" "split" constr(n) := charge_split_n n.

Section demo.
  Context {L : Type}
          {ILO : ILogicOps L}
          {IL : ILogic L}.

  Goal forall D E F G : L,
      |-- (D -->> F) -->> E //\\ (F \\// D) -->> (E -->> F -->> G) -->> G.
  Proof. intros.
         charge destruct 1.
         charge split 2.
         { charge apply 3. charge_tauto. }
         { charge_tauto. }
  Qed.
End demo.


From CoindSemWhile Require Import SsrExport Trace Language BigRel.

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

Section Exec.

Variable tt: expr.
Hypothesis tt_spec: forall st, is_true (tt st) = true.

CoInductive exec1: stmt -> state -> trace -> Prop :=
| exec1_skip: forall st,
    exec1 Sskip st (Tnil st)
| exec1_assign: forall id a st,
    exec1 (Sassign id a) st (Tcons st (Tnil (update id (a st) st)))
| exec1_seq: forall s1 s2 st tr tr',
    exec1 s1 st tr ->
    execseq1 s2 tr tr' ->
    exec1 (Sseq s1 s2) st tr'
| exec1_ifthenelse_true: forall a s1 s2 st tr,
    is_true (a st) = true ->
    execseq1 s1 (Tcons st (Tnil st)) tr ->
    exec1 (Sifthenelse a s1 s2) st tr
| exec1_ifthenelse_false: forall a s1 s2 st tr,
    is_true (a st) = false ->
    execseq1 s2 (Tcons st (Tnil st)) tr ->
    exec1 (Sifthenelse a s1 s2) st tr
| exec1_while_false: forall a s st,
    is_true (a st) = false ->
    exec1 (Swhile a s) st (Tnil st)
| exec1_while_loop: forall a s st tr tr',
    is_true (a st) = true ->
    exec1 s st tr ->
    execseq1 (Swhile a s) tr tr' ->
    exec1 (Swhile a s) st tr'

with execseq1: stmt -> trace -> trace -> Prop :=
| exec1_nil: forall st s tr,
  exec1 s st tr ->
  execseq1 s (Tnil st) tr
| exec1_cons: forall tr s tr' e,
  execseq1 s tr tr' ->
  execseq1 s (Tcons e tr) (Tcons e tr').

Lemma lemma1: forall st tr, exec1 (Swhile tt Sskip) st tr.
Proof.
cofix COINDHYP. move => st tr. apply: exec1_while_loop.
* by apply: tt_spec.
* by apply exec1_skip.
* by have := exec1_nil (COINDHYP st tr); apply.
Qed.

CoInductive last_true (e: expr): trace -> Prop :=
| last_true_nil: forall st,
  is_true (e st) = true ->
  last_true e (Tnil st)
| last_true_cons: forall st tr,
  last_true e tr ->
  last_true e (Tcons st tr).

CoInductive last_false (e: expr): trace -> Prop :=
| last_false_nil: forall st,
  is_true (e st) = false ->
  last_false e (Tnil st)
| last_false_cons: forall st tr,
  last_false e tr ->
  last_false e (Tcons st tr).

CoFixpoint duplast (tr: trace): trace :=
match tr with
| Tnil st => Tcons st (Tnil st)
| Tcons st tr' => Tcons st (duplast tr')
end.

CoFixpoint updatelast (id: id) (e: expr) (tr: trace): trace :=
match tr with
| Tnil st => Tcons st (Tnil (update id (e st) st))
| Tcons st tr' => Tcons st (updatelast id e tr')
end.

CoInductive execseq2: stmt -> trace -> trace -> Prop :=
| execseq2_skip: forall tr,
    execseq2 Sskip tr tr
| execseq2_assign: forall id a tr,
    execseq2 (Sassign id a) tr (updatelast id a tr)
| execseq2_seq: forall s1 s2 tr tr' tr'',
    execseq2 s1 tr tr' ->
    execseq2 s2 tr' tr'' ->
    execseq2 (Sseq s1 s2) tr tr''
| execseq2_ifthenelse_true: forall a s1 s2 tr tr',
    last_true a tr ->
    execseq2 s1 (duplast tr) tr' ->
    execseq2 (Sifthenelse a s1 s2) tr tr'
| execseq2_ifthenelse_false: forall a s1 s2 tr tr',
    last_false a tr ->
    execseq2 s2 (duplast tr) tr' ->
    execseq2 (Sifthenelse a s1 s2) tr tr'
| execseq2_while_false: forall a s tr,
    last_false a tr ->
    execseq2 (Swhile a s) tr (duplast tr)
| execseq2_while_loop: forall a s tr tr' tr'',
  last_true a tr ->
  execseq2 s (duplast tr) tr' ->
  execseq2 (Swhile a s) tr' tr'' ->
  execseq2 (Swhile a s) tr tr''.

Inductive exec2: stmt -> state -> trace -> Prop :=
| exec2_intro: forall s st tr,  execseq2 s (Tnil st) tr -> exec2 s st tr.

Lemma lemma2: forall st tr, exec2 (Swhile tt Sskip) st tr.
Proof.
have h1: forall tr tr', execseq2 (Swhile tt Sskip) tr tr'.
* cofix COINDHYP. move => tr tr'.
  have := (@execseq2_while_loop _ _ _ (duplast tr) tr'); apply.
  * move: tr. cofix COINDHYP2. case.
    - move => st. apply: last_true_nil. by apply: tt_spec.
    - move => st tr. by have := last_true_cons _ (COINDHYP2 _); apply.
  * by apply: execseq2_skip.
  * by apply: COINDHYP.
* move => st tr. apply: exec2_intro. by apply: h1.
Qed.

Lemma lemma3: forall x st tr, exec2 (Swhile tt (Sassign x (fun st => (st x + 1)))) st tr.
Proof.
move => x.
have h1: forall tr tr', execseq2 (Swhile tt (Sassign x (fun st => (st x + 1)))) tr tr'.
* cofix COINDHYP. move => tr0 tr1.
  have := (@execseq2_while_loop _ _ _ (updatelast x (fun st => (st x + 1)) (duplast tr0)) tr1); apply.
  * move: tr0. cofix COINDHYP0. case.
    - move => st. apply: last_true_nil. by apply: tt_spec.
    - move => st tr. by have := last_true_cons _ (COINDHYP0 _); apply.
  * by apply: execseq2_assign.
  * by apply: COINDHYP.
* move => st tr. apply: exec2_intro. by apply: h1.
Qed.

End Exec.

CoInductive split: trace -> trace -> state -> trace -> Prop :=
| split_nil: forall st,
  split (Tnil st) (Tnil st) st (Tnil st)
| split_cons: forall st tr,
  split (Tcons st tr) (Tnil st) st (Tcons st tr)
| split_delay: forall st st' tr tr' tr'',
  split tr tr' st' tr'' ->
  split (Tcons st tr) (Tcons st tr') st' tr''.

CoInductive exec3: stmt -> state -> trace -> Prop :=
| exec3_skip: forall st,
  exec3 Sskip st (Tnil st)
| exec3_assign: forall id a st,
  exec3 (Sassign id a) st (Tcons st (Tnil (update id (a st) st)))
| exec3_seq: forall s1 s2 st st' tr tr' tr'',
  split tr tr' st' tr'' ->
  exec3 s1 st tr' ->
  exec3 s2 st' tr'' ->
  exec3 (Sseq s1 s2) st tr
| exec3_ifthenelse_true: forall a s1 s2 st tr,
  is_true (a st) = true ->
  exec3 s1 st tr ->
  exec3 (Sifthenelse a s1 s2) st (Tcons st tr)
| exec3_ifthenelse_false: forall a s1 s2 st tr,
  is_true (a st) = false ->
  exec3 s2 st tr ->
  exec3 (Sifthenelse a s1 s2) st (Tcons st tr)
| exec3_while_false: forall a s st,
  is_true (a st) = false ->
  exec3 (Swhile a s) st (Tcons st (Tnil st))
| exec3_while_loop: forall a s st st' tr tr' tr'',
  split tr tr' st' tr'' ->
  is_true (a st) = true ->
  exec3 s st tr' ->
  exec3 (Swhile a s) st' tr'' ->
  exec3 (Swhile a s) st (Tcons st tr).

Lemma lemma4: forall s st tr, exec3 s st tr -> exec s st tr.
Proof.
cofix  COINDHYP. move => s st tr h1. foo h1.
- by apply: exec_skip.
- by apply: exec_assign.
- have := exec_seq (COINDHYP _ _ _ H0); apply.
  move => {H0}. move: tr' st' tr'' tr H H1. cofix COINDHYP0.
  move => st0 st1 tr0 tr1 h1 h2. foo h1.
  - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
  - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
  - apply execseq_cons. by have := COINDHYP0 _ _ _ _ H h2; apply.
- apply exec_ifthenelse_true.
  * by apply H.
  * apply execseq_cons. apply execseq_nil.
     have := COINDHYP _ _ _ H0; apply.
- apply exec_ifthenelse_false.
  * by apply H.
  * apply execseq_cons. apply execseq_nil.
    have := COINDHYP _ _ _ H0; apply.
- apply exec_while_false. by apply H.
- apply: exec_while_loop.
  * by apply H0.
  * apply execseq_cons. apply execseq_nil.
     have h:= COINDHYP _ _ _ H1. by apply h.
  * apply execseq_cons. move => {H0 H1}. move: tr0 st' tr' tr'' H H2.
    cofix COINDHYP0. move => tr0 st0 tr1 tr2 h1 h2. foo h1.
    - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
    - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
    - apply execseq_cons. by have := COINDHYP0 _ _ _ _ H h2.
Qed.


Require Import Coq.Relations.Relations.
Require Import Coq.Setoids.Setoid.
Require Import Coq.funind.Recdef.
Require Import Coq.PArith.BinPos.
Require Import Lia.
From compcert.lib Require Import Maps.

Require Import Coq.Lists.List.
Import ListNotations.

Require Import Ltac2.Ltac2.
Import Ltac2.Notations.
Set Default Proof Mode "Ltac2".

Require Import Coq.Logic.JMeq.
Require Import Coq.Logic.Eqdep.
Ltac inv_ex :=
  repeat progress match goal with
  | H : existT ?P ?T _ = existT ?P ?T _ |- _ => apply inj_pairT2 in H
  end.

Require Export CertiCoq.LambdaANF.Frame.

Set Implicit Arguments.

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

Definition Rec {A} (rhs : A) : A := rhs.
Definition BottomUp {A} (rhs : A) : A := rhs.

(* -------------------- Erased values -------------------- *)

(* An erased value of type [A] is a value which can only be used to construct Props.
   We can represent erased values [x] in CPS with answer type Prop, as functions of
   the form [fun k => k x]: *)
Definition erased A := (A -> Prop) -> Prop.
Class e_ok {A} (x : erased A) := erased_ok : exists (y : A), x = (fun k => k y).
(* These two items are carried separately so that they can both be erased during extraction.
   Bundling them together in a dependent pair type would erase to a pair type [box × box] *)

(* Erasing a value *)
Definition erase {A} : A -> erased A := fun x k => k x.
Instance erase_ok {A} (x : A) : e_ok (erase x). Proof. exists x; reflexivity. Qed.

(* Erased values can always be used to construct other erased values *)
Definition e_map {A B} (f : A -> B) (x : erased A) : erased B := fun k => x (fun x => k (f x)).
Instance e_map_ok {A B} (f : A -> B) (x : erased A) `{H : e_ok _ x} : e_ok (e_map f x).
Proof. destruct H as [y Hy]; subst x; unfold e_map; now exists (f y). Qed.

Definition e_map_fuse {A B C} (f : B -> C) (g : A -> B) (x : erased A) :
  e_map f (e_map g x) = e_map (fun x => f (g x)) x.
Proof. reflexivity. Qed.

(* Only proofs can be unerased *)
Definition recover (x : erased Prop) : Prop := x (fun x => x).
Notation "'«' P '»'" := (recover P).

(* Remove all erased operators from a goal using e_ok hypotheses *)
Ltac unerase :=
  repeat match goal with
  | H : e_ok ?x |- _ =>
    let x' := fresh x in
    rename x into x';
    destruct H as [x H];
    subst x'
  end;
  unfold recover, e_map, erase in *.

Ltac2 unerase () := ltac1:(unerase).
Ltac2 Notation "unerase" := unerase ().

(* Example *)
Require Import Lia.
Require Extraction.
Module Example.

Fixpoint thingy (n : erased nat) `{Hn : e_ok _ n} (m p : nat) (Hmp : «e_map (fun n => n + m = p) n») {struct m} : nat.
Proof.
  destruct m as [|m] > [exact p|].
  specialize (thingy (e_map S n) _ m p); apply thingy; clear thingy.
  ltac1:(unerase; lia).
Defined.

(* Print thingy. *)
(* (* Since n and its proof are carried separately, both are erased entirely *) *)
(* Recursive Extraction thingy. *)
End Example.

(* -------------------- Fixpoint combinator -------------------- *)

(* Equations and Program Fixpoint use a fixpoint combinator which has the following type when
   specialized to a particular measure [measure]:
     [forall arg_pack, (forall arg_pack', measure arg_pack' < measure arg_pack -> P arg_pack') -> P arg_pack]
   This requires wrapping and unwrapping [arg_pack]s. Instead we'll make
     [forall (cost : erased nat), e_ok cost -> (forall cost', e_ok cost' -> cost' < cost -> Q cost') -> Q cost]
   which can achieve the same thing without arg packs by setting
     [Q := fun cost => arg1 -> ‥ -> arg_n -> cost = measure(arg1, ‥, arg_n) -> P (arg1, ‥, arg_n)].

   After a function has been defined this way, unfolding all fixpoint combinators will leave behind a
   primitive fixpoint of type
     [forall (cost : erased nat), e_ok cost -> Accessible cost -> arg1 -> ‥ -> arg_n -> cost = measure ‥ -> P ‥]
   that is structurally recursive on the accessibility proof [Accessible cost].

   Extraction will erase [cost : erased nat], [e_ok cost], [Accessible cost], and [cost = measure ‥],
   leaving a plain recursive function of type [arg1 -> ‥ -> arg_n -> P ‥]. *)
Require Import Coq.Arith.Wf_nat.
Section WellfoundedRecursion.

(* Modelled after https://coq.inria.fr/library/Coq.Init.Wf.html#Acc *)
Section AccS.

  Context (A : Type) (B : A -> Prop) (R : forall x, B x -> forall y, B y -> Prop).

  Inductive AccS (x : A) (Hx : B x) : Prop :=
    AccS_intro : (forall (y : A) (Hy : B y), R Hy Hx -> @AccS y Hy) -> AccS Hx.

  Definition well_foundedS := forall (x : A) (Hx : B x), AccS Hx.

  Section FixS.

    Context
      (Rwf : well_foundedS)
      (P : A -> Type)
      (F : forall (x : A) (Hx : B x), (forall (y : A) (Hy : B y), R Hy Hx -> P y) -> P x).

    Fixpoint FixS_F (x : A) (Hx : B x) (H : AccS Hx) {struct H} : P x :=
      F (fun (y : A) (Hy : B y) (Hyx : R Hy Hx) =>
          FixS_F (let 'AccS_intro H := H in H y Hy Hyx)).

    Definition FixS (x : A) (Hx : B x) : P x := FixS_F (Rwf Hx).

  End FixS.

End AccS.

Section FixEN.

Definition enat := erased nat.
Definition e_lt : forall x : enat, e_ok x -> forall y : enat, e_ok y -> Prop :=
  fun n Hn m Hm => «e_map (fun n => «e_map (fun m => n < m) m») n».

Lemma e_lt_wf : well_foundedS e_ok e_lt.
Proof.
  intros n Hn; unerase.
  induction n as [n IHn] using Wf_nat.lt_wf_ind.
  constructor; intros m Hm Hmn; unerase.
  now (apply IHn).
Defined.

Definition FixEN :
  forall P : enat -> Type,
  (forall (x : enat) (Hx : e_ok x), (forall (y : enat) (Hy : e_ok y), e_lt Hy Hx -> P y) -> P x) ->
  forall x : enat, e_ok x -> P x
  := FixS e_lt_wf.

End FixEN.

End WellfoundedRecursion.

Extraction Inline FixEN FixS FixS_F.

Module FixENExample.

Definition plus : forall (cost : enat) `{e_ok _ cost}, forall n m : nat, «e_map (eq n) cost» -> nat.
Proof.
  apply (FixEN (fun cost => forall n m : nat, «e_map (eq n) cost» -> nat)).
  intros cost Hok rec n m Hcost.
  destruct n as [|n] > [exact m|].
  specialize rec with (n := n).
  specialize (rec (erase n) _).
  apply S, rec > [|exact m|]; unfold e_lt in *; ltac1:(unerase; lia).
Defined.

End FixENExample.

(* Print FixENExample.plus. *)
Set Extraction Flag 2031. (* default + linear let + linear beta *)
(* Recursive Extraction FixENExample.plus. *)

(* -------------------- 1-hole contexts built from frames -------------------- *)

(* A 1-hole context made out of frames F *)
Inductive frames_t' {U : Set} {F : U -> U -> Set} : U -> U -> Set :=
| frames_nil : forall {A}, frames_t' A A
| frames_cons : forall {A B C}, F A B -> frames_t' B C -> frames_t' A C.
Arguments frames_t' {U} F _ _.
Notation "C '>::' f" := (frames_cons f C) (at level 50, left associativity).
Notation "<[]>" := (frames_nil).
Notation "<[ x ; .. ; z ]>" := (frames_cons z .. (frames_cons x frames_nil) ..).

(* The 1-hole contexts you usually want *)
Definition frames_t {U : Set} `{Frame U} : U -> U -> Set := frames_t' frame_t.

(* Context application *)
Reserved Notation "C '⟦' x '⟧'" (at level 50, no associativity).
Fixpoint framesD {U : Set} `{Frame U} {A B : U}
         (fs : frames_t A B) : univD A -> univD B :=
  match fs with
  | <[]> => fun x => x
  | fs >:: f => fun x => fs ⟦ frameD f x ⟧
  end
where "C '⟦' x '⟧'" := (framesD C x).

Lemma framesD_cons {U : Set} `{Frame U} {A B C : U}
      (fs : frames_t B C) (f : frame_t A B)
      (x : univD A)
  : (fs >:: f) ⟦ x ⟧ = fs ⟦ frameD f x ⟧.
Proof. reflexivity. Qed.

Fixpoint frames_lift {U : Set} {F : U -> U -> Set}
      (P : U -> Set) (Hf : forall {A B}, F A B -> P A -> P B)
      {A B} (fs : frames_t' F A B)
  : P A -> P B :=
  match fs with
  | <[]> => fun pa => pa
  | fs >:: f => fun pa => frames_lift P (@Hf) fs (Hf f pa)
  end.

(* Context composition *)
Reserved Notation "gs '>++' fs" (at level 50, left associativity).
Fixpoint frames_compose {U : Set} {F : U -> U -> Set} {A B C : U}
         (fs : frames_t' F A B) : frames_t' F B C -> frames_t' F A C :=
  match fs with
  | <[]> => fun gs => gs
  | fs >:: f => fun gs => gs >++ fs >:: f
  end
where "gs '>++' fs" := (frames_compose fs gs).

(* Laws: functor laws + injectivity *)

Lemma frames_id_law {U : Set} `{Frame U} {A} (x : univD A) : <[]> ⟦ x ⟧ = x.
Proof. auto. Qed.

Lemma frames_compose_law {U : Set} `{Frame U} {A B C} :
  forall (fs : frames_t B C) (gs : frames_t A B) (x : univD A),
  (fs >++ gs) ⟦ x ⟧ = fs ⟦ gs ⟦ x ⟧ ⟧.
Proof. intros fs gs; revert fs; induction gs; simpl; auto. Qed.

Class Frame_inj (U : Set) `{Frame U} :=
  frame_inj :
    forall {A B : U} (f : frame_t A B) (x y : univD A),
    frameD f x = frameD f y -> x = y.

Lemma frames_inj {U : Set} `{Frame U} `{Frame_inj U} {A B} (fs : frames_t A B) :
  forall (x y : univD A), fs ⟦ x ⟧ = fs ⟦ y ⟧ -> x = y.
Proof.
  induction fs; auto; cbn; intros x y Heq.
  apply IHfs, (frame_inj f) in Heq; auto.
Qed.

(* Misc. lemmas (mostly about how frames_t is similar to list) *)

Definition flip {U} (F : U -> U -> Set) : U -> U -> Set := fun A B => F B A.
Fixpoint frames_rev {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) : frames_t' (flip F) B A :=
  match fs with
  | <[]> => <[]>
  | fs >:: f => <[f]> >++ frames_rev fs
  end.
Fixpoint frames_revD {U : Set} `{Frame U} {A B : U}
         (fs : frames_t' (flip frame_t) B A) : univD A -> univD B :=
  match fs with
  | <[]> => fun x => x
  | fs >:: f => fun x => frameD f (frames_revD fs x)
  end.

Lemma frames_nil_comp {U : Set} {F : U -> U -> Set} {A B : U}
      (fs : frames_t' F A B)
  : <[]> >++ fs = fs.
Proof. induction fs > [reflexivity|cbn; now (rewrite IHfs)]. Qed.

Lemma frames_revD_comp {U : Set} `{HFrame : Frame U} {A B C : U}
      (fs : frames_t' (flip frame_t) B A) (gs : frames_t' (flip frame_t) C B)
      (x : univD A)
  : frames_revD (fs >++ gs) x = frames_revD gs (frames_revD fs x).
Proof. induction gs > [reflexivity|cbn; now (rewrite IHgs)]. Qed.

Lemma framesD_rev {U : Set} `{Frame U} {A B : U} (fs : frames_t A B) (x : univD A)
  : fs ⟦ x ⟧ = frames_revD (frames_rev fs) x.
Proof.
  induction fs > [reflexivity|cbn].
  now (rewrite frames_revD_comp, <- IHfs).
Qed.

Lemma frames_rev_assoc {U : Set} {F : U -> U -> Set} {A B C D : U}
      (fs : frames_t' F A B) (gs : frames_t' F B C) (hs : frames_t' F C D)
  : hs >++ (gs >++ fs) = hs >++ gs >++ fs.
Proof. induction fs > [reflexivity|cbn; now (rewrite IHfs)]. Qed.

Lemma frames_rev_comp {U : Set} {F : U -> U -> Set} {A B C : U}
      (fs : frames_t' F A B) (gs : frames_t' F B C)
  : frames_rev (gs >++ fs) = frames_rev fs >++ frames_rev gs.
Proof.
  induction fs; cbn.
  - now (rewrite frames_nil_comp).
  - now (rewrite IHfs, frames_rev_assoc).
Qed.

Lemma frames_rev_rev {U : Set} `{Frame U} {A B : U} (fs : frames_t A B)
  : frames_rev (frames_rev fs) = fs.
Proof. induction fs > [reflexivity|cbn]. now (rewrite frames_rev_comp, IHfs). Qed.

Fixpoint frames_any {U : Set} {F : U -> U -> Set} (P : forall {A B : U}, F A B -> Prop)
         {A B} (fs : frames_t' F A B) : Prop :=
  match fs with
  | <[]> => False
  | fs >:: f => P f \/ frames_any (@P) fs
  end.

Lemma frames_any_app
      {U : Set} {F : U -> U -> Set} (P : forall {A B : U}, F A B -> Prop)
      {A B C} (gs : frames_t' F B C) (fs : frames_t' F A B)
  : frames_any (@P) (gs >++ fs) <-> frames_any (@P) gs \/ frames_any (@P) fs.
Proof. induction fs > [cbn; ltac1:(tauto)|cbn]. rewrite IHfs; ltac1:(tauto). Qed.

Lemma frames_any_cons
      {U : Set} {F : U -> U -> Set} (P : forall {A B : U}, F A B -> Prop)
      {A B C} (fs : frames_t' F B C) (f : F A B)
  : frames_any (@P) (fs >:: f) <-> frames_any (@P) fs \/ P f.
Proof. unfold frames_any; ltac1:(tauto). Qed.

Fixpoint frames_len {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) : nat :=
  match fs with
  | <[]> => O
  | fs >:: f => S (frames_len fs)
  end.

Lemma frames_len_compose {U : Set} {F : U -> U -> Set} {A B C}
      (fs : frames_t' F A B) (gs : frames_t' F B C) :
  frames_len (gs >++ fs) = frames_len fs + frames_len gs.
Proof. induction fs as [|A' AB B' f fs IHfs] > [reflexivity|cbn]. now (rewrite IHfs). Qed.

(* Useful in situations where [destruct] struggles with dependencies *)
Lemma frames_split' {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) :
  (exists AB (g : F A AB) (gs : frames_t' F AB B), fs = gs >:: g) \/
  (A = B /\ JMeq fs (<[]> : frames_t' F A A) /\ frames_len fs = 0%nat).
Proof. destruct fs as [| A' AB B' f fs] > [now right|left; now do 3 eexists]. Qed.

(* Like frames_split', but peels off frames from the left instead of from the right *)
Lemma frames_split {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) :
  (exists AB (g : F AB B) (gs : frames_t' F A AB), fs = <[g]> >++ gs) \/ (frames_len fs = O).
Proof.
  induction fs as [| A' AB B' f fs IHfs] > [now right|left].
  destruct IHfs as [[AB' [g [gs Hgs]]] | Hnil].
  - subst. do 2 eexists; exists (gs >:: f); reflexivity.
  - destruct fs; simpl in Hnil; inversion Hnil. do 2 eexists; exists <[]>; reflexivity.
Qed.

(* Well-founded induction on the length of the context *)
Lemma frames_len_ind (U : Set) (F : U -> U -> Set)
      (P : forall {A B}, frames_t' F A B -> Prop)
      (Hlt : forall {A B} (fs : frames_t' F A B),
        (forall {C D} (gs : frames_t' F C D), frames_len gs < frames_len fs -> P gs) ->
        P fs)
      A B (fs : frames_t' F A B)
  : P fs.
Proof.
  remember (frames_len fs) as n eqn:Hlen.
  ltac1:(generalize dependent B; generalize dependent A).
  induction n as [n IHn] using lt_wf_ind; intros A B fs Hlen.
  apply Hlt; intros C D gs Hlt_gs; eapply IHn > [|reflexivity]; ltac1:(lia).
Qed.

(* [frames_t] is a snoc-list of frames; this is an induction principle for reasoning about
   them as if they were cons-lists. *)
Lemma frames_rev_ind (U : Set) (F : U -> U -> Set)
      (P : forall {A B}, frames_t' F A B -> Prop)
      (Hnil : forall {A}, P (<[]> : frames_t' F A A))
      (Hcons : forall {A B C} (f : F B C) (fs : frames_t' F A B), P fs -> P (<[f]> >++ fs))
      A B (fs : frames_t' F A B)
  : P fs.
Proof.
  induction fs as [A B fs IHfs] using frames_len_ind.
  destruct (frames_split fs) as [[AB [f [fs' Hfs']]] | Hfs_nil] > [subst fs|].
  - apply Hcons, IHfs; rewrite frames_len_compose; cbn; ltac1:(lia).
  - destruct fs > [|now (cbn in Hfs_nil)]; apply Hnil.
Qed.

(* -------------------- Rewriters -------------------- *)
Section Rewriters.

Context
  (* Types the rewriter will encounter + type of 1-hole contexts *)
  (U : Set) `{HFrame : Frame U}
  (* The type of trees being rewritten *)
  (Root : U).

(* State variables, parameters, and delayed computations *)
Section Strategies.

Context
  (D : Set) (I_D : forall (A : U), univD A -> D -> Prop)
  (R : Set) (I_R : forall (A : U), frames_t A Root -> R -> Prop)
  (S : Set) (I_S : forall (A : U), frames_t A Root -> univD A -> S -> Prop).

Definition Delay {A} (e : univD A) : Set := {d | I_D A e d}.
Definition Param {A} (C : erased (frames_t A Root)) : Set :=
  {r | «e_map (fun C => I_R C r) C»}.
Definition State {A} (C : erased (frames_t A Root)) (e : univD A) : Set :=
  {s | «e_map (fun C => I_S C e s) C»}.

Class Delayed := {
  delayD : forall {A} (e : univD A), Delay e -> univD A;
  delay_id : forall {A} (e : univD A), Delay e;
  delay_id_law : forall {A} (e : univD A), delayD (delay_id e) = e }.

Class Preserves_R :=
  preserve_R :
    forall {A B : U} (fs : erased (frames_t B Root)) `{e_ok _ fs} (f : frame_t A B),
    Param fs -> Param (e_map (fun fs => fs >:: f) fs).

Class Preserves_S_up :=
  preserve_S_up :
    forall {A B : U} (fs : erased (frames_t B Root)) `{e_ok _ fs} (f : frame_t A B) (x : univD A),
    State (e_map (fun fs => fs >:: f) fs) x -> State fs (frameD f x).

Class Preserves_S_dn :=
  preserve_S_dn :
    forall {A B : U} (fs : erased (frames_t B Root)) `{e_ok _ fs} (f : frame_t A B) (x : univD A),
    State fs (frameD f x) -> State (e_map (fun fs => fs >:: f) fs) x.

Extraction Inline delayD delay_id preserve_R preserve_S_up preserve_S_dn.

End Strategies.

(* Handy instances *)

(* Structures with no invariants *)

Definition I_D_plain (D : Set) (A : U) (_ : univD A) (_ : D) : Prop := True.
Definition id_Delay := @Delay unit (@I_D_plain unit).

Global Instance Delayed_id_Delay : Delayed (@I_D_plain unit).
Proof.
  ltac1:(unshelve econstructor).
  - intros A x _; exact x.
  - intros; exists tt; exact I.
  - reflexivity.
Defined.

Definition I_R_plain (R : Set) (A : U) (C : frames_t A Root) (_ : R) : Prop := True.
Definition I_S_plain (S : Set) (A : U) (C : frames_t A Root) (_ : univD A) (_ : S) : Prop := True.

Global Instance Preserves_R_plain (R : Set) : Preserves_R (@I_R_plain R).
Proof. unfold Preserves_R; intros; assumption. Defined.

Global Instance Preserves_S_up_plain (S : Set) : Preserves_S_up (@I_S_plain S).
Proof. unfold Preserves_S_up; intros; assumption. Defined.

Global Instance Preserves_S_dn_plain (S : Set) : Preserves_S_dn (@I_S_plain S).
Proof. unfold Preserves_S_dn; intros; assumption. Defined.

Extraction Inline Delayed_id_Delay Preserves_R_plain Preserves_S_up_plain Preserves_S_dn_plain.

(* Composing two parameters *)
Section R_prod.

Context
  (R1 R2 : Set)
  (I_R1 : forall A, frames_t A Root -> R1 -> Prop)
  (I_R2 : forall A, frames_t A Root -> R2 -> Prop).

Definition I_R_prod A (C : frames_t A Root) : R1 * R2 -> Prop :=
  fun '(r1, r2) => I_R1 C r1 /\ I_R2 C r2.

Global Instance Preserves_R_prod
       `{H1 : @Preserves_R _ (@I_R1)}
       `{H2 : @Preserves_R _ (@I_R2)} :
  Preserves_R I_R_prod.
Proof.
  unfold I_R_prod; intros A B C C_ok f [[r1 r2] Hr12].
  assert (Hr1 : «e_map (fun C => I_R1 _ C r1) C»). { unerase; now (destruct Hr12). }
  assert (Hr2 : «e_map (fun C => I_R2 _ C r2) C»). { unerase; now (destruct Hr12). }
  pattern r1 in Hr1; pattern r2 in Hr2. apply exist in Hr1; apply exist in Hr2. clear Hr12 r1 r2.
  ltac1:(unshelve eapply preserve_R with (f := f) in Hr1); try assumption.
  ltac1:(unshelve eapply preserve_R with (f := f) in Hr2); try assumption.
  destruct Hr1 as [r1 Hr1], Hr2 as [r2 Hr2]; exists (r1, r2).
  unerase; auto.
Defined.

Extraction Inline Preserves_R_prod.

End R_prod.

(* Composing two states *)
Section S_prod.

Context
  (S1 S2 : Set)
  (I_S1 : forall A, frames_t A Root -> univD A -> S1 -> Prop)
  (I_S2 : forall A, frames_t A Root -> univD A -> S2 -> Prop).

Definition I_S_prod A (C : frames_t A Root) (e : univD A) : S1 * S2 -> Prop :=
  fun '(s1, s2) => I_S1 C e s1 /\ I_S2 C e s2.

Global Instance Preserves_S_up_prod
         `{H1 : @Preserves_S_up _ (@I_S1)}
         `{H2 : @Preserves_S_up _ (@I_S2)} :
  Preserves_S_up I_S_prod.
Proof.
  unfold I_S_prod; intros A B C C_ok f x [[s1 s2] Hs12].
  assert (Hs1 : «e_map (fun C => I_S1 _ (C >:: f) x s1) C»). { unerase; now (destruct Hs12). }
  assert (Hs2 : «e_map (fun C => I_S2 _ (C >:: f) x s2) C»). { unerase; now (destruct Hs12). }
  pattern s1 in Hs1; pattern s2 in Hs2; apply exist in Hs1; apply exist in Hs2; clear Hs12 s1 s2.
  ltac1:(unshelve eapply preserve_S_up with (f := f) in Hs1); try assumption.
  ltac1:(unshelve eapply preserve_S_up with (f := f) in Hs2); try assumption.
  destruct Hs1 as [s1 Hs1], Hs2 as [s2 Hs2]; exists (s1, s2); unerase; auto.
Defined.

Global Instance Preserves_S_dn_prod
         `{H1 : @Preserves_S_dn _ (@I_S1)}
         `{H2 : @Preserves_S_dn _ (@I_S2)} :
  Preserves_S_dn I_S_prod.
Proof.
  unfold I_S_prod; intros A B C C_ok f x [[s1 s2] Hs12].
  assert (Hs1 : «e_map (fun C => I_S1 _ C (frameD f x) s1) C»). { unerase; now (destruct Hs12). }
  assert (Hs2 : «e_map (fun C => I_S2 _ C (frameD f x) s2) C»). { unerase; now (destruct Hs12). }
  pattern s1 in Hs1; pattern s2 in Hs2; apply exist in Hs1; apply exist in Hs2; clear Hs12 s1 s2.
  ltac1:(unshelve eapply preserve_S_dn with (f := f) in Hs1); try assumption.
  ltac1:(unshelve eapply preserve_S_dn with (f := f) in Hs2); try assumption.
  destruct Hs1 as [s1 Hs1], Hs2 as [s2 Hs2]; exists (s1, s2); unerase; auto.
Defined.

Extraction Inline Preserves_S_up_prod Preserves_S_dn_prod.

End S_prod.

Section FuelAndMetric.

Definition Fuel (fueled : bool) := if fueled then positive else True.

Definition is_empty (fueled : bool) : Fuel fueled -> bool :=
  match fueled with
  | true => fun fuel => match fuel with xH => true | _ => false end
  | false => fun 'I => false
  end.

Definition fuel_dec (fueled : bool) : Fuel fueled -> Fuel fueled :=
  match fueled with
  | true => fun fuel => Pos.pred fuel
  | false => fun fuel => fuel
  end.

Definition lots_of_fuel : positive := (1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1)%positive.

Extraction Inline is_empty fuel_dec lots_of_fuel.

Definition Metric (fueled : bool) :=
  if fueled then unit
  else forall A, frames_t A Root -> univD A -> nat.

Definition run_metric (fueled : bool) (metric : Metric fueled)
           (fuel : Fuel fueled) A (C : frames_t A Root) (e : univD A) : nat :=
  match fueled return Fuel fueled -> Metric fueled -> nat with
  | true => fun fuel 'tt => Pos.to_nat fuel
  | false => fun fuel metric => metric A C e
  end fuel metric.

End FuelAndMetric.

(* The type of the rewriter *)
Section Rewriter.

Context
  (* Fueled rewriters use [positive] as fuel parameter *)
  (fueled : bool)
  (Fuel := Fuel fueled)
  (metric : Metric fueled)
  (run_metric := run_metric fueled metric)
  (* One rewriting step *)
  (Rstep : relation (univD Root))
  (* Delayed computation, parameter, and state variable *)
  (D : Set) (I_D : forall (A : U), univD A -> D -> Prop)
  (R : Set) (I_R : forall (A : U), frames_t A Root -> R -> Prop)
  (S : Set) (I_S : forall (A : U), frames_t A Root -> univD A -> S -> Prop)
  `{HDelay : Delayed _ I_D}.

(* The result returned by a rewriter when called with context C and exp e *)
Record result A (C : erased (frames_t A Root)) (e : univD A) : Set := mk_result {
  resTree : univD A;
  resState : State I_S C resTree;
  resProof : «e_map (fun C => clos_refl_trans _ Rstep (C ⟦ e ⟧) (C ⟦ resTree ⟧)) C» }.

Definition rw_for (fuel : Fuel) A (C : erased (frames_t A Root)) (e : univD A) :=
  forall n (eok : e_ok n) (r : Param I_R C) (s : State I_S C e),
  «e_map (fun n => «e_map (fun C => n = run_metric fuel C e) C») n» ->
  result C e.

Definition rewriter' :=
  forall (fuel : Fuel) A (C : erased (frames_t A Root)) (eok : e_ok C) (e : univD A) (d : Delay I_D e),
  rw_for fuel C (delayD d).

Definition res_chain A (C : erased (frames_t A Root)) `{e_ok _ C} (e : univD A) (m : result C e)
           (k : forall e (s : State I_S C e), result C e) : result C e.
Proof.
  destruct m as [e' s' Hrel1]; cbn in k.
  specialize (k e' s'); destruct k as [e'' s'' Hrel2].
  econstructor > [exact s''|unerase; eapply rt_trans; eauto].
Defined.

Extraction Inline res_chain.

End Rewriter.

End Rewriters.


Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).

Proof.
  firstorder.
Qed.