From PetitC Require Import Semantics TypedTree Values Memory Ids Star Tactics InbuiltFuncLemmas.
Import TypedTree.

From Coq Require Import ZArith Lia Program.Basics Lists.List Logic.FunctionalExtensionality.
Open Scope nat.

Ltac inv H := (inversion H; subst; clear H).

Lemma map_injective {X Y : Type} (f : X -> Y) (Hinj : forall x x', f x = f x' -> x = x')
      (xs xs' : list X) :
    map f xs = map f xs' ->
  xs = xs'.
Proof.
  generalize dependent xs'.
  induction xs; intros; destruct xs'; try discriminate.
  - reflexivity.
  - injection H; intros.
    f_equal.
    + apply Hinj. assumption.
    + apply IHxs. assumption.
Qed.

Lemma combine_injective_of_same_length {X Y : Type} (xs xs' : list X) (ys ys' : list Y) :
    length xs = length ys ->
    length xs' = length ys' ->
    combine xs ys = combine xs' ys' ->
  xs = xs' /\ ys = ys'.
Proof.
  generalize dependent xs'. generalize dependent ys. generalize dependent ys'.
  induction xs; intros;
  destruct xs'; destruct ys; destruct ys'; try discriminate.
  - split; reflexivity.
  - injection H. intros. injection H0. intros. injection H1. intros. subst.
    split; f_equal.
    + eapply proj1; apply IHxs; eassumption.
    + eapply proj2; apply IHxs; eassumption.
Qed.

Lemma cast_reduction_deterministic : forall ty_from val_from ty_to val_to val_to',
    cast_reduction ty_from val_from ty_to val_to ->
    cast_reduction ty_from val_from ty_to val_to' ->
  val_to = val_to'.
Proof.
  intros.
  inv H; inv H0; reflexivity.
Qed.

Lemma int_arith_binop_reduction_deterministic : forall op lhs rhs result result',
    int_arith_binop_reduction op lhs rhs result ->
    int_arith_binop_reduction op lhs rhs result' ->
  result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma comparison_reduction_determimnistic : forall comparison lhs rhs result result',
    comparison_reduction comparison lhs rhs result ->
    comparison_reduction comparison lhs rhs result' ->
  result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma binop_reduction_deterministic :
  forall op lhs rhs result result',
      binop_reduction op lhs rhs result ->
      binop_reduction op lhs rhs result' ->
    result = result'.
Proof.
  intros.
  inv H; inv H0;
  try (inv H1; inv H2; inv H3; inv H5; inv H6; inv H7;
       reflexivity).
  - inv H1; inv H4;
    f_equal;
    apply int_value_to_Z_eq;
    etransitivity; eassumption || (symmetry; eassumption).
  - inv H1; inv H4;
    reflexivity.
  - inv H4; inv H10;
    inv H1; inv H2; inv H7; inv H8;
    reflexivity.
  - inv H1; inv H2; inv H5; inv H6;
    f_equal; apply int_value_to_Z_eq;
    eapply Z.mul_reg_l;
    try (etransitivity; eassumption || (symmetry; eassumption));
    unfold word_size; lia.
Qed.

Lemma short_circuit_reduction_first_deterministic : forall short_circuit_op lhs result result',
    short_circuit_reduction_first short_circuit_op lhs result ->
    short_circuit_reduction_first short_circuit_op lhs result' ->
  result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma short_circuit_reduction_second_deterministic :
  forall short_circuit_op lhs rhs result result',
      short_circuit_reduction_second short_circuit_op lhs rhs result ->
      short_circuit_reduction_second short_circuit_op lhs rhs result' ->
    result = result'.
Proof.
  intros. inv H; inv H0; reflexivity.
Qed.

Lemma short_circuit_reduction_not_first_and_second :
  forall short_circuit_op lhs rhs result result',
      short_circuit_reduction_first short_circuit_op lhs result ->
      short_circuit_reduction_second short_circuit_op lhs rhs result' ->
    False.
Proof.
  intros. inv H; inv H0.
Qed.

Lemma bool_to_value_injective : forall b b',
    bool_to_value b = bool_to_value b' ->
  b = b'.
Proof.
  intros [|] [|]; reflexivity || discriminate.
Qed.

Lemma incr_or_decr_reduction_deterministic : forall ty incr_or_decr val result result',
    incr_or_decr_reduction ty incr_or_decr val result ->
    incr_or_decr_reduction ty incr_or_decr val result' ->
  result = result'.
Proof.
  intros.
  inv H; inv H0; repeat f_equal.
  - apply int_value_to_Z_eq.
    etransitivity; eassumption || (symmetry; eassumption).
  - apply bool_to_value_injective; symmetry; assumption.
Qed.

Lemma write_deterministic : forall mem ptr value mem' mem'',
    write mem ptr value mem' ->
    write mem ptr value mem'' ->
  mem' = mem''.
Proof.
  intros.
  inv H; inv H0; repeat f_equal.
  rewrite H1 in H8. injection H8. intros. subst. reflexivity.
Qed.

Lemma read_deterministic : forall mem ptr value value',
    read mem ptr value ->
    read mem ptr value' ->
  value = value'.
Proof.
  intros.
  inv H; inv H0.
  - rewrite H1 in H5. injection H5. intros. subst. reflexivity.
  - rewrite H1 in H7. injection H7. intros. subst.
    rewrite H2 in H8. injection H8. intros. subst. reflexivity.
Qed.

Lemma expr_head_reduction_determinisntic :
  forall var_ptrs state expr state' expr' state'' expr'',
      expr_head_reduction var_ptrs (state, expr) (state', expr') ->
      expr_head_reduction var_ptrs (state, expr) (state'', expr'') ->
    state' = state'' /\ expr' = expr''.
Proof.
  intros.
  inv H; inv H0.
  - split; try reflexivity; repeat f_equal.
    eapply cast_reduction_deterministic; eassumption.
  - split; reflexivity.
  - split; try reflexivity; repeat f_equal.
    eapply binop_reduction_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4. subst.
    eapply short_circuit_reduction_first_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4. subst.
    exfalso. eapply short_circuit_reduction_not_first_and_second; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4. subst.
    exfalso. eapply short_circuit_reduction_not_first_and_second; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective in H4.
    apply bool_to_value_injective in H5. subst.
    eapply short_circuit_reduction_second_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    apply bool_to_value_injective. symmetry. assumption.
  - assert (Hbefore : before = before0).
    { eapply read_deterministic; eassumption. }
    subst.
    assert (Hafter : after = after0).
    { eapply incr_or_decr_reduction_deterministic; eassumption. }
    subst.
    split; try reflexivity; repeat f_equal.
    eapply write_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    eapply write_deterministic; eassumption.
  - assert (Heq : mem' = mem'0 /\ out' = out'0 /\ returned = returned0);
    try (destruct Heq as [Heq0 [Heq1 Heq2]]; subst; split; reflexivity).
    assert (Hargs : args = args0).
    { apply list_to_list_annotated_expr_injective in H5.
      apply map_injective in H5;
      try (intros [] [] H; injection H; intros; subst; reflexivity).
      apply combine_injective_of_same_length in H5; try assumption.
      destruct H5. symmetry. assumption. }
    subst.
    eapply inbuilt_func_deterministic; eassumption.
  - split; try reflexivity; repeat f_equal.
    rewrite H2 in H1. injection H1. intros. subst. reflexivity.
Qed.

Definition reducible (expr : annotated_expr) : Prop :=
  (exists var_ptrs state state' expr',
    expr_head_reduction var_ptrs (state, expr) (state', expr')).

Lemma expr_head_reduction_context_injective : forall ctx expr expr',
    expr_context ctx ->
    ctx expr = ctx expr' ->
  expr = expr'.
Proof.
  intros.
  generalize dependent expr'. generalize dependent expr0.
  revert H. generalize dependent ctx.
  apply (expr_context_mutual_ind
    (fun ctx => forall expr expr', ctx expr = ctx expr' -> expr = expr')
    (fun ctx => forall expr expr', ctx expr = ctx expr' -> expr = expr')
    (fun ctx => forall expr expr', ctx expr = ctx expr' -> expr = expr'));
  intros;
  assumption || apply H0; injection H1 as H1; assumption.
Qed.

Ltac inv_context :=
  match goal with
  | H : expr_context _ |- _      => inv H; try discriminate; try reflexivity
  | H : lvalue_context _ |- _    => inv H; try discriminate; try reflexivity
  | H : list_expr_context _ |- _ => inv H; try discriminate; try reflexivity
  end.

Ltac destruct_reducible :=
  match goal with
  | H : reducible _ |- _ =>
    let var_ptrs := fresh "var_ptrs" in
    let state := fresh "state" in
    let state' := fresh "state" in
    let expr := fresh "expr" in
    destruct H as [var_ptrs [state [state' [expr H]]]];
    inv H; try discriminate; try reflexivity
  end.

Lemma not_arg_exprs_eq_subst_call : forall ctx arg_vals arg_rich_types func_id arg_exprs return_ty,
    list_expr_context ctx ->
    list_to_list_annotated_expr (map (fun '(val, ty) => Const val <: ty)
                                     (combine arg_vals arg_rich_types))
    = ctx (Call func_id arg_exprs <: return_ty) ->
  False.
Proof.
  intros. generalize dependent arg_vals. generalize dependent arg_rich_types.
  induction H; intros;
  destruct arg_vals; destruct arg_rich_types; try discriminate.
  - inv H; discriminate.
  - injection H0. intros. subst.
    eapply IHlist_expr_context. eassumption.
Qed.

Lemma not_arg_exprs_eq_subst_head_reducible :
  forall ctx arg_vals arg_rich_types var_ptrs state state' expr expr',
      list_expr_context ctx ->
      expr_head_reduction var_ptrs (state, expr) (state', expr') ->
      list_to_list_annotated_expr (map (fun '(val, ty) => Const val <: ty)
                                      (combine arg_vals arg_rich_types))
      = ctx expr ->
    False.
Proof.
  intros. generalize dependent arg_vals. generalize dependent arg_rich_types.
  induction H; intros;
  destruct arg_vals; destruct arg_rich_types; try discriminate.
  - inv H; try discriminate.
    inv H0; discriminate.
  - injection H1. intros. subst.
    eapply IHlist_expr_context. eassumption.
Qed.

Lemma expr_head_reduction_context_unique : forall ctx expr ctx' expr',
    reducible expr ->
    reducible expr' ->
    expr_context ctx ->
    expr_context ctx' ->
    ctx expr = ctx' expr' ->
  ctx = ctx'.
Proof.
  (* this takes a few minutes and a few gigabytes of ram *)
  intros. revert H3. revert H2. revert H0. revert H. revert expr'. revert ctx'. revert expr0.
  revert H1. revert ctx.
  apply (expr_context_mutual_ind
    (fun ctx => forall expr ctx' expr', reducible expr -> reducible expr' ->
      expr_context ctx' -> ctx expr = ctx' expr' -> ctx = ctx')
    (fun ctx => forall expr ctx' expr', reducible expr -> reducible expr' ->
      lvalue_context ctx' -> ctx expr = ctx' expr' -> ctx = ctx')
    (fun ctx => forall expr ctx' expr', reducible expr -> reducible expr' ->
      list_expr_context ctx' -> ctx expr = ctx' expr' -> ctx = ctx'));
  intros;
  try (inv H3;
       try (injection H4; intros; subst;
           assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity);
           (apply (H0 expr0 ctx0 expr') || apply (H0 expr1 ctx0 expr')); assumption);
      inv_context; repeat destruct_reducible;
      fail);
  try (inv_context;
       try (injection H4; intros; subst;
            assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity);
            (apply (H0 expr0 ctx0 expr') || apply (H0 expr1 ctx0 expr')); assumption;
            fail);
       try (destruct_reducible; destruct H1 as [var_ptrs [state [state' [expr' H1]]]];
            injection H5; intros;
            exfalso; eapply not_arg_exprs_eq_subst_head_reducible; eassumption);
       try (inv H5; inv H3; destruct_reducible; fail);
       try (repeat destruct_reducible; inv_context; fail);
       try (inv H; repeat destruct_reducible; fail);
       try (inv_context; inv_context; repeat destruct_reducible; fail);
       try (inv H; inv H3; repeat destruct_reducible; fail);
       fail).
  repeat destruct_reducible;
  try (inv_context; inv_context; inv_context; fail);
  inv_context;
  injection H2; intros;
  exfalso;
  try (eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs state0 state0) ||
       eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs (mem, out) (mem', out)) ||
       eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs (mem', out') (mem'0, out'0));
       eassumption || (econstructor; eassumption)).
  eapply (not_arg_exprs_eq_subst_head_reducible _ _ _ var_ptrs (mem, out) (mem', out'));
  eassumption || (econstructor; eassumption).
Qed.

Lemma expr_func_reduction_context_unique :
  forall ctx ctx' func_id return_ty arg_vals arg_rich_types
                  func_id' return_ty' arg_vals' arg_rich_types',
    expr_context ctx ->
    expr_context ctx' ->
    let arg_exprs := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals arg_rich_types)) in
    let call_expr := Call func_id arg_exprs <: return_ty in
    let arg_exprs' := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals' arg_rich_types')) in
    let call_expr' := Call func_id' arg_exprs' <: return_ty' in
    ctx call_expr = ctx' call_expr' ->
  ctx = ctx'.
Proof.
  intros. generalize dependent ctx'. generalize dependent ctx.
  apply (expr_context_mutual_ind
    (fun ctx => forall ctx',
      expr_context ctx' -> ctx call_expr = ctx' call_expr' -> ctx = ctx')
    (fun ctx => forall ctx',
      lvalue_context ctx' -> ctx call_expr = ctx' call_expr' -> ctx = ctx')
    (fun ctx => forall ctx',
      list_expr_context ctx' -> ctx call_expr = ctx' call_expr' -> ctx = ctx'));
  intros;
  unfold call_expr in *; unfold call_expr' in *;
  try (inv H1; try discriminate;
       try (inv H; try discriminate; inv H1; discriminate);
       try (inv H3; try discriminate; inv H1; discriminate);
       injection H2; intros; subst;
       assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity);
       apply H0; assumption).
  - unfold arg_exprs in *.
    inv H; try discriminate; try reflexivity.
    injection H0; intros.
    exfalso. eapply not_arg_exprs_eq_subst_call; eassumption.
  - inv H1; try discriminate.
    + injection H2; intros.
      unfold arg_exprs' in *.
      exfalso. eapply not_arg_exprs_eq_subst_call.
      * eassumption.
      * symmetry. eassumption.
    + injection H2. intros. subst.
      assert (Hctx : ctx = ctx0); try (rewrite Hctx; reflexivity).
      apply H0; assumption.
Qed.

Lemma expr_func_reduction_context_injective :
  forall ctx,
    expr_context ctx ->
  forall func_id return_ty arg_vals arg_rich_types
         func_id' return_ty' arg_vals' arg_rich_types',
    let arg_exprs := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals arg_rich_types)) in
    let call_expr := Call func_id arg_exprs <: return_ty in
    let arg_exprs' := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
           (combine arg_vals' arg_rich_types')) in
    let call_expr' := Call func_id' arg_exprs' <: return_ty' in
    ctx call_expr = ctx call_expr' ->
  call_expr = call_expr'.
Proof.
  apply (expr_context_mutual_ind
    (fun ctx => forall func_id return_ty arg_vals arg_rich_types
                       func_id' return_ty' arg_vals' arg_rich_types',
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        let arg_exprs' := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals' arg_rich_types')) in
        let call_expr' := Call func_id' arg_exprs' <: return_ty' in
        ctx call_expr = ctx call_expr' ->
      call_expr = call_expr')
  (fun ctx => forall func_id return_ty arg_vals arg_rich_types
                     func_id' return_ty' arg_vals' arg_rich_types',
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        let arg_exprs' := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals' arg_rich_types')) in
        let call_expr' := Call func_id' arg_exprs' <: return_ty' in
        ctx call_expr = ctx call_expr' ->
      call_expr = call_expr')
  (fun ctx => forall func_id return_ty arg_vals arg_rich_types
                     func_id' return_ty' arg_vals' arg_rich_types',
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        let arg_exprs' := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals' arg_rich_types')) in
        let call_expr' := Call func_id' arg_exprs' <: return_ty' in
        ctx call_expr = ctx call_expr' ->
      call_expr = call_expr'));
  intros;
  assumption || apply H0; injection H1 as H1; assumption.
Qed.

Lemma not_subst_call_expr_eq_subst_head_reducible :
  forall ctx,
    expr_context ctx ->
  forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
    expr_context ctx' ->
    expr_head_reduction var_ptrs (state, expr) (state', expr') ->
    let arg_exprs := list_to_list_annotated_expr
      (map (fun '(val, ty) => Const val <: ty)
          (combine arg_vals arg_rich_types)) in
    let call_expr := Call func_id arg_exprs <: return_ty in
    ctx call_expr = ctx' expr ->
  False.
Proof.
  apply (expr_context_mutual_ind
    (fun ctx =>
      forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
        expr_context ctx' ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        ctx call_expr = ctx' expr ->
      False)
    (fun ctx =>
      forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
        lvalue_context ctx' ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        ctx call_expr = ctx' expr ->
      False)
    (fun ctx =>
      forall ctx' arg_vals arg_rich_types func_id return_ty var_ptrs expr expr' state state',
        list_expr_context ctx' ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
              (combine arg_vals arg_rich_types)) in
        let call_expr := Call func_id arg_exprs <: return_ty in
        ctx call_expr = ctx' expr ->
      False));
  intros;
  try (inv H1; try discriminate;
       (inv H2; try discriminate; inv H; discriminate) ||
       (inv H; inv H2; inv H1; discriminate) ||
       (injection H3; intros; subst; eapply H0; eassumption) ||
       (inv H4; try discriminate; inv H2; discriminate) ||
       (inv H4; inv H1; try discriminate; inv H2; discriminate)).
  - unfold call_expr in *. inv H; try discriminate.
    + inv H0; discriminate.
    + injection H1. intros. subst.
      eapply not_arg_exprs_eq_subst_head_reducible; eassumption.
  - inv H1; try discriminate.
    + assert (H2' := H2).
      inv H2; try discriminate.
      injection H4. intros. subst.
      unfold call_expr in *. unfold arg_exprs in *.
      eapply not_arg_exprs_eq_subst_call; eassumption.
    + injection H3. intros.
      eapply H0; eassumption.
Qed.

Lemma assign_vars_deterministic : forall var_ptrs mem var_ids vals mem' mem'',
    assign_vars var_ptrs mem var_ids vals mem' ->
    assign_vars var_ptrs mem var_ids vals mem'' ->
  mem' = mem''.
Proof.
  intros.
  generalize dependent mem''.
  induction H; intros.
  - inv H0. reflexivity.
  - inv H0. inv H1. inv H10.
    rewrite H2 in H0. injection H0. intros. subst.
    assert (Heq : mem' = mem'0).
    { apply IHassign_vars. assumption. }
    subst.
    eapply write_deterministic; eassumption.
Qed.

Lemma allocate_vars_deterministic :
  forall mem var_ptrs var_ids mem' var_ptrs' mem'' var_ptrs'',
      allocate_vars mem var_ptrs var_ids mem' var_ptrs' ->
      allocate_vars mem var_ptrs var_ids mem'' var_ptrs'' ->
    (mem', var_ptrs') = (mem'', var_ptrs'').
Proof.
  intros.
  generalize dependent var_ptrs''. generalize dependent mem''.
  induction H; intros.
  - inv H0. reflexivity.
  - inv H1.
    apply IHallocate_vars in H6.
    injection H6. intros. subst.
    rewrite <- H0 in H9.
    injection H9. intros. subst. reflexivity.
Qed.

Lemma call_var_ptrs_and_mem_deterministic :
  forall var_ptrs mem arg_var_ids arg_vals var_ptrs' mem' var_ptrs'' mem'',
    call_var_ptrs_and_mem
      var_ptrs mem arg_var_ids arg_vals var_ptrs' mem' ->
    call_var_ptrs_and_mem
      var_ptrs mem arg_var_ids arg_vals var_ptrs'' mem'' ->
  (var_ptrs', mem') = (var_ptrs'', mem'').
Proof.
  intros.
  inv H. inv H0.
  assert (Heq : (mem'0, var_ptrs') = (mem'1, var_ptrs'')).
  { eapply allocate_vars_deterministic; eassumption. }
  injection Heq. intros. subst.
  f_equal.
  eapply assign_vars_deterministic; eassumption.
Qed.

Theorem continued_step_deterministic' :
  forall funcs var_ptrs var_ptrs' var_ptrs'' state state' state'' cont cont' cont'',
      continued_step funcs (var_ptrs, state, cont) (var_ptrs', state', cont') ->
      continued_step funcs (var_ptrs, state, cont) (var_ptrs'', state'', cont'') ->
    (var_ptrs', state', cont') = (var_ptrs'', state'', cont'').
Proof.
  intros; inv H; inv H0; try reflexivity;
  try (f_equal; f_equal; inv_context; inv H8; discriminate);
  try (apply bool_to_value_injective in H3; subst; reflexivity).
  - assert (Hctx: ctx0 = ctx).
    { eapply expr_head_reduction_context_unique;
      eassumption || (repeat eexists); eassumption. }
    subst.
    apply expr_head_reduction_context_injective in H4; try assumption. subst.
    f_equal; f_equal.
    + eapply proj1. eapply expr_head_reduction_determinisntic; eassumption.
    + f_equal. eapply proj2. eapply expr_head_reduction_determinisntic; eassumption.
  - eapply not_subst_call_expr_eq_subst_head_reducible in H2; try eassumption.
    destruct H2.
  - symmetry in H3.
    eapply not_subst_call_expr_eq_subst_head_reducible in H3; try eassumption.
    destruct H3.
  - assert (H3' := H3).
    eapply expr_func_reduction_context_unique in H3'; try assumption. subst.
    apply expr_func_reduction_context_injective in H3; try assumption.
    injection H3. intros. subst.
    rewrite H6 in H4. injection H4. intros. subst.
    apply list_to_list_annotated_expr_injective in H0.
    apply map_injective in H0.
    + apply combine_injective_of_same_length in H0; try assumption.
      destruct H0. subst.
      f_equal.
      assert (Heq : (var_ptrs', mem') = (var_ptrs'', mem'0)).
      { eapply call_var_ptrs_and_mem_deterministic; eassumption. }
      injection Heq. intros. subst. reflexivity.
    + intros. destruct x. destruct x'. injection H1. intros. subst. reflexivity.
Qed.

Fixpoint csubst (outer inner : continuation_after_cmd) :
                       continuation_after_cmd :=
  match outer with
  | KStop => inner
  | KSeq cmd cont                 => KSeq cmd (csubst cont inner)
  | KWhileAfterCmd expr cmd cont  => KWhileAfterCmd expr cmd (csubst cont inner)
  | KCall ctx var_ptrs cont       => KCall ctx var_ptrs (esubst cont inner)
  end

with esubst (outer : continuation_after_expr) (inner : continuation_after_cmd) :
                   continuation_after_expr :=
  match outer with
  | KExpr cont                    => KExpr (csubst cont inner)
  | KIf cmd cmd' cont             => KIf cmd cmd' (csubst cont inner)
  | KWhileAfterExpr expr cmd cont => KWhileAfterExpr expr cmd (csubst cont inner)
  end.

Lemma Skip_KStop_final funcs var_ptrs state :
  final (continued_step funcs) (var_ptrs, state, ContinuedCmd Skip KStop).
Proof.
  intros y H. inv H.
Qed.

Lemma continued_step_deterministic funcs :
  deterministic (continued_step funcs).
Proof.
  intro. intros.
  destruct x. destruct y. destruct y'. destruct p. destruct p0. destruct p1.
  eapply continued_step_deterministic'; eassumption.
Qed.

Lemma continued_step_same_continuation_of_continued_step_SKip_KStop funcs nb_steps var_ptrs state
                                                                    var_ptrs' state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip KStop) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd cont)
                                                (var_ptrs'', state'', ContinuedCmd Skip cont).
Proof. Admitted.

Lemma continued_step_KStop_of_continued_step_Skip_same_cont
        funcs nb_steps var_ptrs var_ptrs' state state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip cont) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd KStop)
                                                (var_ptrs'', state'', ContinuedCmd Skip KStop).
Proof. Admitted.

Lemma continued_step_csubst_of_continued_step
        nb_steps funcs var_ptrs state var_ptrs' state' cmd cmd' cont cont' sub_cont :
  star_count (continued_step funcs) nb_steps
    (var_ptrs, state, ContinuedCmd cmd cont)
    (var_ptrs', state', ContinuedCmd cmd' cont) ->
  star_count (continued_step funcs) nb_steps
    (var_ptrs, state, ContinuedCmd cmd (csubst cont sub_cont))
    (var_ptrs', state', ContinuedCmd cmd' (csubst cont' sub_cont)).
Proof. Admitted.

Lemma continued_step_KStop_and_cont_of_continued_step_Skip_same_cont
        funcs nb_steps var_ptrs var_ptrs' state state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip cont) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd KStop)
                                                (var_ptrs'', state'', ContinuedCmd Skip KStop) /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd cont)
                                                (var_ptrs'', state'', ContinuedCmd Skip cont).
Proof.
  intros.
  destruct (continued_step_KStop_of_continued_step_Skip_same_cont _ _ _ _ _ _ _ _ H)
    as [nb_steps' [var_ptrs'' [state'' [Hle Hstar_count]]]].
  exists nb_steps'. exists var_ptrs''. exists state''.
  repeat split; try assumption.
  assert (Heq_subst : cont = csubst KStop cont). { reflexivity. }
  rewrite Heq_subst.
  apply continued_step_csubst_of_continued_step.
  assumption.
Qed.

Lemma continued_step_KStop_and_cont_of_continued_step_Skip_KStop
        funcs nb_steps var_ptrs var_ptrs' state state' cmd cont :
  star_count (continued_step funcs) nb_steps (var_ptrs, state, ContinuedCmd cmd cont)
                                             (var_ptrs', state', ContinuedCmd Skip KStop) ->
  exists nb_steps' var_ptrs'' state'', nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd KStop)
                                                (var_ptrs'', state'', ContinuedCmd Skip KStop) /\
    star_count (continued_step funcs) nb_steps' (var_ptrs, state, ContinuedCmd cmd cont)
                                                (var_ptrs'', state'', ContinuedCmd Skip cont).
Proof.
  intros.
  destruct (continued_step_same_continuation_of_continued_step_SKip_KStop _ _ _ _ _ _ _ _ H)
      as [nb_steps' [var_ptrs'' [state'' [Hle Hstar_count]]]].
  destruct
    (continued_step_KStop_and_cont_of_continued_step_Skip_same_cont _ _ _ _ _ _ _ _ Hstar_count)
    as [nb_steps0 [var_ptrs0 [state0 [Hineq [Hstar_count0 Hstar_count1]]]]].
  exists nb_steps0. exists var_ptrs0. exists state0.
  repeat split; try assumption. lia.
Qed.

Lemma continued_step_KExpr_of_continued_step_KStop
  nb_steps funcs var_ptrs var_ptrs' state state' expr :
    star_count (continued_step funcs) nb_steps
                    (var_ptrs, state, ContinuedExpr expr (KExpr KStop))
                    (var_ptrs', state', ContinuedCmd Skip KStop) ->
    exists val ty,
      star_count (continued_step funcs) (nb_steps-1)
                      (var_ptrs, state, ContinuedExpr expr (KExpr KStop))
                      (var_ptrs', state', ContinuedExpr (Const val <: ty) (KExpr KStop)).
Proof. Admitted.

Lemma continued_step_KStop_and_cont_of_continued_step_Expr_const_KStop
        funcs nb_steps var_ptrs var_ptrs' state state' expr cont :
  star_count (continued_step funcs) nb_steps
                    (var_ptrs, state, ContinuedExpr expr cont)
                    (var_ptrs', state', ContinuedCmd Skip KStop) ->
  exists nb_steps' var_ptrs'' state'' val ty, nb_steps' <= nb_steps /\
    star_count (continued_step funcs) nb_steps'
                      (var_ptrs, state, ContinuedExpr expr (KExpr KStop))
                      (var_ptrs'', state'', ContinuedExpr (Const val <: ty) (KExpr KStop)) /\
    star_count (continued_step funcs) nb_steps'
                      (var_ptrs, state, ContinuedExpr expr cont)
                      (var_ptrs'', state'', ContinuedExpr (Const val <: ty) cont).
Proof. Admitted.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__7a.
Require Export lemma__betweennotequal.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__differenceofparts.
Require Export lemma__extension.
Require Export lemma__lessthanadditive.
Require Export lemma__lessthanbetween.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export logic.
Definition lemma__21helper : forall A B C E, (euclidean__defs.TG B A A E B E) -> ((euclidean__axioms.BetS A E C) -> (euclidean__defs.TT B A A C B E E C)).
Proof.
intro A.
intro B.
intro C.
intro E.
intro H.
intro H0.
assert (exists H1, (euclidean__axioms.BetS B A H1) /\ ((euclidean__axioms.Cong A H1 A E) /\ (euclidean__defs.Lt B E B H1))) as H1 by exact H.
destruct H1 as [H2 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
assert (* Cut *) (euclidean__axioms.neq B A) as H8.
- assert (* Cut *) ((euclidean__axioms.neq A H2) /\ ((euclidean__axioms.neq B A) /\ (euclidean__axioms.neq B H2))) as H8.
-- apply (@lemma__betweennotequal.lemma__betweennotequal B A H2 H4).
-- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
exact H11.
- assert (* Cut *) (~(B = E)) as H9.
-- intro H9.
assert (* Cut *) (euclidean__defs.Lt B B B H2) as H10.
--- apply (@eq__ind__r euclidean__axioms.Point E (fun B0 => (euclidean__defs.TG B0 A A E B0 E) -> ((euclidean__axioms.BetS B0 A H2) -> ((euclidean__defs.Lt B0 E B0 H2) -> ((euclidean__axioms.neq B0 A) -> (euclidean__defs.Lt B0 B0 B0 H2)))))) with (x := B).
----intro H10.
intro H11.
intro H12.
intro H13.
exact H12.

---- exact H9.
---- exact H.
---- exact H4.
---- exact H7.
---- exact H8.
--- assert (exists K, (euclidean__axioms.BetS B K H2) /\ (euclidean__axioms.Cong B K B B)) as H11 by exact H10.
destruct H11 as [K H12].
destruct H12 as [H13 H14].
assert (* Cut *) (~(euclidean__axioms.neq B K)) as H15.
---- intro H15.
assert (* Cut *) (euclidean__axioms.neq B B) as H16.
----- apply (@euclidean__axioms.axiom__nocollapse B K B B H15 H14).
----- assert (* Cut *) (B = B) as H17.
------ assert (* Cut *) (False) as H17.
------- assert (* Cut *) (B = B) as H17.
-------- apply (@logic.eq__refl Point B).
-------- apply (@H16 H17).
------- assert (False) as H18 by exact H17.
apply (@logic.eq__refl Point B).
------ apply (@H16 H17).
---- assert (* Cut *) (euclidean__axioms.BetS B B H2) as H16.
----- apply (@eq__ind__r euclidean__axioms.Point K (fun X => euclidean__axioms.BetS B X H2)) with (x := B).
------ exact H13.
------apply (@euclidean__tactics.NNPP (B = K) H15).

----- assert (* Cut *) (euclidean__axioms.neq B B) as H17.
------ assert (* Cut *) ((euclidean__axioms.neq B H2) /\ ((euclidean__axioms.neq B B) /\ (euclidean__axioms.neq B H2))) as H17.
------- apply (@lemma__betweennotequal.lemma__betweennotequal B B H2 H16).
------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H20.
------ assert (* Cut *) (B = B) as H18.
------- assert (* Cut *) (False) as H18.
-------- assert (* Cut *) (B = B) as H18.
--------- apply (@logic.eq__refl Point B).
--------- apply (@H17 H18).
-------- assert (False) as H19 by exact H18.
apply (@logic.eq__refl Point B).
------- apply (@H17 H18).
-- assert (* Cut *) (euclidean__axioms.neq A C) as H10.
--- assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A C))) as H10.
---- apply (@lemma__betweennotequal.lemma__betweennotequal A E C H0).
---- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H14.
--- assert (* Cut *) (exists F, (euclidean__axioms.BetS B A F) /\ (euclidean__axioms.Cong A F A C)) as H11.
---- apply (@lemma__extension.lemma__extension B A A C H8 H10).
---- destruct H11 as [F H12].
destruct H12 as [H13 H14].
assert (* Cut *) (euclidean__axioms.neq E C) as H15.
----- assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A C))) as H15.
------ apply (@lemma__betweennotequal.lemma__betweennotequal A E C H0).
------ destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H16.
----- assert (* Cut *) (exists G, (euclidean__axioms.BetS B E G) /\ (euclidean__axioms.Cong E G E C)) as H16.
------ apply (@lemma__extension.lemma__extension B E E C H9 H15).
------ destruct H16 as [G H17].
destruct H17 as [H18 H19].
assert (* Cut *) (euclidean__axioms.Cong A C A F) as H20.
------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A F C H14).
------- assert (* Cut *) (euclidean__axioms.Cong A E A H2) as H21.
-------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A H2 E H6).
-------- assert (* Cut *) (euclidean__axioms.Cong A E A E) as H22.
--------- apply (@euclidean__axioms.cn__congruencereflexive A E).
--------- assert (* Cut *) (euclidean__defs.Lt A E A C) as H23.
---------- exists E.
split.
----------- exact H0.
----------- exact H22.
---------- assert (* Cut *) (euclidean__defs.Lt A E A F) as H24.
----------- apply (@lemma__lessthancongruence.lemma__lessthancongruence A E A C A F H23 H20).
----------- assert (* Cut *) (euclidean__defs.Lt A H2 A F) as H25.
------------ apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 A E A F A H2 H24 H21).
------------ assert (* Cut *) (euclidean__defs.Out A H2 F) as H26.
------------- exists B.
split.
-------------- exact H13.
-------------- exact H4.
------------- assert (* Cut *) (euclidean__axioms.BetS A H2 F) as H27.
-------------- apply (@lemma__lessthanbetween.lemma__lessthanbetween A H2 F H25 H26).
-------------- assert (* Cut *) (euclidean__axioms.Cong E C H2 F) as H28.
--------------- apply (@lemma__differenceofparts.lemma__differenceofparts A E C A H2 F H21 H20 H0 H27).
--------------- assert (* Cut *) (euclidean__axioms.Cong E G H2 F) as H29.
---------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive E G E C H2 F H19 H28).
---------------- assert (* Cut *) (euclidean__axioms.BetS B H2 F) as H30.
----------------- apply (@lemma__3__7a.lemma__3__7a B A H2 F H4 H27).
----------------- assert (* Cut *) (euclidean__defs.Lt B G B F) as H31.
------------------ apply (@lemma__lessthanadditive.lemma__lessthanadditive B E B H2 G F H7 H18 H30 H29).
------------------ assert (* Cut *) (euclidean__defs.TG B A A C B G) as H32.
------------------- exists F.
split.
-------------------- exact H13.
-------------------- split.
--------------------- exact H14.
--------------------- exact H31.
------------------- assert (* Cut *) (euclidean__defs.TT B A A C B E E C) as H33.
-------------------- exists G.
split.
--------------------- exact H18.
--------------------- split.
---------------------- exact H19.
---------------------- exact H32.
-------------------- exact H33.
Qed.


Require Import List Arith Lia Morphisms Setoid.
From Undecidability.HOU Require Import calculus.calculus.
From Undecidability.HOU Require Import
        unification.higher_order_unification unification.nth_order_unification
        concon.conservativity_constants concon.conservativity concon.constants.
Import ListNotations.

(* ** Goldfarb sharp *)

From Undecidability.HOU Require Import
   second_order.diophantine_equations second_order.goldfarb.reduction.

Definition gonly : Const :=
  {|
    const_type := option False;
    ctype := fun o => match o with
                  | None => alpha → alpha → alpha
                  | Some f => match f with end
                  end

  |}.

#[export]
Program Instance RE_ag_gonly : retract gonly ag :=
  {|
    I := fun _ => None;
    R := fun x => match x with None => Some None | _ => None end
  |}.
Next Obligation.
  now destruct x as [[]|].
Qed.

Lemma Goldfarb_remove:
  H10 ⪯ OU 2 ag /\ OU 2 ag ⪯ OU 2 gonly.
Proof.
  split. eapply Goldfarb.
  eapply (@remove_constants_reduction ag gonly); eauto.
  intros [[]|]; cbn; eauto.
  intros [[[]|]|]; cbn; eauto.
  destruct eq_dec; intuition  discriminate.
Qed.

Lemma Goldfarb_sharp (C: Const) (re: retract gonly C):
  ctype C (I None) = alpha → alpha → alpha -> OU 2 gonly ⪯ OU 2 C.
Proof.
  intros. eapply unification_constants_monotone; eauto.
  intros [[]|]; cbn; eauto.
Qed.

Definition cfree : Const :=
  {|
    const_type := False;
    ctype := fun f => match f with end
  |}.

#[export]
Program Instance RE_cfree X : retract cfree X :=
  {|
    I := fun f => match f with end;
    R := fun x => None
  |}.

Lemma Goldfarb_Huet X:
  OU 2 gonly ⪯ OU 3 gonly /\
  OU 3 gonly ⪯ OU 3 cfree /\
  OU 3 cfree ⪯ OU 3 X.
Proof.
  repeat split.
  eapply unification_step; eauto.
  eapply remove_constants_reduction; eauto.
  intros []. intros [[]|]; cbn; eauto.
  eapply unification_constants_monotone; eauto.
  intros [].
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj2synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 Zero) (plus lv1 lv2)).
Admitted.
QuickChick conj2synthconj4.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall C D P Q Dprime S Y : Universe, ((wd_ C D /\ (wd_ P C /\ (wd_ D Dprime /\ (wd_ C Dprime /\ (wd_ P Q /\ (wd_ P D /\ (wd_ C Q /\ (wd_ S C /\ (wd_ P S /\ (col_ C Y S /\ (col_ D C Dprime /\ col_ C S D))))))))))) -> col_ C D Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj6synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 (Succ lv1)) (mult lv0 (Succ lv1))).
Admitted.
QuickChick conj6synthconj5.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e468m17_19limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e489m21_19limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Functors.
Require Import List.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.

Section EffectPure.

  (** SuperFunctor for Types. **)
  Variable DT : Set -> Set.
  Context {Fun_DT : Functor DT}.

  (** SuperFunctor for Values. **)
  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.

  (** TYPING **)
  Variable MT : Set -> Set.
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.

  (** EVALUATION **)
  Variable ME : Set -> Set.
  Context {Functor_ME : Functor ME}.
  Context {Monad_ME : Monad ME}.

  Section WFValue_Sec.

    (* ============================================== *)
    (* WELL-FORMED VALUES RELATION                     *)
    (* ============================================== *)

    Variable TypContext : Set.
    Variable WFV : (WFValue_i DT V TypContext -> Prop) -> WFValue_i DT V TypContext -> Prop.

    Inductive WFValueM_base (A : WFValueM_i DT V MT ME TypContext -> Prop) : WFValueM_i DT V MT ME TypContext -> Prop :=
    | WFVM_Return : forall Sigma v (T : DType DT) (mt : MT (DType DT)),
      WFValueC DT V TypContext WFV Sigma v T ->
      {mt' : MT {T' : DType DT | proj1_sig T = proj1_sig T'} &
        fmap (@proj1_sig _ _) mt' = mt} ->
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) mt)
    | WFVM_Untyped : forall B Sigma me (mt : MT B),
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma me (mt >> fail)).

    Definition ind_alg_WFVM_base (P : WFValueM_i DT V MT ME TypContext -> Prop)
      (H_Return : forall Sigma v T mt,
        WFValueC DT V TypContext WFV Sigma v T ->
        {mt' : MT {T' : DType DT | proj1_sig T = proj1_sig T'} &
          fmap (@proj1_sig _ _) mt' = mt} ->
        P (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) mt))
      (H_Untyped : forall B Sigma me mt,
        P (mk_WFValueM_i DT V MT ME TypContext Sigma me (mt >> fail)))
      (i : WFValueM_i DT V MT ME TypContext)
      (e : WFValueM_base P i)
      :
      P i :=
      match e in WFValueM_base _ i return P i with
        | WFVM_Return Sigma v T mt WF_v_T WF_mt => H_Return Sigma v T mt WF_v_T WF_mt
        | WFVM_Untyped B Sigma me mt => H_Untyped B Sigma me mt
      end.

    Definition WFVM_base_ifmap
      (A B : WFValueM_i  DT V MT ME TypContext-> Prop)
      (i : WFValueM_i DT V MT ME TypContext)
      (f : forall i, A i -> B i)
      (wfvm_v : WFValueM_base A i)
      :
      WFValueM_base B i :=
      match wfvm_v in WFValueM_base _ i return WFValueM_base B i with
        | WFVM_Return Sigma v T mt WF_v_T WF_mt => WFVM_Return B Sigma v T mt WF_v_T WF_mt
        | WFVM_Untyped C Sigma me mt => WFVM_Untyped B C Sigma me mt
      end.

    Global Instance iFun_WFVM_base : iFunctor WFValueM_base.
      constructor 1 with (ifmap := WFVM_base_ifmap).
      destruct a; simpl; intros; reflexivity.
      destruct a; simpl; intros; auto.
    Defined.

    Lemma WFVM_Return_T : forall A Sigma v T,
      WFValueC DT V TypContext WFV Sigma v T ->
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) (return_ T)).
    Proof.
      intros; constructor 1 with (T := T); auto.
      exists (return_ (exist (fun T' => proj1_sig T = proj1_sig T')
        T (refl_equal (proj1_sig T)))).
      rewrite fmap_m, <- left_unit; reflexivity.
    Qed.

    Lemma WFVM_Untyped_T : forall A Sigma v,
      WFValueM_base A (mk_WFValueM_i DT V MT ME TypContext Sigma (return_ v) fail).
    Proof.
      simpl; intros.
      rewrite left_unit with (a := tt) (f := fun _ => fail).
      intros; constructor 2.
    Qed.

  End WFValue_Sec.

  Section BindRule.

    Variable TypContext : Set.
    Context {TypContextCE : ConsExtensionC TypContext}.

    Variable WFV : (WFValue_i DT V TypContext -> Prop) -> WFValue_i DT V TypContext -> Prop.
    Context {funWFV : iFunctor WFV}.

    Variable WFVM : (WFValueM_i DT V MT ME TypContext -> Prop) -> WFValueM_i DT V MT ME TypContext -> Prop.
    (* Context {funWFVM : iFunctor WFVM}. *)

    Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P DT V TypContext WFV) WFV}.
    Context {Sub_WFVM_Base'_WFVM : Sub_iFunctor (WFValueM_base _ WFV) WFVM}.

    Lemma wfvm_skip Sigma (me : ME (Value V)) (mt : MT (DType DT)) (kt : DType DT -> MT (DType DT))
         (WFVM_me_kt : forall T, WFValueMC DT V MT ME TypContext WFVM Sigma me (kt T)) :
      WFValueMC DT V MT ME TypContext WFVM Sigma me (mt >>= kt).
    Proof.
      destruct (MT_eq_dec _ mt) as [[T mt_eq] | mt_eq]; subst.
      rewrite <- left_unit.
      apply WFVM_me_kt.
      rewrite bind_fail.
      apply inject_i.
      rewrite left_unit with (a := tt) (f := fun _ => fail).
      constructor 2.
    Qed.

    Lemma wfvm_fail : forall Sigma ke,
      WFValueM DT V MT ME TypContext WFVM (mk_WFValueM_i DT V MT ME _ Sigma ke fail).
    Proof.
      intros.
      apply inject_i.
      rewrite left_unit with (a := tt) (f := fun _ => fail).
      constructor 2.
    Qed.

    Global Instance wfvm_bind_base' :
      iPAlgebra wfvm_bind_Name (wfvm_bind_P DT V MT ME TypContext WFV WFVM) (WFValueM_base _ WFV).
    Proof.
      econstructor.
      unfold iAlgebra; intros; apply ind_alg_WFVM_base with (WFV := WFV);
        try assumption; unfold wfvm_bind_P; simpl; intros.
      (* WFVM_Return' *)
      destruct (MT_eq_dec _ mt) as [[T0 mt_eq] | mt_eq]; subst.
      repeat rewrite <- left_unit; eapply WFVM_ke_kt; eauto.
      apply ConsExtension_id.
      destruct H1 as [mt' mt'_eq']; subst.
      destruct (MT_eq_dec _ mt') as [[T' mt'_eq] | mt'_eq]; subst.
      rewrite fmap_return in mt'_eq'.
      apply inj_return in mt'_eq'; subst.
      destruct T'.
      destruct x.
      apply (WFV_proj1_b DT V TypContext WFV _ _ H0); simpl; auto.
      destruct (fmap_exists _ _ _ _ _ mt'_eq') as [[T' T_eq] T'_eq].
      simpl in *; subst; auto.
      destruct T0.
      apply (WFV_proj1_b DT V TypContext WFV _ _ H0); simpl; auto.
      rewrite bind_fail.
      apply wfvm_fail.
      (* WFVM_Untyped' *)
      destruct (MT_eq_dec _ mt) as [[T0 mt_eq] | mt_eq]; subst.
      unfold wbind; rewrite <- left_unit.
      rewrite bind_fail.
      apply wfvm_fail.
      unfold wbind.
      rewrite <- associativity.
      rewrite bind_fail.
      apply wfvm_fail.
    Qed.

  End BindRule.

End EffectPure.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import BE_semantics.
Require Import BE_syntax.
Require Import BE_trans_set.
Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations.
Require Import list_helper.
Require Import LTS.
Require Import PeanoNat.
Require Import String.

(* ======================== helper functions ================================ *)
Definition convertEvent (e : Event) : transition_label :=
  match e with
    | ExternalEvent name => event name
    | InternalEvent      => tau
  end.

Lemma convertEvent_inverse : forall e e',
  convertEvent e = convertEvent e' -> e = e'.
Proof.
  intros.
  destruct e, e'; inversion H; reflexivity.
Qed.

Fixpoint indexOf (B : ProcessBehaviour) (Lb : set ProcessBehaviour) : nat :=
  match Lb with
  | nil => 0
  | B' :: Lb' => if ProcessBehaviourDec B B' then 0 else S (indexOf B Lb')
  end.

Section Converter.

Variable ctx : BehaviourExpressions.
Variable behaviourTransitions : BehaviourTransSet.
Variable startProcess : ProcessName.
Hypothesis definitionOkWithTransition :
  BehaviourTransSetR ctx behaviourTransitions startProcess.

Fixpoint createBehaviourSet (T : BehaviourTransSet)
    : set ProcessBehaviour :=
  match T with
  | nil => nil
  | (B, _, B') :: T' =>
      set_add
        ProcessBehaviourDec
        B
        (set_add ProcessBehaviourDec B' (createBehaviourSet T'))
  end.

Definition behaviours := createBehaviourSet behaviourTransitions.

Definition idOf (B: ProcessBehaviour) : nat := indexOf B behaviours.

Definition startBehaviour : ProcessBehaviour :=
  match getProcessBehaviour startProcess ctx with
    | Some B => B
    | None   => stop
  end.

Fixpoint convertBehaviourTransitionsToLtsTransitions (L : BehaviourTransSet)
    : list transition  :=
  match L with
  | nil => nil
  | (B, e, B') :: L' =>
      (idOf B, convertEvent e, idOf B') ::
      (convertBehaviourTransitionsToLtsTransitions L')
  end.

Fixpoint createLabelSet (L : BehaviourTransSet) : set label :=
  match L with
  | (_, ExternalEvent l, _) :: L' => set_add string_dec l (createLabelSet L')
  | (_, InternalEvent, _) :: L'   => createLabelSet L'
  | nil                           => nil
  end.

(* ============================ LTS parameters ============================== *)
Definition transitions :=
  convertBehaviourTransitionsToLtsTransitions behaviourTransitions.
Definition states := seq 0 (List.length behaviours).
Definition labels := createLabelSet behaviourTransitions.
Definition startState := idOf startBehaviour.

(* =============================== LTS lemmas =============================== *)
Lemma StateSetNotEmpty : behaviourTransitions <> nil -> states <> nil.
Proof.
  intros transNotEmpty.
  unfold states.
  unfold behaviours.
  destruct behaviourTransitions as [| hd tl]; try easy.
  clear transNotEmpty.
  destruct (createBehaviourSet (hd :: tl)) eqn:H.
  - simpl in H.
    destruct hd, p.
    destruct (set_add ProcessBehaviourDec p0 (createBehaviourSet tl)).
    + simpl in H.
      easy.
    + simpl in H.
      destruct (ProcessBehaviourDec p p1); easy.
  - simpl.
    easy.
Qed.

Lemma StateRepresentingBehaviourInStateSet :
  forall B, In B behaviours -> In (idOf B) states.
Proof.
  clear.
  unfold idOf.
  intros.
  unfold states.
  apply in_seq.
  simpl. split; try apply Nat.le_0_l.
  induction behaviours.
  - intros. inversion H.
  - intros. simpl. destruct (ProcessBehaviourDec B a).
    + apply Nat.lt_0_succ.
    + apply Lt.lt_n_S. apply IHs. destruct H; try trivial.
      symmetry in H. easy.
Qed.

Lemma AllBehavioursInBehaviourSet :
  forall (B1 B2 : ProcessBehaviour) (e : Event) (T : BehaviourTransSet),
    In (B1, e, B2) T ->
    In B1 (createBehaviourSet T) /\ In B2 (createBehaviourSet T).
Proof.
  clear.
  intros.
  induction T.
  - inversion H.
  - destruct H.
    + simpl. destruct a, p. inversion H. subst. split; apply set_add_iff.
      * left. reflexivity.
      * right. apply set_add_iff. left. reflexivity.
    + apply IHT in H. destruct H. simpl. destruct a, p.
      split; repeat (apply set_add_iff; right); trivial.
Qed.

Lemma AllEventsInLabelsSet :
  forall (B1 B2 : ProcessBehaviour) (e : EventName),
    In (B1, ExternalEvent e, B2) behaviourTransitions ->
    In e labels.
Proof.
  unfold labels.
  unfold transitions.
  clear.
  intros.
  induction behaviourTransitions; trivial.
  simpl. destruct a, p, e0.
  - apply IHb.
    destruct H.
    + inversion H.
    + apply H.
  - destruct H.
    + inversion H. apply set_add_iff. left. reflexivity.
    + apply set_add_iff. right. apply IHb. apply H.
Qed.

Lemma StartBehaviourInBehaviourSet:
  behaviourTransitions <> nil ->
  In startBehaviour behaviours.
Proof.
  intros.
  unfold behaviours.
  pose proof AllBehavioursInBehaviourSet as inBehaviourSet.
  destruct behaviourTransitions as [ | hd tl]; try easy.
  clear H.
  inversion definitionOkWithTransition as [? ? ? ? Behaviour _ H].
  clear H0 H1 H2.
  subst.
  clear definitionOkWithTransition.
  unfold startBehaviour.
  rewrite <- Behaviour.
  inversion H. subst.
  destruct (transFromB B (hd::tl)) eqn:H'.
  - unfold T' in to_visit. simpl in to_visit. unfold to_visit in H6.
    inversion H6.
  - revert H'. revert inBehaviourSet. clear. intros inBehaviourSet H.
    assert (H' : transFromB B (hd :: tl) <> []).
    { unfold not. intros. rewrite H in H0. inversion H0. }
    apply transFromBNotEmpty in H'. destruct H' as [e [B' H']].
    apply inBehaviourSet in H'. destruct H' as [H' _]. apply H'.
Qed.

Local Open Scope type_scope.

Lemma EachLtsTransitionHasAnEquivalentBehaviour :
  forall (x : BehaviourTransSet) (b1 b2 : state) (l : transition_label) ,
    (forall t, In t x -> In t behaviourTransitions) ->
    In (b1, l, b2) (convertBehaviourTransitionsToLtsTransitions x) ->
    exists (B1 B2 : ProcessBehaviour) (e : Event),
      In (B1, e, B2) x /\ b1 = idOf B1 /\ b2 = idOf B2 /\ l = convertEvent e.
Proof.
  clear.
  unfold idOf.
  intros.
  induction x.
  - inversion H0.
  - simpl in H0.
    destruct a, p.
    simpl in H0.
    destruct H0.
    + exists p, p0, e. inversion H0.
      repeat split; try reflexivity.
      simpl. left. reflexivity.
    + assert((forall t : BehaviourTrans, In t x -> In t behaviourTransitions)).
      {  intros. apply H. right. apply H1. }
      apply IHx in H1; auto.
      destruct H1 as [B1 [B2 [ e' ]]].
      destruct H1 as [H1 [H2 [H3 ]]].
      exists B1, B2, e'.
      repeat split; auto.
      right. apply H1.
Qed.

Local Close Scope type_scope.

Lemma ValidTransitionsEquivalence :
forall (x : list transition) (st : list state) (lb : list label),
  (forall t, In t x -> In t transitions) ->
  (forall (b1 b2 : state) (l : label),
    In (b1, event l, b2) transitions -> In b1 st /\ In b2 st /\ In l lb) ->
  (forall (b1 b2 : state), In (b1, tau, b2) transitions -> In b1 st /\ In b2 st) ->
  each_transition_is_valid x st lb.
Proof.
  clear.
  intros.
  induction x.
  - simpl. apply I.
  - destruct a, p.
    destruct t.
    + simpl. pose proof (H0 s0 s l).
      assert (H3 : In (s0, event l, s) transitions).
      { apply H. simpl. left. reflexivity. }
      apply H2 in H3.
      destruct H3 as [H4 [H5 H6] ].
      repeat split; trivial.
      apply IHx.
      intros.
      apply H.
      simpl. right. apply H3.
    + simpl. pose proof (H1 s0 s).
      assert (H3 : In (s0, tau, s) transitions).
      { apply H. simpl. left. reflexivity. }
      apply H2 in H3.
      destruct H3 as [H4 H5].
      repeat split; trivial.
      apply IHx.
      intros.
      apply H.
      simpl. right. apply H3.
Qed.

Lemma AllEventTransitionsAreValid :
  forall (b1 b2 : state) (l : label),
    In (b1, event l, b2) transitions ->
    In b1 states /\ In b2 states /\ In l labels.
Proof.
  unfold transitions.
  unfold behaviours.
  intros.
  assert (forall x, In x behaviourTransitions -> In x behaviourTransitions).
  { trivial. }
  eapply EachLtsTransitionHasAnEquivalentBehaviour in H0; try apply H.
  destruct H0 as [B1 [B2 [e [H1 [H2 [H3] ] ] ] ] ].
  assert(H5 : In (B1, e, B2) behaviourTransitions). { apply H1. }
  apply AllBehavioursInBehaviourSet in H1.
  destruct H1 as [H1 H1'].
  apply StateRepresentingBehaviourInStateSet in H1.
  apply StateRepresentingBehaviourInStateSet in H1'.
  unfold behaviours in H1, H1'.
  destruct e; inversion H0.
  apply AllEventsInLabelsSet in H5.
  subst.
  repeat split; trivial.
Qed.

Lemma AllInternalTransitionsAreValid :
  forall (b1 b2 : state),
    In (b1, tau, b2) transitions -> In b1 states /\ In b2 states.
Proof.
  unfold transitions.
  unfold behaviours.
  intros.
  assert (forall x, In x behaviourTransitions -> In x behaviourTransitions).
  { trivial. }
  eapply EachLtsTransitionHasAnEquivalentBehaviour in H0; try apply H.
  destruct H0 as [B1 [B2 [e [H1 [H2 [H3] ] ] ] ] ].
  apply AllBehavioursInBehaviourSet in H1.
  destruct H1 as [H1 H1'].
  apply StateRepresentingBehaviourInStateSet in H1.
  apply StateRepresentingBehaviourInStateSet in H1'.
  unfold behaviours in H1, H1'.
  destruct e; inversion H0.
  subst.
  repeat split; trivial.
Qed.

Lemma StartStateInStateSet :
  behaviourTransitions <> nil -> In startState states.
Proof.
  intros transNotEmpty.
  apply StateRepresentingBehaviourInStateSet.
  apply StartBehaviourInBehaviourSet.
  auto.
Qed.

Lemma NoRepetitionStates : NoDup states.
Proof.
  apply seq_NoDup.
Qed.

Lemma NoRepetitionLabels : NoDup labels.
Proof.
  clear.
  unfold labels.
  induction behaviourTransitions.
  - simpl. apply NoDup_nil.
  - simpl. destruct a, p.
    destruct e.
    + apply IHb.
    + apply set_add_nodup. apply IHb.
Qed.

Lemma idOf_inverse :
  forall (B1 B2 : ProcessBehaviour),
    In B1 behaviours -> idOf B1 = idOf B2 -> B1 = B2.
Proof.
  clear.
  unfold idOf.
  intros.
  induction behaviours.
  - inversion H.
  - simpl in H. destruct H.
    + simpl in H0. destruct (ProcessBehaviourDec B1 a); subst.
      * destruct (ProcessBehaviourDec B2 B1); easy.
      * easy.
    + simpl in H0. destruct (ProcessBehaviourDec B1 a); subst.
      * destruct (ProcessBehaviourDec B2 a); easy.
      * destruct (ProcessBehaviourDec B2 a); try easy.
        inversion H0.
        apply IHs; auto.
Qed.

Lemma NoRepetitionTransitions' :
forall (x : BehaviourTransSet),
  (forall t, In t x -> In t behaviourTransitions) ->
  (NoDup x -> NoDup (convertBehaviourTransitionsToLtsTransitions x)).
Proof.
  clear.
  intros.
  induction x.
  - simpl. apply NoDup_nil.
  - simpl. destruct a, p.
    apply NoDup_cons.
    + unfold not. intros.
      apply EachLtsTransitionHasAnEquivalentBehaviour in H1.
      * destruct H1 as [p' [p0' [e']]].
        destruct H1 as [H1 [H2 [H3]]].
        assert(H' : In (p', e', p0') behaviourTransitions).
        { apply H. right. auto. }
        apply AllBehavioursInBehaviourSet in H'.
        destruct H' as [H' H'' ].
        apply idOf_inverse with (B2 := p) in H'; auto.
        apply idOf_inverse with (B2 := p0) in H''; auto.
        apply convertEvent_inverse in H4.
        subst. inversion H0. apply H6 in H1. inversion H1.
      * intros. apply H. right. apply H2.
    + inversion H0. apply IHx; auto. intros. apply H. right. apply H5.
Qed.

Lemma NoRepetitionTransitions : NoDup transitions.
Proof.
  inversion definitionOkWithTransition as [? T P B _ H _].
  clear H0 H1 H2.
  clear definitionOkWithTransition startProcess ctx.
  unfold transitions.
  apply NoRepetitionTransitions'.
  - intros. apply H0.
  - apply H.
Qed.

Definition createLtsFromBehaviourTransSet : LTS.
Proof.
  destruct behaviourTransitions eqn:H.
  - clear.
    refine (mkLTS [0] [] [] 0 _ _ _ _ _ _); try apply NoDup_nil.
    + unfold not. intros. inversion H.
    + simpl. left. reflexivity.
    + simpl. apply I.
    + apply NoDup_cons.
      * unfold not. intros H. inversion H.
      * apply NoDup_nil.
  - refine (mkLTS states labels transitions startState _ _ _ _ _ _);
    rewrite <- H in definitionOkWithTransition.
    + apply StateSetNotEmpty. rewrite H. unfold not. intros H'. inversion H'.
    + apply StartStateInStateSet. rewrite H. unfold not. intros H'.
      inversion H'.
    + eapply ValidTransitionsEquivalence.
      * intros. apply H0.
      * apply AllEventTransitionsAreValid.
      * apply AllInternalTransitionsAreValid.
    + apply NoRepetitionStates.
    + apply NoRepetitionLabels.
    + apply NoRepetitionTransitions.
Defined.

(*behaviours
  In (B1, e, B2) T -> In B1 behaviours /\ In B2 behaviours
  In B behaviours -> exists B' e, In (B, e, B') T \/ In (B', e, B) T
states
  In x states -> exists B, In B behaviours /\ idOf B = x
  In B behaviours -> In (idOf B) states
  In B1 behaviour -> idOf B1 = idOf B2 <-> B1 = B2
labels
  In (B1, ExternalEvent e, B2) T -> In e labels
  In e labels -> exists B1 B2, In (B1, ExternalEvent e, B2) T
transitions
  In (B1, e, B2) T -> In (idOf B1, convert e, idOf B2) transitions
  In (b1, l, b2) transitions ->
    exists B1 e B2,
      In (B1, e, B2) T /\ idOf B1 = b1 /\ idOf B2 = b2 /\ convert e = l
startState
  P ::= B -> startState = idOf B *)

(* ========= createLtsFromBehaviourTransSet correctness theorems ============ *)

(* behaviours theorems *)

Theorem behaviours_complete:
  forall (B1 B2 : ProcessBehaviour) (e : Event),
    In (B1, e, B2) behaviourTransitions -> In B1 behaviours /\ In B2 behaviours.
Proof.
  unfold behaviours.
  intros.
  apply AllBehavioursInBehaviourSet with (e:=e).
  auto.
Qed.

Local Open Scope type_scope.

Theorem behaviours_correct:
  forall (B : ProcessBehaviour),
    In B behaviours ->
    exists (B' : ProcessBehaviour) (e : Event),
      In (B, e, B') behaviourTransitions \/ In (B', e, B) behaviourTransitions.
Proof.
  clear.
  unfold behaviours.
  intros B H.
  induction behaviourTransitions as [| a b IHb].
  - inversion H.
  - simpl in H. destruct a as [[B1 e] B2]. apply set_add_elim in H.
    destruct H as [H | H].
    + subst. exists B2, e. left. left. reflexivity.
    + apply set_add_elim in H. destruct H as [H | H].
      * subst. exists B1, e. right. left. reflexivity.
      * apply IHb in H. destruct H as [B' [e' H]]. exists B', e'.
        destruct H as [H | H]; [left | right]; right; apply H.
Qed.

(* states theorem *)

Lemma NoDup_behaviours: NoDup behaviours.
Proof.
  clear. unfold behaviours. induction behaviourTransitions.
  - simpl. apply NoDup_nil.
  -  simpl. destruct a, p. do 2 apply set_add_nodup. apply IHb.
Qed.

Theorem states_correct:
  forall (x : nat), In x states -> exists B, In B behaviours /\ idOf B = x.
Proof.
  clear.
  unfold states.
  unfold idOf.
  intros x H.
  pose proof (NoDup_behaviours) as H'''.
  remember behaviours as bs' eqn:H'. rewrite H' in H.
  assert(Heq: Datatypes.length behaviours = Datatypes.length bs').
  { rewrite H'. reflexivity. }
  clear H'. generalize dependent bs'. induction behaviours as [|B bs IHbs];
  intros bs' H''' Heq.
  - inversion H.
  - simpl Datatypes.length in H.
    pose proof (Nat.add_comm 1 (Datatypes.length bs)) as H'. simpl in H'.
    rewrite H' in H. rewrite seq_app in H. simpl in H. apply in_app_or in H.
    simpl in Heq.
    assert (H'': exists (B' : ProcessBehaviour) (bs'' : list ProcessBehaviour),
            bs' = bs'' ++ [B']).
    { clear IHbs H' H B H'''. generalize dependent bs.
      induction bs'; intros bs H; [inversion H |]. simpl in H. inversion H.
      destruct bs'; [exists a, []; reflexivity |]. destruct bs; [inversion H1 |].
      apply IHbs' in H1. destruct H1 as [B' [bs'' H']]. exists B', (a :: bs'').
      rewrite H'. simpl. reflexivity. }
    destruct H'' as [B' [bs'' H'']]. rewrite H'' in Heq. rewrite app_length in Heq.
    simpl in Heq. rewrite <- plus_n_Sm in Heq. rewrite Nat.add_comm in Heq.
    simpl in Heq.
    destruct H as [H | H].
    + clear B.
      rewrite H'' in H'''. apply NoDup_app in H'''. destruct H''' as [H''' _].
      inversion Heq. eapply IHbs in H; [| apply H''' | apply H1]. clear H'''.
      destruct H as [B H].
      rewrite H''. exists B. clear IHbs bs' Heq H'' H1 H'. destruct H as [H H'].
      split; [apply in_or_app; auto |]. generalize dependent x.
      induction bs''; [inversion H |]. intros x H'. simpl in H'. simpl in H.
      simpl. destruct (ProcessBehaviourDec B a); auto. destruct H as [H | H].
      * elim n. auto.
      * destruct x; [inversion H'|]. inversion H'. apply f_equal. apply IHbs''; auto.
    + destruct H; [| inversion H]. clear IHbs H'. inversion Heq. rewrite H in H1.
      rewrite H1. rewrite H''. rewrite H'' in H'''. clear H Heq bs H'' H1 x B.
      exists B'. induction bs''.
      * split; simpl; auto. destruct (ProcessBehaviourDec B' B'); easy.
      * simpl in H'''. inversion H'''. apply IHbs'' in H2.
        destruct H2 as [H' H'']. simpl. rewrite H''. split; auto.
        destruct (ProcessBehaviourDec B' a); auto. subst. easy.
Qed.

Theorem states_complete : forall B, In B behaviours -> In (idOf B) states.
Proof.
  apply StateRepresentingBehaviourInStateSet.
Qed.

(* idOf *)
Theorem idOf_injective:
  forall B1 B2, In B1 behaviours -> idOf B1 = idOf B2 <-> B1 = B2.
Proof.
  split.
  - apply idOf_inverse. apply H.
  - intros H'. rewrite H'. easy.
Qed.

(* labels *)
Theorem labels_complete:
  forall (B1 B2 : ProcessBehaviour) (e : EventName),
    In (B1, ExternalEvent e, B2) behaviourTransitions -> In e labels.
Proof.
  apply AllEventsInLabelsSet.
Qed.

Theorem labels_correct:
  forall e,
    In e labels -> exists B1 B2, In (B1, ExternalEvent e, B2) behaviourTransitions.
Proof.
  clear.
  unfold labels. intros e H. induction behaviourTransitions.
  - inversion H.
  - simpl in H. destruct a, p. destruct e0.
    + apply IHb in H. destruct H as [B1 [B2 H]]. exists B1, B2. right. auto.
    + apply set_add_elim in H. destruct H as [H | H].
      * exists p, p0. rewrite H. left. auto.
      * apply IHb in H. destruct H as [B1 [B2 H]]. exists B1, B2. right. auto.
Qed.

(* transitions *)
Theorem transitions_complete:
  forall (B1 B2 : ProcessBehaviour) (e : Event),
    In (B1, e, B2) behaviourTransitions ->
    In (idOf B1, convertEvent e, idOf B2) transitions.
Proof.
  clear. unfold transitions. induction behaviourTransitions.
  - intros B1 B2 e H. inversion H.
  - intros B1 B2 e H. destruct a, p. destruct H as [H | H].
    + inversion H. simpl. left. reflexivity.
    + simpl. right. apply IHb. apply H.
Qed.

Theorem transitions_correct:
  forall (b1 b2 : nat) (l : transition_label),
  In (b1, l, b2) transitions ->
    exists B1 B2 e,
      In (B1, e, B2) behaviourTransitions /\
      b1 = idOf B1 /\ b2 = idOf B2 /\ l = convertEvent e.
Proof.
  clear. unfold transitions. intros b1 b2 l H.
  apply EachLtsTransitionHasAnEquivalentBehaviour in H; auto.
Qed.

(* startState *)
Theorem startState_correct:
  forall B, Some B = getProcessBehaviour startProcess ctx -> startState = idOf B.
Proof.
  clear. intros B H. unfold startState. unfold startBehaviour. rewrite <- H. auto.
Qed.

End Converter.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e413m21_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e221m3_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e190m11_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Canonical.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {Gamma: ProofTheory L}
        {SC: NormalSequentCalculus L Gamma}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {AX: NormalAxiomatization L Gamma}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {J: Join (Kworlds M)}
        {SM: Semantics L MD}
        {fsSM: SeparatingSemantics L MD M SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Hypothesis H_J: forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi -> (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).

Instance SA
         (AL_DC: at_least derivable_closed cP)
         (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP):
  SeparationAlgebra (Kworlds M).
Proof.
  constructor.
  + intros.
    destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    destruct (im_bij _ _ rel m) as [Phi ?].
    erewrite H_J in H |- * by eauto.
    hnf; intros.
    destruct H3 as [y [z [? [? ?]]]].
    subst.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    rewrite sepcon_comm.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    apply H.
    exists z, y; split; [| split]; auto.
  + intros.
    destruct (im_bij _ _ rel mx) as [Phi_x ?].
    destruct (im_bij _ _ rel my) as [Phi_y ?].
    destruct (im_bij _ _ rel mz) as [Phi_z ?].
    destruct (im_bij _ _ rel mxy) as [Phi_xy ?].
    destruct (im_bij _ _ rel mxyz) as [Phi_xyz ?].
    erewrite H_J in H, H0 by eauto.
    assert (Included _ (context_sepcon (proj1_sig Phi_x)
             (context_sepcon (proj1_sig Phi_y) (proj1_sig Phi_z))) (proj1_sig Phi_xyz)).
    - hnf; intros xyz ?.
      destruct H6 as [x [yz [? [? ?]]]]; subst xyz.
      apply context_sepcon_derivable in H8.
      destruct H8 as [y [z [? [? ?]]]].
      rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xyz)).
      rewrite <- H6, sepcon_assoc.
      rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xyz)).
      apply H0.
      exists (x * y), z; split; [| split]; auto.
      rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xy)).
      apply H.
      exists x, y; split; [| split]; auto.
    - apply LIN_SR in H6.
      destruct H6 as [Phi_yz [? ?]].
      unfold context_sepcon_included_r in H7.
      destruct (su_bij _ _ rel Phi_yz) as [myz ?].
      exists myz.
      erewrite !H_J by eauto.
      auto.
Qed.

Instance uSA
         (AL_DC: at_least derivable_closed cP):
  UpwardsClosedSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  exists m1, m2.
  destruct (im_bij _ _ rel n) as [Psi ?].
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H |- * by eauto.
  erewrite H_R in H0 by eauto.
  do 2 erewrite H_R by eauto.
  split; [| split].
  + eapply Included_trans; eauto.
  + hnf; intros; auto.
  + hnf; intros; auto.
Qed.

Instance dSA
         (AL_DC: at_least derivable_closed cP):
  DownwardsClosedSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  exists m.
  destruct (im_bij _ _ rel n1) as [Psi1 ?].
  destruct (im_bij _ _ rel n2) as [Psi2 ?].
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H |- * by eauto.
  erewrite H_R in H0, H1 |- * by eauto.
  split.
  + eapply Included_trans; eauto.
    hnf; intros z [x [y [? [? ?]]]]; subst.
    exists x, y.
    split; [| split]; auto.
    - eapply deduction_weaken; eauto.
    - eapply deduction_weaken; eauto.
  + hnf; intros; auto.
Qed.

Lemma garbage_collected_canonical_increaing
      {gcsGamma: GarbageCollectSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP):
  IncreasingSeparationAlgebra (Kworlds M).
Proof.
  constructor.
  intros m; hnf; intros n1 n2 ?.
  destruct (im_bij _ _ rel n1) as [Psi1 ?].
  destruct (im_bij _ _ rel n2) as [Psi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_R by eauto.
  erewrite H_J in H by eauto.
  unfold Included, Ensembles.In; intros.
  rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi1)).
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Psi2)).
  rewrite <- (sepcon_elim2 TT).
  rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Psi2)).
  apply H; auto.
  exists TT, x; split; [| split]; auto.
  apply derivable_impp_refl.
Qed.

Lemma ext_canonical_residual
      {ExtSGamma: ExtSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP):
  ResidualSeparationAlgebra (Kworlds M).
Proof.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  assert (Included _ (context_sepcon (Union _ empty_context (Singleton _ TT)) (proj1_sig Phi)) (proj1_sig Phi)).
  + hnf; intros.
    destruct H0 as [y [z [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H1.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    subst; rewrite <- H1.
    rewrite <- sepcon_comm, <- sepcon_ext; auto.
  + apply LIN_SL in H0.
    destruct H0 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    exists n; split.
    - erewrite H_J by eauto.
      auto.
    - erewrite H_R by eauto.
      hnf; intros; auto.
Qed.

Context {s'L: SeparationEmpLanguage L}
        {EmpsGamma: EmpSeparationLogic L Gamma}
        {feSM: EmpSemantics L MD M SM}.

Instance unitSA
         (AL_DC: at_least derivable_closed cP)
         (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
         (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  UnitalSeparationAlgebra (Kworlds M).
Proof.
  intros.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  assert (Included _ (context_sepcon (proj1_sig Phi) (Union _ empty_context (Singleton _ emp))) (proj1_sig Phi)).
  + hnf; intros.
    destruct H0 as [y [z [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H2.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    subst; rewrite <- H2, sepcon_emp; auto.
  + apply LIN_SR in H0.
    destruct H0 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    split; [exists n; split |].
    - apply (@join_comm _ _ (SA AL_DC LIN_SR)).
      erewrite H_J by eauto.
      auto.
    - erewrite H_R by eauto.
      hnf; intros; auto.
    - clear H1 n Phi H.
      specialize (H0 emp ltac:(right; constructor)).
      unfold Ensembles.In in H0.
      rewrite <- (TRUTH emp) in H0 by eauto.
      rewrite sat_emp in H0; auto.
Qed.

Lemma nonsplit_canonical_split_smaller
      {nssGamma: NonsplitEmpSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  IncreasingSplitSmallerSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H0 by eauto.
  erewrite H_R by eauto.
  unfold Included, Ensembles.In; intros x ?.
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
  rewrite <- (emp_sepcon_truep_elim x).
  apply deduction_andp_intros.
  + apply derivable_assum; apply H0.
    exists x, TT; split; [| split]; auto.
    - apply derivable_assum; auto.
    - apply derivable_impp_refl.
  + rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    rewrite <- (TRUTH emp) by eauto.
    rewrite sat_emp; auto.
Qed.

Lemma dup_canonical_incr_join
      {desGamma: DupEmpSeparationLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  IncreasingJoinSelfSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J by eauto.
  intros z [x [y [? [? ?]]]]; subst.
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
  rewrite <- (andp_elim1 x y).
  rewrite <- (andp_elim2 x y) at 2.
  rewrite <- emp_dup.
  apply deduction_andp_intros; [apply deduction_andp_intros |]; auto.
  rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
  unfold Ensembles.In; rewrite <- (TRUTH emp) by eauto.
  rewrite sat_emp; auto.
Qed.

End Canonical.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e198m17_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e230m27_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From isla Require Import opsem.

Definition a18218 : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 39%Z (Val (Val_Symbolic 38%Z) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 44%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (ZeroExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffe%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 48%Z (Unop (Extract 63%N 0%N) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop Concat [Manyop Concat [Manyop Concat [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Bvnot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 48%Z) Mk_annot) (Unop (Extract 63%N 0%N) (Val (Val_Bits (BV 128%N 0x3f%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Val (Val_Symbolic 48%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (SignExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (SignExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffffffffffffffffffe%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
  Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
  Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
  Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
  Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
  Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  tnil
.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e452m3_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus Zero (plus lv0 lv1)) (plus lv0 lv1)).
Admitted.
QuickChick conj5synthconj1.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e212m29_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(** The Rezk completion *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.

Require Import prelude.cubical_methods.

Local Open Scope cat.

Module Export rezk.
  Private Inductive rezk (C : category) : UU :=
  | rcl : ob C → rezk C.

  Axiom rcleq
    : ∏ (C : category) {x₁ x₂ : C} (f : z_iso x₁ x₂),
      rcl C x₁ = rcl C x₂.

  Axiom re
    : ∏ (C : category) (x : C),
      rcleq C (identity_z_iso x) = idpath (rcl C x).

  Axiom rconcat
    : ∏ (C : category)
        {x₁ x₂ x₃ : C}
        (f₁ : z_iso x₁ x₂) (f₂ : z_iso x₂ x₃),
      rcleq C (z_iso_comp f₁ f₂) = rcleq C f₁ @ rcleq C f₂.

  Definition rinv
    : ∏ (C : category) {x₁ x₂ : C} (f : z_iso x₁ x₂),
      rcleq C (z_iso_inv f) = !(rcleq C f).
  Proof.
    intros C x₁ x₂ f.
    apply path_inverse_from_right.
    rewrite pathsinv0inv0.
    rewrite <- rconcat.
    refine (_ @ re _ x₁).
    apply maponpaths.
    use subtypePath.
    {
      intro.
      apply isaprop_is_z_isomorphism.
    }
    exact (z_iso_inv_after_z_iso f).
  Qed.

  Axiom rtrunc
    : ∏ (C : category), isofhlevel 3 (rezk C).

  Section rezk_ind.
    Variable (C : category)
            (Y : rezk C → UU)
            (rclY : ∏ (x : C), Y(rcl C x))
            (rcleqY : ∏ (x₁ x₂ : C) (f : z_iso x₁ x₂),
                PathOver (rcleq C f) (rclY x₁) (rclY x₂))
            (reY : ∏ (x : C), globe_over
                                Y
                                (re C x)
                                (rcleqY x x (identity_z_iso x))
                                (idpath (rclY x)))
            (rconcatY : ∏ (x₁ x₂ x₃ : C)
                         (f₁ : z_iso x₁ x₂) (f₂ : z_iso x₂ x₃),
                globe_over
                  Y
                  (rconcat C f₁ f₂)
                  (rcleqY x₁ x₃ (z_iso_comp f₁ f₂))
                  (composePathOver
                     (rcleqY x₁ x₂ f₁)
                     (rcleqY x₂ x₃ f₂)))
            (truncY : ∏ (x : rezk C), isofhlevel 3 (Y x)).

    Fixpoint rezk_ind (x : rezk C) : Y x
      := (match x with
         | rcl _ a => fun _ _ _ _ => rclY a
          end) rcleqY reY rconcatY truncY.

    Axiom rezk_ind_beta_rcleq : ∏ (x₁ x₂ : C) (f : z_iso x₁ x₂),
        apd rezk_ind (rcleq C f)
        =
        rcleqY x₁ x₂ f.
  End rezk_ind.
End rezk.

Arguments rezk_ind {C} Y rclY rcleqY reY rconcatY truncY.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^129 - 25
Base: 32.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 32 + 1/4;
    bitwidth := 64;
    s := 2^129;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj9eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus lv0 Zero))).
Admitted.
QuickChick conj9eqsynthconj3.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj9synthconj6 : forall  (lv0 : lst) (lv1 : lst) (lv2 : natural), (@eq natural (len (append lv0 lv1)) (lv2)).
Admitted.
QuickChick conj9synthconj6.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Array.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Semantics.
Require Import bedrock2.Syntax.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import bedrock2.ZnWords.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Byte.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import HmacSpec.SHA256.
Require Import HmacSoftware.HmacSemantics.
Require Import HmacSoftware.HmacProperties.
Require Import HmacSoftware.Sha256Example.
Import Syntax.Coercions List.ListNotations HList.
Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope Z_scope.

Section Proofs.
  Context {word: word.word 32} {mem: map.map word byte}
          {word_ok: word.ok word} {mem_ok: map.ok mem}.
  Context {timing: timing}.

  (* Plug in the right state machine parameters; typeclass inference struggles here *)
  Local Notation execution := (execution (M:=hmac_state_machine)).

  Notation bytearray := (array (mem := mem) ptsto (word.of_Z 1)).

  Definition sha256_post(input_addr: word)(input: list byte)(digest_addr: word)(R: mem -> Prop)
             (tr: trace)(m: mem)(rets: list word): Prop :=
    rets = [] /\
    execution tr (IDLE (sha256 input) (* digest has been read, but still in device *)
                       {| hmac_done := false; (* done flag was already cleared *)
                          intr_enable := word.of_Z 0;
                          hmac_en := false;
                          sha_en := true;
                          swap_endian := true;
                          swap_digest := false; |}) /\
    (* digest has been stored at correct memory location: *)
    (bytearray digest_addr (sha256 input) *
    (* input and rest of memory unmodified: *)
     bytearray input_addr input * R)%sep m.

  Global Instance spec_of_sha256 : spec_of b2_sha256 :=
    fun function_env =>
      forall tr (m: mem) (R : mem -> Prop) (idlebuffer: list byte) (idleconfig: idle_data)
             (input_addr input_len digest_addr: word) (input digest_trash: list byte),
      Z.of_nat (length input) = word.unsigned input_len ->
      Z.of_nat (length digest_trash) = 32 ->
      input_addr <> word.of_Z 0 ->
      digest_addr <> word.of_Z 0 ->
      (bytearray input_addr input * bytearray digest_addr digest_trash * R)%sep m ->
      execution tr (IDLE idlebuffer idleconfig) ->
      call function_env b2_sha256 tr m [digest_addr; input_addr; input_len]
           (sha256_post input_addr input digest_addr R).

  Lemma sha256_correct :
    program_logic_goal_for_function! b2_sha256.
  Proof.
    repeat straightline.
    straightline_call. 1: ecancel_assumption. 1: eassumption.
    repeat straightline.
    straightline_call. 1: symmetry; eassumption. 1: assumption. 1: ecancel_assumption. 1: eassumption.
    repeat straightline.
    straightline_call. 1: eassumption. 1: assumption. 1: ecancel_assumption. 1: eassumption.
    repeat straightline.
    unfold sha256_post.
    split; [reflexivity|]. split; [assumption|].
    rewrite List.app_nil_l in *. ecancel_assumption.
  Qed.
End Proofs.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj7synthconj3 : forall  (lv0 : lst), (@eq natural (len (Cons (len lv0) lv0)) (Succ (len lv0))).
Admitted.
QuickChick conj7synthconj3.


Require Import Effects.

Set Universe Polymorphism.
Set Primitive Projections.

Module Type S.
Axiom E@{i} : Type@{i}.
End S.

Module Make(Import M : S).

Inductive M (A : Type) :=
| Ok : A -> M A
| Err : E -> M A.

Definition ret {A} (x : A) := Ok _ x.

Definition map {A B} (f : A -> B) (l : M A) : M B :=
match l with
| Ok _ x => Ok _ (f x)
| Err _ e => Err _ e
end.

Definition pointwise {A} (f : A -> Type) (l : M A) : Type :=
match l with
| Ok _ x => f x
| Err _ _ => unit
end.

Fixpoint bind {A B} (l : M A) (f : A -> M B) : M B :=
match l with
| Ok _ x => f x
| Err _ e => Err _ e
end.

(** Those are derived constructions. TODO: implement me automagically *)

Definition TYPE := sig Type (fun A => M A -> A).

Definition El (A : M TYPE) : TYPE :=
match A with
| Ok _ X => X
| Err _ e => exist Type (fun A => M A -> A) unit (fun _ => tt)
end.

(** To be defined *)

Definition hbind {A} {B : M TYPE} (x : M A) (f : A -> (El B).(wit)) : (El B).(wit) :=
match x with
| Ok _ x => f x
| Err _ e => (El B).(prf) (Err _ e)
end.

(** More derived stuff *)

Definition Free (A : Type) : M TYPE :=
  ret (exist Type (fun A => M A -> A) (M A) (fun x => bind x (fun x => x))).

Definition Typeᵉ : M TYPE := Free TYPE.

(* Check Typeᵉ : (El Typeᵉ).(wit). *)

Definition Prodᵉ (A : M TYPE) (B : (El A).(wit) -> M TYPE) : M TYPE.
Proof.
refine (ret (exist _ _ (forall x : (El A).(wit), (El (B x)).(wit)) _)).
refine (fun f x => hbind f (fun f => f x)).
Defined.

Notation "⌈ A ⌉" := (El A).(wit).

Notation "x →ᵉ y" := (Prodᵉ _ (fun (_ : x) => y))
  (at level 99, y at level 200, right associativity).

Notation "'Πᵉ'  x .. y , P" := (Prodᵉ _ (fun x => .. (Prodᵉ _ (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity).

End Make.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e166m5_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.