import tactic.basic
import tactic.omega
import tactic.tauto
import .ch11_imp

/-
Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: ∀c st st1 st2,
    st =[ c ]⇒ st1 →
    st =[ c ]⇒ st2 →
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.
-/

-- namespace tactic
-- open native

-- meta def names : list expr → tactic (list name) :=
-- λes, match es with
-- | [] := do pure []
-- | e::es := do
--   es' ← names es,
--   pure $ e.local_pp_name::es'
-- end

-- meta def inv (h : name) (ns : list name := []): tactic unit := do
--   h' ← get_local h,
--   rs ← cases h',
--   try $ clear_lst [h],
--   subst_vars,
--   g ← get_goals,
--   -- supporting naming
--   try $ (list.zip g rs).mmap'(λr, do
--     -- trace r,
--     let ⟨g, n, e⟩ := r,
--     n' ← names e,
--     rename_many (rb_map.of_list $ n'.zip ns)
--     -- trace r
--     -- try $ with_enable_tags $ set_main_tag [n]
--   )

-- end tactic

open interactive interactive.types lean.parser tactic

namespace tactic.interactive

meta def inv (h : parse ident) (w : parse with_ident_list): tactic unit :=
  propagate_tags $ do
  h' ← get_local h,
  rs ← cases (none, pexpr.of_expr h') w,
  try $ propagate_tags $ do
  clear_lst [h],
  subst_vars
  -- g ← get_goals,
  -- -- supporting naming
  -- try $ (list.zip g rs).mmap'(λr, do
  --   -- trace r,
  --   let ⟨g, n, e⟩ := r,
  --   n' ← names e,
  --   rename_many (rb_map.of_list $ n'.zip ns)
  --   -- trace r
  --   -- try $ with_enable_tags $ set_main_tag [n]
  -- )

end tactic.interactive

open imp imp.ceval

/-
inductive ceval : com → state → state → Prop
| E_Skip : ∀st, ceval SKIP st st
| E_Ass : ∀{st a₁ n} x,
  aeval st a₁ = n →
  ceval (x ::= a₁) st (x !→ n ; st)
| E_Seq : ∀{c₁ c₂ st st' st''},
  ceval c₁ st st' →
  ceval c₂ st' st'' →
  ceval (c₁ ;; c₂) st st''
| E_IfTrue : ∀{st st' b c₁} c₂,
  beval st b = tt →
  ceval c₁ st st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st st'
| E_IfFalse : ∀{st st' b} c₁ {c₂},
  beval st b = ff →
  ceval c₂ st st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st st'
| E_WhileFalse : ∀{b st} c,
  beval st b = ff →
  ceval (WHILE b DO c END) st st
| E_WhileTrue : ∀{st st' st'' b c},
  beval st b = tt →
  ceval c st st' →
  ceval (WHILE b DO c END) st' st'' →
  ceval (WHILE b DO c END) st st''

-/

/- it's horrible (like the coq version) -/
/-
TODO  i could make it less so with names since i improved the tactic
-/
theorem ceval_deterministic {c st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : st =[ c ]⇒ st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂; inv h₂,
  case E_Ass { refl, },
  case E_Seq {
    cases h₁_ih_a h₂_a,
    exact h₁_ih_a_1 h₂_a_1,
  },
  case E_IfTrue E_IfTrue { exact h₁_ih h₂_a_1, },
  case E_IfTrue E_IfFalse {
    rw h₁_a at h₂_a,
    contradiction,
  },
  case E_IfFalse E_IfTrue {
    rw h₁_a at h₂_a,
    contradiction,
  },
  case E_IfFalse E_IfFalse { exact h₁_ih h₂_a_1, },
  case E_WhileFalse E_WhileTrue {
    rw h₁_a at h₂_a,
    contradiction,
  },
  case E_WhileTrue E_WhileFalse {
    rw h₁_a at h₂_a,
    contradiction,
  },
  case E_WhileTrue E_WhileTrue {
    cases h₁_ih_a h₂_a_1,
    exact h₁_ih_a_1 h₂_a_2,
  },
end

/-
Example auto_example_1 : ∀(P Q R: Prop),
  (P → Q) → (Q → R) → P → R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.
-/

example {P Q R : Prop} (hpq : P → Q) (hqr : Q → R) (hp : P) : R :=
begin
  apply hqr,
  apply hpq,
  exact hp,
end

/-
Example auto_example_1' : ∀(P Q R: Prop),
  (P → Q) → (Q → R) → P → R.
Proof.
  auto.
Qed.
-/

example (P Q R : Prop) : (P → Q) → (Q → R) → P → R := by tauto

/-
Example auto_example_2 : ∀P Q R S T U : Prop,
  (P → Q) →
  (P → R) →
  (T → R) →
  (S → T → U) →
  ((P→Q) → (P→S)) →
  T →
  P →
  U.
Proof. auto. Qed.
-/

/- tauto is not good -/
example (P Q R S T U : Prop) :
  (P → Q) →
  (P → R) →
  (T → R) →
  (S → T → U) →
  ((P → Q) → (P → S)) →
  T →
  P →
  U := by
begin
  intros,
  apply a_3; tauto,
end

/- cc destroys this though -/
example (P Q R S T U : Prop) :
  (P → Q) →
  (P → R) →
  (T → R) →
  (S → T → U) →
  ((P → Q) → (P → S)) →
  T →
  P →
  U := by cc

/-
Example auto_example_3 : ∀(P Q R S T U: Prop),
  (P → Q) →
  (Q → R) →
  (R → S) →
  (S → T) →
  (T → U) →
  P →
  U.
Proof.
  (* When it cannot solve the goal, auto does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.
-/

/- no depth limit -/
/- tauto is kind of terrible -/
example (P Q R S T U : Prop) :
  (P → Q) →
  (Q → R) →
  (R → S) →
  (S → T) →
  (T → U) →
  P →
  U :=
begin
  intros,
  apply a_4,
  apply a_3,
  apply a_2,
  tauto,
end

/- again, cc ftw -/
example (P Q R S T U : Prop) :
  (P → Q) →
  (Q → R) →
  (R → S) →
  (S → T) →
  (T → U) →
  P →
  U := by cc

/-
Example auto_example_4 : ∀P Q R : Prop,
  Q →
  (Q → R) →
  P ∨ (Q ∧ R).
Proof. auto. Qed.
-/

/- tauto failed here too -/
example (P Q R : Prop) : Q → (Q → R) → P ∨ (Q ∧ R) := by cc

/-
Lemma le_antisym : ∀n m: nat, (n ≤ m ∧ m ≤ n) → n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : ∀n m p : nat,
  (n ≤ p → (n ≤ m ∧ m ≤ n)) →
  n ≤ p →
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.
-/

lemma le_antisym {n m : ℕ} (h : n ≤ m ∧ m ≤ n) : n = m := by finish

/- maybe not the best idea, but tauto can pick this up -/
-- local attribute [refl] le_antisym

/-
hint is dope
-/

/- le_antisym not needed -/
example (n m p : ℕ) :
  (n ≤ p → n ≤ m ∧ m ≤ n) →
  n ≤ p →
  n = m := by finish using [le_antisym] {classical := ff}

/-
Hint Resolve T.

Hint Constructors c.

Hint Unfold d.
-/

/-
seems like attribute refl or simp handles that
-/

/-
Hint Resolve le_antisym.

Example auto_example_6' : ∀n m p : nat,
  (n≤ p → (n ≤ m ∧ m ≤ n)) →
  n ≤ p →
  n = m.
Proof.
  intros.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: ∀x,
  (x ≤ 42 ∧ 42 ≤ x) → is_fortytwo x.
Proof.
  auto. (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : ∀x,
  (x ≤ 42 ∧ 42 ≤ x) → is_fortytwo x.
Proof. auto. Qed.
-/

/- clarify and safe work too -/
/- iversions don't use classical -/

/- hint was never needed -/
example (n m p : ℕ) :
  (n ≤ p → n ≤ m ∧ m ≤ n) →
  n ≤ p →
  n = m := by ifinish

def is_fortytwo (x) := x = 42

-- example (x) : (x ≤ 42 ∧ 42 ≤ x) → is_fortytwo x := by isafe,

example (x) : (x ≤ 42 ∧ 42 ≤ x) → is_fortytwo x := by isafe using is_fortytwo

local attribute [simp] is_fortytwo

example (x) : (x ≤ 42 ∧ 42 ≤ x) → is_fortytwo x := by finish

/-
Theorem ceval_deterministic': ∀c st st1 st2,
    st =[ c ]⇒ st1 →
    st =[ c ]⇒ st2 →
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.
-/

theorem ceval_deterministic' {c st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : st =[ c ]⇒ st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂; inv h₂; try { ifinish },
  /- E_ASS -/ { tauto, },
  /- E_SEQ -/ {
    have : h₁_st' = h₂_st', tauto,
    ifinish,
  },
  /- E_WHILE_TRUE E_WHILE_TRUE -/ {
    have : h₁_st' = h₂_st', tauto,
    ifinish,
  },
end

/- not a lot of repetition above -/
/- it's horribly slow and obnoxious to run though -/

/-
Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': ∀c st st1 st2,
    st =[ c ]⇒ st1 →
    st =[ c ]⇒ st2 →
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.
-/

namespace tactic.interactive

/-
TODO: use rewrite_rules, location, and with_ident_list
-/
meta def rwinv (h₁ h₂ : parse ident) : tactic unit :=
propagate_tags $ do
  h₁' ← get_local h₁,
  h₂' ← get_local h₂,
  rewrite_hyp h₁' h₂',
  inv h₂ []

end tactic.interactive

theorem ceval_deterministic'' {c st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : st =[ c ]⇒ st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂; inv h₂; try { tauto <|> rwinv h₁_a h₂_a },
  case E_Seq {
    have : h₁_st' = h₂_st', tauto,
    ifinish,
  },
  case E_WhileTrue E_WhileTrue {
    have : h₁_st' = h₂_st', tauto,
    ifinish,
  },
end

/-
Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    ⊢ _ ⇒ rwinv H1 H2
  end.
-/

namespace tactic.interactive

-- meta def eq_bool (b : bool): list expr → tactic (option expr)
-- | [] := none
-- | (e::es) := do
--   e' ← infer_type e,
--   match e' with
--   | `(_ = %%b') := if (reflect b).to_expr = b'
--                    then pure $ some e
--                    else eq_bool es
--   | _ := eq_bool es
--   end

meta def find_rwinv : tactic unit :=
do
  ctx ← local_context,
  mv ← mk_mvar,
  h₁ ← find_same_type `(%%mv = tt) ctx,
  h₂ ← find_same_type `(%%mv = ff) ctx,
  rwinv h₁.local_pp_name h₂.local_pp_name

end tactic.interactive

theorem ceval_deterministic''' {c st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : st =[ c ]⇒ st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂; inv h₂; try { tauto <|> find_rwinv },
  case E_Seq {
    have : h₁_st' = h₂_st', tauto,
    ifinish,
  },
  case E_WhileTrue E_WhileTrue {
    have : h₁_st' = h₂_st', tauto,
    ifinish,
  },
end

/-
Ltac find_eqn :=
  match goal with
    H1: ∀x, ?P x → ?L = ?R,
    H2: ?P ?X
    ⊢ _ ⇒ rewrite (H1 X H2) in *
  end.
-/

/-
ltac is nice...
-/
namespace tactic.interactive

open expr binder_info

-- meta def expr_view : expr → tactic string := λe, do
--   trace $ "e: " ++ to_string e,
--   s ← match e with
--   | app e body :=
--     pure $ "app: " ++ to_string e ++ to_string body
--   | const n l := pure $ "const: " ++ to_string n ++ to_string l
--   | elet n e₁ e₂ body :=
--     pure $ "elet: " ++ to_string n ++ to_string e₁ ++
--       to_string e₂ ++ to_string body
--   | lam n bind e body :=
--     pure $ "lam: " ++ to_string n ++ to_string e ++ to_string body
--   | local_const n₁ n₂ bind e :=
--     pure $ "loc: " ++ to_string n₁ ++ to_string n₂ ++ to_string e
--   | macro d es := pure $ "mac: " ++ to_string es
--   | mvar n₁ n₂ e :=
--     pure $ "mvar: " ++ to_string n₁ ++ to_string n₂ ++ to_string e
--   | pi n bind e body :=
--     -- expr_view e >>= λe,
--     -- expr_view body >>= λbody,
--     pure $ "pi: " ++ to_string n ++ to_string e ++ to_string body
--   | sort l := pure $ "sort: " ++ to_string l
--   | var n := pure $ "var: " ++ to_string n
--   end,
--   trace s,
--   pure s

-- meta def ctx_view : tactic unit :=
-- do
--   ctx ← local_context,
--   ctx.mmap' (λh, expr_view h >> infer_type h >>= expr_view)

-- meta def infer (e : expr) : tactic (expr × expr) := do
--   e' ← infer_type e,
--   pure (e, e')

meta def find_pi : (list (expr × expr)) → tactic (list (expr × expr)) := λes,
  match es with
  | (n, (pi _ _ _ (pi _ _ (app e₁ e₂) `(%%l = %%r))))::es := do
    es ← find_pi es,
    pure $ (n, e₁)::es
  | (_::es) := find_pi es
  | _ := pure $ []
  end

meta def find_app (e: expr) : (list (expr × expr)) → tactic (list (expr × expr))
:= λes,
  match es with
  | (n, (app e₁ e₂))::es := do
    es ← find_app es,
    pure $ if e = e₁ then (n, e₂)::es else es
  | (_::es) := find_app es
  | _ := pure $ []
  end

meta def find_props : tactic (list (expr × expr × expr)) := do
  h ← local_context,
  h ← h.mmap (λh, do h' ← infer_type h, pure (h, h')),
  a ← find_pi h,
  p ← a.mmap (λ⟨n, e⟩, do
    p ← find_app e h,
    pure $ p.map (λ⟨n₁, e⟩, (n, n₁, e))
  ),
  pure p.join

meta def find_eqn : tactic unit :=
propagate_tags $ do
  p ← find_props,
  p.mmap' (λ⟨n₁, n₂, e⟩, do
    h ← note `this none (mk_app n₁ [e, n₂]),
    do tactic.subst h <|> tactic.clear h
  )

end tactic.interactive

/-
Theorem ceval_deterministic''''': ∀c st st1 st2,
    st =[ c ]⇒ st1 →
    st =[ c ]⇒ st2 →
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.
-/

/-
note: finish fails to find refl for E_ASS and find_eqn runs a loop internally
-/
theorem ceval_deterministic''''' {c st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : st =[ c ]⇒ st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂;
    inv h₂;
    try { refl <|> find_rwinv };
    find_eqn;
    ifinish,
end

/-
Module Repeat.

Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CRepeat (c : com) (b : bexp).
-/

namespace repeat

inductive com
| CSkip
| CAsgn (x : string) (a : aexp)
| CSeq (c₁ c₂ : com)
| CIf (b : bexp) (c₁ c₂ : com)
| CWhile (b : bexp) (c : com)
| CRepeat (c : com) (b : bexp)

open com

/-
Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state → com → state → Prop :=
  | E_Skip : ∀st,
      ceval st SKIP st
  | E_Ass : ∀st a1 n X,
      aeval st a1 = n →
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : ∀c1 c2 st st' st'',
      ceval st c1 st' →
      ceval st' c2 st'' →
      ceval st (c1 ; c2) st''
  | E_IfTrue : ∀st st' b1 c1 c2,
      beval st b1 = true →
      ceval st c1 st' →
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : ∀st st' b1 c1 c2,
      beval st b1 = false →
      ceval st c2 st' →
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : ∀b1 st c1,
      beval st b1 = false →
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : ∀st st' st'' b1 c1,
      beval st b1 = true →
      ceval st c1 st' →
      ceval st' (WHILE b1 DO c1 END) st'' →
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : ∀st st' b1 c1,
      ceval st c1 st' →
      beval st' b1 = true →
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : ∀st st' st'' b1 c1,
      ceval st c1 st' →
      beval st' b1 = false →
      ceval st' (CRepeat c1 b1) st'' →
      ceval st (CRepeat c1 b1) st''.

Notation "st '=[' c ']⇒' st'" := (ceval st c st')
                                 (at level 40).
-/

local notation `SKIP` := CSkip
local infix ` ::= `:60 := CAsgn
local infix ` ;; `:35 := CSeq
local notation `WHILE ` b ` DO ` c ` END` := CWhile b c
local notation `TEST ` c₁ ` THEN ` c₂ ` ELSE ` c₃ ` FI` := CIf c₁ c₂ c₃
local notation `REPEAT ` e₁ ` UNTIL ` b₂ ` END` := CRepeat e₁ b₂

inductive ceval : com → imp.state → imp.state → Prop
| E_Skip : ∀st, ceval SKIP st st
| E_Ass : ∀{st a₁ n} x,
  aeval st a₁ = n →
  ceval (x ::= a₁) st (x !→ n ; st)
| E_Seq : ∀{c₁ c₂ st st' st''},
  ceval c₁ st st' →
  ceval c₂ st' st'' →
  ceval (c₁ ;; c₂) st st''
| E_IfTrue : ∀{st st' b c₁} c₂,
  beval st b = tt →
  ceval c₁ st st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st st'
| E_IfFalse : ∀{st st' b} c₁ {c₂},
  beval st b = ff →
  ceval c₂ st st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st st'
| E_WhileFalse : ∀{b st} c,
  beval st b = ff →
  ceval (WHILE b DO c END) st st
| E_WhileTrue : ∀{st st' st'' b c},
  beval st b = tt →
  ceval c st st' →
  ceval (WHILE b DO c END) st' st'' →
  ceval (WHILE b DO c END) st st''
| E_RepeatEnd : ∀{st st' b c},
  ceval c st st' →
  beval st' b = tt →
  ceval (REPEAT c UNTIL b END) st st'
| E_RepeatLoop : ∀{st st' st'' b c},
  ceval c st st' →
  beval st' b = ff →
  ceval (REPEAT c UNTIL b END) st' st'' →
  ceval (REPEAT c UNTIL b END) st st''

open ceval

local notation st ` =[ ` c ` ]⇒ ` st' := ceval c st st'

open imp

/-
Theorem ceval_deterministic: ∀c st st1 st2,
    st =[ c ]⇒ st1 →
    st =[ c ]⇒ st2 →
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't find_rwinv solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.
-/

/-
TODO: for reasons i cannot even begin to fathom,
using notation for h₂ breaks it

note: ifinish can handle find_rwinv so moving find_eqn makes no difference
-/
theorem ceval_deterministic {c : com} {st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : ceval c st st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂;
    inv h₂;
    try { refl <|> find_rwinv };
    find_eqn;
    ifinish,
end

/-
Theorem ceval_deterministic': ∀c st st1 st2,
    st =[ c ]⇒ st1 →
    st =[ c ]⇒ st2 →
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.
End Repeat.
-/

theorem ceval_deterministic' {c : com} {st st₁ st₂}
  (h₁ : st =[ c ]⇒ st₁) (h₂ : ceval c st st₂)
  : st₁ = st₂ :=
begin
  induction h₁ generalizing st₂;
    inv h₂;
    find_eqn;
    try { refl <|> find_rwinv };
    ifinish,
end

end repeat

/-
Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X ≤ 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]⇒ (Z !-> 4 ; X !-> 2).
Proof.
  (* We supply the intermediate state st'... *)
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.
-/

example :
  empty_st =[
    X ::= 2;;
    TEST X ≤' 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]⇒ Z !→ 4 ; X !→ 2 :=
begin
  apply E_Seq,
    apply E_Ass,
    refl,
  apply E_IfFalse,
    refl,
  apply E_Ass,
  refl,
end

/-
Example ceval'_example1:
  empty_st =[
    X ::= 2;;
    TEST X ≤ 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]⇒ (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.
-/

/-
eapply doesn't create the metavariable subgoal,
but it doesn't have any other noticeable effects in this proof
-/

example :
  empty_st =[
    X ::= 2;;
    TEST X ≤' 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]⇒ Z !→ 4 ; X !→ 2 :=
begin
  eapply E_Seq,
    eapply E_Ass,
    refl,
  eapply E_IfFalse,
    refl,
  eapply E_Ass,
  refl,
end

/-
Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := (Y !-> 2 ; X !-> 1).
Definition st21 := (Y !-> 1 ; X !-> 2).

Example eauto_example : ∃s',
  st21 =[
    TEST X ≤ Y
      THEN Z ::= Y - X
      ELSE Y ::= X + Z
    FI
  ]⇒ s'.
Proof. eauto. Qed.
-/

/-
TODO: no finishing tactic handles this
-/

-- def st₁₂ := Y !→ 2 ; X !→ 1
-- def st₂₁ := Y !→ 1 ; X !→ 2

-- example : ∃s',
--   st₂₁ =[
--     TEST X ≤' Y
--       THEN Z ::= Y - X
--       ELSE Y ::= X + Z
--     FI
--   ]⇒ s' := by ifinish


import data.complex.basic

namespace cau_seq

theorem const_inv {α β : Type*} [discrete_field β] [discrete_linear_ordered_field α] {abv : β → α}
  [is_absolute_value abv] {x : β} (hx : x ≠ 0) :
  const abv (x⁻¹) = inv (const abv x) (by rwa const_lim_zero) :=
 ext (assume n, by simp[inv_apply, const_apply])

end cau_seq

namespace real

open cau_seq real

lemma eq_lim_of_const_equiv {f : cau_seq ℝ abs} {x : ℝ} (h : cau_seq.const abs x ≈ f) : x = lim f :=
const_equiv.mp $ setoid.trans h $ equiv_lim f

lemma lim_eq_of_equiv_const {f : cau_seq ℝ abs} {x : ℝ} (h : f ≈ cau_seq.const abs x) : lim f = x :=
(eq_lim_of_const_equiv $ setoid.symm h).symm

lemma lim_eq_lim_of_equiv {f g : cau_seq ℝ abs} (h : f ≈ g) : lim f = lim g :=
lim_eq_of_equiv_const $ setoid.trans h $ equiv_lim g

@[simp] lemma lim_const (x : ℝ) : lim (const abs x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq ℝ abs) : lim f + lim g = lim ⇑(f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const abs (lim ⇑f + lim ⇑g) - (f + g)),
  by rw [const_add, add_sub_comm];
  exact add_lim_zero (setoid.symm (equiv_lim f)) (setoid.symm (equiv_lim g))

lemma lim_mul_lim (f g : cau_seq ℝ abs) : lim f * lim g = lim ⇑(f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const abs (lim ⇑f * lim ⇑g) - f * g),
  from have h : const abs (lim ⇑f * lim ⇑g) - f * g = g * (const abs (lim f) - f)
      + const abs (lim f) * (const abs (lim g) - g) :=
    by simp [mul_sub, mul_comm, const_mul, mul_add],
  by rw h; exact add_lim_zero (mul_lim_zero _ (setoid.symm (equiv_lim f)))
      (mul_lim_zero _ (setoid.symm (equiv_lim g)))

lemma lim_mul (f : cau_seq ℝ abs) (x : ℝ) : lim f * x = lim ⇑(f * const abs x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq ℝ abs) : lim ⇑(-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const abs (-lim ⇑f)),
  by rw [const_neg, sub_neg_eq_add, add_comm];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq ℝ abs) : lim f = 0 ↔ lim_zero f :=
⟨assume h,
  by have hf := equiv_lim f;
  rw h at hf;
  exact (lim_zero_congr hf).mpr (const_lim_zero.mpr rfl),
assume h,
  have h₁ : f = (f - const abs 0) := ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

lemma lim_inv {f : cau_seq ℝ abs} (hf : ¬ lim_zero f) : lim ⇑(inv f hf) = (lim f)⁻¹ :=
have hl : lim f ≠ 0 := by rwa ← lim_eq_zero_iff at hf,
lim_eq_of_equiv_const $ show lim_zero (inv f hf - const abs (lim ⇑f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq ℝ abs) (hf : ¬ lim_zero f), lim_zero (g - f * inv f hf * g) :=
    λ g f hf, by rw [← one_mul g, ← mul_assoc, ← sub_mul, mul_one, mul_comm, mul_comm f];
    exact mul_lim_zero _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abs (lim ⇑f)⁻¹) - (const abs (lim f) - f) *
      (inv f hf * const abs (lim ⇑f)⁻¹)) :=
    by rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add];
    exact show lim_zero (inv f hf - const abs (lim ⇑f) * (inv f hf * const abs (lim ⇑f)⁻¹)
      - (const abs (lim ⇑f)⁻¹ - f * (inv f hf * const abs (lim ⇑f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ by rw mul_comm; exact mul_lim_zero _ (setoid.symm (equiv_lim f))

end real

namespace complex
open cau_seq

lemma re_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq abs f) (z : ℂ) :
    cau_seq.const abs z ≈ ⟨f, hf⟩ → cau_seq.const _root_.abs z.re ≈ ⟨(λ (n : ℕ), (f n).re),
    complex.is_cau_seq_re ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_re,←complex.add_re],
  exact lt_of_le_of_lt (complex.abs_re_le_abs _) hi,
end

lemma im_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq abs f) (z : ℂ) :
    cau_seq.const abs z ≈ ⟨f, hf⟩ → cau_seq.const _root_.abs z.im ≈ ⟨(λ (n : ℕ), (f n).im),
    complex.is_cau_seq_im ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_im,←complex.add_im],
  exact lt_of_le_of_lt (complex.abs_im_le_abs _) hi,
end

lemma eq_lim_of_const_equiv {f : cau_seq ℂ abs}  {z: ℂ} :
    cau_seq.const complex.abs z ≈ f → z = complex.lim f := begin
  assume h,
  unfold complex.lim,cases z with zre zim,simp,
  split, have := real.equiv_lim ⟨(λ (n : ℕ), (f.1 n).re), complex.is_cau_seq_re f⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.re_const_equiv_of_const_equiv f.2 {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
  have := real.equiv_lim ⟨(λ (n : ℕ), (f.1 n).im), complex.is_cau_seq_im f⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.im_const_equiv_of_const_equiv f.2 {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
end

lemma lim_eq_of_equiv_const {f : cau_seq ℂ complex.abs} {x : ℂ} (h : f ≈ cau_seq.const complex.abs x) : lim f = x :=
(eq_lim_of_const_equiv $ setoid.symm h).symm

lemma lim_eq_lim_of_equiv {f g : cau_seq ℂ complex.abs} (h : f ≈ g) : lim f = lim g :=
lim_eq_of_equiv_const $ setoid.trans h $ equiv_lim g

@[simp] lemma lim_const (x : ℂ) : lim (const abs x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq ℂ complex.abs) : lim f + lim g = lim ⇑(f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const complex.abs (lim ⇑f + lim ⇑g) - (f + g)),
  by rw [const_add, add_sub_comm];
  exact add_lim_zero (setoid.symm (equiv_lim f)) (setoid.symm (equiv_lim g))

lemma lim_mul_lim (f g : cau_seq ℂ complex.abs) : lim f * lim g = lim ⇑(f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const complex.abs (lim ⇑f * lim ⇑g) - f * g),
  from have h : const complex.abs (lim ⇑f * lim ⇑g) - f * g = g * (const complex.abs (lim f) - f)
      + const complex.abs (lim f) * (const complex.abs (lim g) - g) :=
    by simp [mul_sub, mul_comm, const_mul, mul_add],
  by rw h; exact add_lim_zero (mul_lim_zero _ (setoid.symm (equiv_lim f)))
      (mul_lim_zero _ (setoid.symm (equiv_lim g)))

lemma lim_mul (f : cau_seq ℂ complex.abs) (x : ℂ) : lim f * x = lim ⇑(f * const complex.abs x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq ℂ complex.abs) : lim ⇑(-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const complex.abs (-lim ⇑f)),
  by rw [const_neg, sub_neg_eq_add, add_comm];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq ℂ complex.abs) : lim f = 0 ↔ lim_zero f :=
⟨assume h,
  by have hf := equiv_lim f;
  rw h at hf;
  exact (lim_zero_congr hf).mpr (const_lim_zero.mpr rfl),
assume h,
  have h₁ : f = (f - const complex.abs (0 : ℂ)) := cau_seq.ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

lemma lim_inv {f : cau_seq ℂ complex.abs} (hf : ¬ lim_zero f) : lim ⇑(inv f hf) = (lim f)⁻¹ :=
have hl : lim f ≠ 0 := by rwa ← lim_eq_zero_iff at hf,
lim_eq_of_equiv_const $ show lim_zero (inv f hf - const abs (lim ⇑f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq ℂ abs) (hf : ¬ lim_zero f), lim_zero (g - f * inv f hf * g) :=
    λ g f hf, by rw [← one_mul g, ← mul_assoc, ← sub_mul, mul_one, mul_comm, mul_comm f];
    exact mul_lim_zero _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abs (lim ⇑f)⁻¹) - (const abs (lim f) - f) *
      (inv f hf * const abs (lim ⇑f)⁻¹)) :=
    by rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add];
    exact show lim_zero (inv f hf - const abs (lim ⇑f) * (inv f hf * const abs (lim ⇑f)⁻¹)
      - (const abs (lim ⇑f)⁻¹ - f * (inv f hf * const abs (lim ⇑f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, cau_seq.const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ by rw mul_comm; exact mul_lim_zero _ (setoid.symm (equiv_lim f))

end complex


lemma or_symm (P Q : Prop) : P ∨ Q → Q ∨ P :=
begin
intro h,
cases h with p q,
right,
exact p,
left,
exact q,
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot, Yury Kudryashov, Rémy Degenne
! This file was ported from Lean 3 source module data.set.intervals.order_iso
! leanprover-community/mathlib commit d012cd09a9b256d870751284dd6a29882b0be105
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Intervals.Basic
import Mathlib.Order.Hom.Set

/-!
# Lemmas about images of intervals under order isomorphisms.
-/

open Set

namespace OrderIso

section Preorder

variable [Preorder α] [Preorder β]

@[simp]
theorem preimage_Iic (e : α ≃o β) (b : β) : e ⁻¹' Iic b = Iic (e.symm b) := by
  ext x
  simp [← e.le_iff_le]
#align order_iso.preimage_Iic OrderIso.preimage_Iic

@[simp]
theorem preimage_Ici (e : α ≃o β) (b : β) : e ⁻¹' Ici b = Ici (e.symm b) := by
  ext x
  simp [← e.le_iff_le]
#align order_iso.preimage_Ici OrderIso.preimage_Ici

@[simp]
theorem preimage_Iio (e : α ≃o β) (b : β) : e ⁻¹' Iio b = Iio (e.symm b) := by
  ext x
  simp [← e.lt_iff_lt]
#align order_iso.preimage_Iio OrderIso.preimage_Iio

@[simp]
theorem preimage_Ioi (e : α ≃o β) (b : β) : e ⁻¹' Ioi b = Ioi (e.symm b) := by
  ext x
  simp [← e.lt_iff_lt]
#align order_iso.preimage_Ioi OrderIso.preimage_Ioi

@[simp]
theorem preimage_Icc (e : α ≃o β) (a b : β) : e ⁻¹' Icc a b = Icc (e.symm a) (e.symm b) := by
  simp [← Ici_inter_Iic]
#align order_iso.preimage_Icc OrderIso.preimage_Icc

@[simp]
theorem preimage_Ico (e : α ≃o β) (a b : β) : e ⁻¹' Ico a b = Ico (e.symm a) (e.symm b) := by
  simp [← Ici_inter_Iio]
#align order_iso.preimage_Ico OrderIso.preimage_Ico

@[simp]
theorem preimage_Ioc (e : α ≃o β) (a b : β) : e ⁻¹' Ioc a b = Ioc (e.symm a) (e.symm b) := by
  simp [← Ioi_inter_Iic]
#align order_iso.preimage_Ioc OrderIso.preimage_Ioc

@[simp]
theorem preimage_Ioo (e : α ≃o β) (a b : β) : e ⁻¹' Ioo a b = Ioo (e.symm a) (e.symm b) := by
  simp [← Ioi_inter_Iio]
#align order_iso.preimage_Ioo OrderIso.preimage_Ioo

@[simp]
theorem image_Iic (e : α ≃o β) (a : α) : e '' Iic a = Iic (e a) := by
  rw [e.image_eq_preimage, e.symm.preimage_Iic, e.symm_symm]
#align order_iso.image_Iic OrderIso.image_Iic

@[simp]
theorem image_Ici (e : α ≃o β) (a : α) : e '' Ici a = Ici (e a) :=
  e.dual.image_Iic a
#align order_iso.image_Ici OrderIso.image_Ici

@[simp]
theorem image_Iio (e : α ≃o β) (a : α) : e '' Iio a = Iio (e a) := by
  rw [e.image_eq_preimage, e.symm.preimage_Iio, e.symm_symm]
#align order_iso.image_Iio OrderIso.image_Iio

@[simp]
theorem image_Ioi (e : α ≃o β) (a : α) : e '' Ioi a = Ioi (e a) :=
  e.dual.image_Iio a
#align order_iso.image_Ioi OrderIso.image_Ioi

@[simp]
theorem image_Ioo (e : α ≃o β) (a b : α) : e '' Ioo a b = Ioo (e a) (e b) := by
  rw [e.image_eq_preimage, e.symm.preimage_Ioo, e.symm_symm]
#align order_iso.image_Ioo OrderIso.image_Ioo

@[simp]
theorem image_Ioc (e : α ≃o β) (a b : α) : e '' Ioc a b = Ioc (e a) (e b) := by
  rw [e.image_eq_preimage, e.symm.preimage_Ioc, e.symm_symm]
#align order_iso.image_Ioc OrderIso.image_Ioc

@[simp]
theorem image_Ico (e : α ≃o β) (a b : α) : e '' Ico a b = Ico (e a) (e b) := by
  rw [e.image_eq_preimage, e.symm.preimage_Ico, e.symm_symm]
#align order_iso.image_Ico OrderIso.image_Ico

@[simp]
theorem image_Icc (e : α ≃o β) (a b : α) : e '' Icc a b = Icc (e a) (e b) := by
  rw [e.image_eq_preimage, e.symm.preimage_Icc, e.symm_symm]
#align order_iso.image_Icc OrderIso.image_Icc

end Preorder

/-- Order isomorphism between `Iic (⊤ : α)` and `α` when `α` has a top element -/
def IicTop [Preorder α] [OrderTop α] : Iic (⊤ : α) ≃o α :=
  { @Equiv.subtypeUnivEquiv α (Iic (⊤ : α)) fun x => le_top with
    map_rel_iff' := @fun x y => by rfl }
#align order_iso.Iic_top OrderIso.IicTop

/-- Order isomorphism between `Ici (⊥ : α)` and `α` when `α` has a bottom element -/
def IciBot [Preorder α] [OrderBot α] : Ici (⊥ : α) ≃o α :=
  { @Equiv.subtypeUnivEquiv α (Ici (⊥ : α)) fun x => bot_le with
    map_rel_iff' := @fun x y => by rfl }
#align order_iso.Ici_bot OrderIso.IciBot

end OrderIso


/-
Copyright (c) 2022 Arthur Paulino, Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Arthur Paulino, Damiano Testa
-/
import tactic.core
import algebra.group.basic

/-!
# `move_add`: a tactic for moving summands

Calling `move_add [a, ← b, c]`, recursively looks inside the goal for expressions involving a sum.
Whenever it finds one, it moves the summands that unify to `a, b, c`, removing all parentheses.

See the doc-string for `tactic.interactive.move_add` for more information.

##  Implementation notes

This file defines a general `move_op` tactic, intended for reordering terms in an expression
obtained by repeated applications of a given associative, commutative binary operation.  The
user decides the final reordering.  Applying `move_op` without specifying the order will simply
remove all parentheses from the expression.
The main user-facing tactics are `move_add` and `move_mul`, dealing with addition and
multiplication, respectively.

In what is below, we talk about `move_add` for definiteness, but everything applies
to `move_mul` and to the more general `move_op`.

The implementation of `move_add` only moves the terms specified by the user (and rearranges
parentheses).

Note that the tactic `abel` already implements a very solid heuristic for normalizing terms in an
additive commutative semigroup and produces expressions in more or less standard form.
The scope of `move_add` is different: it is designed to make it easy to move individual terms
around a sum.

##  Future work

* Add support for `neg/div/inv` in additive/multiplicative groups?
* Currently the tactic has special support for `+` and `*`.  Every other operation is outsourced
  to `ac_refl` (see the proof of `reorder_hyp`).  Should there be the desire for specialized support
  of other operations (e.g. `∪, ∩, ⊓, ⊔, ...`), that is the definition to modify, at least in the
  first instance.
* Add functionality for moving terms across the two sides of an in/dis/equality.
  E.g. it might be desirable to have `to_lhs [a]` converting `b + c = a + d` to `- a + b + c = d`.
* Add a non-recursive version for use in `conv` mode.
* Revise tests?
-/

namespace tactic

namespace move_op

/-!
Throughout this file, `op : pexpr` denotes an arbitrary (binary) operation.  We do not use,
but implicitly imagine, that this operation is associative, since we extract iterations of
such operations, with complete disregard of the order in which these iterations arise.
-/

/--  Given a list `un` of `α`s and a list `bo` of `bool`s, return the sublist of `un`
consisting of the entries of `un` whose corresponding entry in `bo` is `tt`.

Used for error management: `un` is the list of user inputs, `bo` is the list encoding which input
is unused (`tt`) and which input is used (`ff`).
`return_unused` returns the unused user inputs.

If `bo` is shorter than `un`, `return_unused` will include the remainder of `un`.
-/
def return_unused {α : Type*} : list α → list bool → list α
| un [] := un
| [] bo := []
| (u::us) (b::bs) := if b then u::return_unused us bs else return_unused us bs

/--  Given a list `lp` of `bool × pexpr` and a list `l_un` of `expr`, scan the elements of `lp` one
at a time and produce 3 sublists of `l_un`.

If `(tf,pe)` is the first element of `lp`, we look for the first element of `l_un` that unifies with
`pe.to_expr`.  If no such element exists, then we discard `(tf,pe)` and move along.
If `eu ∈ l_un` is the first element of `l_un` that unifies with `pe.to_expr`, then we add `eu` as
the next element of either the first or the second list, depending on the boolean `tf` and we remove
`eu` from the list `l_un`.  In this case, we continue our scanning with the next element of `lp`,
replacing `l_un` by `l_un.erase eu`.

Once we exhaust the elements of `lp`, we return the four lists:
* `l_tt`: the list of elements of `l_un` that came from an element of `lp` whose boolean was `tt`,
* `l_ff`: the list of elements of `l_un` that came from an element of `lp` whose boolean was `ff`,
* `l_un`: the un-unified elements of `l_un`,
* `l_m`: a "mask" list of booleans corresponding to the elements of `lp` that were placed in `l_un`.

The ununified elements of `l_un` get used for error management: they keep track of which user inputs
are superfluous. -/
meta def move_left_or_right : list (bool × expr) → list expr → list bool →
  tactic (list expr × list expr × list expr × list bool)
| [] l_un l_m      := return ([], [], l_un, l_m)
| (be::l) l_un l_m := do
  (ex :: _) ← l_un.mfilter $ λ e', succeeds $ unify be.2 e' |
    move_left_or_right l l_un (l_m.append [tt]),
  (l_tt, l_ff, l_un, l_m) ← move_left_or_right l (l_un.erase ex) (l_m.append [ff]),
  if be.1 then return (ex::l_tt, l_ff, l_un, l_m) else return (l_tt, ex::l_ff, l_un, l_m)

/--  We adapt `move_left_or_right` to our goal:
1. we convert a list of pairs `bool × pexpr` to a list of pairs `bool × expr`,
2. we use the extra input `sl : list expr` to perform the unification and sorting step
   `move_left_or_right`,
3. we jam the third factor inside the first two.
-/
meta def final_sort (lp : list (bool × pexpr)) (sl : list expr) : tactic (list expr × list bool) :=
do
  lp_exp : list (bool × expr) ← lp.mmap $ λ x, (do e ← to_expr x.2 tt ff, return (x.1, e)),
  (l1, l2, l3, is_unused) ← move_left_or_right lp_exp sl [],
  return (l1 ++ l3 ++ l2, is_unused)

/-- `as_given_op op e` unifies the head term of `e`, which is a ≥2-argument function application,
with the binary operation `op`, failing if it cannot. -/
meta def as_given_op (op : pexpr) : expr → tactic expr
| (expr.app (expr.app F a) b) := do
    to_expr op tt ff >>= unify F,
    return F
| _ := failed

/-- `(e, unused) ← reorder_oper op lp e` converts an expression `e` to a similar looking one.
The tactic scans the expression `e` looking for subexpressions that begin with the given binary
operation `op`.  As soon as `reorder_oper` finds one such subexpression,
* it extracts the "`op`-summands" in the subexpression,
* it rearranges them according to the rules determined by `lp`,
* it recurses into each `op`-summand.

The `unused` output is a list of booleans.  It is keeping track of which of the inputs provided
by `lp` is actually used to perform the rearrangements.  It is useful to report unused inputs.

Here are two examples:
```lean
#eval trace $ reorder_oper ``((=)) [(ff,``(2)), (tt,``(7))] `(∀ x y : ℕ, 2 = 0)
--  (ℕ → ℕ → 0 = 2, [ff, tt])
-- the input `[(ff,``(2)), (tt,``(7))]` instructs Lean to move `2` to the right and `7`
-- to the left.  Lean reports that `2` is not unused and `7` is unused as `[ff, tt]`.

#eval trace $ reorder_oper ``((+)) [(ff,``(2)), (tt,``(5))]
  `(λ (e : ℕ), ∀ (x : ℕ), ∃ (y : ℕ),
      2 + x * (y + (e + 5)) + y = x + 2 + e → 2 + x = x + 5 + (2 + y))
/-  `2` moves to the right, `5` moves to the left.  Lean reports that `2, 5` are not unused
    as `[ff,ff]`
   (λ (e : ℕ), ∀ (x : ℕ), ∃ (y : ℕ),
      x * (5 + y + e) + y + 2   = x + e + 2 → x + 2 = 5 + x + y + 2, [ff, ff]) -/
```

TODO: use `ext_simplify_core` instead of traversing the expression manually
-/
meta def reorder_oper (op : pexpr) (lp : list (bool × pexpr)) :
  expr → tactic (expr × list bool)
| F'@(expr.app F b) := do
    is_op ← try_core (as_given_op op F'),
    match is_op with
    | some op := do
        (sort_list, is_unused) ← list_binary_operands op F' >>= final_sort lp,
        sort_all ← sort_list.mmap (λ e, do
          (e, lu) ← reorder_oper e,
          pure (e, [lu, is_unused].transpose.map list.band)),
        let (recs, list_unused) := sort_all.unzip,
        recs_0 :: recs_rest ← pure recs | fail!"internal error: cannot have 0 operands",
        let summed := recs_rest.foldl (λ e f, op.mk_app [e, f]) recs_0,
        return (summed, list_unused.transpose.map list.band)
    | none := do
        [(Fn, unused_F), (bn, unused_b)] ← [F, b].mmap $ reorder_oper,
        return $ (expr.app Fn bn, [unused_F, unused_b].transpose.map list.band)
    end
| (expr.pi na bi e f)           := do
  [en, fn] ← [e, f].mmap $ reorder_oper,
  return (expr.pi  na bi en.1 fn.1, [en.2, fn.2].transpose.map list.band)
| (expr.lam na bi e f)          := do
  [en, fn] ← [e, f].mmap $ reorder_oper,
  return (expr.lam na bi en.1 fn.1, [en.2, fn.2].transpose.map list.band)
| (expr.mvar na pp e)           := do  -- is it really needed to recurse here?
  en ← reorder_oper e,
  return (expr.mvar na pp en.1, [en.2].transpose.map list.band)
| (expr.local_const na pp bi e) := do  -- is it really needed to recurse here?
  en ← reorder_oper e,
  return (expr.local_const na pp bi en.1, [en.2].transpose.map list.band)
| (expr.elet na e f g)          := do
  [en, fn, gn] ← [e, f, g].mmap $ reorder_oper,
  return (expr.elet na en.1 fn.1 gn.1, [en.2, fn.2, gn.2].transpose.map list.band)
| (expr.macro ma le)            := do  -- is it really needed to recurse here?
  len ← le.mmap $ reorder_oper,
  let (lee, lb) := len.unzip,
  return (expr.macro ma lee, lb.transpose.map list.band)
| e := pure (e, (lp.map (λ _, tt)))

/-- Passes the user input `na` to `reorder_oper` at a single location, that could either be
`none` (referring to the goal) or `some name` (referring to hypothesis `name`).  Replaces the
given hypothesis/goal with the rearranged one that `reorder_hyp` receives from `reorder_oper`.
Returns a pair consisting of a boolean and a further list of booleans.
The single boolean is `tt` iff the tactic did *not* change the goal on which it was acting.
The list of booleans records which variable in `ll` has been unified in the application:
`tt` means that the corresponding variable has *not* been unified.

This definition is useful to streamline error catching. -/
meta def reorder_hyp (op : pexpr) (lp : list (bool × pexpr)) (na : option name) :
  tactic (bool × list bool) := do
(thyp, hyploc) ← match na with
  | none := do
      t ← target,
      return (t, none)
  | some na := do
      hl ← get_local na,
      th ← infer_type hl,
      return (th, some hl)
  end,
(reordered, is_unused) ← reorder_oper op lp thyp,
unify reordered thyp >> return (tt, is_unused) <|> do
-- the current `do` block takes place where the reordered expression is not equal to the original
neq ← mk_app `eq [thyp, reordered],
nop ← to_expr op tt ff,
pre ← pp reordered,
(_, prf) ← solve_aux neq $ match nop with
  | `(has_add.add) := `[{ simp only [add_comm, add_assoc, add_left_comm]; refl, done }]
  | `(has_mul.mul) := `[{ simp only [mul_comm, mul_assoc, mul_left_comm]; refl, done }]
  | _ := ac_refl <|>
    fail format!("the associative/commutative lemmas used do not suffice to prove that " ++
      "the initial goal equals:\n\n{pre}\n" ++
      "Hint: try adding `is_associative` or `is_commutative` instances.\n")
  end,
match hyploc with
| none := replace_target reordered prf
| some hyploc := replace_hyp hyploc reordered prf >> skip
end,
return (ff, is_unused)

section parsing_arguments_for_move_op
setup_tactic_parser

/-- `move_op_arg` is a single elementary argument that `move_op` takes for the
variables to be moved.  It is either a `pexpr`, or a `pexpr` preceded by a `←`. -/
meta def move_op_arg (prec : nat) : parser (bool × pexpr) :=
prod.mk <$> (option.is_some <$> (tk "<-")?) <*> parser.pexpr prec

/-- `move_pexpr_list_or_texpr` is either a list of `move_op_arg`, possibly empty, or a single
`move_op_arg`. -/
meta def move_pexpr_list_or_texpr : parser (list (bool × pexpr)) :=
list_of (move_op_arg 0) <|> list.ret <$> move_op_arg tac_rbp <|> return []

end parsing_arguments_for_move_op

end move_op

setup_tactic_parser
open move_op

/--  `move_op args locat op` is the non-interactive version of the main tactics `move_add` and
`move_mul` of this file.  Given as input `args` (a list of terms of a sequence of operands),
`locat` (hypotheses or goal where the tactic should act) and `op` (the operation to use),
`move_op` attempts to perform the rearrangement of the terms determined by `args`.

Currently, the tactic uses only `add/mul_comm, add/mul_assoc, add/mul_left_comm`, so other
operations will not actually work.
-/
meta def move_op (args : parse move_pexpr_list_or_texpr) (locat : parse location) (op : pexpr) :
  tactic unit := do
locas ← locat.get_locals,
tg ← target,
let locas_with_tg := if locat.include_goal then locas ++ [tg] else locas,
ner ← locas_with_tg.mmap (λ e, reorder_hyp op args e.local_pp_name <|> reorder_hyp op args none),
let (unch_tgts, unus_vars) := ner.unzip,
str_unva ← match
  (return_unused args (unus_vars.transpose.map list.band)).map (λ e : bool × pexpr, e.2) with
  | []   := pure []
  | [pe] := do
    nm ← to_expr pe tt ff >>= λ ex, pp ex.replace_mvars,
    return [format!"'{nm}' is an unused variable"]
  | pes  := do
    nms ← pes.mmap (λ e, to_expr e tt ff) >>= λ exs, (exs.map expr.replace_mvars).mmap pp,
    return [format!"'{nms}' are unused variables"]
  end,
let str_tgts := match locat with
  | loc.wildcard := if unch_tgts.band then [format!"nothing changed"] else []
  | loc.ns names := let linames := return_unused locas unch_tgts in
      (if none ∈ return_unused names unch_tgts
        then [format!"Goal did not change"] else []) ++
      (if linames ≠ [] then [format!"'{linames.reverse}' did not change"] else [])
  end,
[] ← pure (str_tgts ++ str_unva) | fail (format.intercalate "\n" (str_tgts ++ str_unva)),
assumption <|> try (tactic.reflexivity reducible)

namespace interactive

/--
Calling `move_add [a, ← b, c]`, recursively looks inside the goal for expressions involving a sum.
Whenever it finds one, it moves the summands that unify to `a, b, c`, removing all parentheses.
Repetitions are allowed, and are processed following the user-specified ordering.
The terms preceded by a `←` get placed to the left, the ones without the arrow get placed to the
right.  Unnamed terms stay in place.  Due to re-parenthesizing, doing `move_add` with no argument
may change the goal. Also, the *order* in which the terms are provided matters: the tactic reads
them from left to right.  This is especially important if there are multiple matches for the typed
terms in the given expressions.

A single call of `move_add` moves terms across different sums in the same expression.
Here is an example.

```lean
import tactic.move_add

example {a b c d : ℕ} (h : c = d) : c + b + a = b + a + d :=
begin
  move_add [← a, b],  -- Goal: `a + c + b = a + d + b`  -- both sides changed
  congr,
  exact h
end

example {a b c d : ℕ} (h : c = d) : c + b * c + a * c = a * d + d + b * d :=
begin
  move_add [_ * c, ← _ * c], -- Goal: `a * c + c + b * c = a * d + d + b * d`
  -- the first `_ * c` unifies with `b * c` and moves to the right
  -- the second `_ * c` unifies with `a * c` and moves to the left
  congr;
  assumption
end
```

The list of expressions that `move_add` takes is optional and a single expression can be passed
without brackets.  Thus `move_add ← f` and `move_add [← f]` mean the same.

Finally, `move_add` can also target one or more hypotheses.  If `hp₁, hp₂` are in the
local context, then `move_add [f, ← g] at hp₁ hp₂` performs the rearranging at `hp₁` and `hp₂`.
As usual, passing `⊢` refers to acting on the goal.

##  Reporting sub-optimal usage

The tactic could fail to prove the reordering.  One potential cause is when there are multiple
matches for the rearrangements and an earlier rewrite makes a subsequent one fail.  Another
possibility is that the rearranged expression changes the *Type* of some expression and the
tactic gets stumped.  Please, report bugs and failures in the Zulip chat!

There are three kinds of unwanted use for `move_add` that result in errors, where the tactic fails
and flags the unwanted use.
1. `move_add [vars]? at *` reports globally unused variables and whether *all* goals
   are unchanged, not *each unchanged goal*.
2. If a target of `move_add [vars]? at targets` is left unchanged by the tactic, then this will be
   flagged (unless we are using `at *`).
3. If a user-provided expression never unifies, then the variable is flagged.

In these cases, the tactic produces an error, reporting unused inputs and unchanged targets as
appropriate.

For instance, `move_add ← _` always fails reporting an unchanged goal, but never an unused variable.

##  Comparison with existing tactics

* `tactic.interactive.abel`
  performs a "reduction to normal form" that allows it to close goals involving sums with higher
  success rate than `move_add`.  If the goal is an equality of two sums that are simply obtained by
  reparenthesizing and permuting summands, then `move_add [appropriate terms]` can close the goal.
  Compared to `abel`, `move_add` has the advantage of allowing the user to specify the beginning and
  the end of the final sum, so that from there the user can continue with the proof.

* `tactic.interactive.ac_change`
  supports a wide variety of operations.  At the moment, `move_add` works with addition, `move_mul`
  works with multiplication.  There is the possibility of supporting other operations, using the
  non-interactive tactic `tactic.move_op`.
  Still, on several experiments, `move_add` had a much quicker performance than `ac_change`.
  Also, for `move_add` the user need only specify a few terms: the tactic itself takes care of
  producing the full rearrangement and proving it "behind the scenes".

###  Remark:
It is still possible that the same output of `move_add [exprs]` can be achieved by a proper sublist
of `[exprs]`, even if the tactic does not flag anything.  For instance, giving the full re-ordering
of the expressions in the target that we want to achieve will not complain that there are unused
variables, since all the user-provided variables have been matched.  Of course, specifying the order
of all-but-the-last variable suffices to determine the permutation.  E.g., with a goal of
`a + b = 0`, applying either one of `move_add [b,a]`, or `move_add a`, or `move_add ← b` has the
same effect and changes the goal to `b + a = 0`.  These are all valid uses of `move_add`.
-/
meta def move_add (args : parse move_pexpr_list_or_texpr) (locat : parse location) :
  tactic unit :=
move_op args locat ``((+))

/--  See the doc-string for `tactic.interactive.move_add` and mentally
replace addition with multiplication throughout. ;-) -/
meta def move_mul (args : parse move_pexpr_list_or_texpr) (locat : parse location) :
  tactic unit :=
move_op args locat ``(has_mul.mul)

/--  `move_oper` behaves like `move_add` except that it also takes an associative, commutative,
binary operation as input.  The operation must be passed as a list consisting of a single element.
For instance
```lean
example (a b : ℕ) : max a b = max b a :=
by move_oper [max] [← a, b] at *
```
solves the goal.  For more details, see the `move_add` doc-string, replacing `add` with your
intended operation.
-/
meta def move_oper
  (op : parse pexpr_list) (args : parse move_pexpr_list_or_texpr) (locat : parse location) :
  tactic unit := do
[op] ← pure op | fail "only one operation is allowed",
move_op args locat op

add_tactic_doc
{ name := "move_add",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.move_add],
  tags := ["arithmetic"] }

add_tactic_doc
{ name := "move_mul",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.move_mul],
  tags := ["arithmetic"] }

end interactive
end tactic


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Kevin Buzzard, Scott Morrison, Johan Commelin, Chris Hughes,
  Johannes Hölzl, Yury Kudryashov

! This file was ported from Lean 3 source module algebra.hom.commute
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Hom.Group
import Mathbin.Algebra.Group.Commute

/-!
# Multiplicative homomorphisms respect semiconjugation and commutation.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/

section Commute

variable {F M N : Type _} [Mul M] [Mul N] {a x y : M}

/- warning: semiconj_by.map -> SemiconjBy.map is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1}} {M : Type.{u2}} {N : Type.{u3}} [_inst_1 : Mul.{u2} M] [_inst_2 : Mul.{u3} N] {a : M} {x : M} {y : M} [_inst_3 : MulHomClass.{u1, u2, u3} F M N _inst_1 _inst_2], (SemiconjBy.{u2} M _inst_1 a x y) -> (forall (f : F), SemiconjBy.{u3} N _inst_2 (coeFn.{succ u1, max (succ u2) (succ u3)} F (fun (_x : F) => M -> N) (FunLike.hasCoeToFun.{succ u1, succ u2, succ u3} F M (fun (_x : M) => N) (MulHomClass.toFunLike.{u1, u2, u3} F M N _inst_1 _inst_2 _inst_3)) f a) (coeFn.{succ u1, max (succ u2) (succ u3)} F (fun (_x : F) => M -> N) (FunLike.hasCoeToFun.{succ u1, succ u2, succ u3} F M (fun (_x : M) => N) (MulHomClass.toFunLike.{u1, u2, u3} F M N _inst_1 _inst_2 _inst_3)) f x) (coeFn.{succ u1, max (succ u2) (succ u3)} F (fun (_x : F) => M -> N) (FunLike.hasCoeToFun.{succ u1, succ u2, succ u3} F M (fun (_x : M) => N) (MulHomClass.toFunLike.{u1, u2, u3} F M N _inst_1 _inst_2 _inst_3)) f y))
but is expected to have type
  forall {F : Type.{u3}} {M : Type.{u2}} {N : Type.{u1}} [_inst_1 : Mul.{u2} M] [_inst_2 : Mul.{u1} N] {a : M} {x : M} {y : M} [_inst_3 : MulHomClass.{u3, u2, u1} F M N _inst_1 _inst_2], (SemiconjBy.{u2} M _inst_1 a x y) -> (forall (f : F), SemiconjBy.{u1} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) a) _inst_2 (FunLike.coe.{succ u3, succ u2, succ u1} F M (fun (_x : M) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) _x) (MulHomClass.toFunLike.{u3, u2, u1} F M N _inst_1 _inst_2 _inst_3) f a) (FunLike.coe.{succ u3, succ u2, succ u1} F M (fun (_x : M) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) _x) (MulHomClass.toFunLike.{u3, u2, u1} F M N _inst_1 _inst_2 _inst_3) f x) (FunLike.coe.{succ u3, succ u2, succ u1} F M (fun (_x : M) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) _x) (MulHomClass.toFunLike.{u3, u2, u1} F M N _inst_1 _inst_2 _inst_3) f y))
Case conversion may be inaccurate. Consider using '#align semiconj_by.map SemiconjBy.mapₓ'. -/
@[simp, to_additive]
protected theorem SemiconjBy.map [MulHomClass F M N] (h : SemiconjBy a x y) (f : F) :
    SemiconjBy (f a) (f x) (f y) := by simpa only [SemiconjBy, map_mul] using congr_arg f h
#align semiconj_by.map SemiconjBy.map
#align add_semiconj_by.map AddSemiconjBy.map

/- warning: commute.map -> Commute.map is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1}} {M : Type.{u2}} {N : Type.{u3}} [_inst_1 : Mul.{u2} M] [_inst_2 : Mul.{u3} N] {x : M} {y : M} [_inst_3 : MulHomClass.{u1, u2, u3} F M N _inst_1 _inst_2], (Commute.{u2} M _inst_1 x y) -> (forall (f : F), Commute.{u3} N _inst_2 (coeFn.{succ u1, max (succ u2) (succ u3)} F (fun (_x : F) => M -> N) (FunLike.hasCoeToFun.{succ u1, succ u2, succ u3} F M (fun (_x : M) => N) (MulHomClass.toFunLike.{u1, u2, u3} F M N _inst_1 _inst_2 _inst_3)) f x) (coeFn.{succ u1, max (succ u2) (succ u3)} F (fun (_x : F) => M -> N) (FunLike.hasCoeToFun.{succ u1, succ u2, succ u3} F M (fun (_x : M) => N) (MulHomClass.toFunLike.{u1, u2, u3} F M N _inst_1 _inst_2 _inst_3)) f y))
but is expected to have type
  forall {F : Type.{u3}} {M : Type.{u2}} {N : Type.{u1}} [_inst_1 : Mul.{u2} M] [_inst_2 : Mul.{u1} N] {x : M} {y : M} [_inst_3 : MulHomClass.{u3, u2, u1} F M N _inst_1 _inst_2], (Commute.{u2} M _inst_1 x y) -> (forall (f : F), Commute.{u1} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) x) _inst_2 (FunLike.coe.{succ u3, succ u2, succ u1} F M (fun (_x : M) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) _x) (MulHomClass.toFunLike.{u3, u2, u1} F M N _inst_1 _inst_2 _inst_3) f x) (FunLike.coe.{succ u3, succ u2, succ u1} F M (fun (_x : M) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : M) => N) _x) (MulHomClass.toFunLike.{u3, u2, u1} F M N _inst_1 _inst_2 _inst_3) f y))
Case conversion may be inaccurate. Consider using '#align commute.map Commute.mapₓ'. -/
@[simp, to_additive]
protected theorem Commute.map [MulHomClass F M N] (h : Commute x y) (f : F) : Commute (f x) (f y) :=
  h.map f
#align commute.map Commute.map
#align add_commute.map AddCommute.map

end Commute