Set Implicit Arguments.

Require Import Aniceto.Graphs.Graph.

Require Import Coq.Lists.List.

Require Import Aniceto.Graphs.FGraph.

Require Aniceto.List.
Require Aniceto.Pair.

Section Dag.
  Variable A:Type.
  Variable Lt: A * A -> Prop.

  Definition DAG E := forall (x:A), ~ Reaches E x x.
End Dag.

Section Finite.
  Variable A:Type.

  Variable eq_dec: forall (x y:A), {x = y} + {x <> y}.

  Lemma f_dag_nil:
    DAG (Edge (@nil (A*A))).
  Proof.
    intros.
    unfold DAG, not; intros.
    apply reaches_to_in_fst in H.
    destruct H as ((y,z),(?,Hp)).
    inversion H.
  Qed.

  Lemma f_dag_cons:
    forall es (x y:A),
    DAG (Edge es) ->
    ~ Reaches (Edge es) y x ->
    x <> y ->
    DAG (Edge ((x,y)::es)).
  Proof.
    intros.
    unfold DAG in *.
    intros z; unfold not; intros Hr.
    inversion Hr as (w, Hw2).
    inversion Hw2; subst.
    destruct (in_dec (Pair.pair_eq_dec eq_dec) (x,y) w). {
      apply walk2_split_not_in with (a:=x) (b:=y) in Hw2; auto.
      destruct Hw2 as [(?,?)|[(?,(w',(Hw,?)))|[(?,(w',(Hw,?)))|((wa,(Hwa,?)),(wb,(Hwb,?)))]]]; subst.
      - contradiction H1; auto.
      - apply walk2_inv_not_in_walk in Hw; auto.
        contradiction H0; eauto using reaches_def.
      - apply walk2_inv_not_in_walk in Hw; auto.
        contradiction H0; eauto using reaches_def.
      - apply walk2_inv_not_in_walk in Hwa; auto.
        apply walk2_inv_not_in_walk in Hwb; auto.
        contradiction H0; eauto using reaches_def, reaches_trans.
    }
    assert (N: ~ Reaches (Edge es) z z) by auto.
    contradiction N.
    apply walk2_inv_not_in_walk in Hw2; eauto using reaches_def.
  Qed.

  Lemma f_dag_cons_reaches:
    forall es (x y:A),
    DAG (Edge es) ->
    Reaches (Edge es) x y ->
    DAG (Edge ((x,y)::es)).
  Proof.
    intros.
    unfold DAG.
    intros z; unfold not; intros R.
    inversion R as (w, Hw).
    destruct (in_dec (Pair.pair_eq_dec eq_dec) (x,y) w). {
      apply walk2_split_not_in with (a:=x) (b:=y) in Hw; auto.
      destruct Hw as [(?,?)|[(?,(w',(Hw,?)))|[(?,(w',(Hw,?)))|((wa,(Hwa,?)),(wb,(Hwb,?)))]]]; subst.
      - apply H in H0; auto.
      - apply walk2_inv_not_in_walk in Hw; auto.
        assert (n: Reaches (Edge es) z z). {
          eauto using reaches_trans, reaches_def.
        }
        apply H in n; auto.
      - apply walk2_inv_not_in_walk in Hw; auto.
        assert (n: Reaches (Edge es) x x). {
          eauto using reaches_trans, reaches_def.
        }
        apply H in n; auto.
      - apply walk2_inv_not_in_walk in Hwa; auto.
        apply walk2_inv_not_in_walk in Hwb; auto.
        assert (n: Reaches (Edge es) x x). {
          eauto using reaches_trans, reaches_def.
        }
        apply H in n; auto.
    }
    assert (N: ~ Reaches (Edge es) z z) by auto.
    contradiction N.
    apply walk2_inv_not_in_walk in Hw; eauto using reaches_def.
  Qed.

  Lemma f_dag_inv_cons:
    forall (e:A*A) es,
    DAG (Edge (e :: es)) ->
    DAG (Edge es).
  Proof.
    intros.
    unfold DAG in *.
    intros.
    assert (Y:=H x).
    unfold not; intros.
    contradiction Y; clear Y.
    auto using reaches_cons.
  Qed.
End Finite.

