Require Import StLib.Main.
Require Import Psatz.

Parameters T Smax : Z.

Module AmPutOpt <: (PROBLEM Z2).
  Local Open Scope aexpr.

  Definition space := 〚0, T〛×〚0, Smax〛.
  Definition target := 〚0, T〛×〚0, Smax〛.
  Definition dep c :=
    match c with
      | (t,s) =>
        [(t+1,s); (t+1,s-1); (t+1,s+1)]
    end.
End AmPutOpt.

Module P := Prog Z2 AmPutOpt.
Import P.

Section Naive.

  Definition naive_st :=
    (For "t" From 0 To T Do
       For "s" From 0 To Smax Do
         Fire ((T - "t")%aexpr, "s":aexpr))%prog.

  Definition v := [] : vars.
  Definition C := ∅ : set cell.

  Fact naive_st_correct_semi_auto :
    exec v C naive_st (C ∪ shape v naive_st).
  Proof.

    symbolic execution.

    unfold C, space; simplify sets with ceval.

    repeat (intro || split).

    - decide i=0.
      + right; forward. simpl in *; nia.
      + left. lhs; forward.
        exists (i-1); forward. nia.
        exists i0; forward. nia.

    - decide i=0.
      + right; forward. simpl in *; nia.
      + decide i0=0.
        * right; forward. simpl in *; nia.
        * left. lhs; forward.
          exists (i - 1); forward. nia.
          exists (i0 - 1); forward; nia.

    - decide i=0.
      + right; forward. simpl in *; nia.
      + decide i0=Smax.
        * right; forward. simpl in *; nia.
        * left. lhs; forward.
          exists (i - 1); forward. nia.
          exists (i0 + 1); forward; nia.
  Qed.

  Fact naive_st_correct_auto :
    exec v C naive_st (C ∪ shape v naive_st).
  Proof.

    symbolic execution.

    unfold C, space; simplify sets with ceval.

    repeat (intro || split).

    - decide i=0; [bruteforce | bruteforce' [i-1; i0]].

    - decide i=0; [bruteforce|].
      decide i0=0; [bruteforce | bruteforce' [i-1; i0-1]].

    - decide i=0; [bruteforce|].
      decide i0=Smax; [bruteforce | bruteforce' [i-1; i0+1]].
  Qed.

  Fact naive_st_complete :
    space ⊆ C ∪ shape v naive_st.
  Proof.
    unfold space; simpl; simplify sets with ceval.
    forward. bruteforce' [T-z; z0].
  Qed.

End Naive.

Section Triangles.

  Hypothesis T_Smax : Smax >= T * 2.

  Definition triangles_st :=
    ((For "t" From 0 To T Do
        For "s" From "t" To Smax - "t" Do
          Fire ((T - "t")%aexpr, "s":aexpr));;
     (For "t" From 0 To T Do
        For "s" From 0 To "t" - 1 Do
          Fire ((T - "t")%aexpr, "s":aexpr));;
     (For "t" From 0 To T Do
        For "s" From Smax - "t" + 1 To Smax Do
          Fire ((T - "t")%aexpr, "s":aexpr)))%prog.

  Fact triangles_st_correct_auto :
    exec v C triangles_st (C ∪ shape v triangles_st).
  Proof.

    symbolic execution.

    unfold C, space; simplify sets with ceval.

    Arguments Zplus x y : simpl never.
    Arguments Zminus m n : simpl never.

    repeat (intro || split).

(*    Ltac get_vars acc k :=
      match goal with
        | [ x : Z |- _ ] =>
          match acc with
            | context[x] => fail 1
            | _ => get_vars (x :: acc) k
          end
        | _ => k acc
(*          let l := constr:(gen_expr acc [Zplus; Zminus] 1) in
          let v := fresh in
          pose (v := l); unfold gen_expr, rev' in v; simpl in v;
          let ls := eval unfold v in v in

          bruteforce' ls*)
      end.
    Ltac candidates :=
      get_vars ([] : list Z)
               ltac:(fun ls =>
                       let ls' :=
                           eval simpl in
                       (ls ++ map (fun x => x+1) ls
                           ++ map (fun x => x-1) ls)%list in
                     bruteforce' ls').*)
    - decide i=0; [bruteforce | bruteforce' [i-1; i0]].
    - decide i=0; [bruteforce |].
      decide i0=0; [bruteforce | bruteforce' [i-1; i0-1]].
    - decide i=0; [bruteforce | bruteforce' [i0+1; i-1]].

    - decide i=0; [bruteforce |].
      decide i0=(i-1); [bruteforce' [i-1] | bruteforce' [i-1; i0]].
    - decide i=0; [bruteforce|].
      decide i0=0; [bruteforce | bruteforce' [i-1; i0-1]].
    - decide i=0; [bruteforce|].
      decide i0=(i-1); [bruteforce' [i-1; i]|].
      decide i0=(i-2); [bruteforce' [i-1] | bruteforce' [i-1; i0+1]].

    - decide i=0; [bruteforce|].
      decide i0=(Smax-i+1); [bruteforce' [Smax-i+1; i-1] | bruteforce' [i-1; i0]].
    - decide i=0; [bruteforce |].
      decide i0=(Smax-i+1); [bruteforce' [i-1; Smax-i]|].
      decide i0=(Smax-i+2); [bruteforce' [i-1; Smax-i+1] | bruteforce' [i-1; i0-1]].
    - decide i=0; [bruteforce|].
      decide i0=Smax; [bruteforce | bruteforce' [i-1; i0+1]].

  Qed.

End Triangles.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo108:
  prime  5734669->
  prime  33594023621.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      33594023621
      5858
      ((5734669,1)::nil)
      12597758859
      0
      16797011812
      25195517718)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Bool.

From Undecidability.Shared.Libs.DLW
  Require Import utils list_bool pos vec subcode sss.

From Undecidability.StackMachines.BSM
  Require Import tiles_solvable bsm_defs.

Set Implicit Arguments.

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "P // s -[ k ]-> t" := (sss_steps (@bsm_sss _) P k s t).
Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).

Section Binary_Stack_Machines.

  Variable (n : nat).

  Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.

  Section pop_many.

    Variable (x : pos n).

    Fixpoint pop_many (k : nat) (i : nat) : list (bsm_instr n) :=
      match k with
      | 0 => nil
      | S k => POP x (i + 1) (S (k + i)) :: pop_many k (S i)
      end.

    Lemma pop_many_length k i : length (pop_many k i) = k.
    Proof.
      induction k in i |- *; cbn; congruence.
    Qed.

    Lemma pop_many_spec (k : nat) (i : nat) v :
      (i, pop_many k i) // (i, v) ->> (k + i,v[(skipn k (v#>x))/x]).
    Proof.
      induction k in v, i |- *; cbn.
      - bsm sss stop. f_equal. now rewrite vec_change_same.
      - destruct (v #> x) as [ |  [] l] eqn:E.
        + bsm sss POP empty with x (i + 1) (S (k + i)). bsm sss stop. rewrite <- E. f_equal. now rewrite vec_change_same.
        + bsm sss POP one with x (i + 1) (S (k + i)) l.
          eapply subcode_sss_compute_trans. 2: eapply IHk. 1:{ cbn. eexists (_ :: nil), nil. split. 2: cbn. 2: lia. cbn. rewrite app_nil_r. reflexivity. }
          bsm sss stop. f_equal. lia. rewrite vec_change_idem. now rewrite vec_change_eq.
        + bsm sss POP zero with x (i + 1) (S (k + i)) l.
          eapply subcode_sss_compute_trans. 2: eapply IHk. 1:{ cbn. eexists (_ :: nil), nil. split. 2: cbn. 2: lia. cbn. rewrite app_nil_r. repeat f_equal. lia. }
          bsm sss stop. f_equal. lia. rewrite vec_change_idem. now rewrite vec_change_eq.
    Qed.

  End pop_many.

  Section pop_exactly.

    Variable (x : pos n) (empty : pos n) (cdiff : nat).

    Hypothesis neq : x <> empty.

    Fixpoint pop_exactly (l : list bool) (i : nat) : list (bsm_instr n) :=
      match l with
      | nil => nil
      | true  :: l => POP x cdiff   cdiff :: POP empty (i + 2) (i + 2) :: pop_exactly l (2 + i)
      | false :: l => POP x (i + 2) cdiff :: POP empty cdiff cdiff     :: pop_exactly l (2 + i)
      end.

    Lemma pop_exactly_length l i : length (pop_exactly l i) = 2 * (length l).
    Proof.
      induction l as [ | [] ] in i |- *; cbn; try rewrite IHl; lia.
    Qed.

    Lemma pop_exactly_spec1 (i : nat) l l' v :
      v #> x = l ++ l' ->
      v #> empty = nil ->
      (i, pop_exactly l i) // (i, v) ->> (2 * length l + i,v[l'/x]).
    Proof using neq.
      induction l as [ | [] l IH] in v, i, l' |- * ; cbn; intros H Hempty.
      - bsm sss stop. f_equal. rewrite <- H. now rewrite vec_change_same.
      - bsm sss POP one with x cdiff cdiff (l ++ l').
        bsm sss POP empty with empty (i + 2) (i + 2). rewrite vec_change_neq; eauto.
        eapply subcode_sss_compute_trans. 2: eapply IH. 1:{ cbn. eexists (_ :: _ :: nil), nil. split. 2: cbn. 2: lia. cbn. rewrite app_nil_r. repeat f_equal. lia. }
        rewrite vec_change_eq. reflexivity. reflexivity. rewrite vec_change_neq; eauto.
        bsm sss stop. f_equal. lia. now rewrite vec_change_idem.
      - bsm sss POP zero with x (i + 2) cdiff (l ++ l').
        eapply subcode_sss_compute_trans. 2: eapply IH. 1:{ cbn. eexists (_ :: _ :: nil), nil. split. 2: cbn. 2: lia. cbn. rewrite app_nil_r. repeat f_equal. lia. }
        rewrite vec_change_eq. reflexivity. reflexivity. rewrite vec_change_neq; eauto.
        bsm sss stop. f_equal. lia. now rewrite vec_change_idem.
    Qed.

    Lemma pop_exactly_spec2 (i : nat) l v :
      (~ exists l', v #> x = l ++ l') ->
      v #> empty = nil ->
      exists x',
      (i, pop_exactly l i) // (i, v) ->> (cdiff, v[x'/x]).
    Proof using neq.
       induction l as [ | [] l IH] in v, i |- * ; cbn; intros H Hempty.
      - destruct H. eexists. reflexivity.
      - destruct (v #> x) as [ | [] l'] eqn:E.
        + eexists.
          bsm sss POP empty with x cdiff cdiff. bsm sss stop. f_equal.
          now rewrite vec_change_same.
        + edestruct IH as [v' Hv'].
          3: { exists v'.
               bsm sss POP one with x cdiff cdiff l'.
               bsm sss POP empty with empty (i + 2) (i + 2). rewrite vec_change_neq; eauto.
               eapply subcode_sss_compute_trans. 2: eapply Hv'. 1:{ cbn. eexists (_ :: _ :: nil), nil. split. 2: cbn. 2: lia. cbn. rewrite app_nil_r. repeat f_equal. lia. }
               bsm sss stop. now rewrite vec_change_idem.
               }
          2: rewrite vec_change_neq; eauto. rewrite vec_change_eq.
          intros (l'' & Eq). eapply H. eexists. f_equal. eassumption. reflexivity.
        + eexists.
          bsm sss POP zero with x cdiff cdiff l'. bsm sss stop.
      - destruct (v #> x) as [ | [] l'] eqn:E.
          + eexists.
            bsm sss POP empty with x (i + 2) cdiff. bsm sss stop. now rewrite vec_change_same.
          + eexists. bsm sss POP one with x (i + 2) cdiff l'.
            bsm sss POP empty with empty cdiff cdiff. now rewrite vec_change_neq. bsm sss stop.
          + edestruct IH as [v' Hv'].
            3: { exists v'.
                 bsm sss POP zero with x (i + 2) cdiff l'.
                 eapply subcode_sss_compute_trans. 2: eapply Hv'. 1:{ cbn. eexists (_ :: _ :: nil), nil. split. 2: cbn. 2: lia. cbn. rewrite app_nil_r. repeat f_equal. lia. }
                 bsm sss stop. now rewrite vec_change_idem. }
            2: rewrite vec_change_neq; eauto. rewrite vec_change_eq.
            intros (l'' & Eq). eapply H. eexists. f_equal. eassumption. reflexivity.
    Qed.
  End pop_exactly.

  Section empty_stack.

    Variable (x : pos n) (i : nat).

    (* Code for emptying stack x *)

    Definition empty_stack := POP x i (3+i) :: PUSH x Zero :: POP x i i :: nil.

    Fact empty_stack_length : length empty_stack = 3.
    Proof. auto. Qed.

    Fact empty_stack_spec v : (i,empty_stack) // (i,v) ->> (3+i,v[nil/x]).
    Proof.
      set (l := v#>x).
      generalize (eq_refl l).
      unfold l at 2.
      generalize l v; clear l v.
      unfold empty_stack.
      induction l as [ | [] l IHl ]; intros v Hv.

      bsm sss POP empty with x i (3+i).
      bsm sss stop; f_equal.
      apply vec_pos_ext; intros p; dest x p.

      bsm sss POP one with x i (3+i) l.
      bsm sss PUSH with x Zero.
      bsm sss POP zero with x i i l; rew vec.
      clear Hv.
      specialize (IHl (v[l/x])).
      spec in IHl.
      rew vec.
      revert IHl; rew vec.

      bsm sss POP zero with x i (3+i) l.
      clear Hv.
      specialize (IHl (v[l/x])).
      spec in IHl.
      rew vec.
      revert IHl; rew vec.
    Qed.

  End empty_stack.

  Section move_rev.

    Variable (x y : pos n) (Hxy : x <> y) (i : nat).

    Let y' := y.

    (* Code that transfers stack x to y, reversing x in the interval *)

    Definition move_rev_stack :=
      (*    i *)   POP x (4+i) (7+i) ::
      (*  1+i *)   PUSH y One  :: PUSH y' Zero :: POP y' i i ::
      (*  4+i *)   PUSH y Zero :: PUSH x  Zero :: POP x i i ::
      (*  7+i *)   nil.

    Fact length_move_rev_stack : length move_rev_stack = 7.
    Proof. auto. Qed.

    Fact move_rev_stack_spec l v w :
              v#>x = l
           -> w = v[nil/x][(rev l++v#>y)/y]
           -> (i,move_rev_stack) // (i,v) ->> (7+i,w).
    Proof using Hxy.
      revert v w; induction l as [ | [] l IHl ]; intros v w Hv Hw; subst w; unfold move_rev_stack.
      * bsm sss POP empty with x (4+i) (7+i).
        bsm sss stop.
        f_equal.
        apply vec_pos_ext; intros z; dest z y; dest z x.
      * bsm sss POP one with x (4+i) (7+i) l.
        bsm sss PUSH with y One.
        bsm sss PUSH with y' Zero.
        bsm sss POP zero with y' i i (One::v#>y); unfold y'; rew vec.
        apply IHl; rew vec.
        apply vec_pos_ext; intros z.
        dest z y; simpl; solve list eq.
        dest z x.
      * bsm sss POP zero with x (4+i) (7+i) l.
        bsm sss PUSH with y Zero.
        bsm sss PUSH with x Zero.
        bsm sss POP zero with x i i l; rew vec.
        apply IHl; rew vec.
        apply vec_pos_ext; intros z.
        dest z y; simpl; solve list eq.
        dest z x.
    Qed.

  End move_rev.

  Section copy_rev_stack.

    Variable (x y z : pos n) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (i : nat).

    Let y' := y.

    (* Code that transfers x to both y and z, reversing x in the interval *)

    Definition copy_rev_stack :=
      (*    i *)   POP x (5+i) (9+i) ::
      (*  1+i *)   PUSH y One  :: PUSH z One  :: PUSH y' Zero :: POP y' i i ::
      (*  5+i *)   PUSH y Zero :: PUSH z Zero :: PUSH x Zero :: POP x i i ::
      (*  9+i *)   nil.

    Fact length_copy_rev_stack : length copy_rev_stack = 9.
    Proof. auto. Qed.

    Fact copy_rev_stack_spec l v w :
              v#>x = l
           -> w = v[nil/x][(rev l++v#>y)/y][(rev l++v#>z)/z]
           -> (i,copy_rev_stack) // (i,v) ->> (9+i,w).
    Proof using Hxy Hyz Hxz.
      revert v w; induction l as [ | [] l IHl ]; intros v w Hv Hw; subst w; unfold copy_rev_stack.
      * bsm sss POP empty with x (5+i) (9+i).
        bsm sss stop.
        f_equal.
        apply vec_pos_ext; intros k; dest k z; dest k y; dest k x.
      * bsm sss POP one with x (5+i) (9+i) l.
        bsm sss PUSH with y One.
        bsm sss PUSH with z One.
        bsm sss PUSH with y' Zero.
        bsm sss POP zero with y' i i (One::v#>y); unfold y'; rew vec.
        apply IHl; rew vec.
        apply vec_pos_ext; intros k.
        dest k z; simpl; solve list eq.
        dest k y; dest k x.
      * bsm sss POP zero with x (5+i) (9+i) l.
        bsm sss PUSH with y Zero.
        bsm sss PUSH with z Zero.
        bsm sss PUSH with x Zero.
        bsm sss POP zero with x i i l; rew vec.
        apply IHl; rew vec.
        apply vec_pos_ext; intros k.
        dest k z; simpl; solve list eq.
        dest k y; dest k x.
    Qed.

  End copy_rev_stack.

  Hint Rewrite empty_stack_length length_move_rev_stack length_copy_rev_stack : length_db.

  Section copy_stack.

    Variable (x y z : pos n) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (i : nat).

    (* Code that copies x into y, stack z must be an empty spare stack *)

    Definition copy_stack := move_rev_stack x z i ++ copy_rev_stack z x y (7+i).

    Fact copy_stack_length : length copy_stack = 16.
    Proof. auto. Qed.

    Fact copy_stack_spec l v w :
              v#>x = l
           -> v#>z = nil
           -> w = v[(l++v#>y)/y]
           -> (i,copy_stack) // (i,v) ->> (16+i,w).
    Proof using Hxy Hyz Hxz.
      intros H1 H2 H3; subst w.
      unfold copy_stack.
      apply sss_compute_trans with (st2 := (7+i,v[nil/x][(rev l)/z])).
      * apply subcode_sss_compute with (P := (i,move_rev_stack x z i)); auto.
        apply move_rev_stack_spec with l; auto.
        rew vec; rewrite H2; solve list eq.
      * apply subcode_sss_compute with (P := (7+i,copy_rev_stack z x y (7+i))); auto.
        apply copy_rev_stack_spec with (rev l); rew vec.
        apply vec_pos_ext; intros k.
        dest k z; simpl; solve list eq.
        dest k y; [ | dest k x ];
        rewrite rev_involutive; auto.
    Qed.

  End copy_stack.

  Hint Rewrite copy_stack_length : length_db.

  Section compare_stacks.

    Variables (x y : pos n) (Hxy : x <> y) (i p q : nat).

    Let x' := x.

    (* Code that compares two stacks x and y:
          - ends at p if the stacks x and y are identical
          - ends at q otherwise
       The status of x and y is unspecified after the
       execution but the stacks other than x and y are
       unmodified *)

    Definition compare_stacks :=
      (*   i    *)  POP x (4+i) (7+i) ::
      (* 1+i    *)  POP y q q ::
      (* 2+i    *)  PUSH x Zero :: POP x i i ::
      (* 4+i    *)  POP y i q ::
      (* 5+i    *)  PUSH y Zero :: POP y q i ::
      (* 7+i    *)  POP y q p ::
      (* 8+i    *)  PUSH x' Zero :: POP x' q q :: nil.

    Fact compare_stacks_length : length compare_stacks = 10.
    Proof. auto. Qed.

    Local Lemma cs_spec_rec l : forall m v, v#>x = l
                                 -> v#>y = m
                                 -> exists w, (forall z, z <> x -> z <> y -> v#>z = w#>z)
                                 /\ (l =  m -> (i,compare_stacks) // (i,v) ->> (p,w))
                                 /\ (l <> m -> (i,compare_stacks) // (i,v) ->> (q,w)).
    Proof using Hxy.
      induction l as [ | [] l IHl ]; intros [ | [] m ] v Hx Hy; unfold compare_stacks.

      (* l = nil, m = nil *)

      exists v; split; auto.
      split; [ intros _ | intros [] ]; auto.
      bsm sss POP empty with x (4+i) (7+i).
      bsm sss POP empty with y q p.
      bsm sss stop.

      (* l = nil, m = One::_ *)

      exists (v[m/y]); split.
      intros; rew vec.
      split; [ discriminate | intros _ ].
      bsm sss POP empty with x (4+i) (7+i).
      bsm sss POP one with y q p m.
      bsm sss PUSH with x' Zero.
      bsm sss POP zero with x' q q nil.
      rew vec; f_equal; auto.
      bsm sss stop; f_equal.
      unfold x'; rew vec.
      apply vec_pos_ext; intros z; dest x z.

      (* l = nil, m = Zero::_ *)

      exists (v[m/y]); split.
      intros; rew vec.
      split; [ discriminate | intros _ ].
      bsm sss POP empty with x (4+i) (7+i).
      bsm sss POP zero with y q p m.
      bsm sss stop.

      (* l = One::_, m = nil *)

      exists (v[l/x]); split.
      intros; rew vec.
      split; [ discriminate | intros _ ].
      bsm sss POP one with x (4+i) (7+i) l.
      bsm sss POP empty with y q q; rew vec.
      bsm sss stop.

      (* l = One::l', m = One::m' *)

      destruct (IHl m (v[l/x][m/y])) as (w & H1 & H2 & H3); rew vec.
      exists w; split.
      intros z G1 G2; specialize (H1 _ G1 G2); rewrite <- H1; rew vec.
      split.

      intros E1; inversion E1 as [ E ]; clear E1.
      specialize (H2 E).
      bsm sss POP one with x (4+i) (7+i) l.
      bsm sss POP one with y q q m; rew vec.
      bsm sss PUSH with x Zero.
      bsm sss POP zero with x i i l; rew vec.
      eq goal H2; do 2 f_equal.
      apply vec_pos_ext; intros z; dest z x.

      intros E1.
      spec in H3.
      contradict E1; subst; auto.
      bsm sss POP one with x (4+i) (7+i) l.
      bsm sss POP one with y q q m; rew vec.
      bsm sss PUSH with x Zero.
      bsm sss POP zero with x i i l; rew vec.
      eq goal H3; do 2 f_equal.
      apply vec_pos_ext; intros z; dest z x.

      (* l = One::l', m = Zero::m' *)

      exists (v[l/x][m/y]).
      split.
      intros; rew vec.
      split; [ discriminate | intros _ ].
      bsm sss POP one with x (4+i) (7+i) l.
      bsm sss POP zero with y q q m; rew vec.
      bsm sss stop.

      (* l = Zero::l', m = nil *)

      exists (v[l/x]).
      split.
      intros; rew vec.
      split; [ discriminate | intros _ ].
      bsm sss POP zero with x (4+i) (7+i) l.
      bsm sss POP empty with y i q; rew vec.
      bsm sss stop.

      (* l = Zero::l', m = nil *)

      exists (v[l/x][m/y]).
      split.
      intros; rew vec.
      split; [ discriminate | intros _ ].
      bsm sss POP zero with x (4+i) (7+i) l.
      bsm sss POP one with y i q m; rew vec.
      bsm sss PUSH with y Zero.
      bsm sss POP zero with y q i m; rew vec.
      bsm sss stop.

      (* l = Zero::l', m = Zero::m' *)

      destruct (IHl m (v[l/x][m/y])) as (w & H1 & H2 & H3); rew vec.
      exists w; split.
      intros z G1 G2; specialize (H1 _ G1 G2); rewrite <- H1; rew vec.
      split.

      intros E1; inversion E1 as [ E ]; clear E1.
      specialize (H2 E).
      bsm sss POP zero with x (4+i) (7+i) l.
      bsm sss POP zero with y i q m; rew vec.

      intros E1.
      spec in H3.
      contradict E1; subst; auto.
      bsm sss POP zero with x (4+i) (7+i) l.
      bsm sss POP zero with y i q m; rew vec.
    Qed.

    Fact compare_stack_eq_spec v :
            v#>x = v#>y
         ->   exists w, (i,compare_stacks) // (i,v) ->> (p,w)
           /\ forall z, z <> x -> z <> y -> v#>z = w#>z.
    Proof using Hxy.
      intros E.
      destruct (cs_spec_rec v eq_refl eq_refl) as (w & H1 & H2 & H3).
      exists w; split; auto.
    Qed.

    Fact compare_stack_neq_spec v :
            v#>x <> v#>y
         ->   exists w, (i,compare_stacks) // (i,v) ->> (q,w)
           /\ forall z, z <> x -> z <> y -> v#>z = w#>z.
    Proof using Hxy.
      intros E.
      destruct (cs_spec_rec v eq_refl eq_refl) as (w & H1 & H2 & H3).
      exists w; split; auto.
    Qed.

    Theorem compare_stack_spec v : exists j w, (i,compare_stacks) // (i,v) ->> (j,w)
                                         /\ forall z, z <> x -> z <> y -> v#>z = w#>z
                                         /\ (v#>x = v#>y /\ j = p \/ v#>x <> v#>y /\ j = q).
    Proof using Hxy.
      destruct (list_bool_dec (v#>x) (v#>y)) as [ H | H ].
      + destruct compare_stack_eq_spec with (1 := H) as (w & H1 & H2); exists p, w; auto.
      + destruct compare_stack_neq_spec with (1 := H) as (w & H1 & H2); exists q, w; auto.
    Qed.

  End compare_stacks.

  Section half_tile.

    Variable (x : pos n).

    (* Code that pushes the reverse of a half tile on a stack *)

    Fixpoint half_tile (l : list bool) :=
      match l with
        | nil  => nil
        | b::l => PUSH x b :: half_tile l
      end.

    Fact half_tile_length l : length (half_tile l) = length l.
    Proof. induction l; simpl; f_equal; auto. Qed.

    Fact half_tile_spec i l v : (i,half_tile l) // (i,v) ->> (length (half_tile l)+i,v[(rev l++v#>x)/x]).
    Proof.
      rewrite half_tile_length.
      revert i v; induction l as [ | b l IHl ]; intros i v; simpl.

      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z x.

      bsm sss PUSH with x b.
      specialize (IHl (1+i) (v[(b::v#>x)/x])).
      apply subcode_sss_compute with (P := (1+i,half_tile l)).
      subcode_tac; solve list eq.
      eq goal IHl; do 2 f_equal.
      lia.
      apply vec_pos_ext; intros z; dest z x.
      solve list eq.
    Qed.

  End half_tile.

  Section push_exactly.

    Variable (x : pos n).

    (* Code that pushes the reverse of a half tile on a stack *)

    Definition push_exactly (l : list bool) := half_tile x (rev l).

    Fact push_exactly_length l : length (push_exactly l) = length l.
    Proof. unfold push_exactly. now rewrite half_tile_length, rev_length. Qed.

    Fact push_exactly_spec i l v : (i, push_exactly l) // (i,v) ->> (length (push_exactly l)+i,v[(l++v#>x)/x]).
    Proof.
      unfold push_exactly.
      rewrite <- (rev_involutive l) at 3.
      eapply half_tile_spec.
    Qed.

  End push_exactly.

  Hint Rewrite empty_stack_length compare_stacks_length half_tile_length : length_db.

  Section tile.

    Variable (x y : pos n) (Hxy : x <> y) (high low : list bool).

    (* Code that pushes a reversed tile on both stacks high and low *)

    Definition tile := half_tile x (rev high) ++ half_tile y (rev low).

    Fact tile_length : length tile = length high + length low.
    Proof. unfold tile; rew length; auto. Qed.

    Fact tile_spec i v st : st = (length tile+i,v[(high++v#>x)/x][(low++v#>y)/y])
                         -> (i,tile) // (i,v) ->> st.
    Proof using Hxy.
      intro; subst.
      unfold tile.
      apply sss_compute_trans with (st2 := (length (half_tile x (rev high))+i,v[(high++v#>x)/x])).
      rewrite <- (rev_involutive high) at 3.
      apply subcode_sss_compute with (P := (i,half_tile x (rev high))).
      subcode_tac.
      apply half_tile_spec.
      rewrite <- (rev_involutive low) at 3.
      apply subcode_sss_compute with (P := (length (half_tile x (rev high))+i,half_tile y (rev low))).
      subcode_tac; solve list eq.
      replace (length (half_tile x (rev high) ++ half_tile y (rev low)) + i)
      with    (length (half_tile y (rev low)) + (length (half_tile x (rev high)) + i)).
      replace (v#>y) with (v[(high ++ v#>x)/x]#>y) by rew vec.
      apply half_tile_spec.
      rew length; lia.
    Qed.

  End tile.

  Hint Rewrite tile_length : length_db.

  Section transfer_ones.

    Variable (x y : pos n) (Hxy : x <> y) (i p q : nat).

    (* Code that does the following:
         * if x is 111110++l where 1 occurs k times then
            - x becomes l
            - y becomes bbbbb++y where b occurs k times
         * if x is 11111 where 1 occurs k times then
            - x becomes nil
            - y becomes bbbbb++y where b occurs k times
     *)

    Definition transfer_ones b := POP x p q :: PUSH y b :: PUSH y Zero :: POP y i i :: nil.

    Fact transfer_ones_length b : length (transfer_ones b) = 4.
    Proof. auto. Qed.

    Fact transfer_ones_spec_1 b k l v st : v#>x = list_repeat One k ++ Zero :: l
                                    -> st = (p,v[l/x][(list_repeat b k ++ v#>y)/y])
                                    -> (i,transfer_ones b) // (i,v) ->> st.
    Proof using Hxy.
      intros H1 E; subst st.
      revert v H1.
      induction k as [ | k IHk ]; intros v; intros Hx;
        simpl list_repeat; simpl app; unfold transfer_ones; simpl in Hx.

      bsm sss POP zero with x p q l.
      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z y.

      bsm sss POP one with x p q (list_repeat One k ++ Zero :: l).
      bsm sss PUSH with y b.
      bsm sss PUSH with y Zero.
      bsm sss POP zero with y i i (b::v#>y); rew vec.
      specialize (IHk (v [(list_repeat One k ++ Zero :: l) / x] [(b :: v #> y) / y])).
      spec in IHk.
      rew vec.
      eq goal IHk; do 2 f_equal.
      apply vec_pos_ext; intros z; dest z y.
      2: dest z x.
      change (b :: list_repeat b k ++ v#>y)
      with (list_repeat b (S k) ++ v#>y).
      replace (S k) with (k+1) by lia.
      rewrite list_repeat_plus; solve list eq.
    Qed.

    Fact transfer_ones_spec_2 b k v st : v#>x = list_repeat One k
                                    -> st = (q,v[nil/x][(list_repeat b k ++ v#>y)/y])
                                    -> (i,transfer_ones b) // (i,v) ->> st.
    Proof using Hxy.
      intros H1 E; subst st.
      revert v H1.
      induction k as [ | k IHk ]; intros v; intros Hx;
        simpl list_repeat; simpl app; unfold transfer_ones; simpl in Hx.

      bsm sss POP empty with x p q.
      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z y; dest z x.

      bsm sss POP one with x p q (list_repeat One k).
      bsm sss PUSH with y b.
      bsm sss PUSH with y Zero.
      bsm sss POP zero with y i i (b::v#>y); rew vec.
      specialize (IHk (v [(list_repeat One k) / x] [(b :: v #> y) / y])).
      spec in IHk.
      rew vec.
      eq goal IHk; do 2 f_equal.
      apply vec_pos_ext; intros z; dest z y.
      2: dest z x.
      change (b :: list_repeat b k ++ v#>y)
      with (list_repeat b (S k) ++ v#>y).
      replace (S k) with (k+1) by lia.
      rewrite list_repeat_plus; solve list eq.
    Qed.

  End transfer_ones.

  Hint Rewrite transfer_ones_length : length_db.

  Section increment.

    Variable (x y : pos n) (Hxy : x <> y).

    (* Code that increments the stack x by one ie.
       for l such that list_bool_succ x l, x becomes l

       y is a spare register which is (globally) unmodified
    *)

    Definition increment i := PUSH y Zero :: transfer_ones x y (1+i)   (5+i) (10+i) One  ++
                              PUSH x One  :: transfer_ones y x (6+i)  (15+i) (15+i) Zero ++
                              PUSH x Zero :: transfer_ones y x (11+i) (15+i) (15+i) Zero ++
                              nil.

    Fact increment_length i : length (increment i) = 15.
    Proof. unfold increment; rew length; auto. Qed.

    Fact increment_spec_1 i v k l : v#>x = list_repeat One k ++ Zero :: l
                               -> (i,increment i) // (i,v) ->> (15+i,v[(list_repeat Zero k ++ One :: l)/x]).
    Proof using Hxy.
      intros Hx.
      unfold increment.

      bsm sss PUSH with y Zero.

      apply subcode_sss_compute_trans with (P := (1+i,transfer_ones x y (1+i) (5+i) (10+i) One))
                                           (st2 := (5+i,v[l/x][(list_repeat One k ++ Zero:: v#>y)/y])); auto.
      apply transfer_ones_spec_1 with (k := k) (l := l); rew vec.
      f_equal.
      apply vec_pos_ext; intros z; dest z y; dest z x.

      bsm sss PUSH with x One.
      apply subcode_sss_compute_trans with (P := (6+i,transfer_ones y x (6+i) (15+i) (15+i) Zero))
                                           (st2 := (15+i,v[(list_repeat Zero k++One::l)/x])); auto.
      apply transfer_ones_spec_1 with (k := k) (l := v#>y); rew vec.
      f_equal.
      apply vec_pos_ext; intros z; dest z y; dest z x.

      bsm sss stop.
    Qed.

    Fact increment_spec_2 i v k : v#>x = list_repeat One k
                               -> (i,increment i) // (i,v) ->> (15+i,v[(list_repeat Zero (S k))/x]).
    Proof using Hxy.
      intros Hx.
      unfold increment.

      bsm sss PUSH with y Zero.

      apply subcode_sss_compute_trans with (P := (1+i,transfer_ones x y (1+i) (5+i) (10+i) One))
                                           (st2 := (10+i,v[nil/x][(list_repeat One k ++ Zero:: v#>y)/y])); auto.
      apply transfer_ones_spec_2 with (k := k); rew vec.
      f_equal.
      apply vec_pos_ext; intros z; dest z y; dest z x.

      bsm sss PUSH with x Zero.
      apply subcode_sss_compute_trans with (P := (11+i,transfer_ones y x (11+i) (15+i) (15+i) Zero))
                                           (st2 := (15+i,v[(list_repeat Zero (S k))/x])); auto.
      apply transfer_ones_spec_1 with (k := k) (l := v#>y); rew vec.
      f_equal.
      apply vec_pos_ext; intros z; dest z y; dest z x.
      replace (S k) with (k+1) by lia.
      rewrite list_repeat_plus; auto.

      bsm sss stop.
    Qed.

    Fact increment_spec i v l m :
           list_bool_succ l m
        -> v#>x = l
        -> (i,increment i) // (i,v) ->> (15+i,v[m/x]).
    Proof using Hxy.
      revert l m; intros ? ? [ k l | k ] H.
      apply increment_spec_1; auto.
      apply increment_spec_2; auto.
    Qed.

  End increment.

  Hint Rewrite increment_length : length_db.

  Section full_decoder.

    Implicit Type (lt : list ((list bool) *  list bool)).

    Definition size_cards lt := fold_right (fun c x => length (fst c) + length (snd c) + x) 0 lt.

    Variables (c h l : pos n) (Hch : c <> h) (Hcl : c <> l) (Hhl : h <> l).
    Variables (p : nat)   (* jumps here when decoding worked correctly *)
              (q : nat)   (* jumps here when decoding produced an error *)
              .

    Let decoder_error := PUSH c Zero :: POP c q q :: nil.

    (* Code that implements a decoder for tile indices
         - ll is a list of tiles (th,tl)

         - when c starts with a valid tile index in ll
           encoded as 00001 (with n 0s to represent b)
           then the corresponding tile is stacked into
           h and l. The code ends up at s

         - otherwise, h and l are left unchanged and the
           code ends up at q
     *)

    Fixpoint decoder s i lt :=
      match lt with
        | nil           => decoder_error
        | (th,tl) :: lt => POP c (3+length (tile h l th tl)+i) q ::
                           tile h l th tl ++
                           PUSH c Zero ::
                           POP c s s ::
                           decoder s (3+length (tile h l th tl)+i) lt
      end.

    Fixpoint length_decoder lt :=
      match lt with
        | nil => 2
        | (th,tl) :: lt => 3+length th+length tl+length_decoder lt
      end.

    Fact decoder_length s i lt : length (decoder s i lt) = length_decoder lt.
    Proof.
      revert s i; induction lt as [ | (th,tl) lt IHlt ]; intros s i; rew length; auto.
      simpl; rew length; rewrite IHlt; lia.
    Qed.

    Fact length_decoder_size lt : length_decoder lt = 2+3*length lt+size_cards lt.
    Proof. induction lt as [ | [] ]; simpl; auto; lia. Qed.

    Local Fact decoder_spec_rec s i mm ll th tl lr lc v w :
           v#>c  = list_repeat Zero (length ll) ++ One :: lc
        -> mm = ll++(th,tl)::lr
        -> w = (s,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])
        -> (i,decoder s i mm) // (i,v) ->> w.
    Proof using Hhl Hcl Hch.
      revert i mm th tl lr lc v w.
      induction ll as [ | (t1,t2) ll IHll ]; simpl; intros i mm th tl lr lc v w H1 H2 H3; subst w.

      (* The list ll is empty *)

      subst mm; simpl decoder.
      bsm sss POP one with c (S (S (S (length (tile h l th tl) + i)))) q lc.

      apply subcode_sss_compute_trans with (P := (1+i,tile h l th tl))
                                           (st2 := (1+length (tile h l th tl)+i,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])); auto.
      apply tile_spec; auto.
      f_equal.
      rew length; lia.
      apply vec_pos_ext; intros z; dest z l.

      bsm sss PUSH with c Zero.
      bsm sss POP zero with c s s lc; rew vec.
      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z c.

      (* The list ll is not empty *)

      subst mm; simpl.
      bsm sss POP zero with c (S (S (S (length (tile h l t1 t2) + i)))) q (list_repeat Zero (length ll) ++ One :: lc).
      apply subcode_sss_compute with (P := (3+length (tile h l t1 t2)+i,
                                            decoder s (S (S (S (length (tile h l t1 t2)+i)))) (ll++(th,tl)::lr))); auto.
      apply IHll with th tl lr lc; auto.
      rew vec.
      f_equal.
      apply vec_pos_ext; intros z; dest z c.
    Qed.

    Fact decoder_spec_ok s i ll th tl lr lc v st :
           v#>c = list_repeat Zero (length ll) ++ One :: lc
        -> st = (s,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])
        -> (i,decoder s i (ll++(th,tl)::lr)) // (i,v) ->> st.
    Proof using Hhl Hcl Hch.
      intros; subst; apply decoder_spec_rec with ll th tl lr lc; auto.
    Qed.

    (* There is no trailing 1 *)

    Fact decoder_spec_nok_1 s i ll v k :
           v#>c = list_repeat Zero k
        -> exists r, (i,decoder s i ll) // (i,v) ->> (q,v[(list_repeat Zero r)/c]).
    Proof.
      revert i v k.
      induction ll as [ | (t1,t2) ll IHll ]; intros i v k H1.

      simpl; unfold decoder_error.
      exists k.
      bsm sss PUSH with c Zero.
      bsm sss POP zero with c q q (v#>c); rew vec.
      bsm sss stop.
      f_equal.
      apply vec_pos_ext; intros z; dest z c.

      unfold decoder; fold decoder.
      destruct k as [ | k ].

      exists 0.
      bsm sss POP empty with c (3 + length (tile h l t1 t2) + i) q.
      bsm sss stop.
      f_equal; apply vec_pos_ext; intros z; dest z c.

      simpl in H1.
      destruct (IHll (3 + length (tile h l t1 t2) + i) (v[(list_repeat Zero k)/c]) k)
        as (r & Hr); rew vec.
      exists r.
      bsm sss POP zero with c (3 + length (tile h l t1 t2) + i) q (list_repeat Zero k).
      revert Hr; rew vec; apply subcode_sss_compute; auto.
    Qed.

    (* There might be a trailing 1 but the list of 0s is too long *)

    Fact decoder_spec_nok_2 s i ll lc v k :
           v#>c = list_repeat Zero k ++ lc
        -> length ll <= k
        -> exists r, (i,decoder s i ll) // (i,v) ->> (q,v[(list_repeat Zero r ++ lc)/c]).
    Proof.
      revert i lc v k.
      induction ll as [ | (t1,t2) ll IHll ]; intros i lc v k H1 H2.

      simpl; unfold decoder_error.
      exists k.
      bsm sss PUSH with c Zero.
      bsm sss POP zero with c q q (v#>c); rew vec.
      bsm sss stop.
      f_equal.
      apply vec_pos_ext; intros z; dest z c.

      unfold decoder; fold decoder.
      destruct k as [ | k ].

      simpl in H2; lia.

      simpl in H1, H2.
      destruct (IHll (3 + length (tile h l t1 t2) + i) lc (v[(list_repeat Zero k++lc)/c]) k)
        as (r & Hr); rew vec.
      lia.
      exists r.
      bsm sss POP zero with c (3 + length (tile h l t1 t2) + i) q (list_repeat Zero k++lc).
      revert Hr; rew vec; apply subcode_sss_compute; auto.
    Qed.

    (* A full decoder of a list of boolean into a list a valid tile indices,
       stacking the tiles in h/l in the list on the run.

       The following list of indices [5,3,0,2] is encoded as 000001 0001 1 001
       A valid list of booleans is an encoding of [n1,...,n_p] where each
       n_i is stricly less than length mm

       If the encoding on the list of indices is incorrect in any way:
         - either not a list of indices
         - or some index is to big
       then the full decoder ends up at q.

       The empty list is not a valid list of tile indices

     *)

    Definition full_decoder i ll :=
         POP c (4+i) p ::
         PUSH c One ::
         PUSH h Zero ::
         POP h (5+i) q ::
         PUSH c Zero ::
         decoder i (5+i) ll.

    Definition length_full_decoder ll := 5 + length_decoder ll.

    Fact full_decoder_length i ll : length (full_decoder i ll) = length_full_decoder ll.
    Proof. unfold full_decoder, length_full_decoder; rew length; rewrite decoder_length; auto. Qed.

    Local Fact full_dec_start_spec_0 i lt v :
        v#>c = nil
     -> (i,full_decoder i lt) // (i,v) ->> (p,v).
    Proof.
      intros H1.
      unfold full_decoder; simpl in H1.
      bsm sss POP empty with c (4+i) p.
      bsm sss stop; f_equal.
    Qed.

    Local Fact full_dec_start_spec_1 i lt v :
        v#>c <> nil
     -> (i,full_decoder i lt) // (i,v) ->> (5+i,v).
    Proof using Hch.
      intros H1.
      case_eq (v#>c).
      intros; destruct H1; auto.
      clear H1.
      unfold full_decoder.
      intros [] lc Hlc.

      bsm sss POP one with c (4+i) p lc.
      bsm sss PUSH with c One.
      bsm sss PUSH with h Zero.
      bsm sss POP zero with h (5+i) q (v#>h); rew vec.
      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z h; dest z c.

      bsm sss POP zero with c (4+i) p lc.
      bsm sss PUSH with c Zero.
      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z c.
    Qed.

    Local Fact full_dec_spec_rec i ln lc lt v :
        v#>c = list_nat_bool ln ++ lc
     -> Forall (fun x => x < length lt) ln
     -> let (hh,ll) := tile_concat ln lt
     in (i,full_decoder i lt) // (i,v) ->> (i,v[lc/c][(hh++v#>h)/h][(ll++v#>l)/l]).
    Proof using Hhl Hcl Hch.
      intros H1 H2; revert H2 v H1.
      induction 1 as [ | k ln Hk Hln IHln ]; intros v H1; simpl.

      bsm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z l; dest z h; dest z c.

      destruct (nth_split _ (nil,nil) Hk) as (ll & lr & H2 & H3).
      revert H2; generalize (nth k lt (nil,nil)); intros (th, tl) H2.
      simpl in H1.
      specialize (IHln (v[(list_nat_bool ln ++ lc)/c][(th++v#>h)/h][(tl++v#>l)/l])).
      spec in IHln; rew vec.
      destruct (tile_concat ln lt) as (thh,tll).

      apply sss_compute_trans with (st2 := (5+i,v)).
      apply full_dec_start_spec_1.
      rewrite H1; destruct k; discriminate.

      unfold full_decoder.
      apply subcode_sss_compute_trans with (P := (5+i,decoder i (5 + i) lt))
           (st2 := (i,v[(list_nat_bool ln++lc)/c][(th++v#>h)/h][(tl++v#>l)/l])); auto.
      subst lt; apply decoder_spec_ok with (list_nat_bool ln++lc); auto.
      rewrite H3; revert H1; solve list eq.

      eq goal IHln; do 2 f_equal.
      apply vec_pos_ext; intros z.
      dest z l; solve list eq.
      dest z h; solve list eq.
      dest z c.
    Qed.

    (* Correctness lemma for the full decoder when
       then input actually encodes a valid list of tiles *)

    Theorem full_decoder_ok_spec i ln lt v :
        v#>c = list_nat_bool ln
     -> v#>h = nil
     -> v#>l = nil
     -> Forall (fun x => x < length lt) ln
     -> let (hh,ll) := tile_concat ln lt
     in (i,full_decoder i lt) // (i,v) ->> (p,v[nil/c][hh/h][ll/l]).
    Proof using Hhl Hcl Hch.
      intros H1 H2 H3 H4.
      rewrite app_nil_end in H1.
      generalize (@full_dec_spec_rec i ln nil lt v H1 H4).
      destruct (tile_concat ln lt) as (hh,ll).
      intros E.
      apply sss_compute_trans with (1 := E); auto.
      rewrite H2, H3; repeat rewrite <- app_nil_end.
      apply full_dec_start_spec_0; rew vec.
    Qed.

    Local Fact full_dec_spec_rec1 i ln lc lt v :
        v#>c = list_nat_bool ln ++ lc
     -> Exists (fun x => length lt <= x) ln
     -> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
               /\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
    Proof using Hhl Hcl Hch.
      intros H1 H2; revert H2 v H1.
      induction ln as [ | x ln IHln ]; intros Hln v H1.
      inversion Hln.

      generalize (full_dec_start_spec_1 i lt v).
      intros H2; spec in H2.
      rewrite H1; simpl; destruct x; discriminate.
      simpl in H1.
      destruct (le_lt_dec (length lt) x) as [ Hx | Hx ].

      unfold full_decoder.
      solve list eq in H1.
      destruct (decoder_spec_nok_2 i (5+i) lt _ _ H1 Hx) as (r & Hr).
      exists (v [(list_repeat Zero r++One::list_nat_bool ln++lc)/c]); split.
      apply sss_compute_trans with (1 := H2); auto.
      unfold full_decoder; revert Hr; apply subcode_sss_compute; auto.
      intros; rew vec.

      apply Exists_cons in Hln.
      destruct Hln as [ Hln | Hln ].
      lia.
      specialize (IHln Hln).
      destruct (nth_split _ (nil,nil) Hx) as (ll & lr & H3 & H4).
      revert H3; generalize (nth x lt (nil,nil)); intros (th, tl) H3.
      specialize (IHln (v[(list_nat_bool ln++lc)/c][(th++v#>h)/h][(tl++v#>l)/l])).
      spec in IHln; rew vec.
      destruct IHln as (w & Hw & Hw1).
      exists w; split.
      apply sss_compute_trans with (2 := Hw).
      apply sss_compute_trans with (1 := H2); auto.
      rewrite <- H4 in H1.
      solve list eq in H1.
      generalize (@decoder_spec_ok i (5+i) ll th tl lr _ _ _ H1 eq_refl).
      unfold full_decoder; apply subcode_sss_compute.
      subst; subcode_tac; solve list eq.
      intros z G1 G2 G3; generalize (Hw1 _ G1 G2 G3); rew vec.
    Qed.

    Local Fact full_dec_spec_rec2 i k lt v :
        v#>c = list_repeat Zero (S k)
     -> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
               /\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
    Proof using Hch.
      intros H.
      destruct (@decoder_spec_nok_1 i (5+i) lt _ _ H) as (r & Hr).
      exists (v[(list_repeat Zero r)/c]); split.
      2: intros; rew vec.
      generalize (@full_dec_start_spec_1 i lt v); intros H1.
      spec in H1.
      rewrite H; discriminate.
      apply sss_compute_trans with (1 := H1); auto.
      revert Hr.
      unfold full_decoder.
      apply subcode_sss_compute; auto.
    Qed.

    (* Correctness lemma for the full decoder when
       then input encodes an invalid list of tiles *)

    Theorem full_decoder_ko_spec i ln lc lt v :
         v#>c = list_nat_bool ln ++ lc
     -> (Exists (fun x => length lt <= x) ln
     \/  Forall (fun x => x < length lt) ln
      /\ exists k, lc = list_repeat Zero (S k))
     ->  exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
               /\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
    Proof using Hhl Hcl Hch.
      intros H1 [ H2 | (H2 & k & H3) ].
      apply full_dec_spec_rec1 with ln lc; auto.
      generalize (@full_dec_spec_rec i ln lc lt v H1 H2).
      destruct (tile_concat ln lt) as (hh,ll); intros H4.
      destruct (@full_dec_spec_rec2 i k lt
           (v[lc/c][(hh++v#>h)/h][(ll++v#>l)/l])) as (w & Hw1 & Hw2); rew vec.
      exists w; split.
      apply sss_compute_trans with (1 := H4); auto.
      intros x E1 E2 E3; rewrite <- Hw2; auto; rew vec.
    Qed.

  End full_decoder.

  Hint Rewrite full_decoder_length : length_db.

  Section simulator.

    Variables (s a h l : pos n) (Hsa : s <> a) (Hsh : s <> h) (Hsl : s <> l)
                                (Hah : a <> h) (Hal : a <> l) (Hhl : h <> l)
              (lt : list ((list bool)*list bool)).

    Section increment_erase.

      Variable (i p : nat).

      (* This code does the following
         - increments s (as a list of booleans)
         - empties h, l and a
         - jumps to p
       *)

      Definition increment_erase :=
      (*      i *) increment s a i ++
      (*   15+i *) empty_stack h (15+i) ++
      (*   18+i *) empty_stack l (18+i) ++
      (*   21+i *) empty_stack a (21+i) ++
      (*   24+i *) PUSH l Zero :: POP l p p :: nil.

      Fact increment_erase_length : length increment_erase = 26.
      Proof. auto. Qed.

      Fact increment_erase_spec v ln mn w :
           list_bool_succ ln mn
        -> v#>s = ln
        -> w = v[mn/s][nil/h][nil/l][nil/a]
        -> (i,increment_erase) // (i,v) ->> (p,w).
      Proof using Hsa Hal.
        intros H1 H2 ?; subst w.
        unfold increment_erase.

        apply sss_compute_trans with (st2 := (15+i,v[mn/s])).
        apply subcode_sss_compute with (P := (i,increment s a i )); auto.
        apply increment_spec with ln; auto.

        apply sss_compute_trans with (st2 := (18+i,v[mn/s][nil/h])).
        apply subcode_sss_compute with (P := (15+i,empty_stack h (15+i))); auto.
        apply empty_stack_spec.

        apply sss_compute_trans with (st2 := (21+i,v[mn/s][nil/h][nil/l])).
        apply subcode_sss_compute with (P := (18+i,empty_stack l (18+i))); auto.
        apply empty_stack_spec.

        apply sss_compute_trans with (st2 := (24+i,v[mn/s][nil/h][nil/l][nil/a])).
        apply subcode_sss_compute with (P := (21+i,empty_stack a (21+i))); auto.
        apply empty_stack_spec.

        bsm sss PUSH with l Zero.
        bsm sss POP zero with l p p nil; rew vec.
        bsm sss stop.
        f_equal.
        apply vec_pos_ext; intros x; dest x l.
      Qed.

    End increment_erase.

    Hint Rewrite increment_erase_length : length_db.

    Section main_init.

      Variable (i : nat).

      (* Self explaining code:
          - s becomes Zero::nil
          - a, h and l are emptied
       *)

      Definition main_init :=
      (*      i *) empty_stack s i ++
      (*    3+i *) empty_stack a (3+i) ++
      (*    6+i *) empty_stack h (6+i) ++
      (*    9+i *) empty_stack l (9+i) ++
      (*   12+i *) PUSH s Zero :: nil.

      Fact main_init_length : length main_init = 13.
      Proof. auto. Qed.

      Fact main_init_spec v : (i,main_init) // (i,v) ->> (13+i,v[(Zero::nil)/s][nil/a][nil/h][nil/l]).
      Proof using Hah Hal Hsa Hsl Hsh.
        unfold main_init.
        apply subcode_sss_compute_trans with (2 := empty_stack_spec s _ _); auto.
        apply subcode_sss_compute_trans with (2 := empty_stack_spec a _ _); auto.
        apply subcode_sss_compute_trans with (2 := empty_stack_spec h (6+i) _); auto.
        apply subcode_sss_compute_trans with (2 := empty_stack_spec l (9+i) _); auto.
        bsm sss PUSH with s Zero.
        bsm sss stop.
        f_equal.
        apply vec_pos_ext; intros x.
        dest x a; dest x l; dest x h; dest x s.
      Qed.

    End main_init.

    Section main_loop.

      Variables (i p : nat).

      Let lFD := length_full_decoder lt.

      (* This code does the following:
           - copies s to a (temporarily using the empty h stack)
           - decodes a as a list of tiles into h/l
             * if the list is correct and h = l at the ends, we
               have a solution to PCP and we jump to p
             * if the list is incorrect, increments s,
               clean up of h, l and a and start over (loop)
       *)

      Definition main_loop :=
      (*          i *) copy_stack s a h i ++
      (*       16+i *) full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt ++
      (*   lFD+16+i *) compare_stacks h l (lFD+16+i) p (lFD+26+i) ++
      (*   lFD+26+i *) increment_erase (lFD+26+i) i.

      Definition length_main_loop := 52 + lFD.

      Fact main_loop_length : length main_loop = length_main_loop.
      Proof. unfold main_loop, length_main_loop, lFD; rew length; lia. Qed.

      Fact main_loop_size : length_main_loop = 59+3*length lt+size_cards lt.
      Proof.
        unfold length_main_loop, lFD, length_full_decoder.
        rewrite length_decoder_size; lia.
      Qed.

      Fact main_loop_ok_spec v ln :
             v#>h = nil
          -> v#>l = nil
          -> v#>a = nil
          -> v#>s = list_nat_bool ln
          -> Forall (fun x => x < length lt) ln
          -> (let (hh,ll) := tile_concat ln lt in hh = ll)
          -> exists w, (i,main_loop) // (i,v) ->> (p,w)
                    /\ forall x, x <> a -> x <> h -> x <> l -> v#>x = w#> x.
      Proof using Hsa Hhl Hal Hah Hsh.
        intros H0 H1 H2 H3 H4 H5.
        case_eq (tile_concat ln lt).
        intros hh ll E; rewrite E in H5.
        destruct (compare_stack_eq_spec Hhl (lFD+16+i) p (lFD+26+i) (v[nil/a][hh/h][ll/l]))
          as (w & Hw1 & Hw2); rew vec.
        exists w; split.
        unfold main_loop.

        apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln)/a])).
        apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
        apply copy_stack_spec with (list_nat_bool ln); auto.
        rewrite H2, <- app_nil_end; auto.

        apply sss_compute_trans with (st2 := (lFD+16+i,v[nil/a][hh/h][ll/l])).
        apply subcode_sss_compute with (P := (16+i,full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt)); auto.
        generalize (@full_decoder_ok_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i) ln lt
          (v[(list_nat_bool ln)/a])); intros H6.
        do 3 (spec in H6; [ rew vec | ]).
        spec in H6; auto.
        rewrite E in H6.
        eq goal H6; do 2 f_equal; rew vec.

        apply subcode_sss_compute with (P := (lFD+16+i,compare_stacks h l (lFD+16+i) p (lFD+26+i))); auto.

        intros x E1 E2 E3; generalize (Hw2 _ E2 E3); rew vec.
      Qed.

      Fact main_loop_ko_spec v ln lc :
             v#>h = nil
          -> v#>l = nil
          -> v#>a = nil
          -> v#>s = list_nat_bool ln ++ lc
          -> (  (   Exists (fun x => length lt <= x) ln
                \/  Forall (fun x => x < length lt) ln /\ exists k, lc = list_repeat Zero (S k) )
             \/  Forall (fun x => x < length lt) ln /\ lc = nil
                 /\ let (hh,ll) := tile_concat ln lt in hh <> ll)
          -> (i,main_loop) // (i,v) ->> (i,v[(list_bool_next (v#>s))/s]).
      Proof using Hsl Hsh Hsa Hhl Hal Hah.
        intros H0 H1 H2 H3 [ H4 | (H4 & ? & H5) ].

        destruct (@full_decoder_ko_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i))
          with (v := v[(list_nat_bool ln ++ lc)/a]) (2 := H4) as (w & Hw1 & Hw2); rew vec.

        unfold main_loop.
        apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln++lc)/a])).
        apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
        apply copy_stack_spec with (list_nat_bool ln++lc); auto.
        rewrite H2, <- app_nil_end; auto.

        apply subcode_sss_compute_trans with (2 := Hw1); auto.

        apply subcode_sss_compute with (P := (lFD+26+i,increment_erase (lFD + 26 + i) i)); auto.
        apply increment_erase_spec with (1 := list_bool_next_spec (v#>s)); auto.
        rewrite <- Hw2; auto; rew vec.
        apply vec_pos_ext; intros x.
        dest x a; dest x l; dest x h; dest x s.
        rewrite <- Hw2; auto; rew vec.

        unfold main_loop.
        subst lc.
        rewrite <- app_nil_end in H3.
        case_eq (tile_concat ln lt).
        intros hh ll E; rewrite E in H5.
        destruct (compare_stack_neq_spec Hhl (lFD+16+i) p (lFD+26+i) (v[nil/a][hh/h][ll/l]))
          as (w & Hw1 & Hw2); rew vec.

        apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln)/a])).
        apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
        apply copy_stack_spec with (list_nat_bool ln); auto.
        rewrite H2, <- app_nil_end; auto.

        apply sss_compute_trans with (st2 := (lFD+16+i,v[nil/a][hh/h][ll/l])).
        apply subcode_sss_compute with (P := (16+i,full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt)); auto.
        generalize (@full_decoder_ok_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i) ln lt
          (v[(list_nat_bool ln)/a])); intros H6.
        do 3 (spec in H6; [ rew vec | ]).
        spec in H6; auto.
        rewrite E in H6.
        eq goal H6; do 2 f_equal; rew vec.

        apply sss_compute_trans with (st2 := (lFD+26+i,w)).
        apply subcode_sss_compute with (P := (lFD+16+i,compare_stacks h l (lFD+16+i) p (lFD+26+i))); auto.

        apply subcode_sss_compute with (P := (lFD+26+i,increment_erase (lFD + 26 + i) i)); auto.
        apply increment_erase_spec with (1 := list_bool_next_spec (v#>s)); auto.
        rewrite <- Hw2; auto; rew vec.
        apply vec_pos_ext; intros x.
        dest x a; dest x l; dest x h; dest x s.
        rewrite <- Hw2; auto; rew vec.
      Qed.

      Implicit Type (v : vec (list bool) n).

      Let pre v := v#>h = nil /\ v#>l = nil /\ v#>a = nil.
      Let spec v w := forall x, x <> a -> x <> h -> x <> l -> v#>x = w#> x.
      Let f v := v[(list_bool_next (v#>s))/s].

      Let Hf v : v <> f v.
      Proof.
        intros E.
        apply (list_bool_succ_neq) with (1 := list_bool_next_spec (v#>s)).
        rewrite E at 1.
        unfold f; rew vec.
      Qed.

      Let C2 v := exists ln,
             v#>s = list_nat_bool ln
          /\ Forall (fun x => x < length lt) ln
          /\ (let (hh,ll) := tile_concat ln lt in hh = ll).

      Let C1 v :=  exists ln lc,
             v#>s = list_nat_bool ln ++ lc
          /\ (  (   Exists (fun x => length lt <= x) ln
                \/  Forall (fun x => x < length lt) ln /\ exists k, lc = list_repeat Zero (S k) )
             \/  Forall (fun x => x < length lt) ln /\ lc = nil
                 /\ let (hh,ll) := tile_concat ln lt in hh <> ll).

      Let HC v : pre v -> { C1 v } + { C2 v }.
      Proof.
        unfold C1, C2.
        intros _.
        generalize (v#>s); clear v; intros m.
        destruct (list_bool_valid_dec (length lt) m)
          as [ (ln & H1) | (ln & H1) ].
        case_eq (tile_concat ln lt); intros hh ll H2.
        destruct (list_bool_dec hh ll) as [ H3 | H3 ].
        * right.
          exists ln.
          destruct H1 as (H1 & H4).
          rewrite H2; auto.
        * left.
          destruct H1 as (H1 & H4).
          exists ln, nil.
          rewrite <- app_nil_end.
          split; auto.
          right.
          rewrite H2; auto.
        * left.
          destruct H1 as (lc & H1 & H2).
          exists ln, lc; split; auto.
      Qed.

      Hypothesis (Hp : out_code p (i,main_loop)).

      Local Lemma HP1 : forall x, pre x -> C1 x -> (i,main_loop) // (i,x) ->> (i,f x) /\ pre (f x).
      Proof using Hsh Hsa Hhl Hal Hah Hsl.
        intros v (H1 & H2 & H3) (ln & lc & H4 & H5).
        split.
        apply main_loop_ko_spec with ln lc; auto.
        red; unfold f; rew vec; auto.
      Qed.

      Local Lemma HP2 : forall x, pre x -> C2 x -> exists y, (i,main_loop) // (i,x) ->> (p,y) /\ spec x y.
      Proof using Hsh Hsa Hhl Hal Hah.
        intros v (H1 & H2 & H3) (ln & H4 & H5 & H6).
        apply  main_loop_ok_spec with ln; auto.
      Qed.

      Local Lemma main_loop_sound_rec v :
                pre v
             -> (exists n, C2 (iter f v n))
             -> exists n w, (i,main_loop) // (i,v) ->> (p,w) /\ spec (iter f v n) w.
      Proof using Hsh Hsa Hhl Hal Hah Hsl.
        apply sss_loop_sound with (C1 := C1); auto using HP1, HP2.
      Qed.

      Local Lemma main_loop_complete_rec v w q : pre v
                                      -> out_code q (i,main_loop)
                                      -> (i,main_loop) // (i,v) ->> (q,w)
                                      -> p = q /\ exists n, C2 (iter f v n) /\ spec (iter f v n) w.
      Proof using Hp Hsh Hsa Hhl Hal Hah Hsl.
        apply sss_loop_complete with (C1 := C1); auto using HP1, HP2.
        apply bsm_sss_fun.
      Qed.

      Local Lemma iter_f_v v k : iter f v k = v[(iter list_bool_next (v#>s) k)/s].
      Proof.
        revert v.
        unfold f; induction k as [ | k IHk ]; intros v; simpl; [ | rewrite IHk ]; rew vec.
      Qed.

      Local Lemma C2_eq v : v#>s = Zero::nil -> (exists n, C2 (iter f v n)) <-> tiles_solvable lt.
      Proof.
        unfold tiles_solvable.
        intros H1; simpl.
        split.

        intros (k & Hk).
        rewrite iter_f_v, H1 in Hk.
        destruct Hk as (ln & H2 & H3 & H4).
        revert H2; rew vec; intros H2.
        exists ln; repeat split; auto.
        intros E.
        subst ln.
        simpl in H2.
        apply iter_list_bool_next_nil in H2.
        destruct H2; discriminate.

        intros (ln & H2 & H3 & H4).
        destruct (@list_bool_next_total (list_nat_bool ln)) as (k & Hk).
        destruct ln as [ | [ | u ] ln ]; simpl; auto; discriminate.
        exists k.
        rewrite iter_f_v, H1, <- Hk.
        exists ln; rew vec; auto.
      Qed.

      Theorem main_loop_sound v :
          v#>s = Zero::nil -> v#>h = nil -> v#>l = nil -> v#>a = nil
       -> tiles_solvable lt
       -> exists w, (i,main_loop) // (i,v) ->> (p,w)
                 /\ forall x, x <> s -> x <> a -> x <> h -> x <> l -> v#>x = w#>x.
      Proof using Hsh Hsa Hhl Hal Hah Hsl.
        intros H1 H2 H3 H4.
        rewrite <- (C2_eq _ H1); auto.
        intros H5.
        destruct main_loop_sound_rec with (2 := H5)
          as (k & w & Hw1 & Hw2).
        red; auto.
        exists w; split; auto.
        unfold spec in Hw2 |- *.
        intros; rewrite <- Hw2; auto.
        rewrite iter_f_v; rew vec.
      Qed.

      Theorem main_loop_complete v w q :
          v#>s = Zero::nil -> v#>h = nil -> v#>l = nil -> v#>a = nil
       -> out_code q (i,main_loop)
       -> (i,main_loop) // (i,v) ->> (q,w)
       -> p = q
       /\ (forall x, x <> s -> x <> a -> x <> h -> x <> l -> v#>x = w#>x)
       /\ tiles_solvable lt.
      Proof using Hp Hsh Hsa Hhl Hal Hah Hsl.
        intros H1 H2 H3 H4 H5 H6.
        rewrite  <- (C2_eq _ H1); auto.
        destruct main_loop_complete_rec with (2 := H5) (3 := H6)
          as (G1 & k & G2 & G3).
        red; auto.
        split; auto.
        split; [ | exists k ]; auto.
        red in G3.
        intros; rewrite <- G3; auto.
        rewrite iter_f_v; rew vec.
      Qed.

    End main_loop.

  End simulator.

End Binary_Stack_Machines.


Require Import HoTT.
Require Import polynomial.

Section Endpoints.
  (* The definition of a HIT signature and a HIT for the signature. *)

  (* An endpoint is also called a "constructor term". It is used in
the HIT signature to describe the endpoints of path constructors. *)

  (* Endpoints are parameterized by a family of polynomials which will
be specialized to the point constructors in the definition of HITS.
   *)
  Variable (I : Type)
           (C : I -> polynomial).

  Inductive endpoint : polynomial -> polynomial -> Type :=
  | endpoint_var :
      forall {P : polynomial},
        endpoint P P
  | endpoint_const :
      forall {P : polynomial} {T : Type},
        T -> endpoint P (poly_const T)
  | endpoint_constr :
      forall {P : polynomial} (i : I),
        endpoint P (C i) -> endpoint P poly_var
  | endpoint_fst :
      forall {P Q R : polynomial},
        endpoint P (poly_times Q R) -> endpoint P Q
  | endpoint_snd :
      forall {P Q R : polynomial},
        endpoint P (poly_times Q R) -> endpoint P R
  | endpoint_pair :
      forall {P Q R : polynomial},
        endpoint P Q -> endpoint P R -> endpoint P (poly_times Q R)
  | endpoint_inl :
      forall {P Q R : polynomial},
        endpoint P Q -> endpoint P (poly_plus Q R)
  | endpoint_inr :
      forall {P Q R : polynomial},
        endpoint P R -> endpoint P (poly_plus Q R).

  Variable (A : Type)
           (F : A -> Type)
           (c : forall (i : I), poly_act (C i) A -> A)
           (f : forall (i : I) (u : poly_act (C i) A), poly_fam (C i) F u -> F (c i u)).

  (* Endpoint acting on data for point constructors. *)
  Fixpoint endpoint_act
           {P Q : polynomial}
           (e : endpoint P Q) (* the endpoint *)
    : poly_act P A -> poly_act Q A
    := match e with
       | endpoint_var _ => idmap
       | endpoint_const _ _ t => fun _ => t
       | endpoint_constr _ i e => fun u => c i (endpoint_act e u)
       | endpoint_fst _ _ _ e => fun u => fst(endpoint_act e u)
       | endpoint_snd _ _ _ e => fun u => snd(endpoint_act e u)
       | endpoint_pair _ _ _ e1 e2 => fun u => (endpoint_act e1 u, endpoint_act e2 u)
       | endpoint_inl _ _ _ e => fun u => inl(endpoint_act e u)
       | endpoint_inr _ _ _ e => fun u => inr(endpoint_act e u)
       end.

  (* The dependent action of an endpoint, this is used for
   "lifting" the path constructors in the elimination principle. *)
  Fixpoint endpoint_dact
           {P Q : polynomial}
           (e : endpoint P Q)
    : forall (x : poly_act P A), poly_fam P F x -> poly_fam Q F (endpoint_act e x)
    := match e with
       | endpoint_var _ => fun _ h => h
       | endpoint_const _ _ t => fun _ _ => t
       | endpoint_constr _ i u => fun x h =>f i (endpoint_act u x) (endpoint_dact u x h)
       | endpoint_fst p p0 p1 e => fun x h => fst (@endpoint_dact p (poly_times p0 p1) e x h)
       | endpoint_snd p p0 p1 e => fun x h => snd (@endpoint_dact p (poly_times p0 p1) e x h)
       | endpoint_pair _ _ _ e1 e2 => fun x h => (endpoint_dact e1 x h, endpoint_dact e2 x h)
       | endpoint_inl p p0 _ e => fun x h => @endpoint_dact p p0 e x h
       | endpoint_inr p _ p1 e => fun x h => @endpoint_dact p p1 e x h
       end.

  (* If [h] commutes with constructors, then it commutes with all endpoints. *)
  Fixpoint endpoint_dact_compute
           {P Q : polynomial}
           (e : endpoint P Q)
    : forall (x : poly_act P A)
             (h : forall x, F x)
             (H : forall i u, h (c i u) = f i u (poly_dmap (C i) h u)),
      endpoint_dact e x (poly_dmap P h x) = poly_dmap Q h (endpoint_act e x)
    := match e with
       | endpoint_var _ => fun _ _ _ => reflexivity _
       | endpoint_const _ _ t => fun _ _ _ => reflexivity t
       | endpoint_constr _ i e' =>
         fun x h H => let u := (endpoint_act e' x) in
           ap (f i u) (endpoint_dact_compute e' x h H) @ (H i u)^
       | endpoint_fst _ _ _ e' =>
         fun x h H =>
           ap fst (endpoint_dact_compute e' x h H)
       | endpoint_snd _ _ _ e' =>
         fun x h H =>
           ap snd (endpoint_dact_compute e' x h H)
       | endpoint_pair _ _ _ e1 e2 =>
         fun x h H =>
           path_prod'
             (endpoint_dact_compute e1 x h H)
             (endpoint_dact_compute e2 x h H)
       | endpoint_inl _ _ _ e' => endpoint_dact_compute e'
       | endpoint_inr _ _ _ e' => endpoint_dact_compute e'
       end.

  (* A general HIT might have an arbitrary number of endpoints and therefore an arbitrarily
   nested point constructors. Our construction of a HIT presumes that there is a bound to
   the nesting. We define here what it means for an endpoint to have such a bound. *)
  Inductive endpoint_rank : forall {P Q : polynomial}, endpoint P Q -> nat -> Type :=
  | rank_var :
      forall {P : polynomial} (n : nat),
        endpoint_rank (@endpoint_var P) n
  | rank_const :
      forall {P : polynomial} {T : Type} (t : T) (n : nat),
        endpoint_rank (@endpoint_const P _ t) n
  | rank_constr :
      forall {P : polynomial} (i : I) (n : nat) (e : endpoint P (C i)),
        endpoint_rank e n -> endpoint_rank (endpoint_constr i e) (S n)
  | rank_fst :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P (poly_times Q R)),
        endpoint_rank e n -> endpoint_rank (endpoint_fst e) n
  | rank_snd :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P (poly_times Q R)),
        endpoint_rank e n -> endpoint_rank (endpoint_snd e) n
  | rank_inl :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P Q),
        endpoint_rank e n -> endpoint_rank (@endpoint_inl _ _ R e) n
  | rank_inr :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P R),
        endpoint_rank e n -> endpoint_rank (@endpoint_inr _ Q _ e) n.
End Endpoints.

Arguments endpoint {_} _ _ _.
Arguments endpoint_var {_ _} {_}.
Arguments endpoint_const {_ _} {_} {_} _.
Arguments endpoint_constr {_ _} {_} _ _ .
Arguments endpoint_fst {_ _} {_ _ _} _.
Arguments endpoint_snd {_ _} {_ _ _} _.
Arguments endpoint_pair {_ _} {_ _ _} _ _.
Arguments endpoint_inl {_ _} {_ _ _} _.
Arguments endpoint_inr {_ _} {_ _ _} _.

Arguments endpoint_act {_ _ _} _ {P Q} _ _.
Arguments endpoint_dact {I C A F} c _ {P Q} _ _ _.
Arguments endpoint_dact_compute {_ _ _} _ _ _ {P Q} _ _ _ _.

Arguments endpoint_rank {_} _ {_ _} _ _.

(* A HIT signature is specified by point constructors and path constructors.

   Note: we are allowing an arbitrary family of poitn and path construcrors.
         We will restrict them later on in existence theorem.
 *)
Structure hit_signature :=
  {
    (* indexing for point constructors *)
    sig_point_index : Type ;

    (* the signatures for point constructors *)
    sig_point : sig_point_index -> polynomial ;

    (* indexing for path constructors *)
    sig_path_index : Type ;

    (* the parameters of each path constructor *)
    sig_path_param : sig_path_index -> polynomial ;

    (* the left and right endpoints of path constructors *)
    sig_path_lhs : forall i, endpoint sig_point (sig_path_param i) poly_var ;
    sig_path_rhs : forall i, endpoint sig_point (sig_path_param i) poly_var
  }.

(* A guarded HIT is a HIT in which all endpoints are constructors. *)
Structure guarded_hit_signature := {
  (* indexing for point constructors *)
  guarded_sig_point_index : Type ;

  (* the signatures for point constructors *)
  guarded_sig_point : guarded_sig_point_index -> polynomial ;

  (* indexing for path constructors *)
  guarded_sig_path_index : Type ;

  (* the parameters of each path constructor *)
  guarded_sig_path_param : guarded_sig_path_index -> polynomial ;

  (* the left and right endpoints of path constructors *)
  guarded_sig_path_lhs : forall i, { c : guarded_sig_point_index & endpoint guarded_sig_point (guarded_sig_path_param i) (guarded_sig_point c) } ;
  guarded_sig_path_rhs : forall i, { c : guarded_sig_point_index & endpoint guarded_sig_point (guarded_sig_path_param i) (guarded_sig_point c) }
}.

Definition unguard (G : guarded_hit_signature) : hit_signature :=
{|
  sig_point_index := guarded_sig_point_index G ;
  sig_point := guarded_sig_point G ;
  sig_path_index := guarded_sig_path_index G ;
  sig_path_param := guarded_sig_path_param G ;
  sig_path_lhs := (fun i => endpoint_constr
                              ((guarded_sig_path_lhs G i).1)
                              ((guarded_sig_path_lhs G i).2)) ;
  sig_path_rhs := (fun i => endpoint_constr
                              ((guarded_sig_path_rhs G i).1)
                              ((guarded_sig_path_rhs G i).2))
|}.

Coercion unguard : guarded_hit_signature >-> hit_signature.

(* A HIT signature has rank [n] if all of its endpoints do. *)
Definition hit_rank Σ n :=
  (forall (j : sig_path_index Σ), endpoint_rank (sig_point Σ) (sig_path_lhs Σ j) n) *
  (forall (j : sig_path_index Σ), endpoint_rank (sig_point Σ) (sig_path_rhs Σ j) n).

Section HIT_Definition.

  (* We define HIT for signature [Σ]. *)
  Variable (Σ : hit_signature).

  (* The type of a lift of the point constructor [c] over a family [F]. *)
  Definition point_over
             {H : Type} (* the carrier type *)
             (F : H -> Type)
             (c : forall i, poly_act (sig_point Σ i) H -> H) (* point constructors *)
             (p : forall j u, endpoint_act c (sig_path_lhs Σ j) u =
                              endpoint_act c (sig_path_rhs Σ j) u) (* path constructors *)
    := forall (i : sig_point_index Σ) (u : poly_act (sig_point Σ i) H),
      poly_fam (sig_point Σ i) F u -> F (c i u).

  (* The type of a lift of the path constructor [p] over a family [F]. *)
  Definition path_over
             {H : Type}
             {F : H -> Type}
             {c : forall i, poly_act (sig_point Σ i) H -> H} (* point constructors *)
             {p : forall j u, endpoint_act c (sig_path_lhs Σ j) u =
                              endpoint_act c (sig_path_rhs Σ j) u} (* path constructors *)
             (c' : point_over F c p)
    := forall (j : sig_path_index Σ)
              (x : poly_act (sig_path_param Σ j) H)
              (h : poly_fam (sig_path_param Σ j) F x),
      transport _ (p j x) (endpoint_dact c c' (sig_path_lhs Σ j) x h) =
      endpoint_dact c c' (sig_path_rhs Σ j) x h.

  (* It is tricky to phrase the computation rule for paths, so we phrase an auxiliary lemma
   that lets us construct the type of the path computation rule interactively. *)
  Definition hit_path_beta_eq
             (H : Type) (* the carrier type *)
             (c : forall i, poly_act (sig_point Σ i) H -> H) (* point constructors *)
             (p : forall j u, endpoint_act c (sig_path_lhs Σ j) u =
                              endpoint_act c (sig_path_rhs Σ j) u) (* path constructors *)
             (E : (* the eliminator *)
                forall (F : H -> Type)
                       (c' : point_over F c p)
                       (p' : path_over c'),
                forall (x : H), F x)
             (point_beta : (* the point computation rule *)
                forall (F : H -> Type)
                       (c' : point_over F c p)
                       (p' : path_over c')
                       i (t : poly_act (sig_point Σ i) H),
                  E F c' p' (c i t) = c' i t (poly_dmap (sig_point Σ i) (E F c' p') t)) :
    Type.
  Proof.
    simple refine (forall (F : H -> Type) (j : sig_path_index Σ)
                          (c' : point_over F c p)
                          (p' : path_over c')
                          (k : sig_path_index Σ)
                          (t : poly_act (sig_path_param Σ k) H), _).
    (* We want an equation between [α] and [β], but their types do not match, so a transport
     is required on each side of the equation. *)
    pose (α := apD (E F c' p') (p k t)).
    pose (β := p' k t (poly_dmap _ (E F c' p') t)).
    simpl in β.
    (* the path along which we will transport lhs *)
    assert (q_lhs : endpoint_dact c c' (sig_path_lhs Σ k) t (poly_dmap (sig_path_param Σ k) (E F c' p') t) =
                    E F c' p' (endpoint_act c (sig_path_lhs Σ k) t)).
    { apply (endpoint_dact_compute F c c' (sig_path_lhs Σ k) t), point_beta. }
    (* the path along which we will transport rhs *)
    assert (q_rhs : endpoint_dact c c' (sig_path_rhs Σ k) t (poly_dmap (sig_path_param Σ k) (E F c' p') t) =
                    E F c' p' (endpoint_act c (sig_path_rhs Σ k) t)).
    { apply (endpoint_dact_compute F c c' (sig_path_rhs Σ k) t), point_beta. }
    pose (β' := transport
                  (fun z => transport F (p k t) z =
                            endpoint_dact c c' (sig_path_rhs Σ k) t (poly_dmap (sig_path_param Σ k) (E F c' p') t))

                  q_lhs β).
    simpl in β'.
    pose (β'' := transport
                   (fun z => transport F (p k t) (E F c' p' (endpoint_act c (sig_path_lhs Σ k) t)) = z)
                   q_rhs β').
    exact (α = β'').
  Defined.

  Structure HIT :=
    {
      (* the carrier of the HIT *)
      hit_carrier :> Type ;

      (* the point constructor *)
      hit_point : forall i, poly_act (sig_point Σ i) hit_carrier -> hit_carrier ;

      (* path constructors *)
      hit_path : forall j u, endpoint_act hit_point (sig_path_lhs Σ j) u =
                             endpoint_act hit_point (sig_path_rhs Σ j) u ;

      (* the eliminator *)
      hit_ind :
        forall (F : hit_carrier -> Type)
               (c : point_over F hit_point hit_path)
               (p : path_over c)
               (x : hit_carrier),
          F x ;

      (* computation rule for points *)
      hit_point_beta :
        forall (F : hit_carrier -> Type)
               (c : point_over F hit_point hit_path)
               (p : path_over c)
               (i : sig_point_index Σ)
               (t : poly_act (sig_point Σ i) hit_carrier),
          hit_ind F c p (hit_point i t) =
          c i t (poly_dmap (sig_point Σ i) (hit_ind F c p) t) ;

      (* computation rule for paths *)
      hit_path_beta :
        hit_path_beta_eq hit_carrier hit_point hit_path hit_ind hit_point_beta
    }.
End HIT_Definition.

Arguments hit_point {_ _} _ _.
Arguments hit_path {_ _} _ _.
Arguments hit_ind {_ _} _ _ _ _.

Section HIT_Primitive_Recursion.
  (** The non-dependent recursion principle follows from the induction principle. *)

  Variable Σ : hit_signature. (* The HIT signature. *)

  (** We give a special name to [endpoint_dact] applied to a constant family.
      To be used for the non-dependent recursion principle. *)
  Definition endpoint_dact_nondep
             {I : Type} {C : I -> polynomial} {A : Type} {B : Type}
             (c : forall i : I, poly_act (C i) A -> A)
             (f : forall i (u : poly_act (C i) A), poly_fam (C i) (fun _ => B) u -> B)
             {P Q : polynomial}
             (e : endpoint C P Q) (x : poly_act P A) (h : poly_fam P (fun _ => B) x)
    := @endpoint_dact I C A (fun _ => B) c f P Q e x h.

  Section Methods.
    Variable (H : HIT Σ) (* the carrier type *)
             (A : Type) (* the target type *)
             (c : forall i, poly_act (sig_point Σ i) H -> H) (* point constructors *)
             (p : forall j u,
                 endpoint_act c (sig_path_lhs Σ j) u
                 =
                 endpoint_act c (sig_path_rhs Σ j) u). (* path constructors *)

    (* The non-dependent version of a lift of a point constructor, to be used in the
     non-dependent recursion principle. *)
    Definition point_over_nondep
      := forall (i : sig_point_index Σ) (u : poly_act (sig_point Σ i) H),
        poly_fam (sig_point Σ i) (fun _ => A) u -> A.

    (* The non-dependent version of a lift of a path constructor, to be used in the
     non-dependent recursion principle. *)
    Definition path_over_nondep (c' : point_over_nondep)
      := forall (j : sig_path_index Σ)
                (x : poly_act (sig_path_param Σ j) H)
                (h : poly_fam (sig_path_param Σ j) (fun _ => A) x),
        transport _ (p j x) (endpoint_dact_nondep c c' (sig_path_lhs Σ j) x h)
        =
        endpoint_dact_nondep c c' (sig_path_rhs Σ j) x h.
  End Methods.

  Variable (H : HIT Σ) (A : Type)
           (c : point_over_nondep H A)
           (p : path_over_nondep H A (@hit_point Σ H) hit_path c).

  Definition hit_primrec : H -> A := hit_ind (fun (x : H) => _) c p.

  Definition hit_point_primrec_beta
          (i : sig_point_index Σ)
          (u : poly_act (sig_point Σ i) H)
    : hit_primrec (hit_point i u)
      =
      c i u (poly_dmap (sig_point Σ i) hit_primrec u)
    := hit_point_beta Σ H _ c p i u.

  Section beta_path.
    Variable (j : sig_path_index Σ)
             (u : poly_act (sig_path_param Σ j) H)
             (x : poly_fam (sig_path_param Σ j) (fun _ => A) u).

    Definition endpoint_compute_lhs
      : endpoint_dact_nondep
          hit_point c (sig_path_lhs Σ j) u
          (poly_dmap (sig_path_param Σ j) hit_primrec u)
        =
        hit_primrec (endpoint_act hit_point (sig_path_lhs Σ j) u)
      := endpoint_dact_compute _ _ _ _ _ _ (hit_point_beta _ H _ c p).

    Definition endpoint_transport_compute_lhs
      := ap (transport (fun _ : H => A) (hit_path j u)) endpoint_compute_lhs.

    Definition endpoint_compute_rhs
      : endpoint_dact_nondep
          hit_point c (sig_path_rhs Σ j) u
          (poly_dmap (sig_path_param Σ j) hit_primrec u)
        =
        hit_primrec (endpoint_act hit_point (sig_path_rhs Σ j) u)
      := endpoint_dact_compute _ _ _ _ _ _ (hit_point_beta _ H _ c p).

    Definition endpoint_const_compute_lhs
      := transport_const (hit_path j u) _ @ endpoint_compute_lhs.

    Theorem hit_path_primrec_beta'
      : apD hit_primrec (hit_path j u)
        =
        endpoint_transport_compute_lhs^
        @ p j u (poly_dmap (sig_path_param Σ j) hit_primrec u)
          @ endpoint_compute_rhs.
    Proof.
      unfold hit_primrec.
      refine (hit_path_beta _ _ _ j _ _ _ _ @ _).
      rewrite !transport_paths_FlFr.
      hott_simpl.
    Defined.

    Theorem hit_path_primrec_beta
      : ap hit_primrec (hit_path j u)
        =
        endpoint_const_compute_lhs^
        @ p j u (poly_dmap (sig_path_param Σ j) hit_primrec u)
          @ endpoint_compute_rhs.
    Proof.
      eapply (cancelL (transport_const (hit_path j u) _)).
      simple refine ((apD_const _ _)^ @ _).
      rewrite hit_path_primrec_beta'.
      hott_simpl.
      repeat f_ap.
      rewrite inv_pp.
      induction endpoint_compute_lhs.
      hott_simpl.
    Defined.
  End beta_path.
End HIT_Primitive_Recursion.

Section HIT_Recursion.
  (** The non-dependent recursion principle follows from the induction principle. *)

  Variable (Σ : hit_signature). (* The HIT signature. *)

  Definition fam_const
             {A B : Type}
             {P : polynomial}
             {p : poly_act P A}
    : poly_fam P (fun _ : A => B) p -> poly_act P B.
  Proof.
    induction P.
    - apply idmap.
    - apply idmap.
    - intros [x1 x2].
      refine (IHP1 (fst p) x1, IHP2 (snd p) x2).
    - intros x.
      destruct p as [p | p].
      * apply (inl (IHP1 p x)).
      * apply (inr (IHP2 p x)).
  Defined.

  (** We give a special name to [endpoint_dact] for the recursion principle. *)
  Definition endpoint_dact_rec
             {I : Type} {C : I -> polynomial} {A : Type} {B : Type}
             (c : forall i : I, poly_act (C i) A -> A)
             (f : forall i, poly_act (C i) B -> B)
             {P Q : polynomial}
             (e : endpoint C P Q) (x : poly_act P A) (h : poly_fam P (fun _ => B) x)
    := @endpoint_dact I C A (fun _ => B) c (fun i _ u => f i (fam_const u)) P Q e x h.

  Definition endpoint_dact_const
        {I : Type} {C : I -> polynomial} {A : Type} {B : Type}
        (c : forall i : I, poly_act (C i) A -> A)
        (f : forall i, poly_act (C i) B -> B)
        {P Q : polynomial}
        (e : endpoint C P Q) (x : poly_act P A) (h : poly_fam P (fun _ => B) x)
    : fam_const (@endpoint_dact I C A _ c (fun i _ u => f i (fam_const u)) P Q e x h)
      =
      @endpoint_act I C B f P Q e (fam_const h).
  Proof.
    induction e ; simpl in *.
    - reflexivity.
    - reflexivity.
    - refine (ap (f i) (IHe _ _)).
    - refine (ap fst (IHe x h)).
    - refine (ap snd (IHe x h)).
    - refine (path_prod' (IHe1 x h) (IHe2 x h)).
    - refine (ap inl (IHe x h)).
    - refine (ap inr (IHe x h)).
  Defined.

  Variable (H : HIT Σ)
           (A : Type).

  (* The non-dependent version of a lift of a point constructor, to be used in the
     non-dependent recursion principle. *)
  Definition point_over_rec
    := forall (i : sig_point_index Σ), poly_act (sig_point Σ i) A -> A.

  (* The non-dependet version of a lift of a path constructor, to be used in the
     non-dependent recursion principle. *)
  Definition path_over_rec_help (cY : point_over_rec)
    := forall (j : sig_path_index Σ)
              (x : poly_act (sig_path_param Σ j) H)
              (h : poly_fam (sig_path_param Σ j) (fun _ => A) x),
      endpoint_dact_rec hit_point cY (sig_path_lhs Σ j) x h =
      endpoint_dact_rec hit_point cY (sig_path_rhs Σ j) x h.

  Definition path_over_rec (cY : point_over_rec)
    := forall (j : sig_path_index Σ)
              (x : poly_act (sig_path_param Σ j) A),
      endpoint_act cY (sig_path_lhs Σ j) x =
      endpoint_act cY (sig_path_rhs Σ j) x.

  Variable (cY : point_over_rec)
           (pY_rec : path_over_rec cY).

  Definition pY : path_over_rec_help cY :=
    fun j x h =>
      endpoint_dact_const hit_point cY _ _ _
                          @ pY_rec j (fam_const h)
                          @ (endpoint_dact_const hit_point cY _ _ _ )^.

  Definition cY' : point_over_nondep Σ H A
    := fun i _ x => cY i (fam_const x).

  Definition pY' : @path_over_nondep Σ H A hit_point hit_path cY'.
  Proof.
    intros j x h ; simpl.
    refine (transport_const _ _ @ _).
    pose (pY j x).
    apply pY.
  Defined.

  Definition hit_rec : H -> A := hit_primrec Σ H A cY' pY'.

  Theorem hit_point_rec_beta
          (i : sig_point_index Σ)
          (u : poly_act (sig_point Σ i) H)
    : hit_rec (hit_point i u)
      =
      cY i (poly_map (sig_point Σ i) hit_rec u).
  Proof.
    unfold hit_rec.
    rewrite hit_point_primrec_beta.
    - unfold cY'.
      f_ap.
      induction (sig_point Σ i) ; simpl ; try reflexivity.
      * rewrite IHp1, IHp2.
        reflexivity.
      * destruct u ; rewrite IHp1 || rewrite IHp2 ; try f_ap ; auto.
  Defined.

  Section beta_path.
    Variable (j : sig_path_index Σ)
             (u : poly_act (sig_path_param Σ j) H).

    Definition t5
      : endpoint_dact_rec hit_point cY (sig_path_lhs Σ j) u
                          (poly_dmap (sig_path_param Σ j) hit_rec u)
        =
        hit_rec (endpoint_act hit_point (sig_path_lhs Σ j) u)
      := (transport_const _ _)^ @ endpoint_const_compute_lhs Σ H A cY' pY' j u.

    Definition t6
      : endpoint_dact_rec hit_point cY (sig_path_rhs Σ j) u
                          (poly_dmap (sig_path_param Σ j) hit_rec u)
        =
        hit_rec (endpoint_act hit_point (sig_path_rhs Σ j) u)
      := endpoint_compute_rhs Σ H A cY' pY' j u.

    Theorem hit_rec_beta_path
      : ap hit_rec (hit_path j u)
        =
        t5^ @ pY j u (poly_dmap (sig_path_param Σ j) hit_rec u) @ t6.
    Proof.
      unfold hit_rec.
      rewrite hit_path_primrec_beta.
      unfold pY', t5.
      rewrite inv_pp.
      hott_simpl.
    Defined.
  End beta_path.
End HIT_Recursion.


(** * Encoding of well-scoped syntax as unscoped syntax *)

Require Import utype wstype.
Require Import Lia Arith Utils.Various_utils Program.Equality.

Inductive closed : utype.type -> nat -> Prop :=
  | cVar x n : x<n -> closed (utype.var_type x) n
  | cAll s t n : closed s n -> closed t (S n) -> closed (utype.all s t) n.

Fixpoint encode {n : nat} (t : wstype.type n) : utype.type :=
  match t with
   | var_type f => let s := fin2nat f in let (x, _) := s in utype.var_type x
   | all t1 t2 => utype.all (encode t1) (encode t2)
   end.

Notation "⟦ t ⟧" := (encode t).

Definition encode_ren {n m : nat} (ξ : fin n -> fin m) : nat -> nat.
Proof. intro x. destruct (le_lt_dec n x) as [ |H].
  - exact x.
  - eapply fin2nat,ξ,(nat2fin H).
Defined.

Notation "« r »" := (encode_ren r).

Fact wellscoped_closed {n} (t : wstype.type n) : closed ⟦t⟧ n.
Proof. induction t; simpl.
  -destruct (fin2nat f). now apply cVar.
  -now apply cAll.
Qed.

Fact bext_ren (n:nat) (t : utype.type) (Hc : closed t n) (ξ ξ' : nat -> nat) (Hx : forall x, x<n -> ξ x = ξ' x) :
  utype.ren_type ξ t = utype.ren_type ξ' t.
Proof. revert n Hc ξ ξ' Hx. induction t; intros; depind Hc; simpl.
  -now rewrite (Hx n H).
  -apply utype.congr_all.
    +eapply IHt1. exact Hc1. exact Hx.
    +eapply IHt2. exact Hc2. intros. destruct (le_lt_dec n x).
      *assert (x=n) as -> by lia. destruct n; simpl; auto. unfold unscoped.funcomp. now rewrite Hx.
      *destruct x; simpl; auto. unfold unscoped.funcomp. rewrite Hx. auto. lia.
Qed.

Lemma ext_ren_upto (n:nat) (ξ ξ' : nat -> nat) (Hx : forall x, x<n -> ξ x = ξ' x) (t : wstype.type n) :
  utype.ren_type ξ ⟦t⟧ = utype.ren_type ξ' ⟦t⟧.
Proof. apply (bext_ren n). apply wellscoped_closed. assumption.
Qed.

Fact n2f_S {n m} (H : S n < S m) (H': n<m) : nat2fin H = shift (nat2fin H').
Proof. simpl. now rewrite (nat2fin_ext _ H'). Qed.

Fixpoint f2n_n2f' {n x} {f : fin n} {H : x<n} {struct n}: fin2nat f = exist (fun x => x < n) x H -> nat2fin H = f.
Proof. intro. destruct n. contradiction. unfold nat2fin. destruct x.
  { destruct f. simpl in *.  destruct (fin2nat f). discriminate. auto. }
  fold (@nat2fin n). destruct f. 2: simpl in *; discriminate. f_equal. apply f2n_n2f'.
  simpl in *. destruct (fin2nat f).
Admitted.

Theorem encoding_ren {n m : nat} (ξ : fin n -> fin m) (t : wstype.type n) :
  ⟦ wstype.ren_type ξ t ⟧ = utype.ren_type «ξ»  ⟦t⟧.
Proof. revert m ξ. induction t; intros; simpl.
  -destruct (fin2nat f) eqn:Hf. simpl. unfold encode_ren. destruct (le_lt_dec ntype x).
   exfalso. lia. rewrite (nat2fin_ext _ l). enough (nat2fin l=f). rewrite H. now destruct (fin2nat (ξ f)).
   now apply f2n_n2f'.
  -apply utype.congr_all. apply IHt1. rewrite IHt2. eapply ext_ren_upto.
   intros. destruct x. simpl. unfold encode_ren. destruct (le_lt_dec (S ntype) 0); now simpl.
   simpl. unfold unscoped.funcomp. unfold encode_ren. destruct (le_lt_dec ntype x). lia.
   destruct (le_lt_dec (S ntype) (S x)). lia. rewrite (n2f_S _ l). simpl.
   now destruct (fin2nat (ξ (nat2fin l))).
Qed.

Definition encode_subst {n m : nat} (ξ : fin n -> wstype.type m) : nat -> utype.type.
Proof. intro x. destruct (le_lt_dec n x) as [ |H].
  - apply utype.var_type,x.
  - eapply encode,ξ,(nat2fin H).
Defined.

Notation "[| s |]" := (encode_subst s).

Fact bext_subst (n:nat) (t : utype.type) (Hc : closed t n) (θ θ' : nat -> utype.type) (Hx : forall x, x<n -> θ x = θ' x) :
  utype.subst_type θ t = utype.subst_type θ' t.
Proof. revert n Hc θ θ' Hx. induction t; intros; depind Hc; simpl.
  -now apply Hx.
  -apply utype.congr_all.
    +eapply IHt1. exact Hc1. exact Hx.
    +eapply IHt2. exact Hc2. intros. destruct (le_lt_dec n x).
      *assert (x=n) as -> by lia. destruct n; simpl; auto. unfold unscoped.funcomp. now rewrite Hx.
      *destruct x; simpl; auto. unfold unscoped.funcomp. rewrite Hx. auto. lia.
Qed.

Lemma ext_subst_upto (n:nat) (θ θ' : nat -> utype.type) (Hx : forall x, x<n -> θ x = θ' x) (t : wstype.type n) :
  utype.subst_type θ ⟦t⟧ = utype.subst_type θ' ⟦t⟧.
Proof. apply (bext_subst n). apply wellscoped_closed. assumption.
Qed.

Theorem encoding_subst {n m : nat} (θ : fin n -> wstype.type m) (t : wstype.type n) :
   ⟦ wstype.subst_type θ t ⟧ = utype.subst_type [|θ|]  ⟦t⟧.
Proof. revert m θ. induction t; intros; simpl.
  -destruct (fin2nat f) eqn:Hf. simpl. unfold encode_subst. destruct (le_lt_dec ntype x).
   lia. rewrite (nat2fin_ext _ l). enough (nat2fin l=f). now rewrite H. now apply f2n_n2f'.
  -apply utype.congr_all. apply IHt1. rewrite IHt2. eapply ext_subst_upto.
   intros. destruct x. simpl. unfold encode_subst. destruct (le_lt_dec (S ntype) 0); now simpl.
   simpl. unfold unscoped.funcomp. unfold encode_subst. destruct (le_lt_dec ntype x). lia.
   destruct (le_lt_dec (S ntype) (S x)). lia. rewrite (n2f_S _ l). simpl.
   unfold funcomp. rewrite encoding_ren. apply ext_ren_upto. intros.
   unfold encode_ren. destruct (le_lt_dec m x0). lia. simpl.
   destruct (fin2nat (nat2fin l1)) eqn:Hf2n. f_equal. auto. rewrite <- (@f2n_n2f _ _ l1).
   now rewrite Hf2n.
Qed.


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file collects general purpose definitions and theorems on the fin type
(bounded naturals). It uses the definitions from the standard library, but
renames or changes their notations, so that it becomes more consistent with the
naming conventions in this development. *)
From stdpp Require Export base tactics.
Set Default Proof Using "Type".

(** * The fin type *)
(** The type [fin n] represents natural numbers [i] with [0 ≤ i < n]. We
define a scope [fin], in which we declare notations for small literals of the
[fin] type. Whereas the standard library starts counting at [1], we start
counting at [0]. This way, the embedding [fin_to_nat] preserves [0], and allows
us to define [fin_to_nat] as a coercion without introducing notational
ambiguity. *)
Notation fin := Fin.t.
Notation FS := Fin.FS.

Delimit Scope fin_scope with fin.
Arguments Fin.FS _ _%fin : assert.

Notation "0" := Fin.F1 : fin_scope. Notation "1" := (FS 0) : fin_scope.
Notation "2" := (FS 1) : fin_scope. Notation "3" := (FS 2) : fin_scope.
Notation "4" := (FS 3) : fin_scope. Notation "5" := (FS 4) : fin_scope.
Notation "6" := (FS 5) : fin_scope. Notation "7" := (FS 6) : fin_scope.
Notation "8" := (FS 7) : fin_scope. Notation "9" := (FS 8) : fin_scope.
Notation "10" := (FS 9) : fin_scope.

Fixpoint fin_to_nat {n} (i : fin n) : nat :=
  match i with 0%fin => 0 | FS i => S (fin_to_nat i) end.
Coercion fin_to_nat : fin >-> nat.

Notation fin_of_nat := Fin.of_nat_lt.
Notation fin_rect2 := Fin.rect2.

Instance fin_dec {n} : EqDecision (fin n).
Proof.
 refine (fin_rect2
  (λ n (i j : fin n), { i = j } + { i ≠ j })
  (λ _, left _)
  (λ _ _, right _)
  (λ _ _, right _)
  (λ _ _ _ H, cast_if H));
  abstract (f_equal; by auto using Fin.FS_inj).
Defined.

(** The inversion principle [fin_S_inv] is more convenient than its variant
[Fin.caseS] in the standard library, as we keep the parameter [n] fixed.
In the tactic [inv_fin i] to perform dependent case analysis on [i], we
therefore do not have to generalize over the index [n] and all assumptions
depending on it. Notice that contrary to [dependent destruction], which uses
the [JMeq_eq] axiom, the tactic [inv_fin] produces axiom free proofs.*)
Notation fin_0_inv := Fin.case0.

Definition fin_S_inv {n} (P : fin (S n) → Type)
  (H0 : P 0%fin) (HS : ∀ i, P (FS i)) (i : fin (S n)) : P i.
Proof.
  revert P H0 HS.
  refine match i with 0%fin => λ _ H0 _, H0 | FS i => λ _ _ HS, HS i end.
Defined.

Ltac inv_fin i :=
  let T := type of i in
  match eval hnf in T with
  | fin ?n =>
    match eval hnf in n with
    | 0 =>
      revert dependent i; match goal with |- ∀ i, @?P i => apply (fin_0_inv P) end
    | S ?n =>
      revert dependent i; match goal with |- ∀ i, @?P i => apply (fin_S_inv P) end
    end
  end.

Instance FS_inj: Inj (=) (=) (@FS n).
Proof. intros n i j. apply Fin.FS_inj. Qed.
Instance fin_to_nat_inj : Inj (=) (=) (@fin_to_nat n).
Proof.
  intros n i. induction i; intros j; inv_fin j; intros; f_equal/=; auto with lia.
Qed.

Lemma fin_to_nat_lt {n} (i : fin n) : fin_to_nat i < n.
Proof. induction i; simpl; lia. Qed.
Lemma fin_to_of_nat n m (H : n < m) : fin_to_nat (fin_of_nat H) = n.
Proof.
  revert m H. induction n; intros [|?]; simpl; auto; intros; exfalso; lia.
Qed.
Lemma fin_of_to_nat {n} (i : fin n) H : @fin_of_nat (fin_to_nat i) n H = i.
Proof. apply (inj fin_to_nat), fin_to_of_nat. Qed.

Fixpoint fin_plus_inv {n1 n2} : ∀ (P : fin (n1 + n2) → Type)
    (H1 : ∀ i1 : fin n1, P (Fin.L n2 i1))
    (H2 : ∀ i2, P (Fin.R n1 i2)) (i : fin (n1 + n2)), P i :=
  match n1 with
  | 0 => λ P H1 H2 i, H2 i
  | S n => λ P H1 H2, fin_S_inv P (H1 0%fin) (fin_plus_inv _ (λ i, H1 (FS i)) H2)
  end.

Lemma fin_plus_inv_L {n1 n2} (P : fin (n1 + n2) → Type)
    (H1: ∀ i1 : fin n1, P (Fin.L _ i1)) (H2: ∀ i2, P (Fin.R _ i2)) (i: fin n1) :
  fin_plus_inv P H1 H2 (Fin.L n2 i) = H1 i.
Proof.
  revert P H1 H2 i.
  induction n1 as [|n1 IH]; intros P H1 H2 i; inv_fin i; simpl; auto.
  intros i. apply (IH (λ i, P (FS i))).
Qed.

Lemma fin_plus_inv_R {n1 n2} (P : fin (n1 + n2) → Type)
    (H1: ∀ i1 : fin n1, P (Fin.L _ i1)) (H2: ∀ i2, P (Fin.R _ i2)) (i: fin n2) :
  fin_plus_inv P H1 H2 (Fin.R n1 i) = H2 i.
Proof.
  revert P H1 H2 i; induction n1 as [|n1 IH]; intros P H1 H2 i; simpl; auto.
  apply (IH (λ i, P (FS i))).
Qed.