From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div.

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

Module Lect3.
  (*** Universal quantifier *)

  Section Motivation.
    Variables A B : Type.

    (** Suppose we wrote two functions:
        a simple (a.k.a. gold) implementation and
        its optimized version.
        How do we go about specifying their equivalence? *)
    Variables fgold fopt : A -> B.

    Lemma fopt_equiv_fgold :
      forall x : A, fgold x = fopt x.
    Abort.

    (* Dependently typed functions *)

    (* Рекомендую предварительно получить какое-то представление или освежить знания о зависимых типах.
       Достаточно потратить 5 минут на чтение русской вики:
       https://ru.wikipedia.org/wiki/%D0%97%D0%B0%D0%B2%D0%B8%D1%81%D0%B8%D0%BC%D1%8B%D0%B9_%D1%82%D0%B8%D0%BF  *)

    (** ** Dependently typed predecessor function *)

    Definition Pred n :=
      if n is S n' then nat else unit.

    (** the value of [unit] type plays the role of a placeholder *)
    Print unit.

    Definition predn_dep : forall n, Pred n :=
      fun n => if n is S n' then n' else tt.

    Print erefl.
    Print Logic.eq_refl.

    Check erefl : predn_dep 7 = 6.
    Compute predn_dep 7.
    Fail Check erefl : predn_dep 0 = 0.
    Check predn_dep 0 : unit.
    Check predn_dep 0 : Pred 0.
    Check predn_dep 7 : nat.

    Check erefl : predn_dep 0 = tt.
    Check erefl : Pred 0 = unit.

    (** ** Annotations for dependent pattern matching *)

    (** Type inference is undecidable *)

    (* Тут мы просим вывести ф-цию над типами.
       Другими словами мы "просим" провести унификацию
       высшего порядка, т.е. вывести "теорему",
       которую мы "доказали", построив данный proof-term,
       а это алгоритмически не разрешимая задача. *)
    Fail Check (fun n => if n is S n' then n' else tt).

    Check (
        fun n =>
          if n is S n' as n0 return Pred n0
          then n'
          else tt).

    (**
    General form of pattern matching construction:
    [match expr as T in (deptype A B) return exprR].

    - [return exprR] denotes the dependent type of the expression
    - [as T] is needed when we are matching on complex expressions,
    not just variables
    *)

    (* Functional type is just a notation *)
    (* for a special case of [forall] *)

    (*
       "A -> B" := forall _ : A, B
       Это зависимая ф-ция, в том случае, когда возвращаемый тип
       никак не зависит от входного значения.

       Это нотация из стандартной библиотеки, которая означает:
       для неважно какого значения из типа [A] мы всегда возвращаем один и тот же тип [B]

       Вообще говоря, обычное функциональное пространство является
       тем частным случаем, когда область значений не зависит от входного параметра
    *)
    Locate "->".

    (* Следующие записи эквивалентны *)
    Check predn : nat -> nat.
    (* Мы можем назвать как-то входное значение в типе ф-ции, но
       [Check] распечатает без него, тк в выходном типе оно никак не используется *)
    Check predn : forall _ : nat, nat.
    (* Аналогично *)
    Check predn : forall x : nat, (fun _ => nat) x.

  End Motivation.

  (** * Usage of [forall] in standalone expressions *)

  Section StandardPredicates.
    Variable T : Type.
    Implicit Types (op add : T -> T -> T).

    Definition associative op :=
      forall x y z, op x (op y z) = op (op x y) z.

    Definition left_distributive op add :=
      forall x y z, op (add x y) z = add (op x z) (op y z).

    Definition left_id e op :=
      forall x, op e x = x.
  End StandardPredicates.

  (* Закон исключённого третьего влечёт
     за собой дуальноe правило Фробениуса *)

  Definition LEM :=
    forall P : Prop, P \/ ~ P.

  Definition Frobenius2 :=
    forall (A : Type) (P : A -> Prop) (Q : Prop),
      (forall x, Q \/ P x) <-> (Q \/ forall x, P x).

  Lemma lem_implies_Frobenius2 :
    LEM -> Frobenius2.
  Proof.
    rewrite /LEM /Frobenius2.
    move=> lem.
    move=> A P Q.
    split.
    - move=> all_qpx.
      move: (lem Q).
      case.
      + move=> q.
        left.
        exact q.
      + move=> nq.
        right.
        move=> x.
        Check all_qpx x.
        case: (all_qpx x).
        Undo.
        move: (all_qpx x).
        case.
        (* Check nq : Q -> False. *)
        (* Конструкция "вид" [move/H] это приблизительный аналог
           [move=> top. move: (H top)]

           Соотвественно это работает и с [case/H],
           что будет эквивалентно [move=> top. case: (H top)] *)
        * move/nq.
          Undo.
          move=> q. move: (nq q).
          done.
        * by [].
    case.
    - move => q x.
      left.
      exact: q.
    - move => all_px x.
      right.
      exact: all_px x.
    Undo 9.

    case; first by move=> q x; left.
    move=> all_px x.
    right. exact: all_px.
    Undo 2.
    by right.
  Qed.

  (* Давайте докажем, что это работает и в обратную сторону *)

  Lemma Frobenius2_lem : Frobenius2 -> LEM.
  Proof.
    rewrite /Frobenius2=> frob.
    rewrite /LEM. Undo.
    (* Поскольку мы знаем определение [LEM], то
       мы можем сразу ввести [P] в контекст и
       Coq развернёт определение автоматически *)
    move=> P.
    (* rewrite /not. *)
    Check (frob P (fun _ => False) P).
    (* frob : forall (A : Type) (P : A -> Prop) (Q : Prop), *)
    (*        (forall x : A, Q \/ P x) <-> Q \/ (forall x : A, P x) *)
    (* frob P (fun _ : P => False) P *)
    (*      : (P -> P \/ False) <-> P \/ (P -> False) *)
    case: (frob P (fun _ => False) P).
    (* Переносим в контекст первые два, но
       второе пропускаем и сразу возвращаем первое в цель *)
    move=> H _; move: H.
    (* [apply.] это "дефективная форма" тактики [apply],
       что значит по сути "использование тактики без модификаторов" *)
    apply. move=> x. left. exact: x.
    Undo 4.
    (* Т.е. получается, что [left]/[right] переносит
       всё до первой дизъюнкии в контекст? Да.
       Это плохо. Способ выше -- правильный *)
    apply. left. exact: x.
    Undo 3.
    by apply; left.
  Qed.

  Module MyExistential.

Inductive ex_my (A : Type) (P : A -> Prop) : Prop :=
| ex_intro (x : A) (proof : P x).

    (* ex_intro [предикат] [значение] [доказательство, что предикат выполняется на этом значении] *)

    (* Если у нас написано, что существует [x] для
       которого выполняется [P x], то мы имеем дело с некой парой.
       Для того, чтобы воспользоваться этой парой мы должны сделать
       по ней pattern-matching типа [case x px] и получим в контексте 2 значения.
       Зависимая типизация тут это ключевая особенность. *)

    (* В Coq уже есть [ex], определение выше нужно было просто,
       чтобы посмотреть как оно устроено под капотом. *)

    (** Simplified notation *)
    Notation "’exists’ x : A , p" :=
      (ex_my (fun x : A => p))
        (at level 200, right associativity).

    (** Full-blown notation: multiple binders *)
    Notation "'exists' x .. y , p" :=
      (ex_my (fun x => .. (ex_my (fun y => p)) ..))
        (at level 200, x binder, right associativity,
         format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
      : type_scope.

    Print ex_my.
    Print ex.

  End MyExistential.

  (* Т.е. если существует [x] для которого утверждение истинно,
     то не для всех [x] оно не истинно. *)
  Lemma exists_not_forall A (P : A -> Prop) :
    (exists x, P x) -> ~ (forall x, ~ P x).
  Proof.
    case=> x px.
    move=> all.
    Check (all x).
    exact: (all x px).
  Qed.

  (* Можно имитировать обычную пару при помощи exists:
     A /\ B
     exists _ : A, B

     Т.е. существует некоторое
     утверждение _ (которое мы никак не именуем) типа [A]
     и утверждение типа [B].

     Можно посмотреть на подстановку:

     Notation "’exists’ _ : A, B" :=
      (ex (fun x : A => B))
        (at level 200, right associativity).
  *)

  (* Definition curry' {A B C} : *)
  (*   (A * B -> C) -> (A -> B -> C) := *)
  (*   fun f => (fun a b => f (a; b)). *)

  Definition curry {A B C} :
    (A * B -> C) -> (A -> B -> C).
  (* Не будем тут писать слово [Proof], тк тут мы
     имеем ввиду некую вычислительную сущность, а не док-во *)
  move=> f a b.
  (* exact: (f (pair a b)). *)
  exact: (f (a, b)).
  (* Используем Defined, тк мы хотим уметь считать при помощи этой ф-ции. *)
 Defined.

  Lemma curry_dep A (P : A -> Prop) Q :
    ((exists x, P x) -> Q) -> (forall x, P x -> Q).
  Proof.
    move=> f x px.
    (* Print ex_intro. *)
    (* ex_intro : forall x : A, P x -> exists y, P y *)
    exact: (f (ex_intro P x px)).
  Qed.

  Section Symmetric_Transitive_Relation.
    (* У нас есть некоторое отношение [R] над типом [D] *)
    Variables (D : Type) (R : D -> D -> Prop).

    (* [Hypothesis] is a different syntax for [Variable] *)

    (* Отношение симметрично *)
    Hypothesis Rsym :
      forall x y, R x y -> R y x.

    (* Отношение транзитивно *)
    Hypothesis Rtrans :
      forall x y z, R x y -> R y z -> R x z.

    (* Если нам известно про некое соотношение,
       в котором есть хотя бы одна пара (оно не пустое),
       то такое отношение ещё и рефлексивно, т.е. любой [x]
       находится в отношении [R] с самим собой. *)
    Lemma relf_if :
      forall x : D, (exists y, R x y) -> R x x.
    Proof.
      move=> x.
      case=> y rxy.
      move: (Rsym rxy).
      move: rxy.
      apply: Rtrans.
    Qed.

  End Symmetric_Transitive_Relation.

  Lemma exfalso_quodlibet :
    False -> forall P : Prop, P.
  Proof. by []. Qed.

  (* Импликация это ф-ция, которая принимает [f : False] и
     производит некоторую ф-цию, которая принимает
     произвольное утверждение [P] и производит его доказательство. *)
  Definition exfalso_quodlibet_term :
    False -> forall P : Prop, P :=
    fun f =>
      (* Поскольку [False] это индуктивный тип, то
         по его значениям можно паттерн-матчить.
         А конструкторов у нас 0, столько и запишем :) *)
      match f with end.

  (* Частный случай *)
  Lemma False_implies_false :
    False -> false.
  Check false : Type.
  Print false.
  Set Printing Coercions.
  (* Set Printing All. *)
  rewrite /is_true.
  (* Теперь мы видим, что на самом деле от нас требуется доказать, что:
     False -> false = true

     Мы тут видим [false = true], потому что
     is_true = fun b : bool => eq b true : forall _ : bool, Prop

     Вообще говоря, у нас это не тайпчекается,
     потому что здесь должен быть тип.

     Коэрции это такой способ реализовать в Coq подтипирование.
     Поскольку в теории типов, на которой основан Coq подтипирования нет,
     то это реализовано при помощи такого мета-механизма.
     Как только Coq видит, что есть некий терм, который
     не проходит проверку типов (у нас это [false = true]),
     то он ищет в своей базе коэрций способ преобразовать его так,
     чтобы он тайпчекался. В нашем случае наиболее простой выход,
     который он находит это использовать [is_true].

     False -> is_true false

     forall _ : False, @eq bool false true
  *)
  Proof. case. Qed.

  (* Вот так, например, определена коэрция [is_true]: *)
  Unset Printing Notations.
  Print is_true.
  Set Printing Notations.

  (* Coercion is_true : bool >-> Sortclass. *)
  (* Print Coercions. *)

  (* Going in the other direction *)
  Lemma false_implies_False :
    false -> False.
  Proof. by []. Qed.

  Check I : True.

  (* Чтобы разобраться что происходит под капотом,
     можно построить следующий пруф-терм: *)
  Definition false_implies_False_term :
    false -> False :=
 (* Раскроем коэрцию: *)
 (* fun eq : false         => *)
 (* fun eq : is_true false => *)
    fun eq : false = true  =>
      (* тут false не меняется, а true меняется (тк это индекс) *)
      (* [in] это по сути [:],
         т.е. это нужно читать как [eq : eq _ b] *)
      match eq in (_ = b)
            return (if b then False else True)

      (* до паттерн-матчинга мы знаем,
         что [true] унифицируется с [b] /
         что [b] и [true] это одно и то же:

         return (if true False else True)
         return False *)

      (* внутри паттерн-матчинга [b]
         "унифицируется c" / "заменяется на" [false]):

         return (if false False else True)
         return True *)

      with
      | erefl => I : True
      end.

  (* See:
     https://coq.inria.fr/refman/addendum/extended-pattern-matching.html#dependent-pattern-matching
     https://github.com/coq/coq/wiki/MatchAsInReturn.

     [match] allows the result type to depend on both
     the input value, and the parameters of the input type. *)

  (* Все параметры индуктивного типа заменяются на _,
     а всем индексам можно дать имена *)

  (* fun     eq : false = true => *)
  (*   match eq : (_    = b) *)

  (* Ещё один хороший\понятный пример из документации.
     Здесь тип возвращаемого списка зависит от типов переданных списков.

     Fixpoint concat (n:nat) (l:listn n) (m:nat) (l':listn m) {struct l} : listn (n + m) :=
     match l in listn n return listn (n + m) with
     | niln => l'
     | consn n' a y => consn (n' + m) a (concat n' y m l')
     end.

     И ещё один:

     Definition tail n (v: listn (S n)) :=
     match v in listn (S m) return listn m with
     | niln => False_rect unit
     | consn n' a y => y
     end.
  *)

  (* Injectivity of constructors *)

Lemma succ_inj n m :
  S n = S m -> n = m.
Proof.
  case. (* special case for [case] *)
    (* Тактика [case] работает особым образом в таком случае.
       Если мы на таком равенстве с конструкторами используем её, то
       она нам преобразует в соотв. форму -- "распаковывает" конструкторы.
     *)
    Show Proof.
    (* f_equal : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y *)
    done.
  Qed.

  Lemma pair_inj A B (a1 a2 : A) (b1 b2 : B) :
    (a1, b1) = (a2, b2) -> (a1 = a2) /\ (b1 = b2).
  Proof.
    case.
    move=> H1 H2.
    rewrite H1.
    rewrite H2.
    by [].

    Restart.

    case.
    move=> ->->.
    by [].

    Restart.

    by case=> ->->.
  Qed.

  (*** Induction *)

    Lemma addnA :
      associative addn.
    Proof.
      (* Мы знаем определение ассоциативности,
         поэтому можем сразу переместить x, y и z в контекст и
         Coq поймёт, что нужно развенуть определение *)

      (* Либо можно вот так развернуть его в цели: *)
      Eval hnf in associative addn.

      move=> x y z.
      (* Есть такая эвристика, что если ф-ция определена рекурсивно по
         1-му аргументу, то индукцию следует тоже делать по 1-му аргументу.

         Индукция есть в некотором смысле символическое вычисление. *)

      elim: x.
      - by [].

      (* Мы хотим избавляться от таких тривиальных целей,
         как в первом случае. Это можно сделать при помощи
         флага [//], который делает тоже самое, что и [by []]. *)
      Undo 3.

      elim: x=> //.
      Undo 1.

      elim: x.
      have : 0 + 1 = 1.

      Print addn.
      (* Модификатор [/=] запускает классическую тактику [simpl],
         которая двойные определения не разворачивает:
         [addn = nosimpl addn_rec] *)

      (* Set Printing All. *)
      (* rewrite /addn. *)
      (* Print addn. *)
      (* [/=] запускает классическую тактику [simpl] *)
      (* addn тут не развернётся, тк внутри него [addn_rec] помечена как [nosimpl]:
         addn = nosimpl addn_rec : nat -> nat -> nat
         см. https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html?highlight=nosimpl *)
      move=> /=.

      (* Unset Printing All. *)
      done.

      Restart.

      move=> x y z.
      elim: x=> // x IH.
      Search _ (_.+1 + _).
      rewrite addSn.
      rewrite IH.
      done.

      Restart.

      by move=> x y z; elim: x=> // x IH; rewrite addSn IH.
    Qed.

    Lemma add0n :
      left_id 0 addn.
    Proof.
      (* Это просто вычисляется (по определению суммы [add_n]) *)
      rewrite /left_id.
      by [].
    Qed.

    Lemma addn0 :
      right_id 0 addn.
    Proof.
      rewrite /right_id.
      (* А вот тут уже только по индукции *)

      elim.
      - by [].
      - move=> n IHn.
        About addSn.
        rewrite addSn.
        rewrite IHn.
        done.

      Restart.

      move=> x.
      elim: x=> // x IHn.

      Restart.

      by elim=> // x IH; rewrite addSn IH.
    Qed.

    Lemma addSnnS m n :
      m.+1 + n = m + n.+1.
    Proof.
      elim: m=> //.
      move=> m IH.
      rewrite addSn IH.
      done.

      Restart.

      by elim: m=> // m IH; rewrite addSn IH.
    Qed.

    Lemma addnC :
      commutative addn.
    Proof.
      move=> x y.
      elim: x.
      - rewrite addn0. done.
      - move=> n IHn.
        rewrite addSn.
        rewrite -addSnnS.
        rewrite IHn.
        rewrite addSn.
        done.

      Restart.

      move=> x y.
      elim: x; first by rewrite addn0.
      by move=> x IHn; rewrite addSn IHn -addSnnS.
    Qed.

    Check nat_ind.

    (* Определим элиминатор индукции.
       В теории типов индукция кодируется через рекурсию,
       т.е. у нас нет отдельно рекурсии и отдельно индукции. *)

    Definition nat_ind_my :
      forall P : nat -> Prop,
        P 0 -> (forall n : nat, P n -> P n.+1) ->
        forall n : nat, P n :=
      fun P p0 step =>
        fix rec n :=
          if n is n'.+1
            then step n' (rec n')
            else p0.
End Lect3.


From mathcomp Require Import all_ssreflect.
Require Import ssromega.

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

(* ゴールと前提にある if式の条件で場合分けする。 *)
Ltac if_condition' :=
  intros;
  repeat match goal with
         | [ |- context[if ?b then _ else _] ] =>
           let H' := fresh in destruct b eqn: H'
         | [ H : context[if ?b then _ else _] |- _ ] =>
           let H' := fresh in destruct b eqn: H'
         | _ => idtac
         end.

Ltac if_condition :=
  if_condition'; try done; ssromega.

(* Sample *)
Goal forall m n, (if m < n then m else n) = (if n <= m then n else m).
Proof.
  if_condition.
Qed.

(* END *)


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

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

(** * Definition of channels and of the capacity *)

(*Local Open Scope tuple_ext_scope.*)

Module Channel1.

Section Channel1_sect.

Variables A B : finType.

(** Probability transition matrix: *)

(** Definition of a discrete channel of input alphabet A and output alphabet B.
    It is a collection of probability mass functions, one for each a in A: *)

Local Notation "'`Ch_1'" := (A -> dist B).

(** Channels with non-empty alphabet: *)

Record chan_star := mkChan {
  c :> `Ch_1 ;
  input_not_0 : (0 < #|A|)%nat }.

Local Notation "'`Ch_1*'" := (chan_star).

Lemma chan_star_eq (c1 c2 : `Ch_1*) : c c1 = c c2 -> c1 = c2.
Proof.
destruct c1 as [c1 Hc1].
destruct c2 as [c2 Hc2].
move=> /= ?; subst c2.
f_equal.
apply eq_irrelevance.
Qed.

End Channel1_sect.

End Channel1.

Definition chan_star_coercion := Channel1.c.
Coercion chan_star_coercion : Channel1.chan_star >-> Funclass.

Notation "'`Ch_1(' A ',' B ')'" := (A -> dist B) (at level 10, A, B at next level) : channel_scope.

Notation "'`Ch_1*(' A ',' B ')'" := (@Channel1.chan_star A B) (at level 10, A, B at next level) : channel_scope.

Local Open Scope channel_scope.

Module DMC.

Section DMC_sect.

Variables A B : finType.
Variable W : `Ch_1(A, B).
Variable n : nat.

(** nth extension of the discrete memoryless channel (DMC): *)

Local Open Scope proba_scope.
Local Open Scope ring_scope.

Definition channel_ext n := 'rV[A]_n -> {dist 'rV[B]_n}.

Local Notation "'`Ch_' n" := (channel_ext n) (at level 9, n at next level, format "'`Ch_'  n").

(** Definition of a discrete memoryless channel (DMC).
    W(y|x) = \Pi_i W_0(y_i|x_i) where W_0 is a probability
    transition matrix. *)

Local Open Scope vec_ext_scope.

Definition f (va vb : 'rV_n) := \rmul_(i < n) W (va ``_ i) (vb ``_ i).

Lemma f0 va vb : 0 <= f va vb.
Proof. apply Rle_0_big_mult => /= i; by apply Rle0f. Qed.

Lemma f1 va : \rsum_(vb in 'rV_n) f va vb = 1%R.
Proof.
set f' := fun i b => W va ``_ i b.
suff H : \rsum_(g : {ffun 'I_n -> B}) \rmul_(i < n) f' i (g i) = 1%R.
  rewrite -{}[RHS]H /f'.
  rewrite (reindex_onto (fun vb : 'rV_n => [ffun x => vb ``_ x])
    (fun g  => \row_(k < n) g k)) /=; last first.
    move=> g _; apply/ffunP => /= i; by rewrite ffunE mxE.
  apply eq_big => vb.
  - rewrite inE.
    apply/esym/eqP/matrixP => a b; by rewrite {a}(ord1 a) mxE ffunE.
  - move=> _; apply eq_bigr => i _; by rewrite ffunE.
rewrite -bigA_distr_bigA /= /f'.
transitivity (\rmul_(i < n) 1%R); first by apply eq_bigr => i _; rewrite pmf1.
by rewrite big_const_ord iter_Rmult pow1.
Qed.

Definition c : `Ch_n := locked (fun ta => makeDist (f0 ta) (f1 ta)).

End DMC_sect.

End DMC.

Notation "'`Ch_' n '(' A ',' B ')'" := (@DMC.channel_ext A B n) (at level 10, n, A, B at next level) : channel_scope.

Notation "'`Ch_' n '(' A ',' B ')'" := (@DMC.channel_ext A B n) (at level 10, A, B, n at next level, format "'`Ch_'  n  '(' A ','  B ')'") : channel_scope.

Notation "W '``^' n" := (@DMC.c _ _ W n) (at level 10) : channel_scope.

Notation "W '``^' n '(|' c ')'" := (@DMC.c _ _ W n c) (at level 10, n, c at next level) : channel_scope.

Notation "W '``^' n '(' b '|' a ')'" := (@DMC.c _ _ W n a b) (at level 10, n, b, a at next level) : channel_scope.

Local Open Scope proba_scope.

Lemma DMC_nonneg {A B : finType} n (W : `Ch_1(A, B)) b a : 0 <= W ``^ n (b | a).
Proof. rewrite /DMC.c. unlock. by apply DMC.f0. Qed.

Module OutDist.

Section OutDist_sect.

Variables A B : finType.
Variable P : dist A.
Variable W  : `Ch_1(A, B).

(** Output distribution for the discrete channel: *)

Definition f (b : B) := \rsum_(a in A) W a b * P a.

Lemma f0 (b : B) : 0 <= f b.
Proof. apply: Rle_big_0_P_g => a _; apply: Rmult_le_pos; by apply Rle0f. Qed.

Lemma f1 : \rsum_(b in B) f b = 1.
Proof.
rewrite exchange_big /= -(pmf1 P).
apply eq_bigr => a _; by rewrite -big_distrl /= (pmf1 (W a)) Rmult_1_l.
Qed.

Definition d : dist B := makeDist f0 f1.

End OutDist_sect.

End OutDist.

Notation "'`O(' P , W )" := (OutDist.d P W) (at level 10, P, W at next level) : channel_scope.

Section OutDist_prop.

Variables A B : finType.

(** Equivalence between both definition when n = 1: *)

Local Open Scope reals_ext_scope.
Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma tuple_pmf_out_dist (W : `Ch_1(A, B)) (P : dist A) n (b : 'rV_ _):
   \rsum_(j0 : 'rV[A]_n)
      ((\rmul_(i < n) W j0 ``_ i b ``_ i) * P `^ _ j0)%R =
   TupleDist.f (`O(P , W)) b.
Proof.
rewrite /TupleDist.f /=.
apply/esym.
rewrite bigA_distr_big_dep /=.
rewrite (reindex_onto (fun p : 'rV_ _ => [ffun x => p ``_ x]) (fun y => \row_(k < n) y k)) //=; last first.
  move=> i _.
  apply/ffunP => /= n0.
  by rewrite ffunE mxE.
(*rewrite (@big_tcast _ _ _ _ _ (card_ord n)) //.*)
apply eq_big.
- move=> a /=.
  apply/andP; split.
    by apply/forallP.
  by apply/eqP/matrixP => a' b'; rewrite {a'}(ord1 a') mxE ffunE.
- move=> a Ha.
  rewrite big_split /=.
  congr (_ * _)%R.
  + apply eq_bigr => i /= _; by rewrite ffunE.
  + apply eq_bigr => i /= _; by rewrite ffunE.
Qed.

End OutDist_prop.

(** Output entropy: *)

Local Open Scope entropy_scope.

Notation "'`H(' P '`o' W )" := (`H ( `O( P , W ))) (at level 10, P, W at next level) : channel_scope.

Module JointDist.

Section JointDist_sect.

Variables A B : finType.
Variable P : dist A.
Variable W : `Ch_1(A, B).

(** Joint distribution: *)

Definition f (ab : A * B) := W ab.1 ab.2 * P ab.1.

Lemma f0 (ab : A * B) : 0 <= f ab.
Proof. apply: Rmult_le_pos; by [apply ptm0 | apply Rle0f]. Qed.

Lemma f1 : \rsum_(ab | ab \in {: A * B}) (W ab.1) ab.2 * P ab.1 = 1.
Proof.
rewrite -(pair_big xpredT xpredT (fun a b => (W a) b * P a)) /= -(pmf1 P).
apply eq_bigr => /= t Ht; by rewrite -big_distrl /= pmf1 Rmult_1_l.
Qed.

Definition d : dist [finType of A * B] := makeDist f0 f1.

End JointDist_sect.

End JointDist.

Definition JointDistd {A B : finType} (P : dist A) (W : `Ch_1(A, B)) :=
  nosimpl JointDist.d _ _ P W.

Notation "'`J(' P , W )" := (JointDistd P W) (at level 10, P, W at next level) : channel_scope.

Section Pr_tuple_prod_sect.

Variable A B : finType.
Variable P : dist A.
Variable W : `Ch_1(A, B).
Variable n : nat.

Lemma Pr_tuple_prod Q : Pr (`J(P `^ n, (W ``^ n))) [set x | Q x] =
  Pr (`J(P, W)) `^ n [set x | Q (tuple_prod x)].
Proof.
rewrite /Pr.
rewrite rsum_rV_prod /=.
apply eq_big.
  move=> tab /=.
  by rewrite !inE prod_tupleK.
move=> tab.
rewrite inE => Htab.
rewrite /JointDist.f /TupleDist.f.
rewrite /DMC.c; unlock => /=.
rewrite -big_split /=.
apply eq_bigr => i /= _.
by rewrite /JointDist.f /= -snd_tnth_prod_tuple -fst_tnth_prod_tuple.
Qed.

End Pr_tuple_prod_sect.

(** Mutual entropy: *)

Notation "`H( P , W )" := (`H ( `J(P , W))) (at level 10, P, W at next level) : channel_scope.

Section conditional_entropy.

Variable A B : finType.
Variable W : `Ch_1(A, B).
Variable P : dist A.

(** Definition of conditional entropy *)

Definition cond_entropy := `H(P , W) - `H P.

End conditional_entropy.

Notation "`H( W | P )" := (cond_entropy W P) (at level 10, W, P at next level) : channel_scope.

Local Open Scope channel_scope.

Section conditional_entropy_prop.

Variables A B : finType.
Variable W : `Ch_1(A, B).
Variable P : dist A.
Local Open Scope channel_scope.
Local Open Scope Rb_scope.

(** Equivalent expression of the conditional entropy (cf. Lemma 6.23) *)

Lemma cond_entropy_single_sum : `H( W | P ) = \rsum_(a in A) P a * `H (W a).
Proof.
rewrite /cond_entropy /`H /OutDist.d /JointDist.d /=.
rewrite -(pair_big xpredT xpredT (fun a b => (W a) b * P a * log (W a b * P a))) /=.
rewrite /Rminus -Ropp_plus_distr /=; f_equal.
rewrite (big_morph _ morph_Ropp Ropp_0) -big_split /= (big_morph _ morph_Ropp Ropp_0).
apply eq_bigr => // a _.
case/boolP : (P a == 0); move=> Hcase.
- move/eqP in Hcase.
  rewrite Hcase !(mul0R, addR0, Ropp_0).
  transitivity (- \rsum_(b : B) 0).
    f_equal.
    apply eq_bigr => // b _.
    by rewrite !(mul0R, mulR0).
  by rewrite big_const iter_Rplus mulR0 Ropp_0.
- rewrite Rmult_comm -(Rmult_1_r (-(log (P a) * P a))) -(pmf1 (W a)).
  rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)) Ropp_mult_distr_r_reverse; f_equal.
  rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)) -big_split /=.
  apply eq_bigr => // b _.
  case/boolP : (W a b == 0); move=> Hcase2.
  - move/eqP in Hcase2.
    by rewrite Hcase2 !mul0R !mulR0 addR0.
  - rewrite log_mult; last 2 first.
    + apply Rlt_le_neq; first by apply Rle0f.
      move=> abs; by rewrite -abs eqxx in Hcase2.
    + apply Rlt_le_neq; first by apply Rle0f.
      move=> abs; by rewrite -abs eqxx in Hcase.
   by field.
Qed.

End conditional_entropy_prop.

Section mutual_information_section.

Variables A B : finType.

(** Mutual information of distributions *)

Definition mut_info_dist (P : dist [finType of A * B]) :=
  `H (ProdDist.proj1 P) + `H (ProdDist.proj2 P) - `H P.

(** Mutual information of input/output *)

Definition mut_info P (W : `Ch_1(A, B)) := `H P + `H(P `o W) - `H(P , W).

End mutual_information_section.

Notation "`I( P ; W )" := (mut_info P W) (at level 50) : channel_scope.

Section capacity_definition.

Variables A B : finType.

(** Relation defining the capacity of a channel: *)

Definition ubound {S : Type} (f : S -> R) (ub : R) := forall a, f a <= ub.

Definition lubound {S : Type} (f : S -> R) (lub : R) :=
  ubound f lub /\ forall ub, ubound f ub -> lub <= ub.

Definition capacity (W : `Ch_1(A, B)) cap := lubound (fun P => `I(P ; W)) cap.

Lemma capacity_uniq (W : `Ch_1(A, B)) r1 r2 :
  capacity W r1 -> capacity W r2 -> r1 = r2.
Proof. case=> H1 H2 [H3 H4]; apply Rle_antisym; by [apply H2 | apply H4]. Qed.

End capacity_definition.


(** * Hashfun: Functional model of hash tables *)

(** ** This C program, [hash.c], implements a hash table with
   external chaining.  See http://www.cs.princeton.edu/~appel/HashTables.pdf
   for an introduction to hash tables.  *)

(**

#include <stddef.h>

extern void * malloc (size_t n);
extern void exit(int n);
extern size_t strlen(const char *str);
extern char *strcpy(char *dest, const char *src);
extern int strcmp(const char *str1, const char *str2);

unsigned int hash (char *s) {
  unsigned int n=0;
  unsigned int i=0;
  int c=s[i];
  while (c) {
    n = n*65599u+(unsigned)c;
    i++;
    c=s[i];
  }
  return n;
}

struct cell {
  char *key;
  unsigned int count;
  struct cell *next;
};

enum {N = 109};

struct hashtable {
  struct cell *buckets[N];
};

char *copy_string (char *s) {
  int i,n = strlen(s)+1;
  char *p = malloc(n);
  if (!p) exit(1);
  strcpy(p,s);
  return p;
}

struct hashtable *new_table (void) {
  int i;
  struct hashtable *p = (struct hashtable * )malloc(sizeof(struct hashtable));
  if (!p) exit(1);
  for (i=0; i<N; i++) p->buckets[i]=NULL;
  return p;
}

struct cell *new_cell (char *key, int count, struct cell *next) {
  struct cell *p = (struct cell * )malloc(sizeof(struct cell));
  if (!p) exit(1);
  p->key = copy_string(key);
  p->count = count;
  p->next = next;
  return p;
}

unsigned int get (struct hashtable *table, char *s) {
  unsigned int h = hash(s);
  unsigned int b = h % N;
  struct cell *p = table->buckets[b];
  while (p) {
    if (strcmp(p->key, s)==0)
      return p->count;
    p=p->next;
  }
  return 0;
}

void incr_list (struct cell **r0, char *s) {
  struct cell *p, **r;
  for(r=r0; ; r=&p->next) {
    p = *r;
    if (!p) {
      *r = new_cell(s,1,NULL);
      return;
    }
    if (strcmp(p->key, s)==0) {
      p->count++;
      return;
    }
  }
}

void incr (struct hashtable *table, char *s) {
  unsigned int h = hash(s);
  unsigned int b = h % N;
  incr_list (& table->buckets[b], s);
}
*)

(* ================================================================= *)
(** ** A functional model *)

(** Before we prove the C program correct, we write a functional
 program that models its behavior as closely as possible.
 The functional program won't be (average) constant time per access,
 like the C program, because it takes linear time to get the nth
 element of a list, while the C program can subscript an array in
 constant time.  But we are not worried about the execution time
 of the functional program; only that it serve as a model
 for specifying the C program. *)

Require Import VST.floyd.functional_base.
Require ReflOmegaCore.

Definition string := list byte.
Instance EqDec_string: EqDec string := list_eq_dec Byte.eq_dec.

Fixpoint hashfun_aux (h: Z) (s: string) : Z :=
 match s with
 | nil => h
 | c :: s' =>
      hashfun_aux ((h * 65599 + Byte.signed c) mod Int.modulus) s'
end.

Definition hashfun (s: string) := hashfun_aux 0 s.

Definition hashtable_contents := list (list (string * Z)).

Definition N := 109.
Lemma N_eq : N = 109.
Proof. reflexivity. Qed.
Hint Rewrite N_eq : rep_omega.
Global Opaque N.

Definition empty_table : hashtable_contents :=
  list_repeat (Z.to_nat N) nil.

Fixpoint list_get (s: string) (al: list (string * Z)) : Z :=
  match al with
 | (k,i) :: al' => if eq_dec s k then i else list_get s al'
 | nil => 0
 end.

Fixpoint list_incr (s: string) (al: list (string * Z))
              :  list (string * Z) :=
  match al with
 | (k,i) :: al' => if eq_dec s k
                      then (k, i +1)::al'
                      else (k,i)::list_incr s al'
 | nil => (s, 1)::nil
 end.

Definition hashtable_get  (s: string) (contents: hashtable_contents) : Z :=
  list_get s (Znth (hashfun s mod (Zlength contents)) contents).

Definition hashtable_incr (s: string) (contents: hashtable_contents)
                      : hashtable_contents :=
  let h := hashfun s mod (Zlength contents)
  in let al := Znth h contents
  in upd_Znth h contents (list_incr s al).

(** **** Exercise: 2 stars (hashfun_inrange)  *)

Lemma mod_range: forall z m: Z, 0 < m -> 0 <= z mod m <= m - 1.
Proof.
  intros.
  assert(0 <= z mod m < m). {
    apply Z.mod_pos_bound; auto.
  }
  omega.
Qed.

Lemma mod_in_range: forall z : Z, 0 <= (z mod Int.modulus) <= Int.max_unsigned.
Proof.
  intros.
  unfold Int.max_unsigned.
  assert(4294967296 = Int.modulus). {
    compute; reflexivity.
  }
  rewrite <- H; clear H.
  apply mod_range; omega.
Qed.

Lemma hashfun_aux_inrange: forall s h, 0 <= h <= Int.max_unsigned ->
                                  0 <= hashfun_aux h s <= Int.max_unsigned.
Proof.
  induction s as [|h t].
  - (* s is nil *)
    intros.
    auto.
  - (* s is h :: t *)
    intros.
    simpl.
    apply IHt.
    apply mod_in_range.
Qed.

Lemma hashfun_inrange: forall s, 0 <= hashfun s <= Int.max_unsigned.
Proof.
  unfold hashfun.
  intros.
  apply hashfun_aux_inrange.
  rep_omega.
Qed.

(** [] *)

(** **** Exercise: 1 star (hashfun_get_unfold)  *)
Lemma hashtable_get_unfold:
 forall sigma (cts: list (list (string * Z) * val)),
 hashtable_get sigma (map fst cts) =
  list_get sigma (Znth (hashfun sigma mod (Zlength cts)) (map fst cts)).
Proof.
  intros.
  unfold hashtable_get.
  rewrite Zlength_map.
  auto.
Qed.

(** [] *)

(** **** Exercise: 2 stars (Zlength_hashtable_incr)  *)
Lemma Zlength_hashtable_incr:
 forall sigma cts,
      0 < Zlength cts ->
      Zlength (hashtable_incr sigma cts) = Zlength cts.
Proof.
  intros.
  unfold hashtable_incr.
  rewrite upd_Znth_Zlength; auto.
  apply Z.mod_pos_bound; auto.
Qed.
Hint Rewrite Zlength_hashtable_incr using list_solve : sublist.
(** [] *)

Lemma int_rep_helper: forall x y,
    x mod Int.modulus = y  mod Int.modulus ->
    Int.repr x = Int.repr y.
Proof.
  intros.
  apply Int.eqm_samerepr.
  unfold Int.eqm.
  assert(0 < Int.modulus). {
    rep_omega.
  }
  remember Int.modulus as b.
  clear Heqb.
  unfold Int.eqmod.
  assert(x = b * (x / b) + (x mod b)). {
    apply Z.div_mod.
    rep_omega.
  }
  assert(y = b * (y / b) + (y mod b)). {
    apply Z.div_mod.
    rep_omega.
  }
  assert(y mod b = y - b * (y / b)). {
    omega.
  }
  rewrite H in H1.
  rewrite H3 in H1.
  clear H H2 H3.
  remember (x / b) as xb.
  remember (y / b) as yb.
  clear H0 Heqxb Heqyb.
  exists (xb - yb).
  rewrite Z.mul_comm.
  rewrite H1; clear H1.
  rewrite Z.mul_sub_distr_l.
  rewrite Z.add_sub_assoc.
  omega.
Qed.

Definition hash_step (hin: Z) (c: byte) :=
  ((hin * 65599 + Byte.signed c) mod Int.modulus).

Definition hashfun_aux' (h: Z) (s: string) :=
  fold_left hash_step s h.

Lemma hashfun_aux_equiv:
  forall h s, hashfun_aux h s = hashfun_aux' h s.
Proof.
  intros.
  revert h.
  induction s as [| sh st].
  - (* s is nil *)
    intros.
    unfold hashfun_aux.
    unfold hashfun_aux'.
    simpl.
    auto.
  - (* s is sh :: st *)
    intros.
    unfold hashfun_aux.
    fold hashfun_aux.
    rewrite IHst.
    unfold hashfun_aux'.
    unfold fold_left.
    auto.
Qed.

Definition hash_step' (c: byte) (hin: Z) :=
  hash_step hin c.

Definition hashfun_aux'' (h: Z) (s: string) :=
  fold_right hash_step' h (rev s).

Lemma hashfun_aux_equiv':
  forall h s, hashfun_aux' h s = hashfun_aux'' h s.
Proof.
  intros.
  unfold hashfun_aux'.
  unfold hashfun_aux''.
  assert(hash_step = (fun x y => hash_step' y x)). {
    unfold hash_step'.
    unfold hash_step.
    auto.
  }
  rewrite H.
  rewrite fold_left_rev_right.
  auto.
Qed.

Lemma hashfun_aux_equiv'':
  forall h s, hashfun_aux h s = hashfun_aux'' h s.
Proof.
  intros.
  rewrite hashfun_aux_equiv.
  rewrite hashfun_aux_equiv'.
  auto.
Qed.

Search (rev _ ++ rev _).
Lemma hashfun_snoc0:
  forall (s1 s2: string) (h: Z),
    Int.repr (hashfun_aux h (s1 ++ s2)) =
    Int.repr (hashfun_aux (hashfun_aux h s1) s2).
Proof.
  intros.
  apply int_rep_helper.
  rewrite hashfun_aux_equiv''.
  rewrite hashfun_aux_equiv''.
  rewrite hashfun_aux_equiv''.
  unfold hashfun_aux''.
  rewrite rev_app_distr.
  rewrite fold_right_app.
  auto.
Qed.

Lemma hashfun_snoc:
  forall sigma h lo i,
    0 <= lo ->
    lo <= i < Zlength sigma ->
  Int.repr (hashfun_aux h (sublist lo (i + 1) sigma)) =
  Int.repr (hashfun_aux h (sublist lo i sigma) * 65599 + Byte.signed (Znth i sigma)).
Proof.
  intros.
  assert(sublist lo (i + 1) sigma =
         sublist lo i sigma ++ sublist i (i + 1) sigma). {
    rewrite (sublist_split lo i (i+1)); try omega; auto.
  }
  rewrite H1. clear H1.
  rewrite hashfun_snoc0.
  rewrite sublist_len_1; try omega; auto.
  apply int_rep_helper.
  unfold hashfun_aux at 1.
  rewrite Zmod_mod.
  auto.
Qed.

(** [] *)

(* ================================================================= *)
(** ** Functional model satisfies the high-level specification *)

(** The purpose of a hash table is to implement a finite mapping,
  (a finite function) from keys to values.  We claim that the
  functional model ([empty_table, hashtable_get, hashtable_incr])
  correctly implements the appropriate operations on the abstract
  data type of finite functions.

  We formalize that statement by defining a Module Type: *)

Module Type COUNT_TABLE.
 Parameter table: Type.
 Parameter key : Type.
 Parameter empty: table.
 Parameter get: key -> table -> Z.
 Parameter incr: key -> table -> table.
 Axiom gempty: forall k,   (* get-empty *)
       get k empty = 0.
 Axiom gss: forall k t,      (* get-set-same *)
      get k (incr k t) = 1+(get k t).
 Axiom gso: forall j k t,    (* get-set-other *)
      j <> k -> get j (incr k t) = get j t.
End COUNT_TABLE.

(** This means:  in any [Module] that satisfies this [Module Type],
   there's a type [table] of count-tables,
   and operators [empty], [get], [set] that satisfy the axioms
   [gempty], [gss], and [gso]. *)

(* ----------------------------------------------------------------- *)
(** *** A "reference" implementation of COUNT_TABLE *)

(** **** Exercise: 2 stars (FunTable)  *)
(**  It's easy to make a slow implementation of [COUNT_TABLE], using functions. *)

Module FunTable <: COUNT_TABLE.
 Definition table: Type := nat -> Z.
 Definition key : Type := nat.
 Definition empty: table := fun k => 0.
 Definition get (k: key) (t: table) : Z := t k.
 Definition incr (k: key) (t: table) : table :=
    fun k' => if Nat.eqb k' k then 1 + t k' else t k'.
 Lemma gempty: forall k,  get k empty = 0.
 Proof.
   intros.
   unfold get.
   unfold empty.
   auto.
 Qed.

 Lemma gss: forall k t,  get k (incr k t) = 1+(get k t).
 Proof.
   intros.
   unfold get.
   unfold incr.
   rewrite Nat.eqb_refl.
   auto.
 Qed.

 Lemma gso: forall j k t,  j <> k -> get j (incr k t) = get j t.
 Proof.
   intros.
   unfold get.
   unfold incr.
   rewrite <- Nat.eqb_neq in H.
   rewrite H.
   auto.
 Qed.

End FunTable.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Demonstration that hash tables implement COUNT_TABLE *)

(** **** Exercise: 3 stars (IntHashTable)  *)
(**  Now we make a "fast" implementation using hash tables.  We
  put "fast" in quotes because, unlike the imperative implementation,
 the purely functional implementation takes linear time, not constant time,
 to select the the i'th bucket.  That is, [Znth i al] takes time proportional to [i].
 But that is no problem, because we are not using [hashtable_get] and
 [hashtable_incr] as our real implementation; they are serving as the
 _functional model_ of the fast implementation in C.  *)

Module IntHashTable <: COUNT_TABLE.
 Definition hashtable_invariant (cts: hashtable_contents) : Prop :=
  Zlength cts = N /\
  forall i, 0 <= i < N ->
             list_norepet (map fst (Znth i cts))
             /\ Forall (fun s => hashfun s mod N = i) (map fst (Znth i cts)).
 Definition table := sig hashtable_invariant.
 Definition key := string.

 Lemma empty_invariant: hashtable_invariant empty_table.
 Proof.

   unfold empty_table.
   unfold hashtable_invariant;split.
   { (* Length *)
     rewrite  Zlength_correct.
     rewrite length_list_repeat.
     rewrite Z2Nat.id; auto.
     rewrite N_eq.
     omega.
   }

   { intros;split.
     { (* list_norepet (map fst (Znth i (list_repeat (Z.to_nat N) nil))) *)
       rewrite Znth_list_repeat_inrange;auto.
       simpl.
       apply list_norepet_nil.
     }
     { (* Forall (fun s : string => hashfun s mod N = i)
          (map fst (Znth i (list_repeat (Z.to_nat N) nil))) *)
       rewrite Znth_list_repeat_inrange;auto.
       simpl.
       constructor.
     }
   }
 Qed.

 Lemma list_incr_in_existing:
   forall (s: string) (al: list (string * Z)),
     (In s (map fst al)) ->
     (map fst (list_incr s al)) = (map fst al).
 Proof.
   intros.
   induction al as [|hd tl].
   - (* al is nil *)
     inversion H.
   - (* al is hd :: tl *)
     destruct hd as [hs hz].
     simpl in *.
     destruct (eq_dec s hs) eqn: dshs.
     * simpl;auto.
     * simpl.
       f_equal.
       apply IHtl.
       destruct H; auto.
       subst hs. contradiction.
 Qed.

 Lemma list_incr_not_in_existing:
   forall (s: string) (al: list (string * Z)),
     ~ (In s (map fst al)) ->
     (map fst (list_incr s al)) = (map fst al) ++ s :: nil.
 Proof.
   intros.
   revert H.
   induction al as [|hd tl].
   - (* al is nil *)
     intros.
     simpl; auto.
   - (* al is hd :: tl *)
     intros.
     destruct hd as [hs hz].
     simpl in *.
     assert(hs <> s /\ ~ In s (map fst tl)). {
        split.
        - unfold not.
          intro.
          subst hs.
          apply H.
          left;auto.
        - intro.
          apply H.
          right;auto.
     }
     destruct H0.
     destruct (eq_dec s hs) eqn: dshs.
     * subst hs.
       contradiction.
     * simpl in *.
       f_equal.
       apply IHtl;auto.
 Qed.

 Lemma list_incr_not_in:
   forall (s hstring : string) (t : list (string * Z)),
     ~ In hstring (map fst t) ->
     s <> hstring -> ~ In hstring (map fst (list_incr s t)).
 Proof.
   intros s hstring t H2 n.
   assert(forall l l' : list byte, {l = l'} + {l <> l'}). {
     apply list_eq_dec.
     apply Byte.eq_dec.
   }
   destruct (ListDec.In_dec H s (map fst t)) eqn: si.
   - rewrite list_incr_in_existing; auto.
   - rewrite list_incr_not_in_existing; auto.
     intro.
     remember (map fst t) as ts.
     remember (s :: nil) as ssingle.
     Search app.
     apply in_app_or in H0.
     destruct H0; try contradiction.
     subst ssingle.
     simpl in *.
     destruct H0; try contradiction.
 Qed.

 Lemma list_incr_nodup:
   forall (s: string) (al: list (string * Z)),
     list_norepet (map fst al) -> list_norepet (map fst (list_incr s al)).
 Proof.
   intros.
   induction al as [|h t].
   - (* al is nil *)
     vm_compute.
     assert(~In s nil). {
       auto.
     }
     apply (list_norepet_cons s H0).
     constructor.
   - inversion H.
     simpl.
     destruct h as [hstring hcount].
     simpl in *.
     destruct (eq_dec s hstring) eqn: sh.
     * simpl.
       apply list_norepet_cons; auto.
     * simpl in *.
       apply list_norepet_cons; auto.
       apply list_incr_not_in; auto.
 Qed.

Check ReflOmegaCore.ZOmega.IP.beq_reflect.
 Lemma incr_invariant:
   forall k cts, hashtable_invariant cts -> hashtable_invariant (hashtable_incr k cts).
 Proof.
   intros.
   destruct H.
   unfold hashtable_incr.
   split.
   { (* Length unchanged *)
     rewrite upd_Znth_Zlength; auto.
     assert(forall (A: Type) (l: list A), 0 <= Zlength l). {
       intros.
       apply (Zlength_nonneg l).
     }
     specialize (H1 (list (string * Z)) cts).
     rewrite H in *.
     rewrite N_eq in *.
     generalize (hashfun k).
     intros.
     apply Z.mod_pos_bound; omega.
   }
   intros.
   split.
   {
     (* list_norepet *)
     remember (hashfun k mod Zlength cts) as bucket.
     destruct (ReflOmegaCore.ZOmega.IP.beq_reflect bucket i).
     { (* bucket = i *)
       subst i.
       rewrite <- H in *.
       rewrite upd_Znth_same; auto.
       apply list_incr_nodup.
       specialize (H0 bucket).
       apply H0 in H1.
       destruct H1; auto.
     }
     { (* bucket != i *)
       rewrite <- H in *.
       rewrite upd_Znth_diff; auto.
       specialize (H0 i).
       apply H0 in H1.
       destruct H1;auto.
       subst bucket.
       rewrite H in *.
       rewrite N_eq in *.
       apply Z.mod_pos_bound.
       omega.
     }
   }
   { (* All the strings in the ith bucket hash to i. *)
     remember (hashfun k mod Zlength cts) as bucket.
     destruct (ReflOmegaCore.ZOmega.IP.beq_reflect bucket i).
     { (* bucket = i *)
       subst i.
       rewrite <- H in *.
       rewrite upd_Znth_same; auto.
       assert(forall l l' : list byte, {l = l'} + {l <> l'}). {
         apply list_eq_dec.
         apply Byte.eq_dec.
       }
       destruct (ListDec.In_dec H2 k (map fst (Znth bucket cts))) eqn: si.
       { (* k is in the bucket already. *)
         rewrite list_incr_in_existing; auto.
         specialize (H0 bucket).
         apply H0 in H1.
         destruct H1; auto.
       }
       { (* k is not in the bucket. *)
         rewrite list_incr_not_in_existing; auto.
         specialize (H0 bucket).
         apply H0 in H1.
         destruct H1; auto.
         apply Forall_app.
         split; auto.
       }
     }
     { (* bucket != i *)
       rewrite <- H in *.
       rewrite upd_Znth_diff; auto.
       specialize (H0 i).
       apply H0 in H1.
       destruct H1;auto.
       subst bucket.
       rewrite H in *.
       rewrite N_eq in *.
       apply Z.mod_pos_bound.
       omega.
     }
   }
 Qed.

 Definition empty : table := exist _ _ empty_invariant.
 Definition get : key -> table -> Z := fun k tbl => hashtable_get k (proj1_sig tbl).
 Definition incr : key -> table -> table :=
       fun k tbl => exist _ _ (incr_invariant k _ (proj2_sig tbl)).

 Theorem gempty: forall k, get k empty = 0.
 Proof.
   intros.
   unfold empty.
   unfold empty_table.
   unfold get.
   simpl.
   unfold hashtable_get.
   rewrite  Zlength_correct.
   rewrite length_list_repeat.
   assert(0 < N). {
     rewrite N_eq;omega.
   }
   rewrite Z2Nat.id by omega.
   remember (hashfun k mod N) as bucket.
   assert(0 <= bucket < N). {
     subst bucket.
     apply Z.mod_pos_bound. auto.
   }
   rewrite Znth_list_repeat_inrange by auto.
   simpl; auto.
 Qed.

 Lemma get_incr_result:
   forall (k : key) (bklist : list (string * Z)),
     list_get k (list_incr k bklist) = 1 + list_get k bklist.
 Proof.
   intros k bklist.
   induction bklist as [|hd tl].
   - (* bklist is  nil *)
     simpl.
     rewrite pred_dec_true;auto.
   - (* inductive case *)
     simpl.
     destruct hd as [hk hz].
     destruct (eq_dec k hk).
     * rewrite pred_dec_true; auto.
       unfold list_get.
       rewrite pred_dec_true; auto.
       rewrite pred_dec_true; auto.
       rewrite Z.add_comm.
       reflexivity.
     * rewrite pred_dec_false; auto.
       unfold list_get.
       rewrite pred_dec_false; auto.
       rewrite pred_dec_false; auto.
 Qed.

 Lemma get_incr_diff_result:
   forall (j k : key) (bklist : list (string * Z)),
     j <> k ->
     list_get j (list_incr k bklist) = list_get j bklist.
 Proof.
   intros j k bklist H.
   induction bklist as [|hd tl].
   - (* bklist is  nil *)
     simpl.
     rewrite pred_dec_false;auto.
   - (* inductive case *)
     simpl.
     destruct hd as [hk hz].
     destruct (eq_dec j hk).
     * (* j = hk *)
       rewrite (pred_dec_true (eq_dec j hk)); auto.
       rewrite pred_dec_false.
       simpl.
       rewrite pred_dec_true; auto.
       intro.
       subst j k.
       contradiction.
     * (* j <> hk *)
       rewrite (pred_dec_false (eq_dec j hk)); auto.
       destruct (eq_dec k hk).
     { (* k = hk *)
       rewrite pred_dec_true.
       simpl.
       rewrite pred_dec_false; auto.
       assumption.
     }
     { (* k <> hk *)
       rewrite pred_dec_false; auto.
       simpl.
       rewrite pred_dec_false; auto.
     }
 Qed.

 Theorem gss: forall k t,  get k (incr k t) =  1 + (get k t).
 Proof.
   intros.
   unfold incr.
   unfold get.
   unfold hashtable_get.
   unfold hashtable_incr.
   destruct t.
   simpl.
   destruct h.
   rewrite H in *.
   rewrite N_eq in *.
   remember (hashfun k mod 109) as bk.
   assert(forall z : Z,
             1 + z =
             (match z with
             | 0%Z => 1%Z
             | Z.pos y' => Z.pos match y' with
                                | q~1 => (Pos.succ q)~0
                                | q~0 => q~1
                                | 1 => 2
                                end
             | Z.neg y' => Z.pos_sub 1 y'
              end)%positive). {
     reflexivity.
   }
   rewrite <- H1.
   assert(0 <= bk < Zlength x). {
     rewrite Heqbk.
     rewrite H.
     apply Z.mod_pos_bound; omega.
   }
   rewrite upd_Znth_Zlength;auto.
   rewrite H.
   rewrite <- Heqbk.
   rewrite upd_Znth_same;auto.
   Search list_incr.
   remember (Znth bk x) as bklist.
   rewrite H in *.
   apply get_incr_result.
 Qed.

 Theorem gso: forall j k t,    (* get-set-other *)
      j <> k -> get j (incr k t) = get j t.
 Proof.
   intros j k t Hne.
   unfold incr.
   unfold get.
   unfold hashtable_get.
   unfold hashtable_incr.
   destruct t.
   simpl.
   destruct h.
   rewrite H in *.
   rewrite N_eq in *.
   remember (hashfun k mod 109) as bk.
   assert(0 <= bk < Zlength x). {
     rewrite Heqbk.
     rewrite H.
     apply Z.mod_pos_bound; omega.
   }
   rewrite upd_Znth_Zlength;auto.
   remember (hashfun j mod 109) as bj.
   assert(0 <= bj < Zlength x). {
     rewrite Heqbj.
     rewrite H.
     apply Z.mod_pos_bound; omega.
   }
   rewrite H.
   rewrite <- Heqbj.
   destruct (Z.eq_dec bj bk) eqn:eqbjbk.
   { (* bj = bk *)
     rewrite e.
     rewrite upd_Znth_same.
     apply get_incr_diff_result; auto.
     assumption.
   }
   { (* bj <> bk *)
     rewrite upd_Znth_diff; auto.
   }
 Qed.

(** [] *)

End IntHashTable.


Require Import Naturelle.
Section Session1_2021_Logique_Exercice_1.

Variable A B C : Prop.

Theorem Exercice_1_Naturelle :  ((A -> C) \/ (B -> C)) -> ((A /\ B) -> C).
Proof.
I_imp H1.
I_imp H2.
E_ou (A -> C) (B -> C).
Hyp H1.
I_imp H3.
E_imp A.
Hyp H3.
E_et_g B.
Hyp H2.
I_imp H4.
E_imp B.
Hyp H4.
E_et_d A.
Hyp H2.
Qed.

Theorem Exercice_1_Coq : ((A -> C) \/ (B -> C)) -> ((A /\ B) -> C).
Proof.
intro H1.
intro H2.
elim H1.
intro H3.
cut A.
exact H3.
cut (A /\ B).
intro H.
elim H.
intros HA HB.
exact HA.
exact H2.
intro H4.
cut B.
exact H4.
cut (A /\ B).
intro H.
elim H.
intros HA HB.
exact HB.
exact H2.
Qed.

End Session1_2021_Logique_Exercice_1.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Graph.
Require Import Diagrams.Diagram.
Require Import Diagrams.Cocone.

(** Parallel pairs *)

Definition parallel_pair_graph : Graph.
Proof.
  serapply (Build_Graph Bool).
  intros i j.
  exact (if i then if j then Empty else Bool else Empty).
Defined.

(** Parallel pair diagram *)

Definition parallel_pair {A B : Type} (f g : A -> B)
  : Diagram parallel_pair_graph.
Proof.
  serapply Build_Diagram.
  1: intros []; [exact A | exact B].
  intros [] [] []; [exact f | exact g].
Defined.

(** Cones on [parallel_pair]s *)

Definition Build_parallel_pair_cocone {A B Q} {f g : B -> A}
  `(q: A -> Q) (Hq: q o g == q o f)
  : Cocone (parallel_pair f g) Q.
Proof.
  serapply Build_Cocone.
  1: intros []; [exact (q o f) | exact q].
  intros [] [] []; [reflexivity | exact Hq].
Defined.


Require Import Basics.
Require Import Pointed.Core.
Require Import Colimits.Pushout.

(* Here we define the Wedge sum of two pointed types *)

Local Open Scope pointed_scope.

Definition Wedge (X Y : pType) : pType
  := [Pushout (fun _ : Unit => point X) (fun _ => point Y), pushl (point X)].

Notation "X \/ Y" := (Wedge X Y) : pointed_scope.

Definition wglue {X Y : pType}
  : pushl (point X) = (pushr (point Y) : X \/ Y) := pglue tt.

Definition wedge_incl {X Y : pType} : X \/ Y -> X * Y :=
 Pushout_rec _ (fun x => (x, point Y)) (fun y => (point X, y))
  (fun _ : Unit => idpath).


Definition rewriting (A : Type) := A -> A -> Prop.
Axiom A : Type.
Axiom r : rewriting A.

Inductive path : A -> A -> Type :=
| refl (a : A) : path a a
| trs  {a b c : A} : path a b -> r b c -> path a c.

Fixpoint size {a b : A} (p : path a b) : nat :=
  match p with
  | refl _ => 0
  | trs p' _ => 1 + (size p')
  end.

Theorem diamond_implies_CR :
  forall (diam : forall (x y z : A), r x y -> r x z -> exists w, (r y w) /\ (r z w))
    (a b c : A) (p1 : path a b) (p2 : path a c),
  exists (d : A) (p1' : path b d) (p2' : path c d),
    size p1 = size p2' /\ size p2 = size p1'.
Proof.
  intros. induction p1. (* induction on a --> b *)
  -exists c. exists p2. exists (refl c). split; reflexivity.
  -rename c0 into b'. pose (H := IHp1 p2). destruct H. destruct H. destruct H. destruct H. clear IHp1.
   generalize dependent c.
   assert (exists d (p1' : path b' d) (p2' : r x d), size p1' = size x0).
   +induction x0.
    ++intros. rename a0 into b. exists b'. exists (refl _). exists r0. reflexivity.
    ++rename b into x'. rename a0 into b. pose (H := IHx0 p1 r0).
      destruct H. destruct H. destruct H. pose (H0:= diam _ _ _ x2 r1).
      destruct H0. destruct H0.
      exists x3. exists (trs x1 H0). exists H1. simpl. rewrite H. reflexivity.
   +intros. destruct H. destruct H. destruct H.
    exists x2. exists x3. exists (trs x1 x4). split.
    ++simpl. rewrite H0. reflexivity.
    ++rewrite H. apply H1.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Export Structured.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check list.

Check nil.

Check (cons nat 3 (nil nat)).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool true 2 = cons bool true (cons bool true (nil bool)).
Proof. reflexivity. Qed.

Module MumbleGrumble.

  Inductive mumble : Type :=
    | a : mumble
    | b : mumble -> nat -> mumble
    | c : mumble.

  Inductive grumble (X : Type) : Type :=
    | d : mumble -> grumble X
    | e : X -> grumble X.

  (* Check (d (b a 5)) *)
  Check (d mumble (b a 5)).
  Check (d bool (b a 5)).
  Check (e bool true).
  Check (e mumble (b c 0)).
  (* Check (e bool (b c 0)). *)
  Check c.

End MumbleGrumble.


(* Exercise 66 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

(* This theorem shows that on a domain of at most two elements,
   any instantation of three variables will have a duplicate.
   Try the same for a domain of three elements, if you have
   a spare afternoon, the length of the proof explodes with
   the number of elements of D.
*)

Hypothesis Domain : exists x1 : D, exists x2 : D, forall x : D,
  (x = x1 \/ x = x2).

Theorem exercise_066 : forall x1 : D, forall x2 : D, forall x3 : D, (x1=x2 \/ x1=x3 \/ x2=x3).
Proof.
exi_e (exists x1 : D, exists x2 : D, forall x : D,
  (x = x1 \/ x = x2)) a a1.
  hyp Domain.
exi_e (exists x2 : D, forall x : D,
  (x = a \/ x = x2)) b a2.
hyp a1.
all_i c.
all_i d.
all_i e.
dis_e (c = a \/ c = b) a3 a3.
all_e (forall x:D, x = a \/ x = b) c.
hyp a2.
replace c with a.
dis_e (d = a \/ d = b) a4 a4.
all_e (forall x:D, x = a \/ x = b) d.
hyp a2.
replace d with a.
dis_i1.
lin_solve.
replace d with b.
dis_e (e = a \/ e = b) a5 a5.
all_e (forall x:D, x = a \/ x = b) e.
hyp a2.
replace e with a.
dis_i2.
dis_i1.
lin_solve.
replace e with b.
dis_i2.
dis_i2.
lin_solve.
dis_e (d = a \/ d = b) a4 a4.
all_e (forall x:D, x = a \/ x = b) d.
hyp a2.
replace d with a.
dis_e (e = a \/ e = b) a5 a5.
all_e (forall x:D, x = a \/ x = b) e.
hyp a2.
replace e with a.
dis_i2.
dis_i2.
lin_solve.
replace e with b.
replace c with b.
dis_i2.
dis_i1.
lin_solve.
replace c with b.
replace d with b.
dis_i1.
lin_solve.
Qed.


Section SetTheory.

  (* 「Coqによる定理証明入門」 神戸大学 高橋先生 *)
  (* http://herb.h.kobe-u.ac.jp/coq/coq.pdf *)
  (* bullet を使ってリライトしています。演習問題の答えはありません。 *)

  Require Import Ensembles.
  Require Import Classical.

  Variable U : Type.
  Definition Shugo := Ensemble U.

  Notation "x ∈ A" := (In U A x) (at level 55,no associativity).
  Notation "A ⊆ B" := (Included U A B) (at level 54, no associativity).
  Notation "A ∩ B" := (Intersection U A B) (at level 53, right associativity).
  Notation "A ∪ B" := (Union U A B) (at level 53, right associativity).
  Notation "A \ B" := (Setminus U A B) (at level 52, no associativity).
  Notation ø := (Empty_set U).
  Notation Ω := (Full_set U).

  (* Variables A B C : Shugo. *)

  Lemma in_or_not (A : Shugo) : forall x, (x ∈ A) \/ ~ x ∈ A.
  Proof.
    intros x.
    now apply classic.
  Qed.

  Lemma bubun_traisitive A B C : A ⊆ B /\ B ⊆ C -> A ⊆ C.
  Proof.
    (* unfold Included. *)
    intros H x HxA.
    destruct H as [HAB HBC].
    apply HBC.
    now apply HAB.
  Qed.

  Lemma empty_bubun A : ø ⊆ A.
  Proof.
    (* unfold Included. *)
    intros x He.
    now destruct He.
  Qed.

  Lemma full_bubun A : A ⊆ Ω.
  Proof.
    (* unfold Included. *)
    intros x HxA.
    Check Full_intro : forall (U : Type) (x : U), In U (Full_set U) x.
    now apply Full_intro.
  Qed.

  Ltac seteq := apply Extensionality_Ensembles; unfold Same_set; split.

  Lemma union_id A : A ∪ A = A.
  Proof.
    seteq.
    - intros x HAA.
      now destruct HAA.
    - intros x HA.
      Check Union_introl.
      now apply Union_introl.
  Qed.

  Lemma union_comm A B : A ∪ B = B ∪ A.
  Proof.
    seteq.
    - intros x HxAB.
      destruct HxAB.
      + now apply Union_intror.
      + now apply Union_introl.
    - intros x HxBA.
      destruct HxBA.
      + now apply Union_intror.
      + now apply Union_introl.
  Qed.

  (*
  3. A∪(B∪C) = (A∪B)∪C
  4. A ⊆ A∪B, B ⊆ A∪B
  5. A, B ⊆ C → A∪B ⊆ C
   *)

  Lemma probA4b A B : A ∪ B = B -> A ⊆ B.
  Proof.
    intros HAB_B x HxA.
    rewrite <- HAB_B.
    now apply Union_introl.
  Qed.

  (*
  1. A∩A = A
  2. A∩B = B∩A
  3. A∩(B∩C) = (A∩B)∩C
  4. A∩B ⊆ A, A∩B ⊆ B
  5. C ⊆ A, B → C ⊆ A∩B
  6. A ⊆ B ⇔ A∩B = A
   *)

  (* 素集合 *)
  Lemma Kuu A B : Disjoint U A B <-> A ∩ B = ø.
  Proof.
    split.
    - intros Hd.
      seteq.
      + intros x HxAB.
        destruct Hd as [Hd].
        specialize (Hd x).
        easy.                               (* 前提が矛盾 *)
      + now apply empty_bubun.
    - intros HAB_E.
      apply Disjoint_intro.
      intros x.
      rewrite HAB_E.
      intros HxE.
      now destruct HxE.                     (* 前提にx∈ø で矛盾 *)
  Qed.

  Lemma probA7b A B C : A ∪ B = B ∩ C -> A ⊆ B /\ B ⊆ C.
  Proof.
    intros HAB_BC.
    split.
    - intros x HxA.
      assert (x ∈ A ∪ B).
      + now apply Union_introl; apply HxA.
      + rewrite HAB_BC in H.
        now destruct H.
    - intros x HxB.
      assert (x ∈ A ∪ B).
      + now apply Union_intror; apply HxB.
      + rewrite HAB_BC in H.
        now destruct H.
  Qed.

  (* \ の優先順位を変えている。 *)
  Lemma setminus A B : forall x, x ∈ A -> ~ x ∈ B -> x ∈ A \ B.
  Proof.
    intros x HxA HnxB.
    split.
    - easy.                                 (* x ∈ A *)
    - easy.                                 (* ~ x ∈ B *)
  Qed.

  Lemma probA8 A B : (A \ B) ∪ (A ∩ B) = A.
  Proof.
    seteq.
    - intros x H.
      destruct H as [x [HA HB] | x [HA HB]].
      + easy.
      + easy.
    - intros x.
      destruct (in_or_not B x).
      + intros HxA.
        apply Union_intror.
        now apply Intersection_intro.
      + intros HxA.
        apply Union_introl.
        now apply setminus.
  Qed.

  (* 集合族 *)

  Variable K : Type.
  Definition Fam := K -> Shugo.

  Inductive UnionF (X : Fam) : Shugo :=
    unionf_intro : forall x : U, (exists n : K, x ∈ X n) -> x ∈ UnionF X.

  Inductive InterF (X : Fam) : Shugo :=
    interf_intro : forall x : U, (forall n : K, x ∈ X n) -> x ∈ InterF X.

  Lemma mem_unionf F : forall n, F n ⊆ UnionF F.
  Proof.
    intros n x HxFn.
    apply unionf_intro.
    now exists n.
  Qed.

  Lemma mem_interf F : forall n, InterF F ⊆ F n.
  Proof.
    intros n x HIF.
    destruct HIF as [x HIF].
    specialize (HIF n).
    easy.
  Qed.

  Lemma unionf_inc F G : (forall n, F n ⊆ G n) -> UnionF F ⊆ UnionF G.
  Proof.
    intros HFG x H.
    destruct H as [x [n H]].
    apply unionf_intro.
    exists n.
    now apply (HFG n).
  Qed.

  Lemma interf_inc F G : (forall n, F n ⊆ G n) -> InterF F ⊆ InterF G.
  Proof.
    intros HFG x H.
    unfold Included in HFG.
    destruct H as [x H].
    apply interf_intro.
    intros n.
    specialize (HFG n x).
    specialize (H n).
    now apply HFG.
  Qed.

End SetTheory.

(* END *)


Require Import Bool Arith List.
Import ListNotations.

Module dep_typ.

Inductive fulltree (A:Type) : nat -> Type :=
|leaf : A -> fulltree A 0
|node n : fulltree A n -> fulltree A n -> fulltree A (S(n))
.

Arguments leaf {A}.
Arguments node {A}.

Definition blist (A:Type) : Type :=
list {n & fulltree A n}
.

Definition tcast {A} {n} {m} (v: fulltree A n)(h : n = m) : fulltree A m :=
  match h with
  | eq_refl => v
  end.

Fixpoint tcons {A} {n:nat} (t:fulltree A n) (l:blist A) :=
	match l with
	|[] => [existT _ n t]
	|(existT _ n' t')::ll =>
		match Nat.eq_dec n n' with
		|left p =>  tcons   (node _ (tcast t p) t')   ll
		|right _=> (existT _ n t) ::l
		end
end.

Definition bcons {A} (a:A) l := tcons (leaf a) l.
Compute bcons 1 (bcons 2 (bcons 3 (bcons 4 []))).
Compute bcons 1 (bcons 2 (bcons 3  [])).

Fixpoint tdecons {A} {n} (t:fulltree A n) (l:blist A) :=
	match t with
	|leaf a => (a,l)
	|node n fg fd =>
		tdecons fg ((existT _ _ fd)::l)
	end.

Definition bdecons [A:Type] (l: blist A) :=
	match l with
	| [] => None
	| (existT _ _ t)::ll => Some (tdecons t ll)
	end.

Definition l := bcons 1 (bcons 2 (bcons 3  [])).
Compute l .
Compute bdecons l .

Fixpoint tnth [A:Type] {st} (t: fulltree A st) n :=
	match t,n with
	|leaf a,0 => Some a
	|leaf _,_ => None
	|node st fg fd, _ =>
		let st' := 2^(pred st) in
		if n <? st'
		then tnth fg n
		else tnth fd (n-st')
	end.

Fixpoint bnth [A:Type] (l: blist A) n :=
match l with
	| [] => None
	| (existT _ st t)::ll =>
		let st' := 2^st in
		if n <? st'
		then tnth t n
		else bnth ll (n-st')
end.

Compute l.
Compute bnth l 1.

End dep_typ.

Inductive tree (A:Type) : Type :=
|leaf : A -> tree A
|node : tree A -> tree A -> tree A
.

Arguments leaf {A}.
Arguments node {A}.

Definition option_bind {A B} (o : option A) (f:A -> option B) : option B :=
 match o with
 | Some x => f x
 | None => None
 end.

Infix ">>=" := option_bind (at level 20, left associativity).

Fixpoint perfect_depth {A} (t: tree A) : option nat :=
match t with
|leaf _ => Some 0
|node fg fd =>
	perfect_depth fg >>= fun size_fg =>
	perfect_depth fd >>= fun size_fd =>
	if size_fg =? size_fd then Some (S(size_fd+size_fd))
	else None
end.

Definition t1 := (node (leaf 0) (leaf 0)).
Definition t2 := (node t1 (leaf 0)).
Compute perfect_depth t1.
Compute perfect_depth t2.

Module Type MONAD.
  Parameter t : Type -> Type.
  Parameter bind : forall {A B}, t A -> (A -> t B) -> t B.
  Parameter ret : forall {A}, A -> t A. (* ret, since return is a Coq keyword *)
End MONAD.

Check List.filter_map.

Require Import Bool Arith List.
Module MList <: MONAD.
  Definition t := list.
  Definition ret  (a:nat) := [a].
  Definition bind  (l:list nat) (f:nat->list nat) := List.filter_map Nat.eqb f l.
End MList.

Infix ">>=" := MList.bind (at level 20, left associativity).

Definition scoring (n:nat) := [n+3;n+5;n+7].

Fixpoint next_scores l n :=
	match n with
	|0 => l
	|S n' =>
		next_scores l n' >>= scoring
	end.

Compute next_scores [0] 2.

Check List.flat_map.


(** 2-2-matrices over a ring A *)

Require Import Ring.

Section matrices.
 Variables (A:Type)
           (zero one : A)
           (plus mult minus : A -> A -> A)
           (sym : A -> A).
 Notation "0" := zero.  Notation "1" := one.
 Notation "x + y" := (plus x y).
 Notation "x * y" := (mult x y).

 Variable rt : ring_theory  zero one plus mult minus sym (@eq A).

 Add Ring Aring : rt.

Structure M2 : Type := {c00 : A;  c01 : A;
                        c10 : A;  c11 : A}.

Definition Id2 : M2 := Build_M2 1 0 0 1.

Definition M2_mult (m m':M2) : M2 :=
 Build_M2 (c00 m * c00 m' + c01 m * c10 m')
          (c00 m * c01 m' + c01 m * c11 m')
          (c10 m * c00 m' + c11 m * c10 m')
          (c10 m * c01 m' + c11 m * c11 m').

Lemma M2_eq_intros : forall a b c d a' b' c' d',
  a=a' -> b=b' -> c=c' -> d=d' ->
   Build_M2 a b c d = Build_M2 a' b' c' d'.
Proof.
 intros; now f_equal.
Qed.

End matrices.

Arguments Build_M2 {A} _ _ _ _.
Arguments M2_mult {A} _ _ _  _.
Arguments c00 {A} _.
Arguments Id2 {A} zero one.


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

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

From Undecidability.MinskyMachines.MMA
  Require Import mma_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 (@mma_sss _) P k s t).
Local Notation "P // s -+> t" := (sss_progress (@mma_sss _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mma_sss _) P s t).
Local Notation "P // s ↓" := (sss_terminates (@mma_sss _) P s).

(* Utils for FRACTRAN with two counter *)

Section Minsky_Machine_alt_utils.

  Variable (n : nat).

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

  Hint Resolve subcode_refl : core.

  Section mma_jump.

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

    Definition mma_jump := INCₐ x :: DECₐ x j :: nil.

    Notation JUMPₐ := mma_jump.

    Fact mma_jump_length : length JUMPₐ = 2.
    Proof. auto. Qed.

    Fact mma_jump_progress i v w : w = v -> (i,JUMPₐ) // (i,v) -+> (j,w).
    Proof.
      intros ->.
      unfold mma_jump.
      mma sss INC with x.
      mma sss DEC S with x j (v#>x); rew vec.
      mma sss stop.
    Qed.

    Fact mma_jump_spec i v : (i,JUMPₐ) // (i,v) ->> (j,v).
    Proof. now apply sss_progress_compute, mma_jump_progress. Qed.

  End mma_jump.

  Notation JUMPₐ := mma_jump.

  Hint Rewrite mma_jump_length : length_db.

  Section mma_null.

    (* Empty one register/counter *)

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

    Definition mma_null := DECₐ x i :: nil.

    Fact mma_null_length : length mma_null = 1.
    Proof. auto. Qed.

    Let mma_null_spec k v w :   v#>x = k
                             -> w = v[0/x]
                             -> (i,mma_null) // (i,v) -+> (1+i,w).
    Proof.
      unfold mma_null.
      revert v w.
      induction k as [ | k IHk ]; intros v w H1 H2; subst w.
      + mma sss DEC zero with x i.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros z; dest z x.
      + mma sss DEC S with x i k.
        apply sss_progress_compute.
        apply IHk; rew vec.
    Qed.

    Fact mma_null_progress v st :
             st = (1+i,v[0/x])
          -> (i,mma_null) // (i,v) -+> st.
    Proof.
      intros; subst.
      apply mma_null_spec with (1 := eq_refl); auto.
    Qed.

  End mma_null.

  Notation NULLₐ := mma_null.

  Hint Rewrite mma_null_length : length_db.

  Section mma_null_list.

    Fixpoint mma_null_list (l : list (pos n)) i :=
      match l with
        | nil  => nil
        | x::l => DECₐ x i :: mma_null_list l (S i)
      end.

    Fact mma_null_list_length l i : length (mma_null_list l i) = length l.
    Proof. revert i; induction l; simpl; intro; f_equal; auto. Qed.

    Fact mma_null_list_spec l i v w :
           (forall p, In p l -> w#>p = 0)
        -> (forall p, ~ In p l -> w#>p = v#> p)
        -> (i,mma_null_list l i) // (i,v) ->> (length l+i,w).
    Proof.
      revert i v w; induction l as [ | x l IHl ]; simpl; intros i v w H1 H2.
      + replace w with v.
        1: mma sss stop.
        apply vec_pos_ext; intro p; rewrite H2; auto.
      + apply subcode_sss_compute_trans
          with (P := (i,DECₐ x i::nil)) (st2 := (S i,v[0/x])); auto.
        * apply sss_progress_compute, mma_null_progress; auto.
        * apply subcode_sss_compute with (P := (S i, mma_null_list l (S i))); auto.
          replace (S (length l+i)) with (length l+S i) by lia.
          apply IHl.
          - intros; apply H1; auto.
          - intros p Hp.
            dest p x.
            apply H2; firstorder.
    Qed.

  End mma_null_list.

  Section mma_null_all.

    Variable (i : nat).

    Definition mma_null_all := mma_null_list (pos_list n) i.

    Fact mma_null_all_length : length mma_null_all = n.
    Proof.
      unfold mma_null_all.
      rewrite mma_null_list_length.
      apply pos_list_length.
    Qed.

    Fact mma_null_all_spec v :
          (i,mma_null_all) // (i,v) ->> (n+i,vec_zero).
    Proof.
      replace (n+i) with (length (pos_list n)+i).
      + apply mma_null_list_spec.
        * intros; apply vec_zero_spec.
        * intros ? []; apply pos_list_prop.
      + now rewrite pos_list_length.
    Qed.

  End mma_null_all.

  Section mma_incs.

    (* Add a constant value k to register x *)

    Variable (x : pos n).

    Fixpoint mma_incs k :=
      match k with
        | 0   => nil
        | S k => INCₐ x :: mma_incs k
      end.

    Fact mma_incs_length k : length (mma_incs k) = k.
    Proof. induction k; simpl; f_equal; auto. Qed.

    Fact mma_incs_compute k i v st :
             st = (k+i,v[(k+(v#>x))/x])
          -> (i,mma_incs k) // (i,v) ->> st.
    Proof.
      revert i v st; induction k as [ | k IHk ]; intros i v st ?; subst.
      + mma sss stop; f_equal; auto.
        apply vec_pos_ext; intros p; dest p x.
      + simpl; mma sss INC with x.
        apply subcode_sss_compute with (P := (1+i,mma_incs k)); auto.
        apply IHk; f_equal; try lia.
        apply vec_pos_ext; intros p; dest p x.
    Qed.

  End mma_incs.

  Notation INCSₐ := mma_incs.

  Hint Rewrite mma_incs_length : length_db.

  Section mma_isempty.

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

    Definition mma_isempty := DECₐ x (3+i) :: JUMPₐ p x ++ INCₐ x :: nil.

    Notation EMPTYₐ := mma_isempty.

    Fact mma_isempty_length : length EMPTYₐ = 4.
    Proof. auto. Qed.

    Fact mma_empty_progress v st : st = (p,v) -> v#>x = 0 -> (i,EMPTYₐ) // (i,v) -+> st.
    Proof.
      intros -> H.
      unfold mma_isempty, mma_jump; simpl app.
      mma sss DEC zero with x (3+i); rew vec.
      mma sss INC with x.
      mma sss DEC S with x p (0); rew vec.
      mma sss stop; f_equal.
      apply vec_pos_ext; intros y; dest y x; lia.
    Qed.

    Fact mma_non_empty_progress v st : st = (4+i,v) -> v#>x <> 0 -> (i,EMPTYₐ) // (i,v) -+> st.
    Proof.
      intros -> H.
      unfold mma_isempty.
      case_eq (v#>x).
      + now intros; subst.
      + clear H; intros u H.
        mma sss DEC S with x (3+i) u; rew vec.
        mma sss INC with x; auto.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros y; dest y x; lia.
    Qed.

  End mma_isempty.

  Notation EMPTYₐ := mma_isempty.

  Hint Rewrite mma_isempty_length : length_db.

  Section mma_transfert.

    (* Added the content of src to dst while emptying src *)

    Variables (src dst : pos n) (Hsd : src <> dst) (i : nat).

    Definition mma_transfert := INCₐ dst :: DECₐ src i :: DECₐ dst (3+i) :: nil.

    Fact mma_transfert_length : length mma_transfert = 3.
    Proof. reflexivity. Qed.

    Let mma_transfert_spec v w k x :    v#>src = k
                                     -> v#>dst = x
                                     -> w = v[0/src][(1+k+x)/dst]
                                     -> (i,mma_transfert) // (i,v) -+> (2+i,w).
    Proof.
      unfold mma_transfert.
      revert v w x.
      induction k as [ | k IHk ]; intros v w x H1 H2 H3; subst w.
      + mma sss INC with dst.
        mma sss DEC zero with src i; rew vec.
        mma sss stop; f_equal; auto.
        apply vec_pos_ext; intros z; dest z dst; dest z src.
      + mma sss INC with dst.
        mma sss DEC S with src i k; rew vec.
        apply sss_progress_compute, IHk with (x := 1+x); rew vec.
        apply vec_pos_ext; intros p.
        dest p dst; try lia; dest p src.
    Qed.

    Fact mma_transfert_progress v st :
           st = (3+i,v[0/src][((v#>src)+(v#>dst))/dst])
        -> (i,mma_transfert) // (i,v) -+> st.
    Proof using Hsd.
      intros ?; subst.
      apply sss_progress_trans with (2+i, v[0/src][(1+(v#>src)+(v#>dst))/dst]).
      + apply mma_transfert_spec with (1 := eq_refl) (2 := eq_refl); auto.
      + unfold mma_transfert.
        mma sss DEC S with dst (3+i) ((v#>src)+(v#>dst)); rew vec.
        mma sss stop.
    Qed.

  End mma_transfert.

  Notation TRANSFERTₐ := mma_transfert.

  Hint Rewrite mma_transfert_length : length_db.

  Section mma_mult_cst.

    (* dst <- k*src+dst *)

    Variable (src dst : pos n) (Hsd : src <> dst) (k i : nat).

    Definition mma_mult_cst :=
           DECₐ src (3+i) :: JUMPₐ (5+k+i) src
        ++ INCSₐ dst k ++ JUMPₐ i src.

    Fact mma_mult_cst_length : length mma_mult_cst = 5+k.
    Proof. unfold mma_mult_cst; rew length; lia. Qed.

    Let mma_mult_cst_spec x v st :
             v#>src = x
          -> st = (5+k+i,v[0/src][(x*k+(v#>dst))/dst])
          -> (i,mma_mult_cst) // (i,v) -+> st.
    Proof.
      unfold mma_mult_cst.
      revert v st; induction x as [ | x IHx ]; intros v st Hv ?; subst.
      + mma sss DEC zero with src (3+i).
        apply sss_progress_compute.
        apply subcode_sss_progress with (P := (1+i,JUMPₐ (5+k+i) src)); auto.
        apply mma_jump_progress.
        apply vec_pos_ext; intros y; dest y dst; dest y src; lia.
      + mma sss DEC S with src (3+i) x.
        apply sss_compute_trans with (3+k+i,v[x/src][(k+(v#>dst))/dst]).
        * apply subcode_sss_compute with (P := (3+i,mma_incs dst k)); auto.
          apply mma_incs_compute; f_equal; try lia.
          apply vec_pos_ext; intros y; dest y dst; lia.
        * apply sss_compute_trans with (i,v[x/src][(k+(v#>dst))/dst]).
          - apply sss_progress_compute.
            apply subcode_sss_progress with (P := (3+k+i,JUMPₐ i src)); auto.
            apply mma_jump_progress.
            apply vec_pos_ext; intros y; dest y dst; dest y src; lia.
          - apply sss_progress_compute, IHx; rew vec; f_equal.
            apply vec_pos_ext; intros y; dest y dst; try ring.
            dest y src.
    Qed.

    Fact mma_mult_cst_progress v st :
             st = (5+k+i,v[0/src][(k*(v#>src)+(v#>dst))/dst])
          -> (i,mma_mult_cst) // (i,v) -+> st.
    Proof using Hsd.
      intros ?; subst.
      apply mma_mult_cst_spec with (1 := eq_refl); do 2 f_equal.
      ring.
    Qed.

  End mma_mult_cst.

  Notation MULT_CSTₐ := mma_mult_cst.

  Hint Rewrite mma_mult_cst_length : length_db.

  Section mma_mult_cst_with_zero.

    Variable (x z : pos n) (Hxz : x <> z) (k i : nat).

    Definition mma_mult_cst_with_zero :=
           MULT_CSTₐ x z k i ++ TRANSFERTₐ z x (5+k+i).

    Fact mma_mult_cst_with_zero_length :length mma_mult_cst_with_zero = 8+k.
    Proof. unfold mma_mult_cst_with_zero; rew length; lia. Qed.

    (* v#>x is multiplied by k and the PC jumps to the
       end of this (sub-)program *)

    Fact mma_mult_cst_with_zero_progress v st :
             v#>z = 0
          -> st = (8+k+i,v[(k*(v#>x))/x])
          -> (i,mma_mult_cst_with_zero) // (i,v) -+> st.
    Proof using Hxz.
      unfold mma_mult_cst_with_zero.
      intros H1 H2.
      apply sss_progress_trans with (st2 := (5+k+i, v[0/x][(k*(v#>x))/z])).
      + apply subcode_sss_progress with (P := (i,MULT_CSTₐ x z k i)); auto.
        apply mma_mult_cst_progress; auto.
        do 2 f_equal; lia.
      + apply subcode_sss_progress with (P := (5+k+i,TRANSFERTₐ z x (5+k+i))); auto.
        apply mma_transfert_progress; auto.
        rewrite H2; f_equal; rew vec.
        apply vec_pos_ext; intros p.
        dest p x; dest p z.
    Qed.

  End mma_mult_cst_with_zero.

  Notation MULT_CST_WZₐ := mma_mult_cst_with_zero.

  Hint Rewrite mma_mult_cst_with_zero_length : length_db.

  Section mma_decs.

    (* "mma_dec dst p q k" at i

        removes constant k to dst:

        if dst < k, dst ends up empty and jump to q
        if k <= dst, dst is decremented by k and jump to p

      *)

    Variable (dst : pos n) (p q : nat).

    Fixpoint mma_decs k i :=
      match k with
        | 0   => INCₐ dst :: DECₐ dst p :: nil
        | S k => DECₐ dst (3+i) :: INCₐ dst :: DECₐ dst q :: mma_decs k (3+i)
      end.

    Fact mma_decs_length k i : length (mma_decs k i) = 2+3*k.
    Proof.
      revert i; induction k as [ | ? IHk ]; intros i; simpl; auto.
      rewrite IHk; lia.
    Qed.

    Let mma_decs_spec_lt k i v w :
            v#>dst < k
         -> w = v[0/dst]
         -> (i,mma_decs k i) // (i,v) -+> (q,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + lia.
      + unfold mma_decs; fold mma_decs.
        case_eq (v#>dst).
        * intros H2.
          mma sss DEC zero with dst (3+i).
          mma sss INC with dst.
          mma sss DEC S with dst q (v#>dst); rew vec.
          mma sss stop; f_equal.
          apply vec_pos_ext; intros x; dest x dst.
        * intros d Hd.
          mma sss DEC S with dst (3+i) d.
          apply subcode_sss_compute with (P := (3+i,mma_decs k (3+i))); auto.
          apply sss_progress_compute, IHk; rew vec; try lia.
    Qed.

    Let mma_decs_spec_le k i v w :
            k <= v#>dst
         -> w = v[((v#>dst)-k)/dst]
         -> (i,mma_decs k i) // (i,v) -+> (p,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + simpl.
        mma sss INC with dst.
        mma sss DEC S with dst p (v#>dst); rew vec.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros x; dest x dst; try lia.
      + unfold mma_decs; fold mma_decs.
        mma sss DEC S with dst (3+i) ((v#>dst) - 1); try lia.
        apply subcode_sss_compute with (P := (3+i,mma_decs k (3+i))); auto.
        apply sss_progress_compute, IHk; rew vec; try lia.
        apply vec_pos_ext; intros x; dest x dst; lia.
    Qed.

    Fact mma_decs_lt_progress k i v st :
             v#>dst < k
          -> st = (q,v[0/dst])
          -> (i,mma_decs k i) // (i,v) -+> st.
    Proof.
      intros H1 ?; subst st.
      apply mma_decs_spec_lt; auto.
    Qed.

    Fact mma_decs_le_progress k i v st :
             k <= v#>dst
          -> st = (p,v[((v#>dst)-k)/dst])
          -> (i,mma_decs k i) // (i,v) -+> st.
    Proof.
      intros H1 ?; subst st.
      apply mma_decs_spec_le; auto.
    Qed.

  End mma_decs.

  Notation DECSₐ := mma_decs.

  Section mma_decs_copy.

    (* Same as mma_decs except that the quantity
       removed from dst is transfered into tmp *)

    Variable (dst tmp : pos n) (Hdt : dst <> tmp) (p q : nat).

    Fixpoint mma_decs_copy k i :=
      match k with
        | 0   => INCₐ dst :: DECₐ dst p :: nil
        | S k => DECₐ dst (3+i) :: INCₐ dst :: DECₐ dst q :: INCₐ tmp :: mma_decs_copy k (4+i)
      end.

    Fact mma_decs_copy_length k i : length (mma_decs_copy k i) = 2+4*k.
    Proof.
      revert i; induction k as [ | ? IHk ]; intros i; simpl; auto.
      rewrite IHk; lia.
    Qed.

    Let mma_decs_copy_spec_lt k i v w :
            v#>dst < k
         -> w = v[0/dst][((v#>dst)+(v#>tmp))/tmp]
         -> (i,mma_decs_copy k i) // (i,v) -+> (q,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + lia.
      + unfold mma_decs_copy; fold mma_decs_copy.
        case_eq (v#>dst).
        * intros H2.
          mma sss DEC zero with dst (3+i).
          mma sss INC with dst.
          mma sss DEC S with dst q (v#>dst); rew vec.
          mma sss stop; f_equal.
          apply vec_pos_ext; intros x; dest x tmp; dest x dst.
        * intros d Hd.
          mma sss DEC S with dst (3+i) d.
          mma sss INC with tmp.
          apply subcode_sss_compute with (P := (4+i,mma_decs_copy k (4+i))); auto.
          apply sss_progress_compute; rewrite Nat.add_assoc.
          apply IHk; rew vec; try lia.
          apply vec_pos_ext; intros x; dest x tmp; try lia; dest x dst.
    Qed.

    Let mma_decs_copy_spec_le k i v w :
            k <= v#>dst
         -> w = v[((v#>dst)-k)/dst][(k+(v#>tmp))/tmp]
         -> (i,mma_decs_copy k i) // (i,v) -+> (p,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + simpl.
        mma sss INC with dst.
        mma sss DEC S with dst p (v#>dst); rew vec.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros x; dest x dst; try lia; dest x tmp.
      + unfold mma_decs_copy; fold mma_decs_copy.
        mma sss DEC S with dst (3+i) ((v#>dst) - 1); try lia.
        mma sss INC with tmp.
        apply subcode_sss_compute with (P := (4+i,mma_decs_copy k (4+i))); auto.
        apply sss_progress_compute, IHk; rew vec; try lia.
        apply vec_pos_ext; intros x; dest x tmp; try lia; dest x dst; lia.
    Qed.

    Fact mma_decs_copy_lt_progress k i v st :
             v#>dst < k
          -> st = (q,v[0/dst][((v#>dst)+(v#>tmp))/tmp])
          -> (i,mma_decs_copy k i) // (i,v) -+> st.
    Proof using Hdt.
      intros H1 ?; subst st.
      apply mma_decs_copy_spec_lt; auto.
    Qed.

    Fact mma_decs_copy_le_progress k i v st :
             k <= v#>dst
          -> st = (p,v[((v#>dst)-k)/dst][(k+(v#>tmp))/tmp])
          -> (i,mma_decs_copy k i) // (i,v) -+> st.
    Proof using Hdt.
      intros H1 ?; subst st.
      apply mma_decs_copy_spec_le; auto.
    Qed.

  End mma_decs_copy.

  Notation DECS_COPYₐ := mma_decs_copy.

  Hint Rewrite mma_decs_length mma_decs_copy_length : length_db.

  Section mma_mod_cst.

    (* test whether k divides src and transfer of src into dst *)

    Variable (x t : pos n) (Hxt : x <> t) (p q k i : nat).

    Definition mma_mod_cst :=
            EMPTYₐ x p i ++ DECS_COPYₐ x t i q k (4+i).

    Fact mma_mod_cst_length : length mma_mod_cst = 6+4*k.
    Proof. unfold mma_mod_cst; rew length; lia. Qed.

    (* This is of no use when k = 0 *)

    Hypothesis (Hk : 0 < k).

    Let mma_mod_cst_spec_0 v :
           v#>x = 0
        -> (i,mma_mod_cst) // (i,v) -+> (p,v).
    Proof.
      intros H; unfold mma_mod_cst.
      apply subcode_sss_progress with (P := (i, EMPTYₐ x p i)); auto.
      apply mma_empty_progress; auto.
    Qed.

    Let mma_mod_cst_spec_1 a b v w :
           v#>x = a*k+b
        -> w = v[b/x][(a*k+(v#>t))/t]
        -> (i,mma_mod_cst) // (i,v) ->> (i,w).
    Proof.
      revert v w; induction a as [ | a IHa ]; intros v w H1 H2; subst w.
      + mma sss stop; f_equal.
        simpl in H1; rewrite <- H1; simpl; rew vec.
      + unfold mma_mod_cst.
        apply sss_compute_trans with (4+i,v).
        * apply sss_progress_compute,
                subcode_sss_progress with (P := (i, EMPTYₐ x p i)); auto.
          apply mma_non_empty_progress; auto; lia.
        * apply sss_compute_trans with (i, v[(a*k+b)/x][(k+(v#>t))/t]).
          - apply subcode_sss_compute with (P := (4+i,mma_decs_copy x t i q k (4+i))); auto.
            apply sss_progress_compute, mma_decs_copy_le_progress; auto; rew vec.
            { simpl; generalize (a*k); intro; lia. }
            do 3 f_equal; rewrite H1; simpl mult; generalize (a*k); intro; lia.
          - apply IHa; rew vec.
            apply vec_pos_ext; intros y; dest y t; try ring; dest y x.
    Qed.

    Let mma_mod_cst_spec_2 v w :
           0 < v#>x < k
        -> w = v[0/x][((v#>x)+(v#>t))/t]
        -> (i,mma_mod_cst) // (i,v) -+> (q,w).
    Proof.
      intros H ?; subst; unfold mma_mod_cst.
      apply sss_progress_trans with (4+i,v).
      + apply subcode_sss_progress with (P := (i, EMPTYₐ x p i)); auto.
        apply mma_non_empty_progress; auto; lia.
      + apply subcode_sss_progress with (P := (4+i, DECS_COPYₐ x t i q k (4+i))); auto.
        apply mma_decs_copy_lt_progress; auto; lia.
    Qed.

    Fact mma_mod_cst_divides_progress v a st :
            v#>x = a*k
         -> st = (p,v[0/x][((v#>x)+(v#>t))/t])
         -> (i,mma_mod_cst) // (i,v) -+> st.
    Proof using Hxt Hk.
      intros H1 ?; subst st.
      apply sss_compute_progress_trans with (i,v[0/x][((v#>x)+(v#>t))/t]).
      + apply mma_mod_cst_spec_1 with (a := a) (b := 0); try lia.
        rewrite <- H1; auto.
      + apply mma_mod_cst_spec_0; rew vec.
    Qed.

    Fact mma_mod_cst_not_divides_progress v a b st :
            v#>x = a*k+b
         -> 0 < b < k
         -> st = (q,v[0/x][((v#>x)+(v#>t))/t])
         -> (i,mma_mod_cst) // (i,v) -+> st.
    Proof using Hxt Hk.
      intros H1 H2 ?; subst st.
      apply sss_compute_progress_trans with (i,v[b/x][(a*k+(v#>t))/t]).
      + apply mma_mod_cst_spec_1 with (a := a) (b := b); try lia; auto.
      + apply mma_mod_cst_spec_2; rew vec.
        apply vec_pos_ext; intros y; dest y t; try lia; dest y x.
    Qed.

  End mma_mod_cst.

  Notation MOD_CSTₐ := mma_mod_cst.

  Hint Rewrite mma_decs_length mma_mod_cst_length : length_db.

  Section mma_div_cst.

    (* Division by a constant *)

    Variable (s d : pos n) (Hsd : s <> d) (k i : nat).

    Let p := (2+3*k+i).
    Let q := (5+3*k+i).

    Definition mma_div_cst :=
         DECSₐ s p q k i ++ INCₐ d :: JUMPₐ i s.

    Fact mma_div_cst_length : length mma_div_cst = 5+3*k.
    Proof. unfold mma_div_cst; rew length; lia. Qed.

    Hypothesis (Hk : 0 < k).

    Let mma_div_cst_spec a v w :
           v#>s = a*k
        -> w = v[0/s][(a+(v#>d))/d]
        -> (i, mma_div_cst) // (i,v) -+> (q,w).
    Proof.
      unfold mma_div_cst; revert v w; induction a as [ | a IHa ]; intros v w H1 ?; subst w.
      + apply subcode_sss_progress with (P := (i,mma_decs s p q k i)); auto.
        apply mma_decs_lt_progress; try lia.
        f_equal; simpl.
        apply vec_pos_ext; intros y; dest y d.
      + apply sss_progress_trans with (p,v[(a*k)/s]).
        * apply subcode_sss_progress with (P := (i,mma_decs s p q k i)); auto.
          apply mma_decs_le_progress.
          - rewrite H1; simpl; generalize (a*k); intro; lia.
          - f_equal.
            apply vec_pos_ext; intros y; dest y d; dest y s.
            rewrite H1; simpl; generalize (a*k); intro; lia.
        * unfold p.
          mma sss INC with d.
          apply sss_compute_trans with (i,v[(a*k)/s][(S (v[(a*k)/s]#>d))/d]).
          - apply sss_progress_compute,
                  subcode_sss_progress with (P := (3+3*k+i, JUMPₐ i s)); auto.
            apply mma_jump_progress; auto.
          - apply sss_progress_compute, IHa; rew vec.
            apply vec_pos_ext; intros y; dest y d; try lia; dest y s.
    Qed.

    Fact mma_div_cst_progress a v st :
            v#>s = a*k
         -> st = (q,v[0/s][(a+(v#>d))/d])
         -> (i, mma_div_cst) // (i,v) -+> st.
    Proof using Hsd Hk.
      intros H1 H2; subst st; apply mma_div_cst_spec with (1 := H1); auto.
    Qed.

  End mma_div_cst.

  Notation DIV_CSTₐ := mma_div_cst.

  Hint Rewrite mma_div_cst_length : length_db.

  Section mma_div_branch.

    Variable (x z : pos n) (Hxz : x <> z) (k i j : nat).

    Let p :=  6+4*k+i.
    Let q := 13+7*k+i.

    (* The algorithm:
         - test the divisibility of x by k while
           x is transfered to z
         - if divisible jump to p
           if not jump to q
         - at p: divides z by k, result into x
                 jump to j
         - at q: transfer z to x *)

    Definition mma_div_branch :=
                   MOD_CSTₐ x z p q k i
      (* p: *)  ++ DIV_CSTₐ z x k p ++ JUMPₐ j z
      (* q: *)  ++ TRANSFERTₐ z x q.

    Fact mma_div_branch_length : length mma_div_branch = 16+7*k.
    Proof. unfold mma_div_branch; rew length; lia. Qed.

    (* When k divides v#>x then it gets divided (by k)
       and the PC jumps to j *)

    Fact mma_div_branch_0_progress a v st :
            v#>z = 0
         -> 0 < k
         -> v#>x = a*k
         -> st = (j,v[a/x])
         -> (i, mma_div_branch) // (i,v) -+> st.
    Proof using Hxz.
      intros H1 H2 H3 ->; unfold mma_div_branch.
      apply sss_progress_trans with (st2 := (p,v[0/x][(a*k)/z])).
      1:{ apply subcode_sss_progress with (P := (i,MOD_CSTₐ x z p q k i)); auto.
          apply mma_mod_cst_divides_progress with a; auto.
          do 2 f_equal; lia. }
      apply sss_progress_trans with (st2 := (11+7*k+i,v[a/x])).
      1:{ apply subcode_sss_progress with (P := (p,DIV_CSTₐ z x k p)); auto.
          apply mma_div_cst_progress with a; auto; rew vec.
          unfold p.
          f_equal; try lia.
          apply vec_pos_ext; intros y.
          dest y x; dest y z. }
      1:{ apply subcode_sss_progress with (P := (11+7*k+i,JUMPₐ j z)); auto.
          apply mma_jump_progress; auto. }
    Qed.

    (* When k does not divide v#>x then registers are globally
       unmodified and the PC jumps to the end of this (sub-)program *)

    Fact mma_div_branch_1_progress v st :
            v#>z = 0
         -> 0 < k
         -> ~ divides k (v#>x)
         -> st = (16+7*k+i,v)
         -> (i, mma_div_branch) // (i,v) -+> st.
    Proof using Hxz.
      intros H1 H2 H3 ->; unfold mma_div_branch.
      destruct (div_full (v#>x) k) as (a & r & H5 & H6).
      assert (0 < r < k) as H7.
      1:{ split; destruct r; try lia.
          destruct H3; exists a; lia. }
      apply sss_progress_trans with (st2 := (q,v[0/x][(v#>x)/z])).
      1:{ apply subcode_sss_progress with (P := (i,MOD_CSTₐ x z p q k i)); auto.
          apply mma_mod_cst_not_divides_progress with (3 := H5); auto.
          do 2 f_equal; lia. }
      1:{ apply subcode_sss_progress with (P := (q,TRANSFERTₐ z x q)); auto.
          apply mma_transfert_progress; auto.
          f_equal; rew vec.
          apply vec_pos_ext; intros y.
          dest y x; dest y z. }
    Qed.

  End mma_div_branch.

  Section mma_loop.

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

    Definition mma_loop := JUMPₐ i x.

    Fact mma_loop_loop v : (i,mma_loop) // (i,v) -+> (i,v).
    Proof. apply mma_jump_progress; auto. Qed.

    Theorem mma_loop_spec v : ~ (i,mma_loop) // (i,v) ↓.
    Proof.
      apply sss_progress_non_termination.
      + apply mma_sss_fun.
      + apply mma_loop_loop.
    Qed.

  End mma_loop.

  Notation LOOPₐ := mma_loop.

End Minsky_Machine_alt_utils.