Section Props.

  (** Move to *)
  Lemma dag_impl:
    forall {A:Type} (E F: (A * A) -> Prop),
    (forall e, F e -> E e ) ->
    DAG E ->
    DAG F.
  Proof.
    unfold DAG in *.
    intros.
    unfold not; intros.
    apply reaches_impl with (F0:=E) in H1; auto.
    apply H0 in H1.
    assumption.
  Qed.

  Lemma f_dag_incl:
    forall {A:Type} (es es':list (A*A)),
    DAG (Edge es) ->
    incl es' es ->
    DAG (Edge es').
  Proof.
    intros.
    unfold incl in *.
    apply dag_impl with (E:=Edge es); auto.
  Qed.

  Section find_o.
  Variable A:Type.
  Variable eq_dec: forall (x y:A), {x = y} + {x <> y}.

  Let fst_eq x (e:A*A) := if eq_dec (fst e) x then true else false.

  Let fst_eq_true:
    forall x e,
    fst_eq x e = true ->
    fst e = x.
  Proof.
    intros.
    unfold fst_eq in *.
    destruct (eq_dec (fst e) x); auto.
    inversion H.
  Qed.

  Let fst_eq_false:
    forall x e,
    fst_eq x e = false ->
    fst e <> x.
  Proof.
    intros.
    unfold fst_eq in *.
    destruct (eq_dec (fst e) x); auto.
    inversion H.
  Qed.

  Import Coq.Lists.List.
  Import Aniceto.List.

  Let find_fst_eq_some:
    forall x es e,
    find (fst_eq x) es = Some e ->
    List.In e es /\ fst e = x.
  Proof.
    intros.
    apply List.find_some_spec in H.
    destruct H.
    apply fst_eq_true in H0.
    intuition.
  Qed.

  Import Aniceto.Pair.

  Let find_outgoing x (es:list(A*A)) :=
  find (fst_eq x) es.

  Let find_outgoing_some:
    forall x x' y es,
    find_outgoing x es = Some (x',y) ->
    List.In (x,y) es /\ x' = x.
  Proof.
    intros.
    unfold find_outgoing in H.
    apply find_fst_eq_some in H.
    destruct H.
    intuition.
    simpl in *; subst; auto.
  Qed.

  Let find_outgoing_none:
    forall x es,
    find_outgoing x es = None ->
    forall y z, List.In (y,z) es -> y <> x.
  Proof.
    intros.
    unfold find_outgoing in *.
    remember (find _ _).
    destruct o.
    - inversion H.
    - clear H.
      symmetry in Heqo.
      unfold not; intros; subst.
      apply find_none_impl_existsb in Heqo.
      rewrite existsb_forallb in Heqo.
      rewrite Bool.negb_false_iff in Heqo.
      rewrite forallb_forall in Heqo.
      apply Heqo in H0.
      rewrite Bool.negb_true_iff in H0.
      apply fst_eq_false in H0; simpl in *.
      contradiction H0; trivial.
  Qed.

  Let find_outgoing_some_lt:
    forall x es e,
    find_outgoing x es = Some e ->
    length (rm_edge eq_dec e es) < length es.
  Proof.
    intros.
    unfold find_outgoing in *.
    apply find_some_spec in H.
    destruct H.
    unfold rm_edge.
    auto using remove_in_length_lt.
  Qed.

  Function find_path x es { measure length es } : list (A*A)  :=
  match find_outgoing x es with
  | Some (x',y) => (x',y) :: find_path y (rm_edge eq_dec (x',y) es)
  | None => nil
  end.
  Proof.
    intros.
    eauto using find_outgoing_some_lt.
  Qed.

  Let find_path_starts_with:
    forall x es w,
    find_path x es = w ->
    w <> nil ->
    StartsWith w x.
  Proof.
    intros.
    destruct w; rewrite find_path_equation in H.
    - contradiction H0; trivial.
    - clear H0.
      remember (find_outgoing _ _).
      symmetry in Heqo.
      destruct o.
      + destruct p0 as (a,b).
        inversion H; subst; clear H.
        apply find_outgoing_some in Heqo.
        destruct Heqo.
        subst.
        auto using starts_with_def.
      + inversion H.
  Qed.

  Let find_path_nil:
    forall w x,
    find_path x w = nil ->
    forall y z, List.In (y,z) w -> y <> x.
  Proof.
    induction w; intros; subst.
    - inversion H0.
    - rewrite find_path_equation in H.
      remember (find_outgoing _ _).
      destruct o.
      + destruct p.
        inversion H.
      + clear H.
        symmetry in Heqo.
        assert (Hx := find_outgoing_none _ Heqo).
        eauto.
  Qed.

  Let find_path_rw_nil:
    forall x w,
    find_path x nil = w ->
    w = nil.
  Proof.
    intros.
    rewrite find_path_equation in *.
    remember (find_outgoing _ _).
    symmetry in Heqo.
    destruct o.
    - destruct p as (a,b).
      apply find_outgoing_some in Heqo.
      destruct Heqo.
      inversion H0.
    - auto.
  Qed.

  Let find_path_connected:
    forall l es x,
    find_path x es = l ->
    Connected l.
  Proof.
    induction l; intros; auto using connected_nil.
    rewrite find_path_equation in H.
    remember (find_outgoing _ _ ).
    symmetry in Heqo.
    destruct o.
    - destruct p as (v1,v2).
      apply find_outgoing_some in Heqo.
      destruct Heqo; subst.
      inversion H; subst; clear H.
      remember (find_path _ _).
      symmetry in Heql.
      destruct l. {
        auto using connected_cons, linked_nil, connected_nil.
      }
      assert (Connected (p::l)) by eauto.
      destruct p as (v2', v3).
      assert (S: StartsWith ((v2',v3)::l) v2). {
        assert ((v2',v3)::l <> nil) . {
          unfold not; intros.
          inversion H1.
        }
        eauto using find_path_starts_with.
      }
      apply starts_with_eq in S; subst.
      auto using connected_cons, linked_eq.
    - inversion H.
  Qed.

  Let find_path_incl:
    forall w es x,
    find_path x es = w ->
    incl w es.
  Proof.
    induction w; intros; remember (find_path _ _); symmetry in Heql. {
      subst.
      auto using incl_nil_any.
    }
    subst.
    rewrite find_path_equation in H.
    remember (find_outgoing _ _ ).
    symmetry in Heqo.
    destruct o.
    - destruct p as (v1,v2).
      inversion H; clear H.
      apply find_outgoing_some in Heqo; destruct Heqo.
      rewrite H0 in *; clear H0.
      clear H1.
      assert (incl w (rm_edge eq_dec (x,v2) es)) by eauto.
      rewrite H2.
      apply incl_cons; auto.
      unfold rm_edge in *.
      assert (incl (remove (edge_eq_dec eq_dec) (x, v2) es) es) by eauto using remove_incl.
      eauto using incl_tran.
    - inversion H.
  Qed.

  Let find_path_to_walk:
    forall l es x,
    find_path x es = l ->
    Walk (Edge es) l.
  Proof.
    intros.
    apply walk_def.
    - apply Forall_forall; intros.
      apply find_path_incl in H.
      unfold Edge.
      unfold incl in *; auto.
    - eauto using find_path_connected.
  Qed.

  Let find_path_to_walk2:
    forall x es w y,
    find_path x es = w ->
    EndsWith w y ->
    Walk2 (Edge es) x y w.
  Proof.
    intros.
    eauto using walk2_def, find_path_to_walk, find_path_starts_with, ends_with_non_nil.
  Qed.

  Let find_path_to_reaches:
    forall x es w y,
    find_path x es = w ->
    EndsWith w y ->
    Reaches (Edge es) x y.
  Proof.
    intros.
    eauto using reaches_def, find_path_to_walk2.
  Qed.

  Let find_path_cons_nil:
    forall es x x' z,
    find_path x es = (x', z) :: nil ->
    (x' = x /\ z = x /\ forall e, List.In e es -> e = (x,x) \/ fst e <> z) \/
    (x' = x /\ forall e, List.In e es -> fst e <> z).
  Proof.
    intros.
    rewrite find_path_equation in *.
    remember (find_outgoing _ _).
    symmetry in Heqo.
    destruct o.
    - destruct p as (x'', z').
      apply find_outgoing_some in Heqo.
      destruct Heqo.
      inversion H; repeat subst; clear H.
      destruct (eq_dec x' z). {
        subst.
        left; repeat split; auto.
        assert (X:= find_path_nil _ H5).
        intros.
        destruct e as (e1,e2).
        destruct (pair_eq_dec eq_dec (e1,e2) (z,z)); auto.
        right.
        simpl.
        apply rm_edge_in_neq with (eq_dec:=eq_dec) (e:=(z,z)) in H; auto.
        unfold not; intros.
        subst.
        apply X in H.
        contradiction H; trivial.
      }
      right.
      split; auto.
      intros (e1,e2); intros; simpl.
      destruct (pair_eq_dec eq_dec (e1,e2) (x',z)).
      + inversion e; subst; clear e.
        unfold not; intros; subst.
        contradiction n; trivial.
      + eauto using find_path_nil, rm_edge_in_neq.
    - inversion H.
  Qed.

  Let find_path_cons_nil_nrefl:
    forall es x x' z,
    Forall (fun x=> fst x <> snd x) es ->
    find_path x es = (x', z) :: nil ->
    x' = x /\ forall e, List.In e es -> fst e <> z.
  Proof.
    intros.
    apply find_path_cons_nil in H0.
    destruct H0 as [(?,(?,Hx))|?]; auto.
    subst.
    split; auto.
    intros (e1,e2) Hi; simpl.
    assert (Y:=Hi).
    apply Hx in Hi.
    destruct Hi; auto.
    inversion H0; subst.
    rewrite Forall_forall in H.
    apply H in Y.
    auto.
  Qed.

  Let f_dag_impl_rm_edge:
    forall es,
    DAG (Edge es) ->
    forall e,
    DAG (Edge (rm_edge eq_dec e es)).
  Proof.
    unfold rm_edge.
    eauto using f_dag_incl, remove_incl.
  Qed.

  Let f_dag_lt_to_nrefl:
    forall (es:list (A*A)),
    DAG (Edge es) ->
    Forall (fun x=> fst x <> snd x) es.
  Proof.
    intros.
    rewrite Forall_forall.
    intros.
    destruct x as (x,y).
    simpl.
    intuition; subst.
    assert (n: ~ Reaches (Edge es) y y) by eauto.
    contradiction n.
    auto using edge_to_reaches.
  Qed.

  Let find_path_some:
    forall w (x y:A) es,
    DAG (Edge es) ->
    find_path x es = w ->
    EndsWith w y ->
    forall e, List.In e es -> fst e <> y.
  Proof.
    induction w; intros. {
      apply ends_with_nil_inv in H1; contradiction.
    }
    assert (Reaches (Edge es) x y) by
    eauto using find_path_to_walk2, reaches_def.
    destruct a as (v1,v2).
    destruct w. {
      apply ends_with_eq in H1.
      subst.
      apply find_path_cons_nil_nrefl in H0; auto.
      destruct H0.
      subst.
      auto.
    }
    rewrite find_path_equation in *.
    remember (find_outgoing _ _).
    symmetry in Heqo.
    destruct o.
    - destruct p0 as (a,b).
      inversion H0; subst; clear H0.
      destruct (pair_eq_dec eq_dec e (v1,v2)).
      + subst.
        simpl.
        unfold not; intros; subst.
        apply find_outgoing_some in Heqo.
        destruct Heqo; subst.
        assert (n: ~ Reaches (Edge es) x x) by eauto.
        contradiction n.
      + eauto using ends_with_inv, remove_in_neq.
    - inversion H0.
  Qed.

  Let find_path_cons:
    forall v1 v2 es w,
    find_path v1 ((v1,v2)::es) = w ->
    StartsWith w v1.
  Proof.
    intros.
    rewrite find_path_equation in *.
    remember (find_outgoing _ _).
    symmetry in Heqo.
    destruct o as [(?,?)|]. {
      apply find_outgoing_some in Heqo.
      destruct Heqo.
      subst.
      auto using starts_with_def.
    }
    apply find_outgoing_none with (y:=v1) (z:=v2) in Heqo; auto using in_eq.
    contradiction Heqo; trivial.
  Qed.

  Let dag_find_path:
    forall w es x y,
    DAG (Edge es) ->
    find_path x es = w ->
    EndsWith w y ->
    forall z, ~ Reaches (Edge es) y z.
  Proof.
    intros.
    assert (X: forall e, List.In e es -> fst e <> y) by eauto.
    unfold not; intros.
    assert (Y: exists (v:A), In (y,v) es). {
      inversion H2.
      inversion H3; subst.
      inversion H4.
      destruct H0 as (w', (?,?)); subst.
      destruct x0 as (v1,v2).
      simpl in *.
      exists v2.
      assert (Edge es (v1,v2)). {
        apply walk_to_edge with (w:=(v1,v2)::w'); auto.
        auto using in_eq.
      }
      auto.
    }
    destruct Y.
    apply X in H3.
    simpl in H3; contradiction H3; trivial.
  Qed.

  Let find_outgoing_rw_cons:
    forall v1 v2 es,
    find_outgoing v1 ((v1, v2) :: es) = Some (v1, v2).
  Proof.
    intros.
    unfold find_outgoing.
    simpl.
    remember (fst_eq v1 (v1,v2)).
    symmetry in Heqb.
    destruct b; simpl in *; auto.
    apply fst_eq_false in Heqb.
    simpl in *; contradiction Heqb; auto.
  Qed.

  Let find_path_rw_cons:
    forall v1 v2 es p l,
    find_path v1 ((v1, v2) :: es) = p :: l ->
    p = (v1, v2).
  Proof.
    intros.
    rewrite find_path_equation in H.
    rewrite find_outgoing_rw_cons in *.
    inversion H; auto.
  Qed.

  Lemma dag_infimum:
    forall (es:list (A*A)),
    DAG (Edge es) ->
    es <> nil ->
    exists x, Graph.In (Edge es) x /\ forall y, ~ Reaches (Edge es) x y.
  Proof.
    intros.
    destruct es. {
      contradiction H0; trivial.
    }
    destruct p as (v1,v2).
    remember (find_path v1 ((v1,v2)::es)).
    symmetry in Heql.
    destruct l. {
      apply find_path_nil with (y:=v1) (z:=v2) in Heql; auto using in_eq.
      intros.
      contradiction Heql; trivial.
    }
    assert (X:=Heql).
    apply find_path_cons in Heql.
    assert (Y: exists (y:A), EndsWith (p::l) y). {
      assert (p :: l <> nil). {
        intuition;subst.
        inversion H1.
      }
      auto using ends_with_neq_nil.
    }
    destruct Y as (y, Y).
    exists y.
    split; eauto.
    inversion Y as ((e1,e2),(?,?)); subst; simpl in *.
    assert (p = (v1,v2)) by eauto; subst.
    apply in_def with (e:=(e1,e2)).
    - auto using pair_in_right.
    - unfold Edge.
      assert (I: incl ((v1, v2) :: l) ((v1, v2) :: es)) by eauto.
      unfold incl in *.
      apply end_in in H1.
      eauto.
  Qed.

  End find_o.

End Props.

Section Infinum.
  Import Aniceto.Pair.
  Import Aniceto.List.

  Variable A:Type.

  Lemma dag_es_to_flip_es:
    forall (es:list (A*A)),
    DAG (Edge es) ->
    DAG (Edge (map flip es)).
  Proof.
    intros.
    unfold DAG.
    intros.
    unfold not; intros X.
    apply reaches_flip with (F:=Edge es) in X.
    - apply H in X; contradiction.
    - intros.
      unfold Edge in *.
      auto using in_map_flip_1.
  Qed.

  Let edge_map_flip_iff:
    forall {A:Type} es (x y:A),
    Edge es (y, x) <-> Edge (map flip es) (x, y).
  Proof.
    unfold Edge.
    symmetry.
    eauto using in_map_flip_iff.
  Qed.

  Let in_map_flip:
    forall {A:Type} es (x:A),
    Graph.In (Edge (map flip es)) x ->
    Graph.In (Edge es) x.
  Proof.
    intros.
    destruct H as ((v1,v2),(E,Hp)).
    destruct Hp; simpl in *; subst.
    - apply edge_map_flip_iff in E.
      eauto using in_right.
    - apply edge_map_flip_iff in E.
      eauto using in_left.
  Qed.

  Variable eq_dec: forall x y : A, {x = y} + {x <> y}.

  Lemma dag_sumpremum:
    forall (es:list (A*A)),
    DAG (Edge es) ->
    es <> nil ->
    exists x, Graph.In (Edge es) x /\ forall y, ~ Reaches (Edge es) y x.
  Proof.
    intros.
    assert (exists x, Graph.In (Edge (map flip es)) x /\ (forall y, ~ Reaches (Edge (map flip es)) x y)). {
      apply dag_infimum with (es:=map flip es); auto using dag_es_to_flip_es, map_neq_nil.
    }
    destruct H1 as (x, (Hi,?)).
    exists x.
    split; auto.
    unfold not; intros.
    apply reaches_flip with (F:=Edge (map flip es)) in H2; auto.
    apply H1 in H2; contradiction.
    intros.
    apply edge_map_flip_iff in H3; auto.
  Qed.
End Infinum.

Section Walk2.
  Import Aniceto.List.

  Lemma fdag_walk2_inv_0 {A}:
    forall w (x:A) y z es,
    DAG (FGraph.Edge es) ->
    Walk2 (Edge es) x y w ->
    List.In (x, z) w ->
    exists w', w = (x,z)::w'.
  Proof.
    intros.
    apply List.in_app_split in H1.
    destruct H1 as (l1, (l2, R)).
    subst.
    destruct l1 as [|(x',z')]. {
      simpl in *.
      eauto.
    }
    assert (x' = x) by eauto using walk2_inv_eq_fst.
    subst.
    apply walk2_split_app in H0.
    destruct H0.
    apply reaches_def in H0.
    apply H in H0.
    contradiction.
  Qed.

  Lemma fdag_walk2_inv_1 {A}:
    forall (x:A) y w z es,
    DAG (FGraph.Edge es) ->
    Walk2 (FGraph.Edge es) x y w ->
    List.In (z, y) w ->
    exists w', w = w' ++ ((z,y)::nil).
  Proof.
    intros.
    apply List.in_app_split in H1.
    destruct H1 as (l1, (l2, R)).
    subst.
    destruct l1 as [|(x',z')]. {
      simpl in *.
      destruct l2. {
        exists nil. auto.
      }
      apply walk2_inv in H0.
      destruct H0 as (v2, (Heq, (He, Hw))).
      inversion Heq; subst; clear Heq.
      apply reaches_def in Hw.
      apply H in Hw.
      contradiction.
    }
    assert (x' = x) by eauto using walk2_inv_eq_fst.
    subst.
    apply walk2_split_app in H0.
    destruct H0.
    destruct l2. {
      exists ((x,z')::l1).
      auto.
    }
    clear H0.
    apply walk2_inv in H1.
    destruct H1 as (v2, (Heq, (He, Hw))).
    inversion Heq; subst; clear Heq.
    apply reaches_def in Hw.
    apply H in Hw.
    contradiction.
  Qed.

  Lemma dag_walk2_nodup {A}:
    forall E w (x:A) y,
    DAG E ->
    Walk2 E x y w ->
    NoDup w.
  Proof.
    induction w; intros. {
      apply walk2_nil_inv in H0.
      contradiction.
    }
    destruct a as (x', b).
    assert (x' = x) by eauto using walk2_inv_eq_fst; subst.
    destruct w. {
      assert (b = y) by eauto using walk2_inv_eq_snd; subst.
      apply no_dup_cons_nil.
    }
    apply walk2_inv in H0.
    destruct H0 as (v2, (Heq, (He, Hw))).
    inversion Heq; subst; clear Heq.
    assert (Hx:=Hw).
    apply IHw in Hx; auto.
    apply NoDup_cons; auto.
    unfold not; intros N.
    apply List.in_app_split in N.
    destruct N as (l1, (l2, Heq)).
    rewrite Heq in *; clear Heq.
    apply edge_to_reaches in He.
    destruct l1. {
      simpl in *.
      assert (v2 = x). {
        apply walk2_inv_eq_fst in Hw.
        auto.
      }
      subst.
      apply H in He.
      contradiction.
    }
    apply walk2_split_app in Hw.
    destruct Hw as (Hw, _).
    apply reaches_def in Hw.
    assert (N: Reaches E x x) by eauto using reaches_trans.
    apply H in N.
    contradiction.
  Qed.

  Lemma fdag_walk2_not_in {A}:
    forall es x (y:A) wa wb e,
    DAG (FGraph.Edge es) ->
    Walk2 (FGraph.Edge es) x y (wa ++ e :: wb)  ->
    ~ List.In e wa /\ ~ List.In e wb.
  Proof.
    intros.
    split.
    - unfold not; intros N.
      apply dag_walk2_nodup in H0; auto.
      apply NoDup_rewrite in H0.
      inversion H0; subst; clear H0.
      contradiction H3.
      rewrite in_app_iff.
      auto.
    - unfold not; intros N.
      apply dag_walk2_nodup in H0; auto.
      apply NoDup_rewrite in H0.
      inversion H0; subst; clear H0.
      contradiction H3.
      rewrite in_app_iff.
      auto.
  Qed.

  Let fdag_walk2_absurd_0:
    forall {A} es (v1:A) v2 vn v w1 w2,
    DAG (Edge es) ->
    ~ Walk2 (Edge es) v1 vn (((v1, v2) :: w1) ++ (v, v1) :: w2).
  Proof.
    intros.
    unfold not; intros Hw.
    apply walk2_split_app in Hw.
    destruct Hw as (Hw1, Hw2).
    apply reaches_def in Hw1.
    destruct w2. {
      assert (v1 = vn) by eauto using walk2_inv_eq_snd; subst.
      apply reaches_def in Hw2.
      assert (N:  Reaches (Edge es) vn vn) by eauto using reaches_trans.
      apply H in N.
      contradiction.
    }
    apply walk2_inv in Hw2.
    destruct Hw2 as (c, (Heq, (He, Hw2))).
    inversion Heq; subst.
    assert (Reaches (Edge es) v c) by eauto using edge_to_reaches.
    assert (N:  Reaches (Edge es) c c) by eauto using reaches_trans.
    apply H in N.
    contradiction.
  Qed.

  Let reaches_inv_cons_0 {A} (eq_dec: forall (x y:A), { x = y } + { x <> y }):
    forall x n2 es w (y:A),
    DAG (FGraph.Edge ((x, n2) :: es)) ->
    Walk2 (FGraph.Edge ((x, n2) :: es)) x y w ->
    List.In (x, n2) w ->
    n2 = y \/ (n2 <> y /\ Reaches (FGraph.Edge es) n2 y).
  Proof.
    intros.
    destruct (eq_dec n2 y). {
      auto.
    }
    right; split; auto.
    assert (Hw :=H0).
    apply fdag_walk2_inv_0 with (z:=n2) in H0; auto; clear H1.
    destruct H0 as (w', Hn); subst.
    destruct w' as [|(a,b)]. {
      apply walk2_inv_eq_snd in Hw.
      contradiction.
    }
    apply walk2_inv in Hw.
    destruct Hw as (v2, (Heq, (_,Hw))).
    inversion Heq; subst; clear Heq.
    assert (v2=a). {
      apply walk2_inv_eq_fst in Hw.
      auto.
    }
    subst.
    apply FGraph.walk2_inv_not_in_walk in Hw; auto.
    eauto using reaches_def.
    unfold not; intros N.
    apply List.in_app_split in N.
    destruct N as (l1, (l2, Heq)).
    rewrite Heq in *; clear Heq.
    assert (Hx := Hw).
    apply fdag_walk2_not_in in Hx; auto.
    destruct l1 as [|(v1,v2)]. {
      simpl in *.
      assert (x = a) by eauto using walk2_inv_eq_fst; subst.
      assert (N: Reaches (Edge ((a, a) :: es)) a a). {
        apply edge_to_reaches.
        simpl; auto using in_eq.
      }
      apply H in N.
      contradiction.
    }
    assert (v1 = a) by eauto using walk2_inv_eq_fst; subst.
    apply fdag_walk2_absurd_0 in Hw; auto.
  Qed.

  Let reaches_inv_cons_1 {A} (eq_dec: forall (x y:A), { x = y } + { x <> y }):
    forall n1 y es w (x:A),
    DAG (FGraph.Edge ((n1, y) :: es)) ->
    List.In (n1, y) w ->
    Walk2 (FGraph.Edge ((n1, y) :: es)) x y w ->
    n1 = x \/ Reaches (FGraph.Edge es) x n1.
  Proof.
    intros.
    destruct (eq_dec n1 x). {
      auto.
    }
    right.
    assert (Hw :=H1).
    apply fdag_walk2_inv_1 with (z:=n1) in H1; auto.
    destruct H1 as (w', Hn).
    subst.
    destruct w' as [|(a,b)]. {
      simpl in *.
      apply walk2_inv_eq_fst in Hw.
      contradiction.
    }
    assert (a = x). {
      apply walk2_inv_eq_fst in Hw.
      auto.
    }
    subst.
    assert (Hx:=Hw).
    apply walk2_split_app in Hx.
    destruct Hx as (Hx, _).
    apply FGraph.walk2_inv_not_in_walk in Hx; eauto using reaches_def.
    apply fdag_walk2_not_in in Hw; auto.
    destruct Hw.
    assumption.
  Qed.

  Let reaches_inv_cons_2 {A} (eq_dec: forall (x y:A), { x = y } + { x <> y }):
    forall n1 n2 es (x:A) y wa wb,
    DAG (FGraph.Edge ((n1, n2) :: es)) ->
    Walk2 (FGraph.Edge ((n1, n2) :: es)) x n1 wa ->
    Walk2 (FGraph.Edge ((n1, n2) :: es)) n2 y wb ->
    Walk2 (FGraph.Edge ((n1, n2) :: es)) x y (wa ++ (n1, n2) :: wb) ->
    Reaches (FGraph.Edge es) x n1 /\ Reaches (FGraph.Edge es) n2 y.
  Proof.
    intros.
    assert (Hw:=H2).
    apply fdag_walk2_not_in in H2; auto.
    destruct H2 as (Hn1, Hn2).
    apply FGraph.walk2_inv_not_in_walk in H0; eauto using reaches_def.
    apply FGraph.walk2_inv_not_in_walk in H1; eauto using reaches_def.
  Qed.

  Lemma reaches_inv_cons {A} (eq_dec: forall (x y:A), { x = y } + { x <> y }):
    forall  es n1 n2 (x:A) y w,
    DAG (FGraph.Edge ((n1,n2)::es)) ->
    Walk2 (FGraph.Edge ((n1,n2)::es)) x y w ->
    List.In (n1,n2) w ->
    (n2 = y /\ (n1 = x \/ Reaches (FGraph.Edge es) x n1)) \/
    (n2 <> y /\ Reaches (FGraph.Edge es) n2 y) \/
    (Reaches (FGraph.Edge es) x n1 /\ Reaches (FGraph.Edge es) n2 y).
  Proof.
    intros.
    assert (Hw := H0).
    apply walk2_split with (a:=n1) (b:=n2) in H0; auto.
    destruct H0 as [?|[?|(wa, (wb, (He, (Hw1, Hw2))))]]; subst.
    + apply reaches_inv_cons_0 in Hw; auto.
      destruct Hw as [?|(?,Hr)]; subst; auto.
    + left.
      split; auto.
      apply reaches_inv_cons_1 in Hw; auto.
    + subst.
      apply reaches_inv_cons_2 in Hw; auto.
  Qed.

End Walk2.


(* AES with 128-bit key *)

Set Implicit Arguments.

Require Import FPUtil.
Require Import Arith NArith NPeano Ascii String List.
Import ListNotations.
Local Open Scope prog_scope.
Local Open Scope N_scope.
Local Open Scope nat_scope.
Local Open Scope string_scope.
Local Open Scope list_scope.
Require Import Bitvec.
Local Open Scope bitvec_scope.

Definition s_box : list byte := map byte_of_hex
[
  "63"; "7C"; "77"; "7B"; "F2"; "6B"; "6F"; "C5"; "30"; "01"; "67"; "2B"; "FE"; "D7"; "AB"; "76";
  "CA"; "82"; "C9"; "7D"; "FA"; "59"; "47"; "F0"; "AD"; "D4"; "A2"; "AF"; "9C"; "A4"; "72"; "C0";
  "B7"; "FD"; "93"; "26"; "36"; "3F"; "F7"; "CC"; "34"; "A5"; "E5"; "F1"; "71"; "D8"; "31"; "15";
  "04"; "C7"; "23"; "C3"; "18"; "96"; "05"; "9A"; "07"; "12"; "80"; "E2"; "EB"; "27"; "B2"; "75";
  "09"; "83"; "2C"; "1A"; "1B"; "6E"; "5A"; "A0"; "52"; "3B"; "D6"; "B3"; "29"; "E3"; "2F"; "84";
  "53"; "D1"; "00"; "ED"; "20"; "FC"; "B1"; "5B"; "6A"; "CB"; "BE"; "39"; "4A"; "4C"; "58"; "CF";
  "D0"; "EF"; "AA"; "FB"; "43"; "4D"; "33"; "85"; "45"; "F9"; "02"; "7F"; "50"; "3C"; "9F"; "A8";
  "51"; "A3"; "40"; "8F"; "92"; "9D"; "38"; "F5"; "BC"; "B6"; "DA"; "21"; "10"; "FF"; "F3"; "D2";
  "CD"; "0C"; "13"; "EC"; "5F"; "97"; "44"; "17"; "C4"; "A7"; "7E"; "3D"; "64"; "5D"; "19"; "73";
  "60"; "81"; "4F"; "DC"; "22"; "2A"; "90"; "88"; "46"; "EE"; "B8"; "14"; "DE"; "5E"; "0B"; "DB";
  "E0"; "32"; "3A"; "0A"; "49"; "06"; "24"; "5C"; "C2"; "D3"; "AC"; "62"; "91"; "95"; "E4"; "79";
  "E7"; "C8"; "37"; "6D"; "8D"; "D5"; "4E"; "A9"; "6C"; "56"; "F4"; "EA"; "65"; "7A"; "AE"; "08";
  "BA"; "78"; "25"; "2E"; "1C"; "A6"; "B4"; "C6"; "E8"; "DD"; "74"; "1F"; "4B"; "BD"; "8B"; "8A";
  "70"; "3E"; "B5"; "66"; "48"; "03"; "F6"; "0E"; "61"; "35"; "57"; "B9"; "86"; "C1"; "1D"; "9E";
  "E1"; "F8"; "98"; "11"; "69"; "D9"; "8E"; "94"; "9B"; "1E"; "87"; "E9"; "CE"; "55"; "28"; "DF";
  "8C"; "A1"; "89"; "0D"; "BF"; "E6"; "42"; "68"; "41"; "99"; "2D"; "0F"; "B0"; "54"; "BB"; "16"
].

Goal nth 1 s_box 0 = "01111100" :> bitvec. r. Qed.
Goal nth 16 s_box 0 = "11001010" :> bitvec. r. Qed.
Goal bitvec_to_hex (nth 1 s_box 0) = "7C". r. Qed.
Goal bitvec_to_hex (nth 16 s_box 0) = "CA". r. Qed.

Definition inv_s_box : list byte := map byte_of_hex
[
  "52"; "09"; "6A"; "D5"; "30"; "36"; "A5"; "38"; "BF"; "40"; "A3"; "9E"; "81"; "F3"; "D7"; "FB";
  "7C"; "E3"; "39"; "82"; "9B"; "2F"; "FF"; "87"; "34"; "8E"; "43"; "44"; "C4"; "DE"; "E9"; "CB";
  "54"; "7B"; "94"; "32"; "A6"; "C2"; "23"; "3D"; "EE"; "4C"; "95"; "0B"; "42"; "FA"; "C3"; "4E";
  "08"; "2E"; "A1"; "66"; "28"; "D9"; "24"; "B2"; "76"; "5B"; "A2"; "49"; "6D"; "8B"; "D1"; "25";
  "72"; "F8"; "F6"; "64"; "86"; "68"; "98"; "16"; "D4"; "A4"; "5C"; "CC"; "5D"; "65"; "B6"; "92";
  "6C"; "70"; "48"; "50"; "FD"; "ED"; "B9"; "DA"; "5E"; "15"; "46"; "57"; "A7"; "8D"; "9D"; "84";
  "90"; "D8"; "AB"; "00"; "8C"; "BC"; "D3"; "0A"; "F7"; "E4"; "58"; "05"; "B8"; "B3"; "45"; "06";
  "D0"; "2C"; "1E"; "8F"; "CA"; "3F"; "0F"; "02"; "C1"; "AF"; "BD"; "03"; "01"; "13"; "8A"; "6B";
  "3A"; "91"; "11"; "41"; "4F"; "67"; "DC"; "EA"; "97"; "F2"; "CF"; "CE"; "F0"; "B4"; "E6"; "73";
  "96"; "AC"; "74"; "22"; "E7"; "AD"; "35"; "85"; "E2"; "F9"; "37"; "E8"; "1C"; "75"; "DF"; "6E";
  "47"; "F1"; "1A"; "71"; "1D"; "29"; "C5"; "89"; "6F"; "B7"; "62"; "0E"; "AA"; "18"; "BE"; "1B";
  "FC"; "56"; "3E"; "4B"; "C6"; "D2"; "79"; "20"; "9A"; "DB"; "C0"; "FE"; "78"; "CD"; "5A"; "F4";
  "1F"; "DD"; "A8"; "33"; "88"; "07"; "C7"; "31"; "B1"; "12"; "10"; "59"; "27"; "80"; "EC"; "5F";
  "60"; "51"; "7F"; "A9"; "19"; "B5"; "4A"; "0D"; "2D"; "E5"; "7A"; "9F"; "93"; "C9"; "9C"; "EF";
  "A0"; "E0"; "3B"; "4D"; "AE"; "2A"; "F5"; "B0"; "C8"; "EB"; "BB"; "3C"; "83"; "53"; "99"; "61";
  "17"; "2B"; "04"; "7E"; "BA"; "77"; "D6"; "26"; "E1"; "69"; "14"; "63"; "55"; "21"; "0C"; "7D"
].

Definition RC : list byte := map byte_of_hex
[
  "01"; "02"; "04"; "08"; "10"; "20"; "40"; "80"; "1b"; "36"
].

Definition list_get (ls : list byte) idx := nth idx ls 0.

Definition sub_byte (b : byte) := list_get s_box (byte_to_nat b).

Goal (map_byte sub_byte $ hex "cf4f3c09") = hex "8a84eb01". r. Qed.

Definition get_byte := get 8.
Definition set_byte := set 8.

Definition lcshift_byte := @lcshift bool 8.

Goal (lcshift_byte $ hex "09cf4f3c") = hex "cf4f3c09". r. Qed.

Definition g n (w : key_t) :=
  let w := lcshift_byte w in
  let w := map_byte sub_byte w in
  set_byte w 0 (get_byte w 0 + list_get RC n).

Goal (g 0 $ hex "09cf4f3c") = hex "8b84eb01". r. Qed.

Definition gen_round_key (w : key_t) n : key_t :=
  let w0 := get 32 w 0 in
  let w1 := get 32 w 1 in
  let w2 := get 32 w 2 in
  let w3 := get 32 w 3 in
  let w0' := w0 + g n w3 in
  let w1' := w0' + w1 in
  let w2' := w1' + w2 in
  let w3' := w2' + w3 in
  flat [w0'; w1'; w2'; w3'].

Declare Reduction c := vm_compute.

Definition test_key := hex "2b7e1516 28aed2a6 abf71588 09cf4f3c".
Goal (flip gen_round_key 0 $ test_key) = hex "a0fafe17 88542cb1 23a33939 2a6c7605". r. Qed.

Definition key_schedule (key : key_t) : key_schedule_t := flat (iter_collect gen_round_key 10 key [key]).

Definition test_key_schedule := key_schedule test_key.
Goal (get 128 test_key_schedule 10) = hex "d014f9a8 c9ee2589 e13f0cc8 b6630ca6". r. Qed.

Definition get_round_key (key : key_t) (n : nat) : b128 := get 128 (key_schedule key) n.

Definition matrix A := list (list A).

Arguments map {A B} _ _.

Definition trans_mx A def (mx : matrix A) (m n : nat) : matrix A :=
  for_n n (fun j =>
    flip map mx (fun row =>
      nth j row def)).

Definition to_row_major_mx A (m n : nat) (ls : list A) : matrix A := slice n ls.

Definition to_col_major_mx A def (m n : nat) (ls : list A) : matrix A := trans_mx def (to_row_major_mx n m ls) n m.

Definition of_row_major_mx A (mx : matrix A) (m n : nat) : list A := flat mx.

Definition of_col_major_mx A def (mx : matrix A) (m n : nat) : list A := of_row_major_mx (trans_mx def mx m n) n m.

Definition mx_mul A (def : A) (add mul : A -> A -> A) (a : matrix A) (m n : nat) (b : matrix A) (r : nat) : matrix A :=
  let b := trans_mx def b n r in
  flip mapi a (fun i arow =>
    flip mapi b (fun j bcol =>
      sum def add (map2 mul arow bcol))).

Definition test_mx := to_row_major_mx 4 4 [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16].
Definition test_mx_mx := [[90; 100; 110; 120]; [202; 228; 254; 280]; [314; 356; 398; 440]; [426; 484; 542; 600]].
Goal (mx_mul 0 plus mult test_mx 4 4 test_mx 4) = test_mx_mx. r. Qed.
Definition test_mx_mx' := [[30; 70; 110; 150]; [70; 174; 278; 382]; [110; 278; 446; 614]; [150; 382; 614; 846]].
Goal (mx_mul 0 plus mult test_mx 4 4 (trans_mx 0 test_mx 4 4) 4) = test_mx_mx'. r. Qed.

Definition shift_rows (mx : matrix byte) := mapi (fun n row => lcshift n row) mx.

Definition mix_matrix : matrix byte := to_row_major_mx 4 4 $ map byte_of_nat
[
  2; 3; 1; 1;
  1; 2; 3; 1;
  1; 1; 2; 3;
  3; 1; 1; 2
].

Definition inv_mix_matrix : matrix byte := to_row_major_mx 4 4 $ slice 8 $ flat $ map hex
[
  "0e 0b 0d 09";
  "09 0e 0b 0d";
  "0d 09 0e 0b";
  "0b 0d 09 0e"
].

Definition gf8_byte_mul (a b : byte) : byte := rev $ gf_mul 8 "11011" (rev a) (rev b).

Definition mix_rows (mx : matrix byte) := @mx_mul byte 0 xor gf8_byte_mul mix_matrix 4 4 mx 4.

Definition add_round_key (text : b128) (round_key : b128) := text + round_key.

Definition round (is_last : bool) (bits : b128) (round_key : b128) :=
  let mx := @to_col_major_mx byte 0 4 4 (slice 8 bits) in
  let mx := map (map sub_byte) mx in
  let mx := shift_rows mx in
  let mx := if is_last then mx else mix_rows mx in
  let round_key_mx := @to_col_major_mx byte 0 4 4 (slice 8 round_key) in
  let mx := map2 (map2 add_round_key) mx round_key_mx in
  flat (@of_col_major_mx byte 0 mx 4 4).

Definition test_plain := hex "32 43 f6 a8 88 5a 30 8d 31 31 98 a2 e0 37 07 34".

Definition test_r1 := hex "19 3d e3 be a0 f4 e2 2b 9a c6 8d 2a e9 f8 48 08".
Goal test_plain + get_round_key test_key 0 = test_r1. r. Qed.
Definition test_r1_after_sb := hex "d4 27 11 ae e0 bf 98 f1 b8 b4 5d e5 1e 41 52 30".
Goal (slice 8 >> map sub_byte >> flat $ test_r1) = test_r1_after_sb. r. Qed.
Definition test_r1_after_sb_mx := map (map hex) [["D4"; "E0"; "B8"; "1E"]; ["27"; "BF"; "B4"; "41"]; ["11"; "98"; "5D"; "52"]; ["AE"; "F1"; "E5"; "30"]].
Goal (slice 8 >> @to_col_major_mx byte 0 4 4 $ test_r1_after_sb) = test_r1_after_sb_mx. r. Qed.
Definition test_r1_after_shift := map (map hex) [["D4"; "E0"; "B8"; "1E"]; ["BF"; "B4"; "41"; "27"]; ["5D"; "52"; "11"; "98"]; ["30"; "AE"; "F1"; "E5"]].
Goal (shift_rows $ test_r1_after_sb_mx) = test_r1_after_shift. r. Qed.
Definition test_r1_after_mix := map (map hex) [["04"; "E0"; "48"; "28"]; ["66"; "CB"; "F8"; "06"]; ["81"; "19"; "D3"; "26"]; ["E5"; "9A"; "7A"; "4C"]].
Goal (mix_rows $ test_r1_after_shift) = test_r1_after_mix. r. Qed.
Definition test_roundkey1 := get_round_key test_key 1.
Definition test_r1_final := hex "a4 9c 7f f2 68 9f 35 2b 6b 5b ea 43 02 6a 50 49".
Goal (round false test_r1 test_roundkey1) = test_r1_final. r. Qed.
Definition test_r2_final := hex "aa 8f 5f 03 61 dd e3 ef 82 d2 4a d2 68 32 46 9a".
Goal (round false test_r1_final (get_round_key test_key 2)) = test_r2_final. r. Qed.

Definition encrypt (key : key_t) (plaintext : b128) :=
  let keys := slice 128 (key_schedule key) in
  let get_key n := nth n keys (zeros 128) in
  let after0 := add_round_key plaintext (get_key 0) in
  let after9 := fold_left (round false) (range 1 9 keys) after0 in
  round true after9 (get_key 10).

Definition test_cipher := hex "39 25 84 1d 02 dc 09 fb dc 11 85 97 19 6a 0b 32".
Goal encrypt test_key test_plain = test_cipher. r. Qed.

Definition test_plain2 := hex "00 11 22 33 44 55 66 77 88 99 aa bb cc dd ee ff".
Definition test_key2 := hex "00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f".
Definition test_cipher2 := hex "69 c4 e0 d8 6a 7b 04 30 d8 cd b7 80 70 b4 c5 5a".
Goal encrypt test_key2 test_plain2 = test_cipher2. r. Qed.

Definition test_plain3 := hex "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00".
Definition test_key3 := hex "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00".
Definition test_cipher3 := hex "66 e9 4b d4 ef 8a 2c 3b 88 4c fa 59 ca 34 2b 2e".
Goal encrypt test_key3 test_plain3 = test_cipher3. r. Qed.

Definition test_plain4 := hex "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00".
Definition test_key4 := hex "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01".
Definition test_cipher4 := hex "05 45 aa d5 6d a2 a9 7c 36 63 d1 43 2a 3d 1c 84".
Goal encrypt test_key4 test_plain4 = test_cipher4. r. Qed.

Definition test_plain5 := hex "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01".
Definition test_key5 := hex "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00".
Definition test_cipher5 := hex "58 e2 fc ce fa 7e 30 61 36 7f 1d 57 a4 e7 45 5a".
Goal encrypt test_key5 test_plain5 = test_cipher5. r. Qed.

Definition inv_shift_rows (mx : matrix byte) := mapi (fun n row => rcshift n row) mx.

Definition inv_sub_byte (b : byte) := list_get inv_s_box (byte_to_nat b).

Definition inv_mix_rows (mx : matrix byte) := @mx_mul byte 0 xor gf8_byte_mul inv_mix_matrix 4 4 mx 4.

Definition inv_round (is_last : bool) (bits : b128) (round_key : b128) :=
  let mx := @to_col_major_mx byte 0 4 4 (slice 8 bits) in
  let mx := inv_shift_rows mx in
  let mx := map (map inv_sub_byte) mx in
  let round_key_mx := @to_col_major_mx byte 0 4 4 (slice 8 round_key) in
  let mx := map2 (map2 add_round_key) mx round_key_mx in
  let mx := if is_last then mx else inv_mix_rows mx in
  flat (@of_col_major_mx byte 0 mx 4 4).

Definition decrypt (key : key_t) (ciphertext : b128) :=
  let keys := slice 128 (key_schedule key) in
  let get_key n := nth n keys (zeros 128) in
  let after0 := add_round_key ciphertext (get_key 10) in
  let after9 := fold_left (inv_round false) (rev $ range 1 9 keys) after0 in
  inv_round true after9 (get_key 0).

Goal decrypt test_key test_cipher = test_plain. r. Qed.
Goal decrypt test_key2 test_cipher2 = test_plain2. r. Qed.
Goal decrypt test_key3 test_cipher3 = test_plain3. r. Qed.
Goal decrypt test_key4 test_cipher4 = test_plain4. r. Qed.
Goal decrypt test_key5 test_cipher5 = test_plain5. r. Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Coq Require Import ZArith Decimal String DecimalString.

Section DecimalStringConversions.

  (*
    Decimal.int is renamed to Decimal.signed_int to avoid name clashes since 8.16.0.
    Do not use Decimal.int or any function involving Decimal.int to avoid name clashes.
    See https://github.com/coq/coq/issues/7017.
   *)

  Local Open Scope string_scope.

  Definition newline := String (Ascii.ascii_of_N 10) EmptyString.

  Variant signed_int := Pos (d : uint) | Neg (d : uint).

  Definition nat_to_signed_int (n : nat) : signed_int := Pos (Nat.to_uint n).

  Definition positive_to_signed_int (n : positive) : signed_int := Pos (Pos.to_uint n).

  Definition N_to_signed_int (n : N) : signed_int := Pos (N.to_uint n).

  Definition Z_to_signed_int (n : Z) : signed_int :=
    match n with
    | Z0 => Pos (Nat.to_uint O)
    | Zpos m => Pos (Pos.to_uint m)
    | Zneg m => Neg (Pos.to_uint m)
    end.

  Definition string_of_signed_int (d : signed_int) :=
    match d with
    | Pos d => NilEmpty.string_of_uint d
    | Neg d => "-" ++ (NilEmpty.string_of_uint d)
    end.

  Definition string_of_nat (n : nat) : string :=
    string_of_signed_int (nat_to_signed_int n).

  Definition string_of_positive (n : positive) : string :=
    string_of_signed_int (positive_to_signed_int n).

  Definition string_of_N (n : N) : string :=
    string_of_signed_int (N_to_signed_int n).

  Definition string_of_Z (n : Z) : string :=
    string_of_signed_int (Z_to_signed_int n).

End DecimalStringConversions.

Module Type Printer.
  Parameter t : Type.
  Parameter to_string : t -> string.
End Printer.


(**

To play this document inside your browser use ALT-N and ALT-P.

----
#
#
** Objective of this course

  Give you access to the #Mathematical Components library#

  - formalization principles
  - proof language
  - familiarize with some theories

#
#

----------------------------------------------------------
#
#
** Why another library? Why another language?

  - large, consistent, library organized as a programming language
    library (interfaces, overload, naming conventions, ...)
  - maintainable in the long term (compact, stable, ...)
  - validated on large formalization projects

#
#

----------------------------------------------------------
#
#
** Roadmap of the first 2 lessons

  - the small scale reflection approach (ssr)
  - the ssreflect tactic language (ssr)
  - basic libraries (ssrbool, ssrnat, seq)

#
#

----------------------------------------------------------
#
#
** Disclaimer: this is not standard Coq

  - things are done differently, very differently, than usual
  - it is not easy to appreciate the benefits on small examples,
    but we will try hard ;-)
  - not enough time to explain eveything, I'll focus on
    intuition rather than technical details
#
#

----------------------------------------------------------
----------------------------------------------------------
#
#
** The SSR approach

  - when a concept is "computable", lets represent it as a
    computable function, not as an inductive relation
  - Coq knows how to compute, even symbolically, and computation is
    a very stable form of automation
  - functions to bool are a "simple" concept in type theory
    - EM holds
    - UIP holds

*)

From mathcomp Require Import all_ssreflect.

Module BooleanReflection.
(**
#
#
----------------------------------------------------------
#
#
** A taste of boolean reflection by examples
  - these examples are artificial
  - in the library things are done in a slightly different way
#
#
------------------------------------------------------
#
#
*** The first predicate
   - order ralation on nat is a program
   - if-is-then syntax (simply a 2-way match-with-end)
   - [.+1] syntax (postfix notations [.something] are recurrent)

*)
Fixpoint leq (n m : nat) : bool :=
  if n is p.+1 then
    if m is q.+1 then leq p q
    else false
  else true.

Arguments leq !n !m.
Infix "<=" := leq.

(**
#
#
------------------------------------------------------
#
#
 *** The first proof about leq
   - [... = true] to "state" something
   - proof by computation
   - [by []] to say, provable by trivial means (no mean is inside []).
   - [by tac] to say: tac must solve the goal (up to trivial leftovers)
*)
Lemma leq0n n : (0 <= n) = true.
Proof. (* compute. *) by []. Qed.

(**
#
#
------------------------------------------------------
#
#
*** Another lemma about leq
   - equality as a double implication
   - naming convention
*)
Lemma leqSS n m : (n.+1 <= m.+1) = (n <= m).
Proof. (* simpl. *) by []. Qed.

(**
#
#
------------------------------------------------------
#
#
*** Lets (not) use these lemmas
   - elim with naming and automatic clear of n
   - indentation for subgoals
   - no need to mention lemmas proved by computation
   - apply, exact, rewrite
*)
Lemma leqnn n : (n <= n) = true.
Proof.
(*#
elim: n => [|m IHm].
  by apply: leq0n.  exact: leq0n.
by rewrite leqSS IHm.
#*)
by elim: n. Qed.

(**
#
#
------------------------------------------------------
#
#
*** Connectives can be booleans too *)
Definition andb (b1 b2 : bool) : bool :=
  if b1 then b2 else false.
Infix "&&" := andb.

Definition orb (b1 b2 : bool) : bool :=
  if b1 then true else b2.
Infix "||" := orb.

Definition negb b : bool :=
  if b then false else true.
Notation "~~ b" := (negb b).

(**
#
#
------------------------------------------------------
#
#
*** Proofs by truth tables
   - we can use EM to reason about boolean predicates
     and connectives
   - case
   - bookkeeping [/=]
   - naming convention: C suffix
*)
Lemma andbC b1 b2 : (b1 && b2) = (b2 && b1).
Proof.
(*
case: b1 => /=.
  by case: b2.
by case: b2.
*)
by case: b1; case: b2. Qed.

(**
#
#
------------------------------------------------------
#
#
*** Bookkeeping 101
   - defective case (stack model, the _top_ implicit tactic argument)
   - tactic=>
   - tactic:        (caveat: tactic != apply or exact)
   - "rename", "reorder"
*)
Lemma negb_and : forall b c, ~~ (b && c) = ~~ b || ~~ c.
Proof.
(*
move=> b. move=> c. move: b. move: c.
move=> c b. move: b c.
move=> b; case: b; move=> c; case: c.
*)
by case; case. Qed.

End BooleanReflection.
(**
#
#
------------------------------------------------------
#
#
** Recap (ssr approach and basic tactics)
   - boolean predicates and connectives
   - think "up to" computation
   - case, elim, move, :, =>, basic rewrite
   - if-is-then-else, .+1
   - naming convetion

#
#
------------------------------------------------------
------------------------------------------------------
#
#
** The real MathComp library

   Things to know:
   - [Search head_symbol (pat _ term) "string" name]
   - [(a < b)] is a notation for [(a.+1 <= b)]
   - [==] stands for computable equality (overloaded)
   - [!=] is [~~ (_ == _)]
   - [is_true] coercion
*)
Search _ (_ <= _) in ssrnat.
Locate "_ < _".
Check (forall x, x.+1 <= x).
Search _ orb "C" in ssrbool.
Print commutative.
Check (3 == 4) || (3 <= 4).
Eval compute in (3 == 4) || (3 <= 4).
Check (true == false).
Check (3 != 4).

Lemma test_is_true_coercion : true.
Proof. unfold is_true. by []. Qed.

(**
#
#
-------------------------------------------------------------
#
#
** Equality
   - privileged role (many lemmas are stated with = or is_true)
   - the [eqP] view: "is_true (a == b)   <->    a = b"
   - [=> /eqP] (both directions)
   - [=> ->] (on the fly rewrite, "subst")
   - notation [.*2]

*)
Lemma test_eqP n m : n == m -> n.+1 + m.+1 = m.+1.*2.
Proof.
(*#
Check eqP.
move=> /eqP. move=> /eqP. move=> /eqP Enm. rewrite Enm.
Search _ (_ + _) _.*2 in ssrnat.
exact: addnn.
#*)
by move=> /eqP ->; rewrite -addnn. Qed.

(**
#
#
-------------------------------------------------------------
#
#
 ** Infix [==] is overloaded
   - and [eqP] is too
*)
Lemma test2_eqP b1 b2 : b1 == ~~ b2 -> b1 || b2.
Proof.
(*
Search _ orb in ssrbool.
*)
by move=> /eqP->; exact: orNb.
Qed.

(**
#
#
------------------------------------------------------------
#
#
** Views are just lemmas
   (plus some automatic adaptors)
   - lemmas like [A -> B] can be used as views too
   - boolean connectives have associated views
   - [=> [ ... ]]

*)

Lemma test_leqW i j k : (i <= k) && (k.+1 <= j) -> i <= j.+1.
Proof.
(*# move=> /andP. case. move=> /leqW. move=> leq_ik1. #*)
move=> /andP[/leqW leq_ik1 /leqW leq_k1j1].
exact: leq_trans leq_ik1 leq_k1j1.
Qed.

(**
#
#
------------------------------------------------------------
#
#
** The reflect predicate
   - [reflect P b] is the preferred way to state that
     the predicate [P] (in [Prop]) is logically equivalent
     to [b=true]

*)
Module reflect_for_eqP.

Print reflect.

Fixpoint eqn m n :=
  match m, n with
  | 0, 0 => true
  | j.+1,k.+1 => eqn j k
  | _, _ => false
  end.
Arguments eqn !m !n.

(**
#
#
----------------------------------------------------------
#
#
*** Proving the reflection lemma for eqn
    - the convenience lemma [iffP]
    - the [congr] tactic
    - trivial branches //
    - loaded induction [elim: n m]

*)
Lemma myeqP m n : reflect (m = n) (eqn m n).
Proof.
(*#
apply: (iffP idP) => [|->]; last by elim: n.
elim: m n; first by case.
move=> n IHn m eq_n1m.
case: m eq_n1m => // m eq_n1m1.
congr (_.+1).
exact: IHn.
#*)
apply: (iffP idP) => [|->]; last by elim: n.
by elim: m n => [|m IHm] // [|n] // /IHm->.
Qed.

Lemma test_myeqP n m : (eqn n m) -> m = n.
Proof. by move=> /myeqP ->. Qed.

End reflect_for_eqP.

(**
#
#
--------------------------------------
#
#
** rewrite, one command to rule them all
  - rewrite
  - side condition and // ?
  - rewrite a boolean predicate (is_true hides an eqaution)

*)

Lemma test_leq_cond p : prime p -> p.-1.+1 + p = p.*2.
Proof.
(*#
move=> pr_p.
Search _ predn in ssrnat.
rewrite prednK.
  by rewrite addnn.
Search _ prime leq 0.
by apply: prime_gt0.
#*)
by move=> pr_p; rewrite prednK ?addnn // prime_gt0.
Qed.

(**
#
#
----
#
#
** References for this lesson
  - SSReflect #manual#
  - documentation of the
       #library#
    - in particular #ssrbool#
    - in particular #ssrnat#
  - #Book# (draft) on the Mathematical Components library
    ##
#
#
*)


(** This library describes a [fin_subst] (called a substitution in
    Eder's paper), which is a rule for substituting terms for
    variables in a term. *)

Require Import Lists.List.

Require Import Top.FinSet.FinMod.
Require Import Top.FinSet.ListMod.

Require Import Top.Terms.Term.
Require Import Top.Terms.VecUtils.
Require Import Top.Terms.TermAt.

(** * Substitutions

    Eder's paper talks about substitutions as if they are
    endomorphisms on Term, but he is only interested in the
    endomorphisms that come about from actual substitutions: maps
    from variables to terms which may or may not themselves be
    variables.

    Let's start by defining the induced endomorphism on Term that
    comes from a substitution. *)
Section subst.
  Variable L : lType.

  Definition Subst := Term.V L -> Term L.

  Fixpoint subst_endo (s : Subst) (t : Term L) : Term L :=
    match t with
    | varTerm _ v => s v
    | funTerm f ts => funTerm f (VectorDef.map (subst_endo s) ts)
    end.

  (** One map from [V] to [Term] is [varTerm] (the [Term] constructor
      for variable names). This should induce the identity. The point
      is that the induced endomorphism is exactly filling in each "v"
      with "v" again.  *)

  Lemma subst_endo_varTerm {t}
    : subst_endo (varTerm L) t = t.
  Proof.
    revert t; apply Term_ind'; try reflexivity.
    intros f ts allH.
    unfold subst_endo; fold subst_endo.
    apply f_equal.
    induction ts as [ | t n ts IH ]; try reflexivity.
    destruct allH as [ tH tsH ].
    specialize (IH tsH); clear tsH.
    unfold VectorDef.map;
      fold (@VectorDef.map (Term L) _ (subst_endo (varTerm L))).
    rewrite IH, tH.
    exact eq_refl.
  Qed.

  (** Another fact we might want to know about these induced
      endomorphisms is extensionality. That is, if two substitutions
      have the same values on all of [V] then their induced
      endomorphisms have the same values on all of [Term]. (This sort
      of messing around is needed because functions aren't extensional
      in Coq). *)

  Lemma subst_endo_ex {s s' t}
    : (forall v, s v = s' v) -> subst_endo s t = subst_endo s' t.
  Proof.
    intro eqH.
    revert t; apply Term_ind'.
    - intro v; specialize (eqH v). tauto.
    - intros f ts allH.
      unfold subst_endo; fold subst_endo.
      apply f_equal.
      apply vec_map_ext.
      exact allH.
  Qed.

  (** Obviously, we can't compose substitutions directly (because they
      are maps [V -> Term]). However, we can compose their induced
      endomorphisms and then restrict back to variables by composing
      with [varTerm]. *)

  Definition comp_subst (sigma tau : Subst) : Subst :=
    fun v => subst_endo sigma (tau v).

  (** Fortunately, given the name, [comp_subst] is indeed the right
      notion of composition of substitutions. In fact, if you compose
      the induced endomorphisms from two substitutions, you get the
      same thing as if you use [comp_subst] to compose the
      substitutions and then induce the endomorphism. *)

  Lemma compose_subst_endo (sigma tau : Subst) (t : Term L)
    : subst_endo sigma (subst_endo tau t) =
      subst_endo (comp_subst sigma tau) t.
  Proof.
    revert t; apply Term_ind'; try tauto.
    intros f ts IH.
    unfold subst_endo; fold subst_endo; apply f_equal.
    rewrite vec_map_map.
    auto using vec_map_ext.
  Qed.

  (** As you would hope, [varTerm] is a left and right identity for
      [comp_subst]. *)

  Lemma comp_subst_idl {sigma v} : comp_subst (varTerm L) sigma v = sigma v.
  Proof.
    unfold comp_subst; auto using subst_endo_varTerm.
  Qed.

  Lemma comp_subst_idr {sigma v} : comp_subst sigma (varTerm L) v = sigma v.
  Proof.
    unfold comp_subst; auto using subst_endo_varTerm.
  Qed.

  (** Also, unsurprisingly, [comp_subst] is associative. *)

  Lemma comp_subst_assoc {s1 s2 s3 v}
    : comp_subst s1 (comp_subst s2 s3) v = comp_subst (comp_subst s1 s2) s3 v.
  Proof.
    unfold comp_subst; simpl.
    generalize (s3 v); clear s3 v.
    apply Term_ind'; try reflexivity.
    intros f ts IH.
    unfold subst_endo at 2; fold subst_endo.
    unfold subst_endo at 1; fold subst_endo.
    unfold subst_endo at 3; fold subst_endo.
    apply f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    exact IH.
  Qed.

  (** A technical lemma about extensionality. If we have two
      factorisations where the factors are extensionally equal, then the
      composite maps must be too. *)

  Lemma comp_subst_ex {r r' s s'} (v : Term.V L)
    : (forall v, r v = r' v) ->
      (forall v, s v = s' v) ->
      comp_subst r s v = comp_subst r' s' v.
  Proof.
    intros rH sH.
    unfold comp_subst; rewrite sH, (subst_endo_ex rH); auto.
  Qed.

  (** Define the image of a substitution: the terms that you get when
      applying the substitution to each variable in [V]. The set is
      encoded as a predicate. *)
  Definition subst_im (s : Subst) (t : Term L) : Prop :=
    exists v, t = s v.

  (** * Finite substitutions

      Now we get to an important definition: [fin_subst]. Eder is only
      interested in substitutions that map only finitely many
      variables differently from [varTerm]. In our development, this
      means that it should be a finite modification of [varTerm]. *)

  Definition is_fin_subst := fin_mod (varTerm L).

  Definition fin_subst := sigT is_fin_subst.

  Definition fin_subst_subst : fin_subst -> Subst :=
    projT1 (P := is_fin_subst).

  Definition fin_subst_ext_eq (s s' : fin_subst) : Prop :=
    forall v, fin_subst_subst s v = fin_subst_subst s' v.

  (** We can construct our first [fin_subst] from varTerm. Since this
      is a trivial modification of [varTerm], it definitely satisfies
      the definition. *)

  Lemma fin_subst_varTerm : is_fin_subst (varTerm L).
  Proof.
    apply fin_mod_i.
  Qed.

  (** It's a bit more difficult to show that [fin_subst] maps are
      closed under composition (using [comp_subst]). I think that the
      substitution that induces the composition of two induced
      endomorphisms is actually easiest to define by concatenating
      lists, so we start in terms of list maps. *)

  Section fin_comp_subst.
    Variables sigma tau : Subst.
    Variable sl tl : list (Term.V L * Term L).

    Hypothesis decV : forall x y : Term.V L, {x = y} + {x <> y}.
    Hypothesis decF : forall x y : Term.F L, {x = y} + {x <> y}.

    Hypothesis sH : forall v, sigma v = list_map decV (varTerm L) sl v.
    Hypothesis tH : forall v, tau v = list_map decV (varTerm L) tl v.

    (** A list inducing the correct correct composed map ([compose
        sigma tau]) is given by first mapping all the variables to
        where [tau] would send them and then applying the induced map
        from [sigma] to the resulting term.

        Variables that weren't moved by [tau] get mapped by [sigma],
        which we can express by shoving them to the end of the
        list. *)

    Local Definition stl : list (Term.V L * Term L) :=
      app (map (fun p => (fst p, subst_endo sigma (snd p))) tl)
          sl.

    Lemma stl_map_v v
      : list_map decV (varTerm L) stl v = comp_subst sigma tau v.
    Proof.
      specialize (tH v).
      unfold comp_subst, subst_endo, stl.
      set (pmap := (fun p => (fst p, subst_endo sigma (snd p)))).
      revert tau tH.
      induction tl as [ | p tl' IH ].
      - intros; rewrite tH; simpl; auto.
      - intros tau tH.
        clear tl; rename tl' into tl.
        rewrite (map_cons pmap p tl), <- app_comm_cons.
        destruct p as [ v' sv' ].
        destruct (decV v' v) as [ veqH | vneH ].
        + rewrite veqH in *; clear v' veqH.
          simpl in tH; rewrite upd_map_at in tH.
          unfold pmap; simpl; rewrite upd_map_at.
          rewrite tH. tauto.
        + unfold pmap at 1; simpl.
          rewrite (upd_map_not_at decV _ _ (not_eq_sym vneH)).
          simpl in tH.
          rewrite (upd_map_not_at decV _ _ (not_eq_sym vneH)) in tH.
          apply IH.
          apply tH.
    Qed.
  End fin_comp_subst.

  (** Since we worked in terms of list maps, we now must use the
      correspondence between those and finite mods to conclude that
      the composition of two finite substitutions is itself finite
      (assuming that equality of terms is decidable) *)

  Lemma is_fin_subst_comp sigma tau
    : (forall x y : Term.V L, {x = y} + {x <> y}) ->
      (forall x y : Term.F L, {x = y} + {x <> y}) ->
      is_fin_subst sigma -> is_fin_subst tau ->
      is_fin_subst (comp_subst sigma tau).
  Proof.
    unfold fin_subst.
    intros decV decF fmS fmT.
    set (decT := (decTerm decV decF)).
    apply (fin_mod_ex _ _ _ (comp_subst sigma tau)
                      (fun x => eq_refl (varTerm L x))
                      (stl_map_v _ _ _ _ decV
                                 (fin_mod_is_list_map decV decT fmS)
                                 (fin_mod_is_list_map decV decT fmT))).
    apply list_map_is_fin_mod; auto.
  Qed.

  Definition fin_subst_comp
    : (forall x y : Term.V L, {x = y} + {x <> y}) ->
      (forall x y : Term.F L, {x = y} + {x <> y}) ->
      fin_subst -> fin_subst -> fin_subst :=
    fun decV decF sigma tau =>
      let (s, sH) := sigma in
      let (t, tH) := tau in
      existT _ (comp_subst s t) (is_fin_subst_comp s t decV decF sH tH).

  Lemma fin_subst_subst_comp
        (decV : forall x y : Term.V L, {x = y} + {x <> y})
        (decF : forall x y : Term.F L, {x = y} + {x <> y})
        s t v
  : fin_subst_subst (fin_subst_comp decV decF s t) v =
    comp_subst (fin_subst_subst s) (fin_subst_subst t) v.
  Proof.
    destruct s, t; auto.
  Qed.

  (** Finally, we show that restricting a finite substitution to
      variables satisfying some predicate doesn't stop it being
      finite. *)

  Lemma is_fin_subst_restrict
        {s P} (decP : forall v : Term.V L, {P v} + {~ P v})
    : is_fin_subst s -> is_fin_subst (restrict_map (varTerm L) P decP s).
  Proof.
    unfold fin_subst.
    apply restrict_preserves_fin_mod.
  Qed.

  Definition fin_subst_restrict
             {P} (decP : forall v : Term.V L, {P v} + {~ P v})
    : fin_subst -> fin_subst :=
    fun sigma =>
      let (s, sH) := sigma in
      existT _ (restrict_map (varTerm L) P decP s)
             (is_fin_subst_restrict decP sH).

  Lemma term_height_subst {s}
    : forall t, term_height t <= term_height (subst_endo s t).
  Proof.
    apply Term_ind'; auto using le_0_n.
    intros.
    apply le_n_S; fold (subst_endo s); fold term_height.
    auto using vec_max_at_map_le.
  Qed.

  Lemma term_height_comp_subst {s' s v}
    : term_height (s v) <= term_height (comp_subst s' s v).
  Proof.
    apply term_height_subst.
  Qed.

  (** Since [subst_endo] is defined by recursing on terms, it commutes
      with [term_at] in the way you'd expect *)

  Lemma term_at_subst_endo pos s t t'
    : term_at pos t = Some t' ->
      term_at pos (subst_endo s t) = Some (subst_endo s t').
  Proof.
    revert t; induction pos as [ | i pos IH ]; intro t.
    - simpl; intro someH; injection someH; intro tH; rewrite tH; auto.
    - destruct t; [ inversion 1 | ].
      simpl; destruct (Compare_dec.lt_dec i (Term.a L f)) as [ ltH | ];
        [ | inversion 1 ].
      rewrite vec_map_nth_order.
      apply IH.
  Qed.

End subst.

Hint Rewrite fin_subst_subst_comp : fin_subst.


Require Import HoTT.Basics HoTT.Types HoTT.HIT.Truncations.

Local Open Scope list_scope.

Definition ctxS := list Type.
Fixpoint eval_ctx (c : ctxS) : Type :=
  match c with
  | nil => Unit
  | A :: c => A * eval_ctx c
  end.

Inductive varS (A : Type) : ctxS -> Type :=
| here : forall Γ, varS A (A :: Γ)
| next : forall Γ, varS A Γ -> forall B, varS A (B :: Γ).

(* Fixpoint nat_varS {A Γ} (x : @varS A Γ) : nat := *)
(*   match x with *)
(*   | here _ => 0 *)
(*   | next Γ x B => S (nat_varS x) *)
(*   end. *)

Fixpoint eval_var {A Γ} (x : varS A Γ) : eval_ctx Γ -> A
  := match x with
     | here Γ => fst
     | next Γ x B =>
       (eval_var x) o snd
     end.

Inductive exprS (Γ : ctxS) : Type -> Type :=
| constE : forall A, A -> exprS Γ A
| constfunE : forall A B, (A -> B) -> exprS Γ A -> exprS Γ B
| varE : forall A,  varS A Γ -> exprS Γ A
| pairE : forall A B, exprS Γ A -> exprS Γ B -> exprS Γ (A * B).

Fixpoint eval_expr {Γ A} (e : exprS Γ A) : eval_ctx Γ -> A :=
  match e with
  | constE A x => fun _ => x
  | constfunE A B f a => f o (eval_expr a)
  | varE A x => eval_var x
  | pairE A B a b => fun x => (eval_expr a x, eval_expr b x)
  end.

Fixpoint uses_truncmaps n {Γ A} (a : exprS Γ A) : Type :=
  match a with
  | constE A a => forall b, IsTrunc n (a = b)
  | constfunE A B f a => IsTruncMap n f * uses_truncmaps n a
  | varE _ _ => Unit
  | pairE A B a b => uses_truncmaps n a * uses_truncmaps n b
  end.

Fixpoint ishprop_uses_truncmaps `{Funext} {n Γ A} (a : exprS Γ A) : IsHProp (uses_truncmaps n a)
  := match a with
     | constE A _ => trunc_forall
     | constfunE A B f a => trunc_prod
     | varE _ _ => trunc_succ
     | pairE A B a b => trunc_prod
     end.
Existing Instance ishprop_uses_truncmaps.

Inductive count := Never | Once | Many.

Definition incc x :=
  match x with
  | Never => Once
  | _ => Many
  end.

Definition merge_count x y :=
  match x with
  | Never => y
  | Once => incc y
  | Many => Many
  end.

Fixpoint counts (Γ : ctxS) : Type :=
  match Γ with
    | nil => Unit
    | A :: Γ => count * counts Γ
  end.

Fixpoint merge_counts {Γ} : counts Γ -> counts Γ -> counts Γ
  := match Γ return counts Γ -> counts Γ -> counts Γ with
     | nil => fun _ _ => tt
     | A :: Γ =>
       fun c1 c2 =>
         (merge_count (fst c1) (fst c2), merge_counts (snd c1) (snd c2))
     end.

Fixpoint counts_init (Γ : ctxS) : counts Γ
  := match Γ with
     | nil => tt
     | A :: Γ => (Never, counts_init Γ)
     end.

Definition cond_of_count n A c :=
  match c with
  | Never => IsTrunc n A
  | Once => Unit
  | Many => IsTrunc n.+1 A
  end.

Definition local_of_count@{i} n (A:Type@{i}) c : Type@{i} :=
  match c with
  | Many => IsTrunc n A
  | Never | Once => Unit
  end.

Fixpoint cond_of_counts n {Γ} : counts Γ -> Type :=
  match Γ return counts Γ -> Type with
  | nil => fun _ => Unit
  | A :: Γ =>
    fun c => cond_of_count n A (fst c) * cond_of_counts n (snd c)
  end.

Fixpoint local_of_counts n {Γ} : counts Γ -> Type :=
  match Γ return counts Γ -> Type with
  | nil => fun _ => Unit
  | A :: Γ =>
    fun c => local_of_count n A (fst c) * local_of_counts n (snd c)
  end.

Definition local_unmerge_count {n A} c1 c2 (Hcs : local_of_count n A (merge_count c1 c2))
  : local_of_count n A c1 * local_of_count n A c2.
Proof.
  destruct c1,c2;simpl in *;auto.
Qed.

Fixpoint local_unmerge_counts {n Γ} : forall c1 c2 : counts Γ,
    local_of_counts n (merge_counts c1 c2) ->
    local_of_counts n c1 * local_of_counts n c2.
Proof.
  destruct Γ as [|A Γ];simpl;intros c1 c2.
  - intros _;exact (tt,tt).
  - intros [HA HΓ].
    apply local_unmerge_counts in HΓ.
    apply local_unmerge_count in HA.
    destruct HA as [HA1 HA2], HΓ as [HΓ1 HΓ2];auto.
Qed.

Fixpoint cond_implies_local {n Γ} : forall c : counts Γ, cond_of_counts n c -> local_of_counts n.+1 c.
Proof.
  destruct Γ as [|A Γ];simpl;intros c.
  - intros _; exact tt.
  - refine (functor_prod _ (cond_implies_local _ _ (snd c))).
    generalize (fst c);clear c;intros c;destruct c;simpl;auto.
Qed.

Fixpoint counts_of_var {A Γ} (x : varS A Γ) : counts Γ :=
  match x with
  | here Γ =>
    (Once, counts_init Γ)
  | next Γ x B =>
    (Never, counts_of_var x)
  end.

Fixpoint count_expr {Γ A} (a : exprS Γ A) : counts Γ
  := match a with
     | constE A a => counts_init Γ
     | constfunE A B f a => count_expr a
     | varE A x => counts_of_var x
     | pairE A B a b => merge_counts (count_expr a) (count_expr b)
     end.

Definition global_cond n {Γ A} (a : exprS Γ A)
  := cond_of_counts n (count_expr a).

(* expressions describing functions such that we can prove the function is an embedding. *)
Inductive mexpr : Type -> Type -> Type :=
| mconst : forall A B, B -> mexpr A B
| mid : forall A, mexpr A A
| mapplyl : forall A B C, (B -> C) -> mexpr A B -> mexpr A C
| mapplyr : forall A B C, mexpr B C -> (A -> B) -> mexpr A C
| mpair : forall A B C D,
    mexpr A B -> mexpr C D ->
    mexpr (A * C) (B * D).

Fixpoint eval_mexpr {A B} (e : mexpr A B) : A -> B
  := match e with
     | mconst A B x => fun _ => x
     | mid A => idmap
     | mapplyl A B C g ef => g o (eval_mexpr ef)
     | mapplyr A B C eg f => (eval_mexpr eg) o f
     | mpair A B C D ef eg => functor_prod (eval_mexpr ef) (eval_mexpr eg)
     end.

Fixpoint mcond n {A B} (e : mexpr A B) :=
  match e with
  | mconst A B x => IsTrunc n A * forall y, IsTrunc n (x = y)
  | mid _ => Unit
  | mapplyl A B C g ef => IsTruncMap n g * mcond n ef
  | mapplyr A B C eg f => mcond n eg * IsTruncMap n f
  | mpair A B C D ef eg => mcond n ef * mcond n eg
  end.

Definition dup A (x : A) := (x,x).

Instance istruncmap_dup {n A} {Atrunc : IsTrunc n.+1 A} : IsTruncMap n (dup A).
Proof.
  intros [y1 y2].
  srefine (trunc_equiv' (y1=y2) _).
  srefine (equiv_adjointify _ _ _ _).
  - intros p;exists y1;destruct p;reflexivity.
  - intros [x p].
    exact (ap fst p^ @ ap snd p).
  - intros [x p].
    revert p;apply (equiv_ind (Prod.path_prod_uncurried _ _));intros [p1 p2].
    simpl in * |-;destruct p1,p2. reflexivity.
  - intros p;destruct p. reflexivity.
Defined.

Instance istruncmap_S {n A B} (f : A -> B) {Hf : IsTruncMap n f} : IsTruncMap n.+1 f := fun y => _.

Instance istruncmap_isequiv {n A B} (f : A -> B) `{!IsEquiv f} : IsTruncMap n f.
Proof.
  induction n as [|n IHn].
  - red;apply EquivalenceVarieties.fcontr_isequiv,_.
  - apply _.
Qed.

Fixpoint mcond_S {n A B} (e : mexpr A B) (He : mcond n e) {struct e} : mcond n.+1 e.
Proof.
  destruct e as [A B x|A|A B C g ef|A B C eg f|A B C D ef eg];simpl in *.
  - destruct He;split;apply _.
  - trivial.
  - destruct He;split;[exact _|auto].
  - destruct He;split;[auto|exact _].
  - destruct He;auto.
Qed.

Fixpoint istruncmap_mcond {n A B} (e : mexpr A B) : mcond n e -> IsTruncMap n (eval_mexpr e).
Proof.
  destruct e as [A B x|A|A B C g ef|A B C eg f|A B C D ef eg];simpl;intros Hcond.
  - destruct Hcond as [HA HB]. exact _.
  - apply _.
  - destruct Hcond as [Hg Hf].
    apply Fibrations.istruncmap_compose.
    + exact Hg.
    + exact (istruncmap_mcond _ _ _ _ Hf).
  - destruct Hcond as [Hg Hf].
    apply Fibrations.istruncmap_compose.
    + exact (istruncmap_mcond _ _ _ _ Hg).
    + exact Hf.
  - destruct Hcond as [Hf Hg].
    apply Fibrations.istruncmap_functor_prod.
    + exact (istruncmap_mcond _ _ _ _ Hf).
    + exact (istruncmap_mcond _ _ _ _ Hg).
Qed.

Fixpoint subctx {Γ} : counts Γ -> Type :=
  match Γ with
  | nil => fun _ => Unit
  | A :: Γ =>
    fun c => match fst c with
          | Never => subctx (snd c)
          | _ => A * subctx (snd c)
          end
  end.

Fixpoint subctx_into {Γ} : forall c : counts Γ, eval_ctx Γ -> subctx c.
Proof.
  destruct Γ as [|A Γ].
  - simpl. intros _ _;exact tt.
  - simpl. intros c. destruct (fst c).
    + exact ((subctx_into _ _) o snd).
    + exact (functor_prod idmap (subctx_into _ _)).
    + exact (functor_prod idmap (subctx_into _ _)).
Defined.

Lemma istruncmap_fst {n} A B `{!IsTrunc n B} : IsTruncMap n (@fst A B).
Proof.
  intros x.
  refine (trunc_equiv' B _).
  srefine (equiv_adjointify _ _ _ _).
  - intros y;exists (x,y). reflexivity.
  - intros xy;exact (snd (xy.1)).
  - intros [[x' y] p]. destruct p;reflexivity.
  - intros y. reflexivity.
Qed.

Lemma istruncmap_snd {n} A B `{!IsTrunc n A} : IsTruncMap n (@snd A B).
Proof.
  intros y.
  refine (trunc_equiv' A _).
  srefine (equiv_adjointify _ _ _ _).
  - intros x;exists (x,y). reflexivity.
  - intros xy;exact (fst (xy.1)).
  - intros [[x y'] p]. destruct p;reflexivity.
  - intros x. reflexivity.
Qed.

Fixpoint istruncmap_subctx_into {n Γ} : forall c : counts Γ,
    cond_of_counts n c -> IsTruncMap n (subctx_into c).
Proof.
  destruct Γ as [|A Γ];simpl.
  - intros _ _;apply _.
  - intros [[] c];simpl;intros [HA HΓ].
    + apply Fibrations.istruncmap_compose;[apply istruncmap_subctx_into,HΓ|].
      apply istruncmap_snd,_.
    + apply istruncmap_subctx_into in HΓ. exact _.
    + apply istruncmap_subctx_into in HΓ. exact _.
Qed.

Definition merge_aux1 A B C D : A * B * (C * D) -> B * C * (A * D)
  := (equiv_prod_assoc _ _ _)^-1 o
                             (functor_prod (equiv_prod_symm _ _) idmap) o
                             (functor_prod (equiv_prod_assoc A B C)^-1 idmap) o
                             (equiv_prod_assoc _ _ _).
Definition merge_aux2 A B C : A * (B * C) -> B * (A * C)
  := (equiv_prod_assoc _ _ _)^-1 o
                             (functor_prod (equiv_prod_symm _ _) idmap) o
                             (equiv_prod_assoc _ _ _).

Fixpoint merge_subctx {Γ} : forall c1 c2 : counts Γ,
    subctx (merge_counts c1 c2) ->
    subctx c1 * subctx c2.
Proof.
  destruct Γ as [|A Γ];simpl;intros c1 c2.
  - intros _;exact (tt,tt).
  - destruct c1 as [[] c1], c2 as [[] c2];simpl.
    + exact (merge_subctx _ _ _).
    + exact ((merge_aux2 _ _ _) o
                                (functor_prod (idmap:A->A) (merge_subctx _ c1 c2))).
    + exact ((merge_aux2 _ _ _) o
                                (functor_prod (idmap:A->A) (merge_subctx _ c1 c2))).
    + refine ((equiv_prod_assoc _ _ _) o _).
      refine (functor_prod idmap _).
      exact (merge_subctx _ _ _).
    + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))).
    + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))).
    + exact ((equiv_prod_assoc _ _ _) o (functor_prod idmap (merge_subctx _ _ _))).
    + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))).
    + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))).
Defined.

Instance isequiv_merge_aux1 A B C D : IsEquiv (merge_aux1 A B C D).
Proof.
  unfold merge_aux1. exact _.
Qed.

Instance isequiv_merge_aux2 A B C : IsEquiv (merge_aux2 A B C).
Proof.
  unfold merge_aux2. exact _.
Qed.

Fixpoint init_contr Γ : Contr (subctx (counts_init Γ)).
Proof.
  destruct Γ as [|A Γ];simpl.
  - exact contr_unit.
  - apply init_contr.
Defined.

Instance init_trunc {n} Γ : IsTrunc n (subctx (counts_init Γ)).
Proof.
  induction n as [|n IHn].
  - apply init_contr.
  - apply _.
Qed.

Opaque functor_prod equiv_prod_assoc equiv_prod_symm merge_aux1 merge_aux2 dup.

Fixpoint istruncmap_merge_subctx {n Γ} : forall c1 c2 : counts Γ,
    local_of_counts n.+1 (merge_counts c1 c2) ->
    IsTruncMap n (merge_subctx c1 c2).
Proof.
  destruct Γ as [|A Γ];simpl.
  - intros _ _ _. apply _.
  - intros [c1 cs1] [c2 cs2] [h hs];simpl in *.
    apply istruncmap_merge_subctx in hs.
    destruct c1,c2;simpl in *;apply _.
Qed.

Transparent functor_prod equiv_prod_assoc equiv_prod_symm merge_aux1 merge_aux2 dup.

Fixpoint mexpr_var {A Γ} (x : varS A Γ) : mexpr (subctx (counts_of_var x)) A.
Proof.
  destruct x as [Γ|Γ x B];simpl.
  - apply mapplyr with A.
    + apply mid.
    + exact fst.
  - apply mexpr_var.
Defined.

Fixpoint mexpr_of {Γ A} (e : exprS Γ A) : mexpr (subctx (count_expr e)) A.
Proof.
  destruct e as [A x|A B f a|A x|A B a b];simpl.
  - apply mconst. exact x.
  - apply mapplyl with A.
    + exact f.
    + apply mexpr_of.
  - apply mexpr_var.
  - eapply mapplyr.
    + apply mpair;apply mexpr_of.
    + exact (merge_subctx (count_expr a) (count_expr b)).
Defined.

Fixpoint mcond_var_base {A Γ} (x : varS A Γ) : mcond (-2) (mexpr_var x).
Proof.
  destruct x as [Γ|Γ x B];simpl.
  - apply (pair tt).
    apply istruncmap_fst. exact _.
  - apply mcond_var_base.
Qed.

Lemma mcond_var {n A Γ} (x : varS A Γ) : mcond n (mexpr_var x).
Proof.
  induction n as [|n IHn].
  - apply mcond_var_base.
  - apply mcond_S,IHn.
Qed.

Fixpoint mexpr_preserves_truncmaps {n Γ A} (e : exprS Γ A)
  : local_of_counts n.+1 (count_expr e) -> uses_truncmaps n e -> mcond n (mexpr_of e).
Proof.
  destruct e as [A x|A B f a|A x|A B a b];simpl.
  - intros _ HA;split;exact _.
  - intros H. apply (functor_prod idmap). apply mexpr_preserves_truncmaps,H.
  - intros _ _. apply mcond_var.
  - intros HS HE.
    split.
    + apply local_unmerge_counts in HS.
      exact (functor_prod (mexpr_preserves_truncmaps _ _ _ _ (fst HS))
                          (mexpr_preserves_truncmaps _ _ _ _ (snd HS)) HE).
    + apply istruncmap_merge_subctx. exact HS.
Qed.

Fixpoint path_mexpr_var {A Γ} (x : varS A Γ) : forall y,
    eval_mexpr (mexpr_var x) (subctx_into (counts_of_var x) y) = eval_var x y.
Proof.
  destruct x as [Γ|Γ x B];simpl.
  - auto.
  - intros [_ y]. auto.
Qed.

Fixpoint merge_subctx_into {Γ} : forall (c1 c2 : counts Γ) x,
    merge_subctx c1 c2 (subctx_into _ x) = (subctx_into c1 x, subctx_into c2 x).
Proof.
  destruct Γ as [|A Γ];simpl.
  - intros;reflexivity.
  - intros [[] c1] [[] c2] [x xs];simpl;try solve [rewrite merge_subctx_into; reflexivity].
    all:(unfold merge_aux1,functor_prod;simpl;
      rewrite merge_subctx_into; reflexivity).
Qed.

Fixpoint path_mexpr_of {Γ A} (e : exprS Γ A) : forall x,
    eval_mexpr (mexpr_of e) (subctx_into (count_expr e) x) = eval_expr e x.
Proof.
  destruct e as [A x|A B f a|A x|A B a b];simpl.
  - auto.
  - intros x. apply ap. auto.
  - apply path_mexpr_var.
  - intros x. rewrite merge_subctx_into. unfold functor_prod. simpl.
    apply path_prod';apply path_mexpr_of.
Qed.

Lemma equiv_hfiber_right {A A' B} (f : A -> A') `{!IsEquiv f} (g : A' -> B) y
  : hfiber g y <~> hfiber (g o f) y.
Proof.
  srefine (equiv_adjointify _ _ _ _);unfold hfiber.
  - intros [x ex];exists (f^-1 x).
    path_via (g x). apply ap,eisretr.
  - intros [x ex];exists (f x).
    exact ex.
  - intros [x ex]. destruct ex.
    rewrite concat_p1.
    apply (path_sigma' _ (eissect _ _)).
    rewrite transport_paths_Fl.
    rewrite ap_compose,eisadj.
    apply concat_Vp.
  - intros [x ex]. destruct ex.
    rewrite concat_p1.
    apply (path_sigma' _ (eisretr _ _)).
    rewrite transport_paths_Fl.
    apply concat_Vp.
Qed.

Lemma equiv_hfiber_left {A B B'} (f : A -> B) (g : B -> B') `{!IsEmbedding g} y
  : hfiber f y <~> hfiber (g o f) (g y).
Proof.
  srefine (equiv_adjointify _ _ _ _);unfold hfiber.
  - intros [x ex]. exists x. apply ap,ex.
  - intros [x ex]; exists x. exact ((ap g)^-1 ex).
  - intros [x ex]. apply ap,eisretr.
  - intros [x ex]. apply ap,eissect.
Qed.

Lemma istruncmap_full_homotopic {n A B A' B'} (fA : A <~> A') (fB : B <~> B')
      (f : A -> B) (g : A' -> B')
  : IsTruncMap n f -> fB o f o fA^-1 == g -> IsTruncMap n g.
Proof.
  intros Hf He y.
  apply (trunc_equiv' (hfiber f (fB^-1 y)));[|exact _].
  refine (_ oE _).
  { symmetry. exact (equiv_hfiber_right fA g y). }
  refine (_ oE _).
  2:exact (equiv_hfiber_left _ fB _).
  rewrite eisretr.
  apply Fibrations.equiv_hfiber_homotopic;clear y.
  intros x. rewrite <-He,eissect. reflexivity.
Qed.

Lemma istruncmap_homotopic {n A B} (f : A -> B) {g} `{!IsTruncMap n f} : f == g -> IsTruncMap n g.
Proof.
  intros Heq.
  intros y. apply (trunc_equiv' (hfiber f y));[|exact _].
  apply Fibrations.equiv_hfiber_homotopic. exact Heq.
Defined.

Theorem istruncmap_eval_expr {n Γ A} (e : exprS Γ A)
  : global_cond n e -> uses_truncmaps n e -> IsTruncMap n (eval_expr e).
Proof.
  intros H1 H2.
  refine (istruncmap_homotopic _ (path_mexpr_of e)).
  apply Fibrations.istruncmap_compose.
  - apply istruncmap_mcond. apply mexpr_preserves_truncmaps.
    + apply cond_implies_local,H1.
    + exact H2.
  - apply istruncmap_subctx_into. exact H1.
Qed.


Require Import compcert.lib.Coqlib.

(* Ltac by Andrew Appel *)
Ltac do_range H tac :=
  match type of H with
    | ?lo <= ?i < ?hi =>
      try omega;
    let H' := fresh in let H'' := fresh in
                       destruct (zlt lo i) as [H' | H'];
    [ assert (H'' : lo + 1 <= i < hi) by omega;
      simpl in H'';
      clear H H'; rename H'' into H;
      try do_range H tac
    | try (assert (i = lo) by omega; subst i; tac)
    ]
  end.

Lemma test : forall i,
               0 <= i < 256 -> i + 1 > i.
Proof.
  intros.
  do_range H omega.             (* could use simpl; reflexivity, etc. *)
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Tactics to reason about list inclusion. *)

(** This file (contributed by Laurence Rideau) defines a tactic [in_tac]
  to reason over list inclusion.  It expects goals of the following form:
<<
  id : In x l1
  ============================
     In x l2
>>
and succeeds if it can prove that [l1] is included in [l2].
The lists [l1] and [l2] must belong to the following sub-language [L]
<<
  L ::= L++L | E | E::L
>>
The tactic uses no extra fact.

A second tactic, [incl_tac], handles goals of the form
<<
  =============================
    incl l1 l2
>>
*)

Require Import List.
Require Import Bool.
Require Import ArithRing.
Require Import EqNat.

Ltac all_app e :=
  match e with
  | cons ?x nil => constr:(cons x nil)
  | cons ?x ?tl =>
      let v := all_app tl in constr:(app (cons x nil) v)
  | app ?e1 ?e2 =>
    let v1 := all_app e1 with v2 := all_app e2 in
    constr:(app v1 v2)
  | _ => e
  end.

(** This data type, [flatten], [insert_bin], [sort_bin] and a few theorem
  are taken from the CoqArt book, chapt. 16. *)

Inductive bin : Type := node : bin->bin->bin | leaf : nat->bin.

Fixpoint flatten_aux (t fin:bin){struct t} : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
  end.

Fixpoint flatten (t:bin) : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten t2)
  | x => x
  end.

Fixpoint nat_le_bool (n m:nat){struct m} : bool :=
  match n, m with
  | O, _ => true
  | S _, O => false
  | S n, S m => nat_le_bool n m
  end.

Fixpoint insert_bin (n:nat)(t:bin){struct t} : bin :=
  match t with
  | leaf m =>
    if nat_le_bool n m then
       node (leaf n)(leaf m)
    else
       node (leaf m)(leaf n)
  | node (leaf m) t' =>
    if nat_le_bool n m then node (leaf n) t else node (leaf m)(insert_bin n t')
  | t => node (leaf n) t
  end.

Fixpoint sort_bin (t:bin) : bin :=
  match t with
  | node (leaf n) t' => insert_bin n (sort_bin t')
  | t => t
  end.

Section assoc_eq.
 Variables (A : Type)(f : A->A->A).
 Hypothesis assoc : forall x y z:A, f x (f y z) = f (f x y) z.

 Fixpoint bin_A (l:list A)(def:A)(t:bin){struct t} : A :=
   match t with
   | node t1 t2 => f (bin_A l def t1)(bin_A l def t2)
   | leaf n => nth n l def
   end.

 Theorem flatten_aux_valid_A :
  forall (l:list A)(def:A)(t t':bin),
   f (bin_A l def t)(bin_A l def t') = bin_A l def (flatten_aux t t').
 Proof.
  intros l def t; elim t; simpl; auto.
  intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
  symmetry; apply assoc.
 Qed.

 Theorem flatten_valid_A :
  forall (l:list A)(def:A)(t:bin),
    bin_A l def t = bin_A l def (flatten t).
 Proof.
  intros l def t; elim t; simpl; trivial.
  intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; rewrite <- IHt2.
  trivial.
 Qed.

End assoc_eq.

Ltac compute_rank l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:X2 in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank tl (S n) v
    end
  end.

Ltac term_list_app l v :=
  match v with
  | (app ?X1 ?X2) =>
    let l1 := term_list_app l X2 in term_list_app l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac model_aux_app l v :=
  match v with
  | (app ?X1 ?X2) =>
    let r1 := model_aux_app l X1 with r2 := model_aux_app l X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Theorem In_permute_app_head :
  forall A:Type, forall r:A, forall x y l:list A,
   In r (x++y++l) -> In r (y++x++l).
intros A r x y l; generalize r; change (incl (x++y++l)(y++x++l)).
repeat rewrite ass_app; auto with datatypes.
Qed.

Theorem insert_bin_included :
  forall x:nat, forall t2:bin,
  forall (A:Type) (r:A) (l:list (list A))(def:list A),
     In r (bin_A (list A) (app (A:=A)) l def (insert_bin x t2)) ->
     In r (bin_A (list A) (app (A:=A)) l def (node (leaf x) t2)).
intros x t2; induction t2.
intros A r l def.
destruct t2_1 as [t2_11 t2_12|y].
simpl.
repeat rewrite app_ass.
auto.
simpl; repeat rewrite app_ass.
simpl; case (nat_le_bool x y); simpl.
auto.
intros H; apply In_permute_app_head.
elim in_app_or with (1:= H); clear H; intros H.
apply in_or_app; left; assumption.
apply in_or_app; right;apply (IHt2_2 A r l);assumption.
intros A r l def; simpl.
case (nat_le_bool x n); simpl.
auto.
intros H.
rewrite (app_nil_end (nth x l def)) in H.
rewrite (app_nil_end (nth n l def)).
apply In_permute_app_head; assumption.
Qed.

Theorem in_or_insert_bin :
  forall (n:nat) (t2:bin) (A:Type)(r:A)(l:list (list A)) (def:list A),
  In r (nth n l def) \/ In r (bin_A (list A)(app (A:=A)) l def t2) ->
  In r (bin_A (list A)(app (A:=A)) l def (insert_bin n t2)).
intros n t2 A r l def; induction t2.
destruct t2_1 as [t2_11 t2_12| y].
simpl; apply in_or_app.
simpl; case (nat_le_bool n y); simpl.
intros H.
apply in_or_app.
exact H.
intros [H|H].
apply in_or_app; right; apply IHt2_2; auto.
elim in_app_or with (1:= H);clear H; intros H; apply in_or_app; auto.
simpl; intros [H|H]; case (nat_le_bool n n0); simpl; apply in_or_app; auto.
Qed.

Theorem sort_included :
  forall t:bin, forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app (A:=A)) l def (sort_bin t)) ->
    In r (bin_A (list A) (app (A:=A)) l def t).
induction t.
destruct t1.
simpl;intros; assumption.
intros A r l def H; simpl in H; apply insert_bin_included.
generalize (insert_bin_included _ _ _ _ _ _ H); clear H; intros H.
simpl in H.
elim in_app_or with (1 := H);clear H; intros H;
apply in_or_insert_bin; auto.
simpl;intros;assumption.
Qed.

Theorem sort_included2 :
  forall t:bin, forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app (A:=A)) l def t) ->
    In r (bin_A (list A) (app (A:=A)) l def (sort_bin t)).
induction t.
destruct t1.
simpl; intros; assumption.
intros A r l def H; simpl in H.
simpl; apply in_or_insert_bin.
elim in_app_or with (1:= H); auto.
simpl; auto.
Qed.

Theorem in_remove_head :
  forall (A:Type)(x:A)(l1 l2 l3:list A),
  In x (l1++l2) -> (In x l2 -> In x l3) -> In x (l1++l3).
intros A x l1 l2 l3 H H1.
elim in_app_or with (1:= H);clear H; intros H; apply in_or_app; auto.
Qed.

Fixpoint check_all_leaves (n:nat)(t:bin) {struct t} : bool :=
  match t with
    leaf n1 => beq_nat n n1
  | node t1 t2 => andb (check_all_leaves n t1)(check_all_leaves n t2)
  end.

Fixpoint remove_all_leaves (n:nat)(t:bin){struct t} : bin :=
  match t with
    leaf n => leaf n
  | node (leaf n1) t2 =>
    if beq_nat n n1 then remove_all_leaves n t2 else t
  | _ => t
  end.

Fixpoint test_inclusion (t1 t2:bin) {struct t1} : bool :=
  match t1 with
    leaf n => check_all_leaves n t2
  | node (leaf n1) t1' =>
     check_all_leaves n1 t2 || test_inclusion t1' (remove_all_leaves n1 t2)
  | _ => false
  end.

Theorem check_all_leaves_sound :
  forall x t2,
    check_all_leaves x t2 = true ->
    forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app (A:=A)) l def t2) ->
    In r (nth x l def).
intros x t2; induction t2; simpl.
destruct (check_all_leaves x t2_1);
destruct (check_all_leaves x t2_2); simpl; intros Heq; try discriminate.
intros A r l def H; elim in_app_or with (1:= H); clear H; intros H; auto.
intros Heq A r l def; rewrite (beq_nat_eq x n); auto.
Qed.

Theorem remove_all_leaves_sound :
  forall x t2,
  forall (A:Type)(r:A)(l:list(list A))(def:list A),
  In r (bin_A (list A) (app(A:=A)) l def t2) ->
  In r (bin_A (list A) (app(A:=A)) l def (remove_all_leaves x t2)) \/
  In r (nth x l def).
intros x t2; induction t2; simpl.
destruct t2_1.
simpl; auto.
intros A r l def.
generalize (refl_equal (beq_nat x n)); pattern (beq_nat x n) at -1;
 case (beq_nat x n); simpl; auto.
intros Heq_nateq.
assert (Heq_xn : x=n).
apply beq_nat_eq; rewrite Heq_nateq;unfold Is_true;auto.
rewrite Heq_xn.
intros H; elim in_app_or with (1:= H); auto.
clear H; intros H.
rewrite Heq_xn in IHt2_2; auto.
auto.
Qed.

Theorem test_inclusion_sound :
  forall t1 t2:bin,
  test_inclusion t1 t2 = true ->
  forall (A:Type)(r:A)(l:list(list A))(def:list A),
  In r (bin_A (list A)(app(A:=A)) l def t2) ->
  In r (bin_A (list A)(app(A:=A)) l def t1).
intros t1; induction t1.
destruct t1_1 as [t1_11 t1_12|x].
simpl; intros; discriminate.
simpl; intros t2 Heq A r l def H.
assert
 (check_all_leaves x t2 = true \/
  test_inclusion t1_2 (remove_all_leaves x t2) = true).
destruct (check_all_leaves x t2);
destruct (test_inclusion t1_2 (remove_all_leaves x t2));
simpl in Heq; try discriminate Heq; auto.
elim H0; clear H0; intros H0.
apply in_or_app; left; apply check_all_leaves_sound with (1:= H0); auto.
elim remove_all_leaves_sound with (x:=x)(1:= H); intros H'.
apply in_or_app; right; apply IHt1_2 with (1:= H0); auto.
apply in_or_app; auto.
simpl; apply check_all_leaves_sound.
Qed.

Theorem inclusion_theorem :
  forall t1 t2 : bin,
    test_inclusion (sort_bin (flatten t1)) (sort_bin (flatten t2)) = true ->
    forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app(A:=A)) l def t2) ->
    In r (bin_A (list A) (app(A:=A)) l def t1).
intros t1 t2 Heq A r l def H.
rewrite flatten_valid_A with (t:= t1)(1:= (ass_app (A:= A))).
apply sort_included.
apply test_inclusion_sound with (t2 := sort_bin (flatten t2)).
assumption.
apply sort_included2.
rewrite <- flatten_valid_A with (1:= (ass_app (A:= A))).
assumption.
Qed.

Ltac in_tac :=
  match goal with
  | id : In ?x nil |- _ => elim id
  | id : In ?x ?l1 |- In ?x ?l2 =>
    let t := type of x in
    let v1 := all_app l1 in
    let v2 := all_app l2 in
    (let l := term_list_app (nil (A:=list t)) v2 in
     let term1 := model_aux_app l v1 with
         term2 := model_aux_app l v2 in
        (change (In x (bin_A (list t) (app(A:=t)) l (nil(A:=t)) term2));
        apply inclusion_theorem with (t2:= term1);[apply refl_equal|exact id]))
  end.

Ltac incl_tac :=
  match goal with
  |- incl _ _ => intro; intro; in_tac
  end.

(* Usage examples.

Theorem ex1 : forall x y z:nat, forall l1 l2 : list nat,
   In x (y::l1++l2) -> In x (l2++z::l1++(y::nil)).
intros.
in_tac.
Qed.

Fixpoint mklist (f:nat->nat)(n:nat){struct n} : list nat :=
 match n with 0 => nil | S p => mklist f p++(f p::nil) end.

(* At the time of writing these lines, this example takes about 5 seconds
     for 40 elements and 22 seconds for 60 elements.
   A variant to the example is to replace mklist f p++(f p::nil) with
   f p::mklist f p, in this case the time is 6 seconds for 40 elements and
   35 seconds for 60 elements. *)

Theorem ex2 :
  forall x : nat, In x (mklist (fun y => y) 40) ->
     In x (mklist (fun y => (40 - 1) - y) 40).
lazy beta iota zeta delta [mklist minus].
intros.
in_tac.
Qed.

(* The tactic could be made more efficient by using binary trees and
   numbers of type positive instead of lists and natural numbers. *)

*)


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

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

Print Assumptions square.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_samesidesymmetric_1 : (forall A B P Q : Universe, (oS_ P Q A B -> (oS_ Q P A B /\ (oS_ P Q B A /\ oS_ Q P B A)))).
Variable lemma_planeseparation_2 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable defoppositeside_3 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_4 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable axiom_betweennessidentity_5 : (forall A B : Universe, ~(betS_ A B A)).

Theorem lemma_samenotopposite_6 : (forall A B C D : Universe, (oS_ A B C D -> ~(tS_ A C D B))).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require
  MathClasses.implementations.stdlib_binary_integers MathClasses.theory.integers MathClasses.orders.semirings.
Require Import
  Coq.Numbers.Integer.SpecViaZ.ZSig Coq.Numbers.Integer.SpecViaZ.ZSigZAxioms Coq.NArith.NArith Coq.ZArith.ZArith
  MathClasses.implementations.nonneg_integers_naturals MathClasses.interfaces.orders
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers MathClasses.interfaces.additional_operations.

Module ZType_Integers (Import anyZ: ZType).

Module axioms := ZTypeIsZAxioms anyZ.

Instance ZType_equiv : Equiv t := eq.
Instance ZType_plus : Plus t := add.
Instance ZType_0 : Zero t := zero.
Instance ZType_1 : One t := one.
Instance ZType_mult : Mult t := mul.
Instance ZType_negate: Negate t := opp.

Instance: Setoid t | 10 := {}.

Program Instance: ∀ x y: t, Decision (x = y) := λ x y,
  match compare x y with
  | Eq => left _
  | _ => right _
  end.
Next Obligation.
  apply Zcompare_Eq_eq. now rewrite <-spec_compare.
Qed.
Next Obligation.
  rewrite spec_compare in *.
  intros E.
  apply Zcompare_Eq_iff_eq in E. auto.
Qed.

Ltac unfold_equiv := unfold equiv, ZType_equiv, eq in *.

Lemma ZType_ring_theory: ring_theory zero one add mul sub opp eq.
Proof. repeat split; repeat intro; axioms.zify; auto with zarith. Qed.

Local Instance: Ring t := rings.from_stdlib_ring_theory ZType_ring_theory.

Instance inject_ZType_Z: Cast t Z := to_Z.

Instance: Proper ((=) ==> (=)) to_Z.
Proof. intros x y E. easy. Qed.

Instance: SemiRing_Morphism to_Z.
Proof.
  repeat (split; try apply _).
     exact spec_add.
    exact spec_0.
   exact spec_mul.
  exact spec_1.
Qed.

Instance inject_Z_ZType: Cast Z t := of_Z.
Instance: Inverse to_Z := of_Z.

Instance: Surjective to_Z.
Proof. constructor. intros x y E. rewrite <- E. apply spec_of_Z. apply _. Qed.

Instance: Injective to_Z.
Proof. constructor. unfold_equiv. intuition. apply _. Qed.

Instance: Bijective to_Z := {}.

Instance: Inverse of_Z := to_Z.

Instance: Bijective of_Z.
Proof. apply jections.flip_bijection. Qed.

Instance: SemiRing_Morphism of_Z.
Proof. change (SemiRing_Morphism (to_Z⁻¹)). split; apply _. Qed.

Instance: IntegersToRing t := integers.retract_is_int_to_ring of_Z.
Instance: Integers t := integers.retract_is_int of_Z.

(* Order *)
Instance ZType_le: Le t := le.
Instance ZType_lt: Lt t := lt.

Instance: Proper ((=) ==> (=) ==> iff) ZType_le.
Proof.
  intros ? ? E1 ? ? E2. unfold ZType_le, le. unfold equiv, ZType_equiv, eq in *.
  now rewrite E1, E2.
Qed.

Instance: SemiRingOrder ZType_le.
Proof. now apply (rings.projected_ring_order to_Z). Qed.

Instance: OrderEmbedding to_Z.
Proof. now repeat (split; try apply _). Qed.

Instance: TotalRelation ZType_le.
Proof. now apply (maps.projected_total_order to_Z). Qed.

Instance: FullPseudoSemiRingOrder ZType_le ZType_lt.
Proof.
  rapply semirings.dec_full_pseudo_srorder.
  intros x y.
  change (to_Z x < to_Z y ↔ x ≤ y ∧ x ≠ y).
  now rewrite orders.lt_iff_le_ne.
Qed.

(* Efficient comparison *)
Program Instance: ∀ x y: t, Decision (x ≤ y) := λ x y,
  match compare x y with
  | Gt => right _
  | _ => left _
  end.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Zcompare_spec (to_Z x) (to_Z y)); try discriminate.
  now apply orders.lt_not_le_flip.
Qed.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Zcompare_spec (to_Z x) (to_Z y)); try discriminate; try intuition.
   now apply Zeq_le.
  now apply orders.lt_le.
Qed.

Program Instance: Abs t := abs.
Next Obligation.
  split; intros E; unfold_equiv; rewrite spec_abs.
   apply Z.abs_eq.
   apply (order_preserving to_Z) in E.
   now rewrite rings.preserves_0 in E.
  rewrite rings.preserves_negate.
  apply Z.abs_neq.
  apply (order_preserving to_Z) in E.
  now rewrite rings.preserves_0 in E.
Qed.

(* Efficient division *)
Instance ZType_div: DivEuclid t := anyZ.div.
Instance ZType_mod: ModEuclid t := modulo.

Instance: EuclidSpec t ZType_div ZType_mod.
Proof.
  split; try apply _; unfold div_euclid, ZType_div.
     intros x y E. now apply axioms.div_mod.
    intros x y Ey.
    destruct (Z_mod_remainder (to_Z x) (to_Z y)) as [[Hl Hr] | [Hl Hr]].
      intro. apply Ey. apply (injective to_Z). now rewrite rings.preserves_0.
     left; split.
      apply (order_reflecting to_Z). now rewrite spec_modulo, rings.preserves_0.
     apply (strictly_order_reflecting to_Z). now rewrite spec_modulo.
    right; split.
      apply (strictly_order_reflecting to_Z). now rewrite spec_modulo.
     apply (order_reflecting to_Z). now rewrite spec_modulo, rings.preserves_0.
   intros x. unfold_equiv. rewrite spec_div, rings.preserves_0. now apply Zdiv_0_r.
  intros x. unfold_equiv. rewrite spec_modulo, rings.preserves_0. now apply Zmod_0_r.
Qed.

Lemma ZType_succ_1_plus x : succ x = 1 + x.
Proof.
  unfold_equiv. rewrite spec_succ, rings.preserves_plus, rings.preserves_1.
  now rewrite commutativity.
Qed.

Lemma ZType_two_2 : two = 2.
Proof.
  unfold_equiv. rewrite spec_2.
  now rewrite rings.preserves_plus, rings.preserves_1.
Qed.

(* Efficient [nat_pow] *)
Program Instance ZType_pow: Pow t (t⁺) := pow.

Instance: NatPowSpec t (t⁺) ZType_pow.
Proof.
  split.
    intros x1 y1 E1 [x2] [y2] E2.
    now apply axioms.pow_wd.
   intros x1. apply axioms.pow_0_r.
  intros x [n ?].
  unfold_equiv. unfold "^", ZType_pow. simpl.
  rewrite <-axioms.pow_succ_r; try easy.
  now rewrite ZType_succ_1_plus.
Qed.

Program Instance ZType_Npow: Pow t N := pow_N.

Instance: NatPowSpec t N ZType_Npow.
Proof.
  split; unfold "^", ZType_Npow.
    intros x1 y1 E1 x2 y2 E2. unfold_equiv.
    now rewrite 2!spec_pow_N, E1, E2.
   intros x1. unfold_equiv.
   now rewrite spec_pow_N, rings.preserves_1.
  intros x n. unfold_equiv.
  rewrite spec_mul, 2!spec_pow_N.
  rewrite rings.preserves_plus, Z.pow_add_r.
    now rewrite rings.preserves_1, Z.pow_1_r.
   easy.
  now apply Z_of_N_le_0.
Qed.

(*
(* Efficient [log 2] *)
Program Instance: Log (2:t) (t⁺) := log2.
Next Obligation with auto.
  intros x.
  apply to_Z_Zle_sr_le.
  rewrite spec_log2, preserves_0.
  apply Z.log2_nonneg.
Qed.

Next Obligation with auto.
  intros [x Ex].
  destruct (axioms.log2_spec x) as [E1 E2].
   apply to_Z_sr_le_Zlt...
  unfold nat_pow, nat_pow_sig, ZType_pow; simpl.
  apply to_Z_Zle_sr_le in E1. apply to_Z_Zlt_sr_le in E2.
  rewrite ZType_two_2 in E1, E2.
  rewrite ZType_succ_plus_1, commutativity in E2...
Qed.
*)

(* Efficient [shiftl] *)
Program Instance ZType_shiftl: ShiftL t (t⁺) := shiftl.

Instance: ShiftLSpec t (t⁺) ZType_shiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x [y Ey].
  unfold additional_operations.pow, ZType_pow, additional_operations.shiftl, ZType_shiftl.
  unfold_equiv. simpl.
  rewrite rings.preserves_mult, spec_pow.
  rewrite spec_shiftl, Z.shiftl_mul_pow2.
   now rewrite <-ZType_two_2, spec_2.
  apply (order_preserving to_Z) in Ey. now rewrite rings.preserves_0 in Ey.
Qed.

(* Efficient [shiftr] *)
Program Instance: ShiftR t (t⁺) := shiftr.

End ZType_Integers.