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

(**********************************************************************
    Proof of Huffman algorithm: HeightPred.v

    Definition of the predicate that associates a height list
    with a cover

    Definition: height_pred
                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export OrderedCover.
From Huffman Require Export WeightTree.
Require Import ArithRing.
From Huffman Require Export Ordered.
From Huffman Require Export Prod2List.

Section HeightPred.
Variable A : Type.
Variable f : A -> nat.
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.

(*
  A predicate that associates an initial height, a list of
  height, a cover and a tree
*)
Inductive height_pred : nat -> list nat -> list (btree A) -> btree A -> Prop :=
  | height_pred_nil :
      forall (n : nat) (t : btree A), height_pred n (n :: nil) (t :: nil) t
  | height_pred_node :
      forall (n : nat) (ln1 ln2 : list nat) (t1 t2 : btree A)
        (l1 l2 : list (btree A)),
      height_pred (S n) ln1 l1 t1 ->
      height_pred (S n) ln2 l2 t2 ->
      height_pred n (ln1 ++ ln2) (l1 ++ l2) (node t1 t2).
Hint Resolve height_pred_nil height_pred_node : core.

(* The cover is an ordered cover *)
Theorem height_pred_ordered_cover :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> ordered_cover l t.
Proof using.
intros n ln t l H; elim H; simpl in |- *; auto.
Qed.

(* The height list is never empty *)
Theorem height_pred_not_nil1 :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> ln <> nil.
Proof using.
intros n ln t l H; elim H; simpl in |- *; auto.
intros; discriminate.
intros n0 ln1 ln2 t1 t2 l1 l2 H0; case ln1; simpl in |- *; auto.
intros; discriminate.
Qed.

(* The cover list is never empty *)
Theorem height_pred_not_nil2 :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> l <> nil.
Proof using.
intros n ln t l H; elim H; simpl in |- *; auto.
intros; discriminate.
intros n0 ln1 ln2 t1 t2 l1 l2 H0; case l1; simpl in |- *; auto.
intros; discriminate.
Qed.

(* The height and cover lists have same length *)
Theorem height_pred_length :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> length ln = length l.
Proof using.
intros n ln t l H; elim H; simpl in |- *; auto.
intros; repeat rewrite length_app; auto with arith.
Qed.

(*
  The height and cover list gives a simple relation between
  weight_tree, sum_leaves and the product of the two lists
*)
Theorem height_pred_weight :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t ->
 n * sum_leaves f t + weight_tree f t = prod2list f ln l.
Proof using.
intros n ln t l H; elim H; simpl in |- *; auto.
intros n0 ln1 ln2 t1 t2 l1 l2 H0 H1 H2 H3.
rewrite prod2list_app; auto with arith.
rewrite <- H3; rewrite <- H1; ring.
apply height_pred_length with (1 := H0); auto.
Qed.

(* Ordered covers can be completed with a height list *)
Theorem ordered_cover_height_pred :
 forall (n : nat) (t : btree A) (l : list (btree A)),
 ordered_cover l t -> exists ln : list nat, height_pred n ln l t.
Proof using.
intros n t l H; generalize n; elim H; clear n t l H.
intros t l n; exists (n :: nil); auto.
intros t1 t2 l1 l2 l3 H H0 H1 H2 n.
case (H0 (S n)); intros ln1 HH1.
case (H2 (S n)); intros ln2 HH2.
exists (ln1 ++ ln2); auto.
Qed.

(* Elements in the height list are always larger than the initial height *)
Theorem height_pred_larger :
 forall (n n1 : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> In n1 ln -> n <= n1.
Proof using.
intros n n1 ln t l H; generalize n1; elim H; clear H n ln t l n1;
 auto with arith.
intros n t n1 [H2| H2]; [ rewrite H2 | case H2 ]; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 n1 H3; apply le_trans with (S n);
 auto with arith.
case in_app_or with (1 := H3); auto.
Qed.

(*
  In the height list is not a singleton, all its element are
  strictly larger than the initial height
*)
Theorem height_pred_larger_strict :
 forall (n n1 : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> In n1 ln -> n < n1 \/ ln = n :: nil /\ l = t :: nil.
Proof using.
intros n n1 ln t l H; generalize n1; elim H; clear H n ln t l n1; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 n1 H3; left;
 apply lt_le_trans with (S n); auto.
case in_app_or with (1 := H3).
intros H4; apply height_pred_larger with (1 := H); auto.
intros H4; apply height_pred_larger with (1 := H1); auto.
Qed.

(* There always a larger element that the initial height in the heigh list *)
Theorem height_pred_larger_ex :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> exists n1 : _, In n1 ln /\ n <= n1.
Proof using.
intros n ln t l H; elim H; clear H n ln t l.
intros n t; exists n; auto with datatypes.
intros n ln1 ln2 t1 t2 l1 l2 H (n1, (HH1, HH2)) H1 H2.
exists n1; auto with datatypes arith.
Qed.

Lemma height_pred_disj_larger_aux :
  forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
  height_pred n ln l t ->
  forall ln1 ln2 a,
  ln = ln1 ++ a :: ln2 ->
  (forall n1 : nat, In n1 ln1 -> n1 < a) ->
  (forall n1 : nat, In n1 ln2 -> n1 <= a) ->
  (exists ln3 : _, ln2 = a :: ln3) \/ ln = n :: nil /\ l = t :: nil.
Proof using.
intros n ln t l H; elim H; clear H n ln t l.
intros n t l ln1 ln2 a; case ln1; simpl in |- *; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 ln0 ln3 a H3 H4 H5.
case app_inv_app with (1 := H3).
intros (ln4, H7); auto.
cut (ln3 = ln4 ++ ln2);
 [ intros E1
 | apply app_inv_head with (l1 := ln0 ++ a :: nil); repeat rewrite app_ass;
    simpl in |- *; rewrite <- H3; rewrite H7; rewrite app_ass;
    auto ].
case H0 with (1 := H7); auto; clear H0 H2.
intros n1 H8; apply H5; rewrite E1; auto with datatypes.
intros (ln5, HH); left; exists (ln5 ++ ln2).
apply trans_equal with (1 := E1); rewrite HH; auto.
intros (HH1, HH2).
cut (ln0 = nil /\ ln4 = nil /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H7; case ln0; simpl in |- *;
    [ case ln4; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
generalize E1 H1; case ln2; simpl in |- *; auto; clear E1 H1.
intros E1 H1; case height_pred_not_nil2 with (1 := H1); auto.
generalize (height_pred_length _ _ _ _ H1); case l2; simpl in |- *; auto;
 intros; discriminate.
intros n0 ln5 E1 H1; case height_pred_larger_strict with (n1 := n0) (1 := H1);
 simpl in |- *; auto with datatypes.
intros HH6; Contradict HH6; apply le_not_lt; rewrite <- HH5; apply H5;
 rewrite E1; auto with datatypes.
intros (H8, H9); left; exists (nil (A:=nat)); injection H8.
intros HH7 HH8; rewrite HH5; rewrite <- HH8; rewrite <- HH7; rewrite E1;
 rewrite HH4; auto.
intros (ln4, H7); auto.
cut (ln0 = ln1 ++ ln4);
 [ intros E1
 | apply app_inv_tail with (l1 := a :: ln3); rewrite <- H3; rewrite H7;
    rewrite app_ass; auto ].
case H2 with (1 := H7); auto.
intros n1 H6; apply H4; rewrite E1; auto with datatypes.
intros (HH1, HH2).
cut (ln3 = nil /\ ln4 = nil /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H7; case ln4; simpl in |- *;
    [ case ln3; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
case height_pred_larger_ex with (1 := H); auto.
intros n1; rewrite <- HH5; intros (HH6, HH7).
Contradict HH7; apply lt_not_le; apply H4; rewrite E1; auto with datatypes.
Qed.

(* The first maximum height in the list is immediately repeated once *)
Theorem height_pred_disj_larger :
 forall (n a : nat) (ln1 ln2 : list nat) (t : btree A) (l : list (btree A)),
 height_pred n (ln1 ++ a :: ln2) l t ->
 (forall n1 : nat, In n1 ln1 -> n1 < a) ->
 (forall n1 : nat, In n1 ln2 -> n1 <= a) ->
 (exists ln3 : _, ln2 = a :: ln3) \/
 (ln1 = nil /\ a = n /\ ln2 = nil) /\ l = t :: nil.
Proof using.
intros n a ln1 ln2 t l H H0 H1;
 case
  height_pred_disj_larger_aux
   with (a := a) (ln1 := ln1) (ln2 := ln2) (1 := H);
 auto; case ln1; simpl in |- *;
 [ intros (HH1, HH2); injection HH1; auto
 | intros n0 l1; case l1; simpl in |- *; intuition; try discriminate ].
Qed.

Lemma height_pred_disj_larger2_aux :
  forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
  height_pred n ln l t ->
  forall ln1 ln2 a,
  ln = ln1 ++ a :: ln2 ->
  (exists n1 : _, In n1 ln1 /\ a <= n1) \/
  (exists n1 : _, In n1 ln2 /\ a <= n1) \/ ln = n :: nil /\ l = t :: nil.
Proof using.
intros n ln t l H; elim H; clear H n ln t l.
intros n t l ln1 ln2 a; case ln1; simpl in |- *; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 ln0 ln3 a H3.
case app_inv_app with (1 := H3).
intros (ln4, H4); auto.
cut (ln3 = ln4 ++ ln2);
 [ intros E1
 | apply app_inv_head with (l1 := ln0 ++ a :: nil); repeat rewrite app_ass;
    simpl in |- *; rewrite <- H3; rewrite H4; rewrite app_ass;
    auto ].
case H0 with (1 := H4); auto; intros [(n1, (HH1, HH2))| (HH1, HH2)]; auto;
 clear H0 H2.
right; left; exists n1; split; auto; rewrite E1; auto with datatypes.
cut (ln0 = nil /\ ln4 = nil /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H4; case ln0; simpl in |- *;
    [ case ln4; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
case height_pred_larger_ex with (1 := H1); auto.
intros n1; rewrite <- HH5; intros (HM1, HM2).
right; left; exists n1; split; auto; rewrite E1; auto with datatypes.
intros (ln4, H4); auto.
cut (ln0 = ln1 ++ ln4);
 [ intros E1
 | apply app_inv_tail with (l1 := a :: ln3); rewrite <- H3; rewrite H4;
    rewrite app_ass; auto ].
case H2 with (1 := H4); auto; clear H0 H2.
intros (n1, (HH1, HH2)); left; exists n1; split; auto; rewrite E1;
 auto with datatypes.
intros [HH1| (HH1, HH2)]; auto.
cut (ln3 = nil /\ ln4 = nil /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H4; case ln4; simpl in |- *;
    [ case ln3; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
case height_pred_larger_ex with (1 := H); auto.
intros n1; rewrite <- HH5; intros (HM1, HM2).
left; exists n1; split; auto; rewrite E1; auto with datatypes.
Qed.

(* There is no strict maximum in a list *)
Theorem height_pred_disj_larger2 :
 forall (n a : nat) (ln1 ln2 : list nat) (t : btree A) (l : list (btree A)),
 height_pred n (ln1 ++ a :: ln2) l t ->
 (exists n1 : _, In n1 ln1 /\ a <= n1) \/
 (exists n1 : _, In n1 ln2 /\ a <= n1) \/
 (ln1 = nil /\ a = n /\ ln2 = nil) /\ l = t :: nil.
Proof using.
intros n a ln1 ln2 t l H;
 case
  height_pred_disj_larger2_aux
   with (a := a) (ln1 := ln1) (ln2 := ln2) (1 := H);
 auto.
intros [H1| (H1, H2)]; auto.
generalize H1 H2; case ln1; simpl in |- *;
 [ intros H3; injection H3; auto with datatypes | idtac ].
intros H0 H4 H5; repeat right; auto.
intros n0 l0; case l0; simpl in |- *; intros; discriminate.
Qed.

Let height_pred_shrink_aux :
  forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
  height_pred n ln l t ->
  forall l1 l2 ln1 ln2 a b t1 t2,
  ln = ln1 ++ a :: b :: ln2 ->
  (forall n1 : nat, In n1 ln1 -> n1 < a) ->
  (forall n1 : nat, In n1 (b :: ln2) -> n1 <= a) ->
  length ln1 = length l1 ->
  l = l1 ++ t1 :: t2 :: l2 ->
  height_pred n (ln1 ++ pred a :: ln2) (l1 ++ node t1 t2 :: l2) t.
Proof using.
intros n ln t l H; elim H; clear n ln t l H; auto.
intros n t l1 l2 ln1 ln2 a b t1 t2; case ln1;
 try (simpl in |- *; intros; discriminate).
intros n0 l0; case l0; try (simpl in |- *; intros; discriminate).
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 l0 l3 ln0 ln3 a b t0 t3 H3 H4 H5 H6
 H7.
cut (length ln1 = length l1);
 [ intros Eq2 | apply height_pred_length with (1 := H) ].
cut (length ln2 = length l2);
 [ intros Eq3 | apply height_pred_length with (1 := H1) ].
cut (length ln3 = length l3);
 [ intros Eq4
 | apply plus_reg_l with (length (ln0 ++ a :: b :: nil));
    rewrite <- length_app; rewrite app_ass; simpl in |- *;
    rewrite <- H3; repeat rewrite length_app; simpl in |- *;
    rewrite Eq2; rewrite Eq3; rewrite <- length_app;
    rewrite H7; repeat rewrite length_app; simpl in |- *;
    repeat rewrite (fun x y => plus_comm x (S y));
    simpl in |- *; rewrite plus_comm; auto ].
case app_inv_app2 with (1 := H3); auto.
intros (ln4, Hp1).
cut (ln3 = ln4 ++ ln2);
 [ intros E1
 | apply app_inv_head with (l1 := ln0 ++ a :: b :: nil);
    repeat rewrite app_ass; simpl in |- *; rewrite <- H3;
    rewrite Hp1; repeat rewrite app_ass; auto ].
replace (ln0 ++ pred a :: ln3) with ((ln0 ++ pred a :: ln4) ++ ln2);
 [ idtac | rewrite app_ass; rewrite E1; auto ].
cut (l3 = first_n l3 (length ln4) ++ l2).
intros HH;
 replace (l0 ++ node t0 t3 :: l3) with
  ((l0 ++ node t0 t3 :: first_n l3 (length ln4)) ++ l2);
 [ idtac | pattern l3 at 2 in |- *; rewrite HH; rewrite app_ass; auto ].
apply height_pred_node; auto.
apply H0 with (1 := Hp1); auto.
intros n1 HH1; (apply H5; auto).
simpl in HH1; case HH1; intros H9; try rewrite H9; auto with datatypes.
rewrite E1; auto with datatypes.
apply app_inv_tail with (l1 := l2).
repeat rewrite app_ass; apply trans_equal with (1 := H7); auto.
pattern l3 at 1 in |- *; rewrite HH; auto.
apply sym_equal;
 apply trans_equal with (2 := first_n_skip_n_app _ (length ln4) l3).
apply f_equal2 with (f := app (A:=btree A)); auto.
apply trans_equal with (skip_n l2 (length l1 - length l1)).
rewrite <- minus_n_n; simpl in |- *; auto.
rewrite <- skip_n_app1; auto.
rewrite H7.
rewrite <- Eq2; rewrite Hp1.
rewrite skip_n_app1.
rewrite length_app.
rewrite H6; rewrite minus_plus; simpl in |- *; auto.
rewrite <- H6; rewrite length_app; simpl in |- *; auto with arith.
intros [(ln4, HH)| (HH1, HH2)].
cut (ln0 = ln1 ++ ln4);
 [ intros E1
 | apply app_inv_tail with (l1 := a :: b :: ln3); rewrite <- H3; rewrite HH;
    rewrite app_ass; auto ].
cut (l0 = l1 ++ skip_n l0 (length l1)).
intros Eq1; rewrite Eq1; rewrite E1; repeat rewrite app_ass.
apply height_pred_node; auto.
apply H2 with (b := b); auto.
intros n1 H8; apply H4; (rewrite E1; auto with datatypes).
rewrite skip_n_length; rewrite <- Eq2; rewrite <- H6;
 rewrite <- skip_n_length; rewrite E1; rewrite skip_n_app2;
 auto; rewrite skip_n_id; simpl in |- *; auto.
apply app_inv_head with (l1 := l1).
rewrite <- app_ass; rewrite <- Eq1; auto.
apply sym_equal;
 apply trans_equal with (2 := first_n_skip_n_app _ (length l1) l0).
apply f_equal2 with (f := app (A:=btree A)); auto.
apply trans_equal with (first_n (l1 ++ l2) (length l1)).
rewrite first_n_app1; auto; rewrite <- minus_n_n; simpl in |- *;
 auto with datatypes.
rewrite H7; rewrite first_n_app2; auto.
rewrite <- H6; rewrite <- Eq2; rewrite E1; rewrite length_app;
 auto with arith.
rewrite HH1 in H; case height_pred_disj_larger2 with (1 := H); simpl in |- *;
 auto.
intros (n1, (HH3, HH4)); Contradict HH4; auto with arith.
intros [(n1, (HH3, HH4))| ((HH3, (HH4, HH5)), HH6)]; [ case HH3 | idtac ].
case height_pred_larger_strict with (1 := H1) (n1 := b); auto.
rewrite HH2; auto with datatypes.
rewrite <- HH4; intros HH7; Contradict HH7; apply le_not_lt;
 auto with arith datatypes.
intros (H8, H9); rewrite HH4; rewrite HH3; simpl in |- *.
cut (l0 = nil); [ intros HM1; rewrite HM1 | idtac ].
cut (ln3 = nil); [ intros HM2; rewrite HM2 | idtac ].
replace l3 with (nil (A:=btree A)); simpl in |- *; auto.
rewrite HH6 in H7; rewrite H9 in H7; rewrite HM1 in H7; simpl in H7;
 injection H7.
intros Ht1 Ht2 Ht3; rewrite Ht2; rewrite Ht3; auto.
generalize Eq4; rewrite HM2; case l3; simpl in |- *; auto; intros;
 discriminate.
rewrite HH2 in H8; injection H8; auto.
generalize H6; rewrite HH3; case l0; simpl in |- *; auto; intros;
 discriminate.
Qed.

(*
  A cover can be shrunk at the first maximum of the height while
  preserving the height list
*)
Theorem height_pred_shrink :
 forall (n a b : nat) (ln1 ln2 : list nat) (t t1 t2 : btree A)
   (l1 l2 : list (btree A)),
 height_pred n (ln1 ++ a :: b :: ln2) (l1 ++ t1 :: t2 :: l2) t ->
 (forall n1 : nat, In n1 ln1 -> n1 < a) ->
 (forall n1 : nat, In n1 (b :: ln2) -> n1 <= a) ->
 length ln1 = length l1 ->
 height_pred n (ln1 ++ pred a :: ln2) (l1 ++ node t1 t2 :: l2) t.
Proof using.
intros n a b ln1 ln2 t t1 t2 l1 l2 H H0 H1 H2;
 apply height_pred_shrink_aux with (1 := H) (b := b);
 auto.
Qed.

(*
  Given a tree and its associated code it is possible to build
  a height list (the length of the codes) and a cover (the leaves)
  that are in relation
*)
Theorem height_pred_compute_code :
 forall (n : nat) (t : btree A),
 height_pred n (map (fun x => length (snd x) + n) (compute_code t))
   (map (fun x => leaf (fst x)) (compute_code t)) t.
Proof using.
intros n t; generalize n; elim t; clear t n; simpl in |- *; auto.
intros b H b0 H0 n.
repeat rewrite map_app.
cut
 (forall (b : bool) l,
  map (fun x : A * list bool => length (snd x) + n)
    (map (fun v : A * list bool => let (a1, b1) := v in (a1, b :: b1)) l) =
  map (fun x : A * list bool => length (snd x) + S n) l);
 [ intros E1 | idtac ].
cut
 (forall b l,
  map (fun x : A * list bool => leaf (fst x))
    (map (fun v : A * list bool => let (a1, b1) := v in (a1, b :: b1)) l) =
  map (fun x : A * list bool => leaf (fst x)) l); [ intros E2 | idtac ].
apply height_pred_node; repeat rewrite E1; repeat rewrite E2; auto.
intros b1 l; elim l; simpl in |- *; auto.
intros a; case a; simpl in |- *; auto.
intros a0 l0 l1 H1; apply f_equal2 with (f := cons (A:=btree A)); auto.
intros b1 l; elim l; simpl in |- *; auto.
intros a; case a; simpl in |- *; auto.
intros a0 l0 l1 H1; apply f_equal2 with (f := cons (A:=nat)); auto.
Qed.

(*
  A consequence of the previous theorem, the weight of the tree
  is exactly the encoding of the message of the corresponding code
*)
Theorem weight_tree_compute :
 forall (m : list A) t,
 distinct_leaves t ->
 (forall a : A, f a = number_of_occurrences eqA_dec a m) ->
 length (encode eqA_dec (compute_code t) m) = weight_tree f t.
Proof using.
intros m t H0 H.
rewrite frequency_length; auto.
apply trans_equal with (0 * sum_leaves f t + weight_tree f t); auto.
rewrite height_pred_weight with (1 := height_pred_compute_code 0 t).
unfold prod2list in |- *.
rewrite
 fold_left_eta
               with
               (f :=
                 fun (a : nat) (b : A * list bool) =>
                 a + number_of_occurrences eqA_dec (fst b) m * length (snd b))
              (f1 :=
                fun (a : nat) (b : A * list bool) =>
                a + (fun b => f (fst b) * length (snd b)) b);
 auto.
rewrite <-
 (fold_left_map _ _ (fun a b : nat => a + b) _ 0 (compute_code t)
    (fun b : A * list bool => f (fst b) * length (snd b)))
 .
rewrite fold_left_eta with (f := fun a b : nat => a + b) (f1 := plus); auto.
apply f_equal3 with (f := fold_left (A:=nat) (B:=nat)); auto.
elim (compute_code t); simpl in |- *; auto.
intros a l H1; apply f_equal2 with (f := cons (A:=nat)); auto with arith.
ring.
apply btree_unique_prefix2; auto.
Qed.

End HeightPred.
Arguments height_pred [A].
Hint Resolve height_pred_nil height_pred_node : core.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    FullAtomicJl:
        Decidable, Tag-Based Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * FullAtomicJl: Simple Propositions *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.FullAtomicJl.BaseDefs.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

(* ################################################################# *)
(** ** Decidability *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Value Type *)
(* ================================================================= *)

(** [value_type t] is decidable *)
Theorem value_type__dcdbl : forall (t : ty),
    Decidable.decidable (value_type t).
Proof.
  induction t;
    try solve [right; intros Hcontra; inversion Hcontra].
  - (* CName *)
    left; constructor.
  - (* Pair *)
    destruct IHt1 as [IHt1 | IHt1]; destruct IHt2 as [IHt2 | IHt2];
      try solve [right; intros Hcontra; inversion Hcontra; subst;
                 contradiction].
    left; constructor; assumption.
  - (* Ext *)
    left; constructor.
Qed.

(* ================================================================= *)
(** *** Atom Type *)
(* ================================================================= *)

(** [atom_type t] is decidable *)
Theorem atom_type__dcdbl : forall (t : ty),
    Decidable.decidable (atom_type t).
Proof.
  induction t;
    try solve [
          left; constructor
        | right; intros Hcontra; inversion Hcontra ].
  (* Pair *)
  destruct IHt1 as [IHt1 | IHt1]; destruct IHt2 as [IHt2 | IHt2];
    try solve [right; intros Hcontra; inversion Hcontra; subst;
               contradiction].
  left; constructor; assumption.
Qed.

(* ================================================================= *)
(** *** CName *)
(* ================================================================= *)

(** Equality of names [cn1 = cn2] is decidable *)
Lemma cname_eq__decidable : forall (n1 n2 : cname),
    Decidable.decidable (n1 = n2).
Proof.
  intros n1 n2; destruct n1; destruct n2;
    (left; reflexivity) ||
    (right; intros H; inversion H).
Qed.

(* ================================================================= *)
(** *** AName *)
(* ================================================================= *)

(** Equality of names [an1 = an2] is decidable *)
Lemma aname_eq__decidable : forall (n1 n2 : aname),
    Decidable.decidable (n1 = n2).
Proof.
  intros n1 n2; destruct n1; destruct n2;
    (left; reflexivity) ||
    (right; intros H; inversion H).
Qed.

(* ################################################################# *)
(** ** Validity *)
(* ################################################################# *)

Lemma atom__valid : forall (t : ty),
    atom_type t ->
    valid t.
Proof.
  intros t Hat; induction Hat; constructor; assumption.
Qed.

Lemma nf__valid : forall (t : ty),
    InNF(t) ->
    valid t.
Proof.
  intros t Hnf; induction Hnf.
  apply atom__valid; assumption.
  constructor; assumption.
Qed.

Lemma value_type_valid__atom : forall (v : ty),
    value_type v -> valid v ->
    atom_type v.
Proof.
  intros v Hval HTYv. induction Hval.
  - (* CName *)
    constructor.
  - (* Pair *)
    inversion HTYv; subst.
    constructor; tauto.
  - (* Ext *)
    inversion HTYv.
Qed.

(* ################################################################# *)
(** ** Normal Form irregardless Subtyping *)
(* ################################################################# *)

Open Scope btjnf_scope.

(* ================================================================= *)
(** *** Properties of InNF *)
(* ================================================================= *)

(** Atom type is normal form. *)
Lemma atomty_in_nf : forall (ta : ty),
    atom_type ta ->
    InNF(ta).
Proof.
  intros v Hval; induction Hval;
    try repeat constructor; assumption.
Qed.

(** If union is in normal form, its components also are. *)
Lemma union_in_nf__components_in_nf : forall (t1 t2 : ty),
    InNF(TUnion t1 t2) ->
    InNF(t1) /\ InNF(t2).
Proof.
  intros t1 t2 Hnf. inversion Hnf; subst.
  inversion H. tauto.
Qed.

(* ================================================================= *)
(** *** Properties of MkNF *)
(* ================================================================= *)

(* ----------------------------------------------------------------- *)
(** **** Aux *)
(* ----------------------------------------------------------------- *)

Lemma unite_pairs_t_union : forall (t t1 t2 : ty),
    ~ (exists ta tb, t = TUnion ta tb) ->
    unite_pairs t (TUnion t1 t2) = TUnion (unite_pairs t t1) (unite_pairs t t2).
Proof.
  intros t t1 t2 Hcontra.
  destruct t; try solve [simpl; reflexivity].
  assert (H: exists ta tb, TUnion t3 t4 = TUnion ta tb).
  { exists t3, t4; reflexivity. }
  contradiction.
Qed.

(* Helper for [unite_pairs_t_union] *)
Ltac resolve_not_union :=
  intros [tx [ty Hcontra]]; inversion Hcontra.

Ltac resolve_not_atom_type :=
  try solve [match goal with
               [H: atom_type (TUnion _ _) |-_] => inversion H
             end].

Lemma unite_pairs_union_t : forall (t1 t2 t' : ty),
    unite_pairs (TUnion t1 t2) t' = TUnion (unite_pairs t1 t') (unite_pairs t2 t').
Proof.
  intros t1 t2 t'.
  destruct t'; try solve [simpl; reflexivity].
Qed.

(* DEP: unite_pairs_t_union, unite_pairs_union_t *)
Lemma unite_pairs__preserves_nf : forall (t1 t2 : ty),
    InNF(t1) ->
    InNF(t2) ->
    InNF(unite_pairs t1 t2).
Proof.
  intros ta tb Hnfa. generalize dependent tb.
  induction Hnfa; intros tb; intros Hnfb; induction Hnfb.
  - (* Atom, Atom *)
    destruct ta; destruct ta0; simpl; resolve_not_atom_type;
      try solve [inversion H; inversion H0; subst;
                 repeat constructor; assumption].
  - (* Atom, Union *)
    destruct ta; subst; resolve_not_atom_type;
      rewrite unite_pairs_t_union; try resolve_not_union;
      apply NF_Union; try assumption.
  - (* Union, Atom *)
    rewrite unite_pairs_union_t.
    apply NF_Union; [apply IHHnfa1 | apply IHHnfa2];
      apply NF_Atom; assumption.
  - (* Union, Union *)
    simpl. apply NF_Union;
    [apply IHHnfa1 | apply IHHnfa2]; apply NF_Union; assumption.
Qed.

Lemma unite_pairs_of_atomtys : forall (ta1 ta2 : ty),
    atom_type ta1 ->
    atom_type ta2 ->
    unite_pairs ta1 ta2 = TPair ta1 ta2.
Proof.
  intros ta1 ta2 Hval1; induction Hval1;
    intros Hval2; induction Hval2;
      try solve [simpl; reflexivity].
Qed.

Lemma unite_pairs_of_valuetys : forall (ta1 ta2 : ty),
    value_type ta1 ->
    value_type ta2 ->
    unite_pairs ta1 ta2 = TPair ta1 ta2.
Proof.
  intros ta1 ta2 Hval1; induction Hval1;
    intros Hval2; induction Hval2;
      try solve [simpl; reflexivity].
Qed.

(* DEP: unite_pairs_of_valuetys *)
Lemma mk_nf_valuety__equal : forall (v : ty),
    value_type v ->
    MkNF(v) = v.
Proof.
  intros v Hval; induction Hval;
    try solve [simpl; reflexivity].
  (* Pair *)
  simpl. rewrite IHHval1. rewrite IHHval2.
  rewrite unite_pairs_of_valuetys; try assumption.
  reflexivity.
Qed.

(*
Lemma unite_pairs__preserves_valid : forall (t1 t2 : ty),
    valid t1 ->
    valid t2 ->
    valid (unite_pairs t1 t2).
Proof.
  intros ta tb HTYa. generalize dependent tb.
  induction HTYa;
    intros tb HTYb; induction HTYb;
      try solve [simpl; repeat constructor].
  simpl.
Abort.
*)

(* ----------------------------------------------------------------- *)
(** **** Main Properties *)
(* ----------------------------------------------------------------- *)

(** [MkNF] returns normal form. *)
(* DEP: unite_pairs__preserves_nf *)
Theorem mk_nf__in_nf : forall (t : ty),
    valid t ->
    InNF(MkNF(t)).
Proof.
  intros t HTYt. induction HTYt.
  - (* CName *)
    simpl. repeat constructor.
  - (* AName *)
    destruct an; simpl; repeat apply NF_Union; repeat constructor.
  - (* Pair *)
    simpl. apply unite_pairs__preserves_nf; assumption.
  - (* Union *)
    simpl. apply NF_Union; assumption.
Qed.

(* DEP: unite_pairs_of_atomtys *)
Lemma mk_nf_atomty__equal : forall (v : ty),
    atom_type v ->
    MkNF(v) = v.
Proof.
  intros v Hval; induction Hval;
    try solve [simpl; reflexivity].
  (* Pair *)
  simpl. rewrite IHHval1. rewrite IHHval2.
  rewrite unite_pairs_of_atomtys; try assumption.
  reflexivity.
Qed.

(* DEP: mk_nf_valty__equal *)
Lemma mk_nf_nf__equal : forall (t : ty),
    InNF(t) ->
    MkNF(t) = t.
Proof.
  intros t Hnf; induction Hnf.
  - (* Value *)
    apply mk_nf_atomty__equal; assumption.
  - (* Union *)
    simpl. rewrite IHHnf1. rewrite IHHnf2. reflexivity.
Qed.

(* DEP: mk_nf_of_nf__equal, mk_nf__in_nf *)
Theorem mk_nf__idempotent : forall (t : ty),
    valid t ->
    MkNF( MkNF(t) ) = MkNF(t).
Proof.
  intros t HTYt. apply mk_nf_nf__equal.
  apply mk_nf__in_nf; assumption.
Qed.

(* DEP: mk_nf__in_nf, nf__valid *)
Lemma mk_nf__preserves_valid : forall (t : ty),
    valid t ->
    valid (MkNF(t)).
Proof.
  intros t HTYt.
  pose proof (mk_nf__in_nf t HTYt).
  apply nf__valid; assumption.
Qed.

Lemma mk_nf__preserves_value_type : forall (t : ty),
    value_type t ->
    value_type (MkNF(t)).
Proof.
  intros t Hval; induction Hval;
    try solve [simpl; constructor].
  simpl. rewrite unite_pairs_of_valuetys; try assumption.
  constructor; assumption.
Qed.

(* ################################################################# *)
(** ** Declarative Subtyping *)
(* ################################################################# *)

Open  Scope btj_scope.

Lemma union_sub_d__components_sub_d : forall (t1 t2 t' : ty),
    |- TUnion t1 t2 << t' ->
    |- t1 << t' /\ |- t2 << t'.
Proof.
  intros t1 t2 t' H. remember (TUnion t1 t2) as t eqn:Heq.
  induction H; try solve [inversion Heq].
  - (* Refl *)
    subst; split; constructor.
  - (* Trans *)
    specialize (IHsub_d1 Heq); destruct IHsub_d1 as [Hsub1 Hsub2].
    split; apply SD_Trans with t3; assumption.
  - (* UnionL *)
    inversion Heq; subst. split; assumption.
  - (* UnionR1 *)
    inversion Heq; subst. split; apply union_right_1.
    apply SD_UnionR1. apply SD_UnionR2.
  - (* UnionR2 *)
    inversion Heq; subst. split; apply union_right_2.
    apply SD_UnionR1. apply SD_UnionR2.
Qed.

(* ################################################################# *)
(** ** Reductive Subtyping *)
(* ################################################################# *)

Close Scope btj_scope.
Open  Scope btjr_scope.

(* ================================================================= *)
(** *** Reflexivity *)
(* ================================================================= *)

Lemma sub_r__rflxv : forall (t : ty),
    valid t ->
    |- t << t.
Proof.
  intros t HTY; induction HTY; try solve [constructor; assumption].
  (* Union *)
  constructor;
    [apply SR_UnionR1 | apply SR_UnionR2]; assumption.
Qed.

(*
(* ================================================================= *)
(** *** Relation to Value and Atom Types *)
(* ================================================================= *)

(* DEP: mk_nf_nf__equal, valty_atomty *)
Lemma sub_r_value_types__equal : forall (v1 v2 : ty),
    |- v1 << v2 ->
    value_type v1 ->
    value_type v2 ->
    v1 = v2.
Proof.
  intros v1 v2 Hsub; induction Hsub; intros Hval1 Hval2;
    try solve [reflexivity | inversion Hval1 | inversion Hval2].
  - (* Pair *)
    inversion Hval1; inversion Hval2; subst.
    rewrite IHHsub1; try assumption;
      rewrite IHHsub2; try assumption.
    reflexivity.
  - (* NF *)
    rewrite mk_nf_nf__equal in IHHsub.
    apply IHHsub; assumption.
    apply NF_Atom; apply valty_atomty; assumption.
Qed.

(* DEP: mk_nf_nf__equal *)
Lemma sub_r_atom_types__equal : forall (ta1 ta2 : ty),
    |- ta1 << ta2 ->
    atom_type ta1 ->
    atom_type ta2 ->
    ta1 = ta2.
Proof.
  intros v1 v2 Hsub; induction Hsub; intros Hval1 Hval2;
    try solve [reflexivity | inversion Hval1 | inversion Hval2].
  - (* Pair *)
    inversion Hval1; inversion Hval2; subst.
    rewrite IHHsub1; try assumption;
      rewrite IHHsub2; try assumption.
    reflexivity.
  - (* NF *)
    rewrite mk_nf_nf__equal in IHHsub.
    apply IHHsub; assumption.
    apply NF_Atom; assumption.
Qed.
*)


From Coq Require Export
  Arith
  Bool
  Lia
  List
  RelationClasses.
From FunProofs.Lib Require Export
  Arith
  EqDec
  Function
  Logic
  List
  Tactics
  String.

#[global] Set Default Goal Selector "!".


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

Require Import utils subcode.

Set Implicit Arguments.

Reserved Notation "i '//' r '-1>' s" (at level 70, no associativity).
Reserved Notation "P '//' r ':1>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '-[' n ']->' s" (at level 70, no associativity).
Reserved Notation "P '//' r '-+>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '->>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '-]]' s" (at level 70, no associativity).
Reserved Notation "P '//' r '~~>' s" (at level 70, no associativity).
Reserved Notation "P '//' r ↓" (at level 70, no associativity).

Section Small_Step_Semantics.

  (** * Code
      A generic library to implement Small Step Semantics on programs described
      by lists of instructions that modify a state and a Program Counter (PC)

      An important part of the library is devoted to show locality lemmas
      that related computation inside sub-programs to outer programs

      This is ESSENTIAL to be able to show properties compositionally,
      ie to derive properties of program from properties of sub-programs
   *)

  (** ** Syntax *)

  Variable (instr : Set) (data : Type).

  (* A state contain the PC (current instruction) and data *)

  Notation state := (nat * data)%type.

  Variable one_step : instr -> state -> state -> Prop.

  Notation "i // s -1> t" := (one_step i s t) (at level 70, no associativity).
  Notation "s ⟬ i ⦒  t" := (one_step i s t) (at level 70, no associativity).

  Hypothesis (sss_fun : forall i s t1 t2, i // s -1> t1 -> i // s -1> t2 -> t1 = t2).
  Hypothesis (sss_dec : forall i st1 st2, { i // st1 -1> st2 } + { ~ i // st1 -1> st2 }).

  (* A code is a contiguous list of instructions starting at some position *)

  Notation code := (nat * list instr)%type.

  (** ** Semantics *)

  (* This a one step computation *)

  Definition sss_step P st1 st2 := exists k l i r d, P = (k,l++i::r)
                                                  /\ st1 = (k+length l,d)
                                                  /\ i // st1 -1> st2.

  Notation "P // r :1> s" := (sss_step P r s)  (at level 70, no associativity).

  (* Functionality of one step computations *)

  Fact sss_step_fun P s t1 t2 : P // s :1> t1 -> P // s :1> t2 -> t1 = t2.
  Proof.
    intros (k1 & l1 & i1 & r1 & d1 & ? & ? & H1)
           (k2 & l2 & i2 & r2 & d2 & ? & ? & H2).
    subst.
    inversion H3.
    inversion H4.
    subst k2.
    apply list_app_inj in H5; try omega.
    destruct H5 as (? & H5); inversion H5.
    subst.
    revert H1 H2; apply sss_fun.
  Qed.

  (* A "more general/usable" constructor *)

  Fact in_sss_step k l i r st1 st2 : fst st1 = k+length l
                               ->       i     // st1  -1>  st2
                               -> (k,l++i::r) // st1  :1>  st2.
  Proof. destruct st1 as (j,d); simpl; intro; subst; exists k,l,i,r,d; auto. Qed.

  (* A destructor *)

  Fact sss_step_subcode_inv P ii st st' :
        (fst st, ii::nil) <sc P -> P // st :1> st' -> ii // st -1> st'.
  Proof.
    intros H1 (k & l2 & jj & r2 & d1 & H3 & H4 & H5); subst P st.
    destruct H1 as (l1 & r1 & H1 & H2).
    simpl in H1, H2.
    apply list_app_inj in H1; try omega.
    destruct H1 as (? & H1); subst l2.
    inversion H1; subst jj r2; auto.
  Qed.

  Fact sss_step_supcode P Q st st' :
       P <sc Q -> in_code (fst st) P -> Q // st :1> st' -> P // st :1> st'.
  Proof.
    intros H1 H2 (k & l & ii & r & d & ? & ? & H3); subst.
    destruct P as (iP,cP).
    destruct H1 as (ll & rr & H1 & H4).
    simpl in H2.
    symmetry in H1.
    apply list_app_cons_eq_inv in H1.
    destruct H1 as [ (m & G1 & G2) | (m & G1 & G2) ].
    2: apply f_equal with (f := @length _) in G1;
       exfalso; revert G1; rew length; intro; omega.
    apply list_app_cons_eq_inv in G2.
    destruct G2 as [ (p & G3 & G4) | (p & G3 & G4) ].
    subst; exfalso; revert H2; rew length; intro; omega.
    subst.
    apply in_sss_step; auto.
    revert H2; rew length; simpl; intro; omega.
  Qed.

  (* sss_step is decidable *)

  Fact sss_step_dec P st1 st2 : { P // st1 :1> st2 } + { ~ P // st1 :1> st2 }.
  Proof.
    destruct st1 as (j,d).
    destruct P as (k,ll).
    destruct (le_lt_dec k j) as [ H1 | H1 ].
    destruct (le_lt_dec (S j) (k+length ll)) as [ H2 | H2 ].
    destruct (@list_pick _ ll (j-k)) as (i & l & r & ? & ?).
    omega.
    assert (j = k+length l) by omega; subst.
    destruct (sss_dec i (k+length l,d) st2) as [ | C ].
    left; apply in_sss_step; auto.
    right; contradict C.
    destruct C as (k1 & l1 & i1 & r1 & d1 & ? & ? & ?).
    inversion H3; subst.
    inversion H; subst.
    apply list_app_inj in H8; try omega.
    destruct H8 as (? & H8); inversion H8; subst; auto.

    right; intros (k1 & l1 & i1 & r1 & d1 & ? & ? & ?).
    inversion H; subst.
    inversion H0; subst.
    rewrite app_length in H2; simpl in H2; omega.

    right; intros (k1 & l1 & i1 & r1 & d1 & ? & ? & ?).
    inversion H; subst.
    inversion H0; subst.
    omega.
  Qed.

  (* This is a n steps computation *)

  Inductive sss_steps (P : code) : nat -> state -> state -> Prop :=
    | in_sss_steps_0 : forall st,                  P // st   -[0]->    st
    | in_sss_steps_S : forall n st1 st2 st3,       P // st1   :1>      st2
                                              ->   P // st2  -[n]->    st3
                                              ->   P // st1  -[S n]->  st3
  where "P // r -[ n ]-> s" := (sss_steps P n r s).

  (* More usable constructors *)

  Fact sss_steps_0 P st1 st2 : st1 = st2 -> P // st1 -[0]-> st2.
  Proof. intros []; constructor. Qed.

  Fact sss_steps_1 P st1 st2 : P // st1 :1> st2 -> P // st1 -[1]-> st2.
  Proof.
    constructor 2 with st2; auto.
    constructor 1.
  Qed.

  Fact sss_steps_trans P n m st1 st2 st3 :
         P // st1 -[n]-> st2 -> P // st2 -[m]-> st3 -> P // st1 -[n+m]-> st3 .
  Proof.
    intros H; revert H st3.
    induction 1 as [ | ? ? st2 ]; simpl; intros; auto.
    constructor 2 with st2; auto.
  Qed.

  (* Inversion lemma *)

  Fact sss_steps_0_inv P st1 st2 : P // st1 -[0]-> st2 -> st1 = st2.
  Proof. inversion 1; auto. Qed.

  Fact sss_steps_S_inv P st1 st3 k :
                        st1 <> st3
      ->                P // st1 -[k]-> st3
      -> exists k' st2, k = S k'
                     /\ P // st1 :1> st2
                     /\ P // st2 -[k']-> st3.
  Proof.
    intros H.
    inversion 1; subst.
    destruct H; auto.
    exists n, st2; auto.
  Qed.

  Fact sss_steps_inv P k st1 st3 :
          P // st1 -[k]-> st3
       -> (k = 0 /\ st1 = st3)
        + { k' | exists st2, k = S k'
                       /\ P // st1 :1> st2
                       /\ P // st2 -[k']-> st3 }%type.
  Proof.
    intros H.
    destruct k as [ | k ]; [ left | right ].
    apply sss_steps_0_inv in H; auto.
    exists k.
    inversion H; subst.
    exists st2; auto.
  Qed.

  Fact sss_steps_S_inv' P st1 st3 k :
                        P // st1 -[S k]-> st3
      -> exists st2,    P // st1 :1> st2
                     /\ P // st2 -[k]-> st3.
  Proof.
    intros H.
    inversion H; subst.
    exists st2; auto.
  Qed.

  Fact sss_steps_fun P k s t1 t2 :
         P // s -[k]-> t1
      -> P // s -[k]-> t2
      -> t1 = t2.
  Proof.
    intros H; revert H t2; induction 1 as [ | ? ? st2 ? H1 H2 IH2 ]; simpl; intros t2 Ht2; auto.
    inversion Ht2; auto.
    inversion Ht2; subst.
    generalize (sss_step_fun H1 H0); intro; subst.
    apply IH2 in H3; auto.
  Qed.

  Fact sss_steps_plus_inv P n m st1 st3 :
         P // st1 -[n+m]-> st3
      -> exists st2, P // st1 -[n]-> st2
                  /\ P // st2 -[m]-> st3.
  Proof.
    revert st1 st3; induction n as [ | n IHn ]; intros s t.
    exists s; split; auto; constructor.
    inversion 1; subst.
    apply IHn in H2; destruct H2 as (st & ? & ?).
    exists st; split; auto.
    constructor 2 with st2; auto.
  Qed.

  Definition sss_progress P st1 st2 := exists k, 0 < k /\ P // st1 -[k]-> st2.
  Definition sss_compute  P st1 st2 := exists k, P // st1 -[k]-> st2.

  Notation "P // r -+> s" := (sss_progress P r s).
  Notation "P // r ->> s" := (sss_compute P r s).

  Fact sss_progress_compute P st1 st2 : P // st1 -+> st2 -> P // st1 ->> st2.
  Proof. intros (k & _ & ?); exists k; auto. Qed.

  Fact sss_compute_trans P st1 st2 st3 : P // st1 ->> st2 -> P // st2 ->> st3 -> P // st1 ->> st3.
  Proof. intros (i & H1) (j & H2); exists (i+j); revert H1 H2; apply sss_steps_trans. Qed.

  Fact sss_progress_compute_trans P st1 st2 st3 : P // st1 -+> st2 -> P // st2 ->> st3 -> P // st1 -+> st3.
  Proof. intros (i & ? & H1) (j & H2); exists (i+j); split; try omega; revert H1 H2; apply sss_steps_trans. Qed.

  Fact sss_compute_progress_trans P st1 st2 st3 : P // st1 ->> st2 -> P // st2 -+> st3 -> P // st1 -+> st3.
  Proof. intros (i & H1) (j & ? & H2); exists (i+j); split; try omega; revert H1 H2; apply sss_steps_trans. Qed.

  Fact sss_progress_trans P st1 st2 st3 : P // st1 -+> st2 -> P // st2 -+> st3 -> P // st1 -+> st3.
  Proof. intro; apply sss_compute_progress_trans, sss_progress_compute; trivial. Qed.

  (* Computations must start inside code *)

  Fact sss_step_in_code P st1 st2 : P // st1 :1> st2 -> in_code (fst st1) P.
  Proof.
    revert P st1 st2; intros (n,c) (i,d) st2 (q & l & ii & r & d1 & H1 & H2 & _).
    inversion H1; subst.
    inversion H2; subst.
    simpl; rew length; omega.
  Qed.

  Fact sss_steps_compute P n st1 st2 : P // st1 -[n]-> st2 -> P // st1 ->> st2.
  Proof. exists n; trivial. Qed.

  (** We propose a library of locality lemmas that link computations
      in subcode to computations in the code *)

  (** ** Compisitional Reasoning over Subcode *)

  (* First inclusions lemmas *)

  Fact subcode_sss_step P Q st1 st2: P <sc Q -> P // st1 :1> st2 -> Q // st1 :1> st2.
  Proof.
    destruct P as (n1,c1).
    destruct Q as (n2,c2).
    simpl.
    intros (l & r & H1 & H2) H3.
    destruct H3 as (q & ll & i & rr & d1 & H3 & H4 & H5).
    inversion H3; subst.
    exists n2, (l++ll), i, (rr++r), d1; repeat split; auto.
    f_equal; solve list eq.
    f_equal; rew length; omega.
  Qed.

  Fact subcode_sss_steps P Q k st1 st2: P <sc Q -> P // st1 -[k]-> st2 -> Q // st1 -[k]-> st2.
  Proof.
    induction 2 as [ | k st1 st2 st3 H3 H4 IH4 ].
    constructor.
    constructor 2 with st2; auto.
    revert H3; apply subcode_sss_step; auto.
  Qed.

  Fact subcode_sss_progress P Q st1 st2: P <sc Q -> P // st1 -+> st2 -> Q // st1 -+> st2.
  Proof.
    intros ? (k & ? & Hk); exists k; split; auto; revert Hk; apply subcode_sss_steps; auto.
  Qed.

  Fact subcode_sss_compute P Q st1 st2: P <sc Q -> P // st1 ->> st2 -> Q // st1 ->> st2.
  Proof.
    intros ? (k & Hk); exists k; revert Hk; apply subcode_sss_steps; auto.
  Qed.

  Fact subcode_sss_compute_trans P Q st1 st2 st3 :
       P <sc Q -> P // st1 ->> st2 -> Q // st2 ->> st3 -> Q // st1 ->> st3.
  Proof.
    intros ? H.
    apply sss_compute_trans.
    revert H; apply subcode_sss_compute; auto.
  Qed.

  Fact subcode_sss_compute_linstr k li P st1 st2 st :
            (fst st1,li) // st1 -[k]-> st2
         -> (fst st1,li) <sc P
         -> P // st2 ->> st
         -> P // st1 ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H2).
    exists k; auto.
  Qed.

  Fact subcode_sss_compute_instr P i st1 st2 st3 :
            i // st1 -1> st2
        ->  (fst st1,i::nil) <sc P
        ->  P // st2 ->> st3
        ->  P // st1 ->> st3.
  Proof.
    intro H; apply subcode_sss_compute_linstr with (k := 1).
    apply sss_steps_1, in_sss_step with (l := nil); auto.
  Qed.

  (* Then are reverse inclusion lemmas *)

  Fact subcode_sss_step_inv P Q st1 st2 :
         P <sc Q
      -> in_code (fst st1) P
      -> Q // st1 :1> st2
      -> P // st1 :1> st2.
  Proof.
    revert P Q st1 st2; intros (nP,cP) (nQ,cQ) (i,d) st; simpl.
    intros (l & r & H1 & H2) H3 (q & ll & ii & rr & d1 & H4 & H5 & H6).
    inversion H4; subst.
    inversion H5; subst.
    clear H4 H5.
    apply list_app_cons_eq_inv in H7.
    destruct H7 as [ (m & Hm1 & Hm2) | (m & Hm1 & Hm2) ].
    apply list_app_cons_eq_inv in Hm2.
    destruct Hm2 as [ (p & Hp1 & Hp2) | (p & Hp1 & Hp2) ].

    apply f_equal with (f := @length _) in Hm1.
    apply f_equal with (f := @length _) in Hp1.
    revert Hm1 Hp1; rew length; intros; omega.

    subst cP; apply in_sss_step; auto.
    simpl; subst; rew length; omega.

    apply f_equal with (f := @length _) in Hm1.
    apply f_equal with (f := @length _) in Hm2.
    revert Hm1 Hm2; rew length; intros; omega.
  Qed.

  Definition sss_output P st st' := P // st ->> st' /\ out_code (fst st') P.

  Notation "P // x ~~> y" := (sss_output P x y).

  Definition sss_terminates P st := exists st', P // st ~~> st'.

  Notation "P // x ↓" := (sss_terminates P x).

  (* No computation is possible *)

  Definition sss_stall ii st := forall st', ~ ii // st -1> st'.
  Definition sss_step_stall P st := forall st', ~ P // st :1> st'.

  Fact sss_steps_stall_inv P p s1 s2 : sss_step_stall P s1 -> P // s1 -[p]-> s2 -> p = 0 /\ s1 = s2.
  Proof.
    intros H; induction 1 as [ | p st1 st2 st3 H1 ]; auto.
    apply H in H1; destruct H1.
  Qed.

  Fact sss_steps_stall_fun P p q s1 s2 :
         sss_step_stall P s2
      -> P // s1 -[p]-> s2
      -> P // s1 -[q]-> s2
      -> p = q.
  Proof.
    intros H1 H2; revert H2 q.
    induction 1 as [ s1 | p s1 s2 s3 H2 H3 IH3 ];
      intros q H5.
    apply sss_steps_stall_inv, proj1 in H5; auto.
    destruct q.
    apply sss_steps_0_inv in H5; subst.
    apply H1 in H2; destruct H2.
    specialize (IH3 H1).
    apply sss_steps_S_inv' in H5.
    destruct H5 as (st2' & H5 & H6).
    generalize (sss_step_fun H2 H5).
    intros; subst st2'.
    apply IH3 in H6; subst; auto.
  Qed.

  Definition sss_compute_max P s1 s2 := (P // s1 ->> s2 /\ sss_step_stall P s2).

  Notation " P // s1 -]] s2 " := (sss_compute_max P s1 s2).

  (* No computation outside the code *)

  Fact sss_out_step_stall P st : out_code (fst st) P -> sss_step_stall P st.
  Proof.
    revert P st; intros (n,code) (i,st).
    intros H1 st' (k & l & ii & r & d1 & H2 & H3 & H4).
    inversion H2; inversion H3; subst.
    simpl in H1.
    revert H1; rew length; intros []; omega.
  Qed.

  Fact sss_stall_step_stall ii P st :
          (fst st,ii::nil) <sc P
       -> sss_stall ii st
       -> sss_step_stall P st.
  Proof.
    intros H1 H2 st' H.
    apply sss_step_subcode_inv  with (1 := H1) in H.
    revert H; apply H2.
  Qed.

  Fact sss_stall_step_0 ii P q st st' :
          (fst st,ii::nil) <sc P
       -> sss_stall ii st
       -> P // st -[q]-> st' -> q = 0 /\ st = st'.
  Proof.
    intros H1 H2.
    generalize (sss_stall_step_stall H1 H2).
    intros H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ | (k & st2 & _ & H5 & _) ]; auto.
    contradict H5; apply H3.
  Qed.

  Fact sss_step_stall_inv P st :
          sss_step_stall P st
       -> { ii | (fst st,ii::nil) <sc P /\ sss_stall ii st }
        + { out_code (fst st) P }.
  Proof.
    intros H.
    destruct (in_out_code_dec (fst st) P) as [ H1 | H1 ].
    2: tauto.
    destruct P as (iP,cP).
    destruct st as (j,d).
    simpl in H1.
    destruct (@list_pick _ cP (j-iP)) as (ii & l & r & H2 & H3).
    omega.
    left; exists ii; simpl; split.
    exists l, r; split; auto; omega.
    intros st' H4.
    apply (H st').
    subst; apply in_sss_step; auto.
    simpl; omega.
  Qed.

  Fact sss_steps_stall k P st st' :
         out_code (fst st) P
      -> P // st -[k]-> st'
      -> k = 0 /\ st = st'.
  Proof.
    destruct P; simpl.
    intros H1 H2.
    apply sss_steps_inv in H2.
    destruct H2 as [ (? & ?) | (m & st2 & ? & H2 & _) ]; auto.
    apply sss_out_step_stall in H2; try red; tauto.
  Qed.

  (** This is a critical lemma about the locality of computations

      If P is subcode of Q and a computation in Q starts in P and ends outside of P,
      then it is decomposed in a first computation in P ending outside of P
      and a second computation in Q

    *)

  Lemma subcode_sss_steps_inv P Q k st1 st3 :
       P <sc Q
    -> in_code  (fst st1) P
    -> out_code (fst st3) P
    -> Q // st1 -[k]-> st3
    -> exists k1 k2 st2,
          P // st1 -[k1]-> st2
       /\ Q // st2 -[k2]-> st3
       /\ k = k1+k2
       /\ out_code (fst st2) P.
  Proof.
    intros H1 H2 H3 H4; revert H4 H2 H3.
    induction 1 as [ st1 | k st1 st2 st3 H4 H5 IH5 ]; intros H2 H3.

    exists 0, 0, st1; repeat split; auto; constructor.

    apply subcode_sss_step_inv with (1 := H1) in H4; auto.
    destruct (in_out_code_dec (fst st2) P) as [ H6 | H6 ].

    destruct (IH5 H6 H3) as (k1 & k2 & st & ? & ? & ? & ?).
    exists (S k1), k2, st; repeat split; auto.
    constructor 2 with (1 := H4); auto.
    omega.

    exists 1, k, st2; repeat split; auto.
    apply sss_steps_1; auto.
  Qed.

  Lemma subcode_sss_compute_inv P Q st1 st3 :
       P <sc Q
    -> out_code (fst st3) P
    -> Q // st1 ->> st3
    -> exists st2,
          P // st1 ->> st2
       /\ Q // st2 ->> st3
       /\ out_code (fst st2) P.
  Proof.
    intros H1 H3 (k & Hk).
    destruct (in_out_code_dec (fst st1) P) as [ H2 | H2 ].
    + apply subcode_sss_steps_inv with (1 := H1) in Hk; auto.
      destruct Hk as (k1 & k2 & st2 & H4 & H5 & H6 & H7).
      exists st2; repeat split; auto; red; firstorder.
    + exists st1; repeat split; auto.
      * exists 0; constructor.
      * red; firstorder.
  Qed.

  (* Inversion lemma *)

  Fact subcode_sss_step_inv_1 P i st1 st2 : (fst st1,i::nil) <sc P -> P // st1 :1> st2 -> i // st1 -1> st2.
  Proof.
    revert P st1; intros (j,cj) (n,d) H1 H2.
    apply subcode_sss_step_inv with (1 := H1) in H2.
    2: simpl; omega.
    destruct H2 as (q & l & ii & r & d1 & H2 & H3 & H4).
    inversion H3; subst n d1; auto.
    eq goal H4; f_equal.
    inversion H2.
    destruct l as [ | ? [ | ] ]; try discriminate.
    inversion H5; subst; auto.
  Qed.

  (* Starting a computation in subcode ending outside of it
     can be cut in half *)

  Fact subcode_sss_subcode_inv P Q p k st1 st2 st3 :
           out_code (fst st3) P
        -> P <sc Q
        -> P // st1 -[p]-> st2
        -> Q // st1 -[k]-> st3
        -> exists q, k = p+q /\ Q // st2 -[q]-> st3.
  Proof.
    revert P Q st3; intros P (j,cj) (n,d) H1 H2 H3.
    simpl in H1.
    revert k.
    induction H3 as [ st | p st1 st2 st3 H4 H5 IH5 ];
      intros k Hk.
    exists k; auto.
    apply sss_steps_inv in Hk.
    destruct Hk as [ (? & Hk) | (m & st4 & ? & Hk & H3) ].
    1: subst st1; apply sss_step_in_code in H4; simpl in H4; omega.
    apply subcode_sss_step with (1 := H2) in H4.
    rewrite (sss_step_fun Hk H4) in H3.
    apply IH5 in H3; auto.
    destruct H3 as (q & ? & H3).
    exists q; split; auto; omega.
  Qed.

  Fact subcode_sss_progress_inv P Q p st1 st2 st3 :
           out_code (fst st3) P
        -> P <sc Q
        -> P // st1 -+> st2
        -> Q // st1 -[p]-> st3
        -> exists q, q < p /\ Q // st2 -[q]-> st3.
  Proof.
    intros H1 H2 (k & ? & H3) H4.
    apply subcode_sss_subcode_inv with (3 := H3) in H4; auto.
    destruct H4 as (q & ? & ?); exists q; split; auto; omega.
  Qed.

  Section sss_terminates_ind.

    Variable (P : code) (R : state -> Prop).

    Hypothesis (HR0 : forall st, out_code (fst st) P -> R st)
               (HR1 : forall st1, (forall Q st2, Q <sc P -> Q // st1 -+> st2 -> P // st2 ↓ -> R st2) -> R st1).

    Theorem sss_terminates_ind st : P // st ↓ -> R st.
    Proof.
      intros (st2 & (k & H1) & H2); revert st st2 H1 H2.
      induction k as [ k IH ] using (well_founded_induction_type lt_wf).
      intros st1 st2 H1 H2.
      destruct k as [ | k ].
      + apply sss_steps_0_inv in H1.
        subst; apply HR0; auto.
      + apply HR1.
        intros Q st2' HQ H5 (st3 & H6 & H7).
        apply subcode_sss_progress_inv with (3 := H5) in H1; auto.
        destruct H1 as (q & G1 & G2).
        apply IH with (2 := G2); auto.
        revert H2; apply subcode_out_code; auto.
    Qed.

  End sss_terminates_ind.

  Section sss_compute_max_ind.

    Variable (P : code) (R : state -> state -> Prop).

    Hypothesis (HQ0 : forall st, sss_step_stall P st -> R st st)
               (HQ1 : forall st1 st3, (forall Q st2, Q <sc P -> Q // st1 -+> st2 -> P // st2 -]] st3 -> R st2 st3) -> R st1 st3).

    Theorem sss_compute_max_ind st1 st3 : P // st1 -]] st3 -> R st1 st3.
    Proof.
      intros ((k & H1) & H2); revert st1 H1.
      induction k as [ k IH ] using (well_founded_induction_type lt_wf).
      intros st1 H1.
      destruct k as [ | k ].
      apply sss_steps_0_inv in H1.
      subst; apply HQ0; auto.
      apply HQ1.
      intros Q st2' HQ H5 ((q & H6) & _).
      apply subcode_sss_progress with (1 := HQ) in H5.
      destruct H5 as (l & Hl & H5).
      generalize (sss_steps_trans H5 H6); intro H7.
      generalize (sss_steps_stall_fun H2 H1 H7); intros H8.
      apply IH with q; auto; omega.
    Qed.

  End sss_compute_max_ind.

  Fact sss_compute_inv P st1 st2 st3 :
             out_code (fst st3) P
          -> P // st1 ->> st2
          -> P // st1 ->> st3
          -> P // st2 ->> st3.
  Proof.
    intros H2 (p & H3) (k & H4).
    apply subcode_sss_subcode_inv with (3 := H3) in H4; auto.
    destruct H4 as (q & _ & ?); exists q; auto.
    apply subcode_refl.
  Qed.

  Fact sss_compute_step_out_inv P k st1 st2 st3 :
           st1 <> st2
        -> out_code (fst st3) P
        -> P // st1 ->> st2
        -> P // st1 -[k]-> st3
        -> exists q, q < k /\ P // st2 -[q]-> st3.
  Proof.
    intros H1 H2 (p & H3) H4.
    apply subcode_sss_subcode_inv with (3 := H3) in H4; auto.
    destruct H4 as (q & H4 & H5).
    exists q; split; auto.
    destruct p.
    apply sss_steps_0_inv in H3.
    destruct H1; auto.
    omega.
    apply subcode_refl.
  Qed.

  Fact subcode_sss_subcode_compute_inv P Q k st1 st2 st3 :
           in_code (fst st1) P
        -> out_code (fst st2) P
        -> out_code (fst st3) P
        -> P <sc Q
        -> P // st1 ->> st2
        -> Q // st1 -[k]-> st3
        -> exists q, q < k /\ Q // st2 -[q]-> st3.
  Proof.
    intros H H0 H1 H2 (p & H3) H4.
    apply subcode_sss_subcode_inv with (2 := H2) (3 := H3) in H4; auto.
    destruct H4 as (q & Hq & H4).
    exists q; split; auto.
    destruct p; try omega.
    apply sss_steps_0_inv in H3; subst st2.
    red in H, H0; omega.
  Qed.

  Fact subcode_sss_steps_inv_1 P i k st1 st2 st3 :
        st1 <> st3
     -> i // st1 -1> st2
     -> (fst st1,i::nil) <sc P
     -> P // st1 -[k]-> st3
     -> exists k', k = S k' /\ P // st2 -[k']-> st3.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (_ & H4) | (k' & st & ? & H4 & ?) ].
    contradict H1; auto.
    exists k'; split; auto.
    apply subcode_sss_step_inv_1 with (1 := H3) in H4.
    rewrite (sss_fun H2 H4); auto.
  Qed.

  Fact subcode_sss_steps_stop P i k st1 st2 :
            (forall st, ~ i // st1 -1> st)
        ->  (fst st1,i::nil) <sc P
        ->  P // st1 -[k]-> st2 -> k = 0 /\ st1 = st2.
  Proof.
    intros H1 H2 H3.
    apply sss_steps_inv in H3.
    destruct H3 as [ | (k' & st & ? & H3 & H4) ]; auto; exfalso.
    apply (H1 st), subcode_sss_step_inv_1 with (1 := H2); auto.
  Qed.

  Fact sss_steps_stop P k st1 st2 :
             out_code (fst st1) P
          -> P // st1 -[k]-> st2
          -> st1 = st2.
  Proof.
    intros H1 H2.
    apply sss_steps_inv in H2.
    destruct H2 as [ [ _ ? ] | (k' & st3 & H2 & H3 & H4) ]; auto.
    destruct (sss_out_step_stall H1 H3).
  Qed.

  Fact sss_compute_stop P st1 st2 :
             out_code (fst st1) P
          -> P // st1 ->> st2
          -> st1 = st2.
  Proof.
    intros H1 (k & H2); revert H2; apply sss_steps_stop; auto.
  Qed.

  Fact sss_compute_fun P st1 st2 st3 :
             out_code (fst st2) P
          -> out_code (fst st3) P
          -> P // st1 ->> st2
          -> P // st1 ->> st3
          -> st2 = st3.
  Proof.
    intros H1 H2 H3 H4.
    destruct (in_out_code_dec (fst st1) P) as [ H5 | H5 ].
    destruct H4 as (k & H4).
    apply subcode_sss_subcode_compute_inv with (5 := H3) in H4; auto.
    destruct H4 as (q & _ & H4).
    apply sss_steps_stop in H4; auto.
    apply subcode_refl.
    apply sss_compute_stop in H3; auto.
    apply sss_compute_stop in H4; auto.
    subst; auto.
  Qed.

  Fact sss_output_fun P st st1 st2 : P // st ~~> st1 -> P // st ~~> st2 -> st1 = st2.
  Proof.
    intros (H1 & H2) (H3 & H4); revert H2 H4 H1 H3; apply sss_compute_fun.
  Qed.

  Fact subcode_sss_terminates P Q st : P <sc Q -> Q // st ↓ -> P // st ↓.
  Proof.
    intros H (st' & H1 & H2).
    apply subcode_sss_compute_inv with (1 := H) in H1; auto.
    + destruct H1 as (st2 & H1 & H3 & H4).
      exists st2; split; auto.
    + revert H2; apply subcode_out_code; auto.
  Qed.

  Section sss_loop.

    (* P contains a loop that modifies the data (in a way computable by f)
       when condition C1 is satisfied and otherwise stops somewhere outside
       of P when condition C2 is satisfied.

       Then P stops iff exists n, C2 (iter f x n) *)

    Variable (P : code) (pre : data -> Prop) (spec : data -> data -> Prop)
             (f : data -> data) (Hf : forall x, x <> f x)
             (C1 C2 : data -> Prop) (HC : forall x, pre x -> { C1 x } + { C2 x })
             (i : nat) (p : nat) (Hp : out_code p P)
             (HP1 : forall x, pre x -> C1 x -> P // (i,x) ->> (i,f x) /\ pre (f x))
             (HP2 : forall x, pre x -> C2 x -> exists y, P // (i,x) ->> (p,y) /\ spec x y).

    Theorem sss_loop_sound x : pre x
                            -> (exists n, C2 (iter f x n))
                            -> exists n y, P // (i,x) ->> (p,y) /\ spec (iter f x n) y.
    Proof.
      intros H (n & Hn); revert x H Hn.
      induction n as [ | n IHn ]; intros x Hx Hn.
      simpl; exists 0; apply HP2; auto.
      destruct (HC Hx) as [ H | H ].
      apply IHn in Hn.
      destruct Hn as (m & y & H1 & H2).
      exists (S m), y; split; auto.
      generalize H1; apply sss_compute_trans.
      apply HP1; auto.
      apply HP1; auto.
      destruct (HP2 Hx) as (y & H1 & H2); auto.
      exists 0, y; auto.
    Qed.

    Theorem sss_loop_complete x y q : pre x
                                   -> out_code q P
                                   -> P // (i,x) ->> (q,y)
                                   -> p = q /\ exists n, C2 (iter f x n) /\ spec (iter f x n) y.
    Proof.
      intros Hx Hq (k & Hk); revert x Hx y q Hq Hk.
      induction k as [ k IHk ] using (well_founded_induction lt_wf); intros x Hx y q Hq Hk.
      destruct (HC Hx) as [ H | H ].
      * apply HP1 in H; auto; destruct H as [ H1 H2 ].
        destruct (@sss_compute_step_out_inv P k (i,x) (i,f x) (q,y))
          as (k' & H3 & H4); auto.
        { inversion 1 as [ H3 ]; revert H3; apply Hf. }
        destruct IHk with (2 := H2) (4 := H4) as (E & n & Hn); auto.
        split; auto; exists (S n); auto.
      * destruct HP2 with (2 := H) as (z & Hz & Hy); auto.
        apply ex_intro with (x := k) in Hk.
        generalize (@sss_compute_fun _ _ (p,z) (q,y) Hp Hq Hz Hk).
        inversion 1; subst; auto.
        split; auto.
        exists 0; simpl; auto.
    Qed.

  End sss_loop.

End Small_Step_Semantics.

(*
Notation " P '//' r ':1>' s " := (sss_step _ P r s)  (at level 70, no associativity).
Notation " P '//' r '-[' n ']->' s " := (sss_steps _ P n r s) (at level 70, no associativity).
Notation " P '//' r '->>' s " := (sss_compute _ P r s) (at level 70, no associativity).
*)


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

Require Import Undecidability.Synthetic.Undecidability.

From Undecidability.PCP
  Require Import PCP PCP_undec.

From Undecidability.StackMachines
  Require Import BSM iPCPb_to_BSM_HALTING BSM_sss.

(** ** BSM_HALTING is undecidable *)

Theorem BSM_undec : undecidable Halt_BSM.
Proof.
  apply (undecidability_from_reducibility iPCPb_undec).
  apply iPCPb_to_BSM_HALTING.
Qed.


(** * program.v : the probabilistic program finding a corner *)

Add Rec LoadPath "ALEA/src" as ALEA.
Add Rec LoadPath "../Combi/LRrule".

Require Import Misc Ccpo Qmeasure.
Set Implicit Arguments.
Local Open Scope O_scope.

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype rat
               finfun ssrnum ssralg ssrint bigop.
Local Open Scope ring_scope.
Require Import partition.
Require Import equerre.
Local Open Scope rat_scope.

(* Require Import equerre. *)

Section FindCorner.

Variable p : intpart.

Fact is_part_p : is_part p.
apply intpartP.
Save.
Hint Resolve is_part_p.

Definition is_in_hook (i j:nat) (k l : nat) :=
     ((i == k) && (j < l < nth 0 p i))%N || ((j == l) && (i < k < haut p j))%N.

Lemma in_hook_part (i j:nat) (k l : nat) :
   is_in_part p i j -> is_in_hook i j k l -> is_in_part p k l.
Proof.
  rewrite /is_in_part /is_in_hook => Hj /orP [] /and3P [] /eqP <- // H1 H2.
  by rewrite ltnNge (haut_nth _ (intpartP p)) -ltnNge.
Save.

Definition hook_next_seq i j : seq (nat+nat) :=
    [seq (inl k) | k <- iota (i.+1) ((haut p j).-1 - i)]++
    [seq (inr k) | k <- iota (j.+1) ((nth O p i).-1 - j)].

(* Lemma size_hook : forall i j, size (hook_seq i j) == hook' i j. *)

Definition hook_next i j n : nat * nat :=
    match n with inl k => (k,j) | inr k => (i,k) end.

Definition hook_seq i j := [seq (hook_next i j n) | n <- hook_next_seq i j].

Lemma size_hook_seq_next_eq i j : size (hook_seq i j)=size (hook_next_seq i j).
apply: size_map.
Save.

Lemma in_hook_seq (i j:nat) (k l : nat) :
   (k,l) \in (hook_seq i j) -> is_in_hook i j k l.
Proof.
  rewrite /hook_seq /is_in_hook => /mapP [] x.
  rewrite mem_cat => /orP [] /mapP [] u; rewrite mem_iota => Hu -> /= [] -> -> {x k l}.
  - rewrite eq_refl /=; apply/orP; right.
    move: Hu; case: (haut p j) => [|n] /=.
    + rewrite sub0n addn0 ltnS => /andP [] /leq_trans => H/H{H}.
      by rewrite ltnn.
    + rewrite addSn !ltnS.
      case: (leqP i n) => [Hi | /ltnW Hi].
      * by rewrite (subnKC Hi).
      * move: Hi; rewrite {1}/leq => /eqP ->.
        rewrite addn0 => /andP [] /leq_trans => H/H{H}.
      by rewrite ltnn.
  - rewrite eq_refl /=; apply/orP; left.
    move: Hu; case: (nth O p i) => [|n] /=.
    + rewrite sub0n addn0 ltnS => /andP [] /leq_trans => H/H{H}.
      by rewrite ltnn.
    + rewrite addSn !ltnS.
      case: (leqP j n) => [Hj | /ltnW Hj].
      * by rewrite (subnKC Hj).
      * move: Hj; rewrite {1}/leq => /eqP ->.
        rewrite addn0 => /andP [] /leq_trans => H/H{H}.
      by rewrite ltnn.
Save.

Lemma hook_seq_empty (i j:nat) :
      is_in_part p i j -> (hook_seq i j == [::])%B
      -> (j == lindex p i)%B && is_out_corner p i.
Proof.
  rewrite /is_in_part => Hpart.
  rewrite /hook_seq => /eqP/nilP; rewrite /nilp size_map.
  rewrite /hook_next_seq size_cat !size_map.
  rewrite addn_eq0 !size_iota /lindex => /andP [].
  rewrite /is_out_corner => Hhaut Hnth.
  apply/andP; split.
  - apply/eqP; apply anti_leq.
    rewrite {2}/leq Hnth andbT.
    by rewrite -ltnS (ltn_predK Hpart).
  - move: Hnth; rewrite subn_eq0 -ltnS (ltn_predK Hpart) => Hnth.
    have Hj : nth O p i = j.+1 by apply anti_leq; rewrite Hpart Hnth.
    move: Hhaut => {Hpart Hnth}; rewrite subn_eq0 Hj.
    case: p Hj => pp /=.
    elim: pp i j => [//= | p0 p' IHp'] /= i j /andP [] Hhead Hpart Hj.
    case: ltnP => //=.
    + rewrite -Hj => H1 H2.
      move: H2; rewrite -(haut_nth _ Hpart) Hj => /leq_trans; by apply.
    + case: i Hj => [| i]/= Hj Hp0 _.
      * case: p' Hhead Hpart {IHp'} => [| p1 p'] //=.
        subst p0; move: Hp0; by rewrite ltnn.
      * apply: (IHp' _ _ Hpart Hj) => {IHp'}.
        exfalso.
        move: Hpart => /is_part_ijP [] _ Hpart.
        have {Hpart} /Hpart : (0 <= i)%N by [].
        rewrite Hj => Habs.
        have:= leq_ltn_trans (leq_trans Hhead Hp0) Habs.
        case p' => //= p1 /= _.
        by rewrite ltnn.
Save.

Lemma size_hook_seq_hook' i j : size (hook_seq i j) = hook' p i j.
rewrite size_hook_seq_next_eq /hook' /hook_next_seq size_cat !size_map !size_iota.
rewrite addnC -!subn1.
congr addn; apply subnAC.
Save.

Lemma size_hook_next_seq_hook' i j : size (hook_next_seq i j) = hook' p i j.
rewrite -size_hook_seq_next_eq; apply size_hook_seq_hook'.
Save.

Lemma leq_subnKC : forall m n, (n <= m + (n - m))%N.
move => m n; rewrite -leq_subLR //.
Save.

Lemma leq_subnK : forall m n, (n <= (n - m) + m)%N.
move => m n; rewrite addnC; apply leq_subnKC.
Save.

Lemma leq_ltn_add : forall m1 m2 n1 n2, ((m1<=n1) -> (m2<n2) -> (m1+m2<n1+n2))%N.
move => m1 m2 n1 n2 H1 H2; rewrite -addnS; apply leq_add => //.
Save.

Lemma ltn_leq_add : forall m1 m2 n1 n2, ((m1<n1) -> (m2<=n2) -> (m1+m2<n1+n2))%N.
move => m1 m2 n1 n2 H1 H2; rewrite -addSn; apply leq_add => //.
Save.

Lemma in_hook_seq_decr (i j:nat) (k l : nat) :
   is_in_part p i j -> (k,l) \in (hook_seq i j) -> (size (hook_seq k l) < size (hook_seq i j))%N.
rewrite (is_in_part_simpl i j) // => /andP [] Hijl Hijc.
rewrite !size_hook_seq_hook' /hook_seq /hook_next_seq map_cat mem_cat -!map_comp /hook_next /funcomp /=
  => /orP [].
+ rewrite -(rwP (mapP (y:=(k, l)))) => [[x Hx Hy]].
  move: Hx; rewrite mem_iota; move /andP => [[Hx1 Hx2]].
  injection Hy => Hy1 Hy2; subst.
  rewrite /hook' -!subn1.
  apply leq_ltn_add.
  - apply leq_sub => //; apply leq_sub => //.
  have [_ Hm]:=(elimT (is_part_ijP p) is_part_p).
  apply Hm; apply ltnW => //.
  - rewrite -!subnDA.
  move: Hijc.
  rewrite (leq_eqVlt (i.+1) (haut p j)) => /orP [].
  move /eqP => Hh.
  exfalso; move: Hx2; rewrite -Hh => /=.
  rewrite subnn addn0 => Hxi.
  have abs := (leq_ltn_trans Hx1 Hxi).
  by move:abs; rewrite ltnn //.
  move => Hh.
  move: Hh Hx2.
  rewrite -(add1n i) => Hh; rewrite -subn1 -subnDA.
  rewrite subnKC //=.
  move => Hj; apply leq_trans with (haut p j - x)%N.
  apply ltn_sub2l => //.
  rewrite addn1 //.
  apply leq_sub => //.
  rewrite addn1 //.
  apply ltnW => //.
+ rewrite -(rwP (mapP (y:=(k, l)))) => [[x Hx Hy]].
  move: Hx; rewrite mem_iota; move /andP => [[Hx1 Hx2]].
  injection Hy => Hy1 Hy2; subst.
  rewrite /hook' -!subn1.
  apply ltn_leq_add.
  - rewrite -!subnDA.
  move: Hijl.
  rewrite (leq_eqVlt (j.+1) (nth O p i)) => /orP [].
  move /eqP => Hh.
  exfalso; move: Hx2; rewrite -Hh => /=.
  rewrite subnn addn0 => Hxi.
  have abs := (leq_ltn_trans Hx1 Hxi).
  by move:abs; rewrite ltnn //.
  move => Hh.
  move: Hh Hx2.
  rewrite -(add1n j) => Hh; rewrite -subn1 -subnDA.
  rewrite subnKC //=.
  move => Hj; apply leq_trans with (nth O p i - x)%N.
  apply ltn_sub2l => //.
  rewrite addn1 //.
  apply leq_sub => //.
  rewrite addn1 //.
  apply ltnW => //.
  - apply leq_sub => //; apply leq_sub => //.
  apply haut_decr => //.
  by apply ltnW => //.
Save.

Fixpoint choose_corner (m:nat) (i j : nat) : distr ((seq nat) * (seq nat)) :=
   if m is m'.+1 then
     let s := hook_next_seq i j in
     (if size s is p.+1
     then Mlet (Uniform (unif_def (inl 0%N) s))
          (fun n => match n with inl k =>
               Mlet (choose_corner m' k j) (fun X => Munit (i::X.1,X.2))
                               | inr k =>
               Mlet (choose_corner m' i k) (fun X => Munit (X.1,j::X.2))
                    end)
     else Munit ([::i],[::j]))
   else Munit ([::i],[::j]).

Lemma choose_corner0_simpl i j : choose_corner 0 i j = Munit ([::i],[::j]).
trivial.
Save.

Lemma choose_corner_end_simpl m i j
      : (size (hook_next_seq i j) == 0)%N -> choose_corner m i j = Munit ([::i],[::j]).
case m; rewrite //=.
move => N /eqP H.
rewrite H; trivial.
Save.

Lemma choose_corner_rec_simpl m i j :
      forall (Hs : (size (hook_next_seq i j) != 0)%N),
      choose_corner (m.+1) i j = Mlet (Uniform (mkunif (hook_next_seq i j) Hs))
          (fun n => match n with inl k =>
               Mlet (choose_corner m k j) (fun X => Munit (i::X.1,X.2))
                               | inr k =>
               Mlet (choose_corner m i k) (fun X => Munit (X.1,j::X.2))
                    end).
rewrite /=.
case (hook_next_seq i j) => //=.
Save.

Lemma choose_corner_inv m  :
      forall i j, mu (choose_corner m i j)
         (fun R => ((size R.1!=0)&&(size R.2!=0)&&(head 0 R.1==i)&&(head 0 R.2==j))%N%:Q)
      = 1.
elim m.
move => i j //=; rewrite 2!eq_refl //=.
move => n Hin i j.
case (boolP (size (hook_next_seq i j)== O)) => [H0|Hs].
rewrite choose_corner_end_simpl => //=.
by rewrite 2!eq_refl.
rewrite (choose_corner_rec_simpl n i j Hs).
rewrite Mlet_simpl.
rewrite mu_one_eq => //=.
move => [k|k] /=.
apply mu_bool_impl1 with (2:=Hin k j).
move => [A B] /=.
apply /implyP => /andP [H1 H2].
move:H1 => /andP [H3 _].
move:H3 => /andP [_ H3].
by rewrite H3 H2 eq_refl.
apply mu_bool_impl1 with (2:=Hin i k).
move => [A B] /=.
apply /implyP => /andP [H1 H2].
move:H1 => /andP [H3 H4].
move:H3 => /andP [H3 _].
by rewrite H3 H4 eq_refl.
Save.

Lemma choose_corner_emptyl m i j (A B : seq nat) :
      (A == [::])%B -> mu (choose_corner m i j) (fun R => (R==(A,B))%:Q) = 0.
move => HA.
apply: (mu_bool_negb0 _ _ _ _ (choose_corner_inv m i j)).
   move => [X Y] /=.
   apply /implyP => /andP [] /andP [] /andP [] SX SY _ _.
   move: SX; apply contra.
   by rewrite size_eq0 xpair_eqE (eqP HA); move => /andP [].
Save.

Lemma choose_corner_emptyr m i j (A B : seq nat) :
      (B == [::])%B -> mu (choose_corner m i j) (fun R => (R==(A,B))%:Q) = 0.
move => HB.
apply: (mu_bool_negb0 _ _ _ _ (choose_corner_inv m i j)).
   move => [X Y] /=.
   apply /implyP => /andP [] /andP [] /andP [] SX SY _ _.
   move: SY; apply contra.
   by rewrite size_eq0 xpair_eqE (eqP HB); move => /andP [].
Save.

Lemma choose_corner_headl m i j (A B : seq nat) :
      (i != head O A)%B -> mu (choose_corner m i j) (fun R => (R==(A,B))%:Q) = 0.
move => Ha.
apply: (mu_bool_negb0 _ _ _ _ (choose_corner_inv m i j)).
   move => [X Y] /=.
   apply /implyP => /andP [] /andP [] /andP [] _ _ hi hj.
   rewrite xpair_eqE.
   apply /negP; move => /andP [] /eqP Ha1 _.
   move:hi; rewrite Ha1 /=.
   move => Ha2; apply (elimN eqP Ha).
   by move: Ha2 => /eqP.
Save.

Lemma choose_corner_headr m i j (A B : seq nat) :
      (j != head O B)%B -> mu (choose_corner m i j) (fun R => (R==(A,B))%:Q) = 0.
move => Hb.
apply: (mu_bool_negb0 _ _ _ _ (choose_corner_inv m i j)).
   move => [X Y] /=.
   apply /implyP => /andP [] /andP [] /andP [] _ _ hi hj.
   rewrite xpair_eqE.
   apply /negP; move => /andP [] _ /eqP Hb1.
   move:hj; rewrite Hb1 /=.
   move => Hb2; apply (elimN eqP Hb).
   by move: Hb2 => /eqP.
Save.

Require Import path.

Definition is_trace (A B : seq nat) :=
      [&& (A != [::]), (B != [::]), is_out_corner p (last O A),
          lindex p (last O A) == last O B, sorted ltn A & sorted ltn B].

Lemma is_trace_in_part (A B : seq nat) : is_trace A B ->
      forall a b, a \in A -> b \in B -> is_in_part p a b.
admit.
Save.

Lemma is_trace_tll (a:nat) (A B : seq nat) : A != [::] -> is_trace (a::A) B -> is_trace A B.
admit.
Save.

Lemma is_trace_tlr (b:nat) (A B : seq nat) : B != [::] -> is_trace A (b::B) -> is_trace A B.
admit.
Save.

Lemma is_trace_corner_nil (a b:nat) (A B : seq nat) : is_trace (a::A) (b::B)
      -> (size (hook_next_seq a b) == 0)%N -> (A == [::]) && (B == [::]).
admit.
Save.

Lemma is_trace_corner_not_nil (a b:nat) (A B : seq nat) : is_trace (a::A) (b::B)
      -> (size (hook_next_seq a b) != 0)%N -> (A != [::]) || (B != [::]).
admit.
Save.

Lemma fun_cons_simpll a A B :
    (fun x : seq nat * seq nat => ((a :: x.1, x.2) == (a :: A, B))%:~R) ==
    (fun x : seq nat * seq nat => (x == (A, B))%:~R).
move => [X Y] /=.
rewrite /eq_op /=.
rewrite {1}/eq_op /=.
by rewrite eq_refl.
Save.

Lemma fun_cons_simplr a A B :
    (fun x : seq nat * seq nat => ((x.1, a :: x.2) == (A, a :: B))%:~R) ==
    (fun x : seq nat * seq nat => (x == (A, B))%:~R).
move => [X Y] /=.
rewrite /eq_op /=.
rewrite {2}/eq_op /=.
by rewrite eq_refl.
Save.

Lemma choose_corner_decomp m a b (A B : seq nat) :
      (size (hook_next_seq a b) != 0)%N -> is_trace (a::A) (b::B) ->
      mu (choose_corner m.+1 a b) (fun R => (R==(a::A,b::B))%:Q)
      = (mu (choose_corner m  a (head O B)) (fun R => (R==(a::A,B))%:Q) +
        mu (choose_corner m  (head O A) b) (fun R => (R==(A,b::B))%:Q))
        / (size (hook_next_seq a b))%:Q.
move => Hs Ht.
rewrite (choose_corner_rec_simpl _ _ _ Hs) Mlet_simpl.
rewrite mu_uniform_sum /=.
congr (_ / _).
rewrite /hook_next_seq.
rewrite big_cat /=.
rewrite !big_map /=.
rewrite GRing.addrC.
congr (_+_)%R.
+ case (boolP (B == [::])) => HB.
 - rewrite big1.
   * apply esym.
     by apply choose_corner_emptyr.
   * move => i _; rewrite fun_cons_simplr.
     by apply choose_corner_emptyr.
 - rewrite (bigD1_seq (head O B) _ (iota_uniq _ _)) /=.
   * rewrite -{1}(fun_cons_simplr b).
     rewrite -[RHS]GRing.addr0.
     congr (_+_)%R.
     apply: big1.
     move => i Hi.
     rewrite fun_cons_simplr.
     by apply choose_corner_headr.
   * rewrite mem_iota.
     have:= Ht => /and5P [_ _ _ _] /andP [_ H4].
     apply /andP; split.
     move: HB H4; rewrite /sorted.
     case B => [//|b0 B' /=].
     by move => _ /andP [].
     have Hh : (head O B \in b :: B).
     move: HB; case B => //=.
     move => n l _; by rewrite !inE eq_refl orbT.
     have := (is_trace_in_part _ _ Ht a (head O B) (mem_head _ _) Hh).
     rewrite /is_in_part addSn.
     move => Hlt.
     apply (leq_trans Hlt).
     apply leq_trans with ((nth O p a).-1).+1.
     by apply leqSpred => /=.
     rewrite ltnS.
     by rewrite -leq_subLR.
+ case (boolP (A == [::])) => HA.
  - rewrite big1.
    * by apply esym; apply choose_corner_emptyl.
    * move => i _; rewrite fun_cons_simpll.
      by apply: choose_corner_emptyl.
  - rewrite (bigD1_seq (head O A) _ (iota_uniq _ _)) /=.
    * rewrite -{1}(fun_cons_simpll a).
      rewrite -[RHS]GRing.addr0.
      congr (_+_)%R.
      apply: big1.
      move => i Hi; rewrite fun_cons_simpll.
      by apply choose_corner_headl.
    * rewrite mem_iota.
      have:= Ht => /and5P [H1 H2 H3 H4] /andP [H5 H6].
  apply /andP; split.
  move: HA H5; rewrite /sorted.
  case A => [//|a0 A' /=].
  by move => _ /andP [].
  have Hh : (head O A \in a :: A).
  move: HA; case A => //=.
  move => n l _; by rewrite !inE eq_refl orbT.
  have := (is_trace_in_part _ _ Ht (head O A) b Hh (mem_head _ _)) => Hp.
  apply (@leq_trans (haut p b)).
  rewrite -(haut_in_le (L:=p) (head O A) b _) //=.
  rewrite addSn.
  apply leq_trans with ((haut p b).-1).+1.
  by apply leqSpred => /=.
  rewrite ltnS.
  by rewrite -leq_subLR.
Save.

Lemma belast_empty  (T:eqType) (x:T) (s : seq T) : (s==[::])%B -> belast x s = [::].
by move => /eqP Hs; subst.
Save.

Lemma cons_head_behead (T:eqType) x (s : seq T) : (s!=[::]) -> s = head x s :: behead s.
case s => //=.
Save.

Definition PI (a b:nat) (A B:seq nat) : rat :=
     \prod_(i <- belast a A) (1/(hook' p i (last b (b::B)))%:Q)
   * \prod_(j <- belast b B) (1/(hook' p (last a (a::A)) j)%:Q).

Lemma PIprog m : forall a b (A B : seq nat), (size A + size B <= m)%N ->  is_trace (a::A) (b::B) ->
      mu (choose_corner m a b) (fun R => (R==(a::A,b::B))%:Q) = PI a b A B.
elim:m.
* move => a b A B.
rewrite leqn0 addn_eq0 size_eq0 size_eq0 => /andP [].
move => /eqP HA /eqP HB; subst.
by move => HT; rewrite choose_corner0_simpl Munit_simpl /PI eq_refl /belast big_nil big_nil //=.
* move => n IHn a b A B Hs Ht.
have [HO|Hn0]:= boolP (size (hook_next_seq a b) == O).
 + rewrite choose_corner_end_simpl //=.
have HAB := is_trace_corner_nil a b A B Ht HO.
move : HAB => /andP [].
move => /eqP HA /eqP HB; subst.
by rewrite xpair_eqE eqseq_cons eqseq_cons eq_refl eq_refl /PI big_nil big_nil.
 + rewrite choose_corner_decomp //=.
have HAB:= is_trace_corner_not_nil a b A B Ht Hn0.
move : HAB => /orP [].
move => HA.
have [HB|HnB]:= boolP (B == [::]).
rewrite /PI.
rewrite (choose_corner_emptyr n a (head O B)) //.
rewrite GRing.add0r.
have HAd := (cons_head_behead _ O A HA).
rewrite  {2} HAd.
rewrite (IHn (head O A) b (behead A)).
rewrite (belast_empty _ b B HB).
rat_to_ring; rewrite big_nil GRing.mulr1.
rewrite /PI (eqP HB) big_nil /=.
rewrite  {3} HAd (belast_cat a [::head O A] (behead A)) big_cat big_seq1 /=.
rewrite size_hook_next_seq_hook'.
rat_to_ring; rewrite GRing.mul1r GRing.mulr1.
rewrite GRing.mulrC //.
rewrite -ltnS size_behead -addSn.
apply: (leq_trans _ Hs).
apply leq_add; trivial.
rewrite prednK //.
by rewrite lt0n size_eq0.
rewrite -HAd.
apply (is_trace_tll _ _ _ HA Ht).
admit.
admit.
Save.
End FindCorner.


Require Import Coq.QArith.QArith.
Require Import Coq.Structures.Orders.
Require Import Coq.micromega.Lia.
Require Import Coq.Bool.Bool.
Require Import Coq.Sorting.Mergesort.
Require Export Coq.Lists.List.
Require Export Coq.ZArith.ZArith.
Export ListNotations.

Global Set Printing Width 1000.
Global Open Scope Z_scope.
Global Open Scope nat_scope.
Global Open Scope list_scope.

(** divisions should be roughly:
- The [Sanity] tests should be just enough to ensure that the code compiles and runs.
- All [SuperFast] tests in a file should finish in under 10 seconds total
- The [Fast] test files should take about a minute each
- The [Medium] tests should go up to about a minute each
- The [Slow] tests should go up to about 10 minutes each
- The [VerySlow] tests may take longer than 10 minutes each *)

Inductive size := Sanity | SuperFast | Fast | Medium | Slow | VerySlow.

Definition seconds_of_size (sz : size) : nat
  := match sz with
     | Sanity => 1
     | SuperFast => 10
     | Fast => 120
     | Medium => 600
     | Slow => 3600
     | VerySlow => 3600 * 10
     end.

Notation "'subst!' x 'for' y 'in' f"
  := (match x return _ with y => f end) (only parsing, at level 200, x at level 200, y ident, f at level 200).

Notation "'eta_size' ( sz' => f ) sz"
  := match sz with
     | Sanity => subst! Sanity for sz' in f
     | SuperFast => subst! SuperFast for sz' in f
     | Fast => subst! Fast for sz' in f
     | Medium => subst! Medium for sz' in f
     | Slow => subst! Slow for sz' in f
     | VerySlow => subst! VerySlow for sz' in f
     end (only parsing, at level 70, sz' ident).

Local Lemma eta_size_sanity : forall T f k, eta_size (k => f k) k = f k :> T.
Proof. intros; repeat match goal with |- context[match ?e with _ => _ end] => destruct e end; reflexivity. Qed.

Definition Zseconds_of_size (sz : size) : Z
  := Z.of_nat (seconds_of_size sz).

Definition Qseconds_of_size (sz : size) : Q
  := inject_Z (Zseconds_of_size sz).

Definition standard_max_seconds_of_size (sz : size) : nat
  := match sz with
     | Sanity => 10
     | SuperFast => 10
     | Fast => 10
     | Medium => 60
     | Slow => 60
     | VerySlow => 60
     end%nat.
Definition Zstandard_max_seconds_of_size (sz : size) : Z
  := Z.of_nat (standard_max_seconds_of_size sz).
Definition Qstandard_max_seconds_of_size (sz : size) : Q
  := inject_Z (Zstandard_max_seconds_of_size sz).

Definition standard_max_seconds : nat := standard_max_seconds_of_size Fast.
Definition Zstandard_max_seconds : Z := Z.of_nat standard_max_seconds.
Definition Qstandard_max_seconds : Q := inject_Z Zstandard_max_seconds.

Definition nat_of_size (sz : size) : nat
  := match sz with
     | Sanity => 0
     | SuperFast => 1
     | Fast => 2
     | Medium => 3
     | Slow => 4
     | VerySlow => 5
     end%nat.

Definition smaller_sizes (sz : size) : list size
  := match sz with
     | Sanity => []
     | SuperFast => [Sanity]
     | Fast => [Sanity; SuperFast]
     | Medium => [Sanity; SuperFast; Fast]
     | Slow => [Sanity; SuperFast; Fast; Medium]
     | VerySlow => [Sanity; SuperFast; Fast; Medium; Slow]
     end.

Definition size_pred (sz : size) : option size
  := match sz with
     | Sanity => None
     | SuperFast => Some Sanity
     | Fast => Some SuperFast
     | Medium => Some Fast
     | Slow => Some Medium
     | VerySlow => Some Slow
     end.

Fixpoint uniquify {T} (T_beq : T -> T -> bool) (ls : list T) : list T
  := match ls with
     | nil => nil
     | cons x xs
       => x :: filter (fun y => negb (T_beq x y)) (uniquify T_beq xs)
     end.

Definition remove_smaller_args_of_size {T} (T_beq : T -> T -> bool) (sz : size)
           (args_of_size : size -> list T)
  : list T
  := let args := uniquify T_beq (args_of_size sz) in
     let smaller_args := flat_map args_of_size (smaller_sizes sz) in
     filter (fun v => negb (existsb (T_beq v) smaller_args)) args.

Module NatProdOrder <: TotalLeBool.
  Definition t := (nat * nat)%type.
  Definition t_to_Z (v : t) : Z := (Z.of_nat (fst v) * Z.of_nat (snd v))%Z.
  Definition ltb (x y : t) : bool
    := (t_to_Z x <? t_to_Z y)%Z
       || (((t_to_Z x =? t_to_Z y)%Z)
             && ((fst x <? fst y)
                 || ((fst x =? fst y) && (snd x <? snd y)))).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Nat.eqb_eq
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt
                 | rewrite !Nat.ltb_lt ].
    destruct (Z.lt_total (t_to_Z a1) (t_to_Z a2)) as [?|[?|?]];
      try solve [ auto ]; [].
    destruct (Nat.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Nat.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End NatProdOrder.

Module NatProdSort := Sort NatProdOrder.
Notation sort_by_prod := NatProdSort.sort.

Module NatFstOrder <: TotalLeBool.
  Definition t := (nat * nat)%type.
  Definition ltb (x y : t) : bool
    := (fst x <? fst y)
       || ((fst x =? fst y)
             && (snd x <? snd y)).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Nat.eqb_eq
                 | rewrite !Nat.ltb_lt ].
    destruct (Nat.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Nat.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End NatFstOrder.

Module NatFstSort := Sort NatFstOrder.
Notation sort_by_fst := NatFstSort.sort.

Module ZProdOrder <: TotalLeBool.
  Local Open Scope Z_scope.
  Definition t := (Z * Z)%type.
  Definition t_to_Z (v : t) : Z := (fst v * snd v)%Z.
  Definition ltb (x y : t) : bool
    := (t_to_Z x <? t_to_Z y)%Z
       || (((t_to_Z x =? t_to_Z y)%Z)
             && ((fst x <? fst y)
                 || ((fst x =? fst y) && (snd x <? snd y)))).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt
                 | rewrite !Z.ltb_lt ].
    destruct (Z.lt_total (t_to_Z a1) (t_to_Z a2)) as [?|[?|?]];
      try solve [ auto ]; [].
    destruct (Z.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Z.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End ZProdOrder.

Module ZProdSort := Sort ZProdOrder.
Notation Zsort_by_prod := ZProdSort.sort.

Module ZFstOrder <: TotalLeBool.
  Local Open Scope Z_scope.
  Definition t := (Z * Z)%type.
  Definition ltb (x y : t) : bool
    := (fst x <? fst y)
       || ((fst x =? fst y)
             && (snd x <? snd y)).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt ].
    destruct (Z.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Z.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End ZFstOrder.

Module ZFstSort := Sort ZFstOrder.
Notation Zsort_by_fst := ZFstSort.sort.

Module ZOrder <: TotalLeBool.
  Local Open Scope Z_scope.
  Definition t := Z.
  Definition ltb := Z.ltb.
  Definition leb := Z.leb.
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt
                 | rewrite !Z.leb_le ].
    lia.
  Qed.
End ZOrder.

Module ZSort := Sort ZOrder.

Module Import LocalReflect.
  Definition reflect := reflect. (* a local copy *)
  Existing Class reflect.
  Notation reflect_rel R1 R2 := (forall x y, reflect (R1 x y) (R2 x y)).
End LocalReflect.
Global Hint Opaque reflect : typeclass_instances.

Lemma reflect_of_beq {beq : bool} {R : Prop}
      (bp : beq = true -> R)
      (pb : R -> beq = true)
  : reflect R beq.
Proof.
  destruct beq; constructor; intuition (discriminate || auto).
Qed.

Definition reflect_rel_of_beq {T} {beq : T -> T -> bool} {R : T -> T -> Prop}
      (bp : forall x y, beq x y = true -> R x y)
      (pb : forall x y, R x y -> beq x y = true)
  : reflect_rel R beq
  := fun x y => reflect_of_beq (bp x y) (pb x y).

Definition reflect_rel_of_beq_iff {T} {beq : T -> T -> bool} {R : T -> T -> Prop}
      (bp : forall x y, beq x y = true <-> R x y)
  : reflect_rel R beq
  := reflect_rel_of_beq (fun x y => proj1 (bp x y)) (fun x y => proj2 (bp x y)).

Definition reflect_rel_to_beq_iff {T} {beq : T -> T -> bool} {R : T -> T -> Prop}
           (Hr : reflect_rel R beq)
  : forall x y, beq x y = true <-> R x y.
Proof.
  intros x y; specialize (Hr x y); destruct Hr; intuition (eauto; congruence).
Qed.

Global Instance reflect_eq_nat : reflect_rel (@eq nat) Nat.eqb
  := reflect_rel_of_beq_iff Nat.eqb_eq.

Global Instance reflect_eq_Z : reflect_rel (@eq Z) Z.eqb
  := reflect_rel_of_beq_iff Z.eqb_eq.

Local Set Implicit Arguments.
Scheme Equality for prod.

Definition prod_beq_iff {A B eqA eqB}
           (A_iff : forall x y : A, eqA x y = true <-> x = y)
           (B_iff : forall x y : B, eqB x y = true <-> x = y)
  : forall x y, prod_beq eqA eqB x y = true <-> x = y.
Proof.
  split; [ apply internal_prod_dec_bl | apply internal_prod_dec_lb ];
    first [ apply A_iff | apply B_iff ].
Defined.
Local Unset Implicit Arguments.

Global Instance reflect_eq_prod {A B eqA eqB} {_ : reflect_rel (@eq A) eqA} {_ : reflect_rel (@eq B) eqB}
  : reflect_rel (@eq (A * B)) (prod_beq eqA eqB)
  := reflect_rel_of_beq_iff (prod_beq_iff (reflect_rel_to_beq_iff _) (reflect_rel_to_beq_iff _)).

Class has_sub T := sub : T -> T -> T.
Global Instance: has_sub nat := Nat.sub.
Global Instance: has_sub Z := Z.sub.

Class has_succ T := succ : T -> T.
Global Instance: has_succ nat := S.
Global Instance: has_succ Z := Z.succ.

Class has_zero T := zero : T.
Global Instance: has_zero nat := O.
Global Instance: has_zero Z := Z0.

Class has_sort T := sort : list T -> list T.
Global Instance: has_sort nat := NatSort.sort.
Global Instance: has_sort Z := ZSort.sort.

Definition remove_smaller_args_of_size_by_reflect
           {T} {T_beq : T -> T -> bool}
           {T_reflect : reflect_rel (@eq T) T_beq}
           (sz : size)
           (args_of_size : size -> list T)
  : list T
  := let args := uniquify T_beq (args_of_size sz) in
     let smaller_args := flat_map args_of_size (smaller_sizes sz) in
     filter (fun v => negb (existsb (T_beq v) smaller_args)) args.

Ltac default_describe_goal x :=
  idtac "Params: n=" x.

Ltac runtests args_of_size describe_goal mkgoal redgoal time_solve_goal sz :=
  let args := (eval vm_compute in (remove_smaller_args_of_size_by_reflect sz args_of_size)) in
  let rec iter ls :=
      lazymatch ls with
      | [] => idtac
      | ?x :: ?xs
        => describe_goal x;
           let T := mkgoal x in
           try (solve [ assert T by (redgoal x; once (time_solve_goal x + fail 2 "time_solve_goal failed!")) ]; []);
           iter xs
      end in
  iter args.

Ltac runtests_verify_sanity args_of_size describe_goal mkgoal redgoal time_solve_goal do_verify sz :=
  let time_solve_goal'
      := lazymatch sz with
         | Sanity
           => fun x => time_solve_goal x; do_verify ()
         | _
           => fun x => time_solve_goal x
         end in
  runtests args_of_size describe_goal mkgoal redgoal time_solve_goal' sz.

Ltac step_goal_from_to_constr step_goal cur_n target_n G :=
  let test := match constr:(Set) with
              | _ => let __ := match constr:(Set) with _ => constr_eq cur_n target_n end in
                     true
              | _ => false
              end in
  lazymatch test with
  | true => G
  | false
    => let next_n := (eval cbv in (succ cur_n)) in
       let G := step_goal next_n G in
       step_goal_from_to_constr step_goal next_n target_n G
  end.

Ltac runtests_step_arg_constr args_of_size describe_goal step_goal redgoal_constr redgoal time_solve_goal sz G extra_args :=
  let args := (eval vm_compute in (remove_smaller_args_of_size_by_reflect sz args_of_size)) in
  let T := lazymatch type of args with list ?T => T end in
  let rec iter cur ls G :=
      lazymatch ls with
      | [] => idtac
      | ?x :: ?xs
        => let G := step_goal_from_to_constr step_goal cur x G in
           let G := redgoal_constr x G in
           describe_goal x;
           try (solve [ redgoal x; once (time_solve_goal x G extra_args + fail 2 "time_solve_goal failed!") ]; []);
           iter x xs G
      end in
  let zero := (eval cbv in (@zero T _)) in
  iter zero args G.

Ltac runtests_step_constr args_of_size describe_goal step_goal redgoal_constr time_solve_goal sz G :=
  runtests_step_arg_constr args_of_size describe_goal step_goal redgoal_constr ltac:(fun _ => idtac) ltac:(fun n G args => time_solve_goal n G) sz G ().

Ltac constr_run_tac f x :=
  lazymatch goal with
  | _ => f x
  end.

Ltac runtests_step_arg args_of_size describe_goal step_goal redgoal time_solve_goal sz extra_args :=
  runtests_step_arg_constr args_of_size describe_goal ltac:(fun n G => constr_run_tac step_goal n) ltac:(fun _ G => G) redgoal ltac:(fun n G args => time_solve_goal n args) sz () extra_args.

Ltac runtests_step args_of_size describe_goal step_goal redgoal time_solve_goal sz :=
  runtests_step_arg args_of_size describe_goal step_goal redgoal ltac:(fun n args => time_solve_goal n) sz ().


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C M Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ M A /\ (wd_ M B /\ (wd_ M Cprime /\ (wd_ M C /\ (wd_ A O /\ (wd_ B O /\ (wd_ C Cprime /\ (col_ C B M /\ (col_ M Cprime C /\ col_ M A B)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m765_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D : Universe, ((wd_ B A /\ (wd_ D A /\ (wd_ A C /\ (wd_ C D /\ (wd_ B C /\ (wd_ B D /\ (col_ A B C /\ (col_ D A C /\ col_ A B D)))))))) -> col_ D B C)).
Proof.
  time tac.
Qed.

End FOFProblem.