/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Group.basic
import Mathlib.data.equiv.ring
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Category instances for semiring, ring, comm_semiring, and comm_ring.

We introduce the bundled categories:
* `SemiRing`
* `Ring`
* `CommSemiRing`
* `CommRing`
along with the relevant forgetful functors between them.
-/

/-- The category of semirings. -/
def SemiRing :=
  category_theory.bundled semiring

namespace SemiRing

protected instance bundled_hom : category_theory.bundled_hom ring_hom :=
  category_theory.bundled_hom.mk ring_hom.to_fun ring_hom.id ring_hom.comp

protected instance large_category : category_theory.large_category SemiRing :=
  category_theory.bundled_hom.category ring_hom

/-- Construct a bundled SemiRing from the underlying type and typeclass. -/
def of (R : Type u) [semiring R] : SemiRing :=
  category_theory.bundled.of R

protected instance inhabited : Inhabited SemiRing :=
  { default := of PUnit }

protected instance semiring (R : SemiRing) : semiring ↥R :=
  category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [semiring R] : ↥(of R) = R :=
  rfl

protected instance has_forget_to_Mon : category_theory.has_forget₂ SemiRing Mon :=
  category_theory.bundled_hom.mk_has_forget₂ (fun (R : Type u_1) (hR : semiring R) => monoid_with_zero.to_monoid R)
    (fun (R₁ R₂ : category_theory.bundled semiring) => ring_hom.to_monoid_hom) sorry

-- can't use bundled_hom.mk_has_forget₂, since AddCommMon is an induced category

protected instance has_forget_to_AddCommMon : category_theory.has_forget₂ SemiRing AddCommMon :=
  category_theory.has_forget₂.mk
    (category_theory.functor.mk (fun (R : SemiRing) => AddCommMon.of ↥R)
      fun (R₁ R₂ : SemiRing) (f : R₁ ⟶ R₂) => ring_hom.to_add_monoid_hom f)

end SemiRing

/-- The category of rings. -/
def Ring :=
  category_theory.bundled ring

namespace Ring

protected instance ring.to_semiring.category_theory.bundled_hom.parent_projection : category_theory.bundled_hom.parent_projection ring.to_semiring :=
  category_theory.bundled_hom.parent_projection.mk

protected instance concrete_category : category_theory.concrete_category Ring :=
  category_theory.bundled_hom.category_theory.bundled.category_theory.concrete_category
    (category_theory.bundled_hom.map_hom ring_hom ring.to_semiring)

/-- Construct a bundled Ring from the underlying type and typeclass. -/
def of (R : Type u) [ring R] : Ring :=
  category_theory.bundled.of R

protected instance inhabited : Inhabited Ring :=
  { default := of PUnit }

protected instance ring (R : Ring) : ring ↥R :=
  category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [ring R] : ↥(of R) = R :=
  rfl

protected instance has_forget_to_SemiRing : category_theory.has_forget₂ Ring SemiRing :=
  category_theory.bundled_hom.forget₂ ring_hom ring.to_semiring

-- can't use bundled_hom.mk_has_forget₂, since AddCommGroup is an induced category

protected instance has_forget_to_AddCommGroup : category_theory.has_forget₂ Ring AddCommGroup :=
  category_theory.has_forget₂.mk
    (category_theory.functor.mk (fun (R : Ring) => AddCommGroup.of ↥R)
      fun (R₁ R₂ : Ring) (f : R₁ ⟶ R₂) => ring_hom.to_add_monoid_hom f)

end Ring

/-- The category of commutative semirings. -/
def CommSemiRing :=
  category_theory.bundled comm_semiring

namespace CommSemiRing

protected instance comm_semiring.to_semiring.category_theory.bundled_hom.parent_projection : category_theory.bundled_hom.parent_projection comm_semiring.to_semiring :=
  category_theory.bundled_hom.parent_projection.mk

protected instance large_category : category_theory.large_category CommSemiRing :=
  category_theory.bundled_hom.category (category_theory.bundled_hom.map_hom ring_hom comm_semiring.to_semiring)

/-- Construct a bundled CommSemiRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_semiring R] : CommSemiRing :=
  category_theory.bundled.of R

protected instance inhabited : Inhabited CommSemiRing :=
  { default := of PUnit }

protected instance comm_semiring (R : CommSemiRing) : comm_semiring ↥R :=
  category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [comm_semiring R] : ↥(of R) = R :=
  rfl

protected instance has_forget_to_SemiRing : category_theory.has_forget₂ CommSemiRing SemiRing :=
  category_theory.bundled_hom.forget₂ ring_hom comm_semiring.to_semiring

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
protected instance has_forget_to_CommMon : category_theory.has_forget₂ CommSemiRing CommMon :=
  category_theory.has_forget₂.mk' (fun (R : CommSemiRing) => CommMon.of ↥R) sorry
    (fun (R₁ R₂ : CommSemiRing) (f : R₁ ⟶ R₂) => ring_hom.to_monoid_hom f) sorry

end CommSemiRing

/-- The category of commutative rings. -/
def CommRing :=
  category_theory.bundled comm_ring

namespace CommRing

protected instance comm_ring.to_ring.category_theory.bundled_hom.parent_projection : category_theory.bundled_hom.parent_projection comm_ring.to_ring :=
  category_theory.bundled_hom.parent_projection.mk

protected instance concrete_category : category_theory.concrete_category CommRing :=
  category_theory.bundled_hom.category_theory.bundled.category_theory.concrete_category
    (category_theory.bundled_hom.map_hom (category_theory.bundled_hom.map_hom ring_hom ring.to_semiring)
      comm_ring.to_ring)

/-- Construct a bundled CommRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_ring R] : CommRing :=
  category_theory.bundled.of R

protected instance inhabited : Inhabited CommRing :=
  { default := of PUnit }

protected instance comm_ring (R : CommRing) : comm_ring ↥R :=
  category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [comm_ring R] : ↥(of R) = R :=
  rfl

protected instance has_forget_to_Ring : category_theory.has_forget₂ CommRing Ring :=
  category_theory.bundled_hom.forget₂ (category_theory.bundled_hom.map_hom ring_hom ring.to_semiring) comm_ring.to_ring

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
protected instance has_forget_to_CommSemiRing : category_theory.has_forget₂ CommRing CommSemiRing :=
  category_theory.has_forget₂.mk' (fun (R : CommRing) => CommSemiRing.of ↥R) sorry
    (fun (R₁ R₂ : CommRing) (f : R₁ ⟶ R₂) => f) sorry

protected instance category_theory.forget₂.category_theory.full : category_theory.full (category_theory.forget₂ CommRing CommSemiRing) :=
  category_theory.full.mk
    fun (X Y : CommRing)
      (f :
      category_theory.functor.obj (category_theory.forget₂ CommRing CommSemiRing) X ⟶
        category_theory.functor.obj (category_theory.forget₂ CommRing CommSemiRing) Y) =>
      f

end CommRing

-- This example verifies an improvement possible in Lean 3.8.

-- Before that, to have `add_ring_hom.map_zero` usable by `simp` here,

-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.

-- Now, it just works.

namespace ring_equiv

/-- Build an isomorphism in the category `Ring` from a `ring_equiv` between `ring`s. -/
@[simp] theorem to_Ring_iso_inv {X : Type u} {Y : Type u} [ring X] [ring Y] (e : X ≃+* Y) : category_theory.iso.inv (to_Ring_iso e) = to_ring_hom (ring_equiv.symm e) :=
  Eq.refl (category_theory.iso.inv (to_Ring_iso e))

/-- Build an isomorphism in the category `CommRing` from a `ring_equiv` between `comm_ring`s. -/
def to_CommRing_iso {X : Type u} {Y : Type u} [comm_ring X] [comm_ring Y] (e : X ≃+* Y) : CommRing.of X ≅ CommRing.of Y :=
  category_theory.iso.mk (to_ring_hom e) (to_ring_hom (ring_equiv.symm e))

end ring_equiv

namespace category_theory.iso

/-- Build a `ring_equiv` from an isomorphism in the category `Ring`. -/
def Ring_iso_to_ring_equiv {X : Ring} {Y : Ring} (i : X ≅ Y) : ↥X ≃+* ↥Y :=
  ring_equiv.mk ⇑(hom i) ⇑(inv i) sorry sorry sorry sorry

/-- Build a `ring_equiv` from an isomorphism in the category `CommRing`. -/
def CommRing_iso_to_ring_equiv {X : CommRing} {Y : CommRing} (i : X ≅ Y) : ↥X ≃+* ↥Y :=
  ring_equiv.mk ⇑(hom i) ⇑(inv i) sorry sorry sorry sorry

end category_theory.iso

/-- Ring equivalences between `ring`s are the same as (isomorphic to) isomorphisms in `Ring`. -/
def ring_equiv_iso_Ring_iso {X : Type u} {Y : Type u} [ring X] [ring Y] : X ≃+* Y ≅ Ring.of X ≅ Ring.of Y :=
  category_theory.iso.mk (fun (e : X ≃+* Y) => ring_equiv.to_Ring_iso e)
    fun (i : Ring.of X ≅ Ring.of Y) => category_theory.iso.Ring_iso_to_ring_equiv i

/-- Ring equivalences between `comm_ring`s are the same as (isomorphic to) isomorphisms
in `CommRing`. -/
def ring_equiv_iso_CommRing_iso {X : Type u} {Y : Type u} [comm_ring X] [comm_ring Y] : X ≃+* Y ≅ CommRing.of X ≅ CommRing.of Y :=
  category_theory.iso.mk (fun (e : X ≃+* Y) => ring_equiv.to_CommRing_iso e)
    fun (i : CommRing.of X ≅ CommRing.of Y) => category_theory.iso.CommRing_iso_to_ring_equiv i

protected instance Ring.forget_reflects_isos : category_theory.reflects_isomorphisms (category_theory.forget Ring) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : Ring) (f : X ⟶ Y)
      (_x : category_theory.is_iso (category_theory.functor.map (category_theory.forget Ring) f)) =>
      let i :
        category_theory.functor.obj (category_theory.forget Ring) X ≅
          category_theory.functor.obj (category_theory.forget Ring) Y :=
        category_theory.as_iso (category_theory.functor.map (category_theory.forget Ring) f);
      let e : ↥X ≃+* ↥Y :=
        ring_equiv.mk (ring_hom.to_fun f) (equiv.inv_fun (category_theory.iso.to_equiv i)) sorry sorry sorry sorry;
      category_theory.is_iso.mk (category_theory.iso.inv (ring_equiv.to_Ring_iso e))

protected instance CommRing.forget_reflects_isos : category_theory.reflects_isomorphisms (category_theory.forget CommRing) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : CommRing) (f : X ⟶ Y)
      (_x : category_theory.is_iso (category_theory.functor.map (category_theory.forget CommRing) f)) =>
      let i :
        category_theory.functor.obj (category_theory.forget CommRing) X ≅
          category_theory.functor.obj (category_theory.forget CommRing) Y :=
        category_theory.as_iso (category_theory.functor.map (category_theory.forget CommRing) f);
      let e : ↥X ≃+* ↥Y :=
        ring_equiv.mk (ring_hom.to_fun f) (equiv.inv_fun (category_theory.iso.to_equiv i)) sorry sorry sorry sorry;
      category_theory.is_iso.mk (category_theory.iso.inv (ring_equiv.to_CommRing_iso e))


/-
Copyright (c) 2017 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Jesse Michael Han

! This file was ported from Lean 3 source module tactic.finish
! leanprover-community/mathlib commit 3c11bd771ef17197a9e9fcd4a3fabfa2804d950c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Hint

/-!
# The `finish` family of tactics

These tactics do straightforward things: they call the simplifier, split conjunctive assumptions,
eliminate existential quantifiers on the left, and look for contradictions. They rely on ematching
and congruence closure to try to finish off a goal at the end.

The procedures *do* split on disjunctions and recreate the smt state for each terminal call, so
they are only meant to be used on small, straightforward problems.

## Main definitions

We provide the following tactics:

* `finish`  -- solves the goal or fails
* `clarify` -- makes as much progress as possible while not leaving more than one goal
* `safe`    -- splits freely, finishes off whatever subgoals it can, and leaves the rest

All accept an optional list of simplifier rules, typically definitions that should be expanded.
(The equations and identities should not refer to the local context.)

-/

initialize
  registerTraceClass.1 `auto.done

initialize
  registerTraceClass.1 `auto.finish

namespace Tactic

namespace Interactive

unsafe def revert_all :=
  tactic.revert_all
#align tactic.interactive.revert_all tactic.interactive.revert_all

end Interactive

end Tactic

open Tactic Expr

namespace Auto

/-! ### Utilities -/

unsafe def whnf_reducible (e : expr) : tactic expr :=
  whnf e reducible
#align auto.whnf_reducible auto.whnf_reducible

-- stolen from interactive.lean
unsafe def add_simps : simp_lemmas → List Name → tactic simp_lemmas
  | s, [] => return s
  | s, n :: ns => do
    let s' ← s.add_simp n
    add_simps s' ns
#align auto.add_simps auto.add_simps

/-- Configuration information for the auto tactics.
* `(use_simp := tt)`: call the simplifier
* `(max_ematch_rounds := 20)`: for the "done" tactic
-/
structure AutoConfig : Type where
  useSimp := true
  maxEmatchRounds := 20
  deriving DecidableEq, Inhabited
#align auto.auto_config Auto.AutoConfig

/-!
### Preprocess goal.

We want to move everything to the left of the sequent arrow. For intuitionistic logic,
we replace the goal `p` with `∀ f, (p → f) → f` and introduce.
-/

theorem by_contradiction_trick (p : Prop) (h : ∀ f : Prop, (p → f) → f) : p :=
  h p id
#align auto.by_contradiction_trick Auto.by_contradiction_trick

unsafe def preprocess_goal : tactic Unit := do
  repeat (intro1 >> skip)
  let tgt ← target >>= whnf_reducible
  if ¬is_false tgt then ((mk_mapp `` by_contradiction [some tgt] >>= apply) >> intro1) >> skip
    else skip
#align auto.preprocess_goal auto.preprocess_goal

/-!
### Normalize hypotheses

Bring conjunctions to the outside (for splitting),
bring universal quantifiers to the outside (for ematching). The classical normalizer
eliminates `a → b` in favor of `¬ a ∨ b`.

For efficiency, we push negations inwards from the top down. (For example, consider
simplifying `¬ ¬ (p ∨ q)`.)
-/

section

universe u

variable {α : Type u}

variable (p q : Prop)

variable (s : α → Prop)

attribute [local instance] Classical.propDecidable

theorem not_not_eq : (¬¬p) = p :=
  propext Classical.not_not
#align auto.not_not_eq Auto.not_not_eq

theorem not_and_eq : (¬(p ∧ q)) = (¬p ∨ ¬q) :=
  propext not_and_or
#align auto.not_and_eq Auto.not_and_eq

theorem not_or_eq : (¬(p ∨ q)) = (¬p ∧ ¬q) :=
  propext not_or
#align auto.not_or_eq Auto.not_or_eq

theorem not_forall_eq : (¬∀ x, s x) = ∃ x, ¬s x :=
  propext not_forall
#align auto.not_forall_eq Auto.not_forall_eq

theorem not_exists_eq : (¬∃ x, s x) = ∀ x, ¬s x :=
  propext not_exists
#align auto.not_exists_eq Auto.not_exists_eq

theorem not_implies_eq : (¬(p → q)) = (p ∧ ¬q) :=
  propext not_imp
#align auto.not_implies_eq Auto.not_implies_eq

theorem Classical.implies_iff_not_or : p → q ↔ ¬p ∨ q :=
  imp_iff_not_or
#align auto.classical.implies_iff_not_or Auto.Classical.implies_iff_not_or

end

def commonNormalizeLemmaNames : List Name :=
  [`` bex_def, `` forall_and, `` exists_imp, `` or_assoc, `` or_comm, `` or_left_comm, `` and_assoc,
    `` and_comm, `` and_left_comm]
#align auto.common_normalize_lemma_names Auto.commonNormalizeLemmaNames

def classicalNormalizeLemmaNames : List Name :=
  commonNormalizeLemmaNames ++ [`` classical.implies_iff_not_or]
#align auto.classical_normalize_lemma_names Auto.classicalNormalizeLemmaNames

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- optionally returns an equivalent expression and proof of equivalence -/ private unsafe
  def
    transform_negation_step
    ( cfg : AutoConfig ) ( e : expr ) : tactic ( Option ( expr × expr ) )
    :=
      do
        let e ← whnf_reducible e
          match
            e
            with
            |
                q( ¬ $ ( Ne ) )
                =>
                do
                  let ne ← whnf_reducible Ne
                    match
                      Ne
                      with
                      |
                          q( ¬ $ ( a ) )
                          =>
                          do let pr ← mk_app ` ` not_not_eq [ a ] return ( some ( a , pr ) )
                        |
                          q( $ ( a ) ∧ $ ( b ) )
                          =>
                          do
                            let pr ← mk_app ` ` not_and_eq [ a , b ]
                              return ( some ( q( ¬ $ ( a ) ∨ ¬ $ ( b ) ) , pr ) )
                        |
                          q( $ ( a ) ∨ $ ( b ) )
                          =>
                          do
                            let pr ← mk_app ` ` not_or_eq [ a , b ]
                              return ( some ( q( ¬ $ ( a ) ∧ ¬ $ ( b ) ) , pr ) )
                        |
                          q( Exists $ ( p ) )
                          =>
                          do
                            let pr ← mk_app ` ` not_exists_eq [ p ]
                              let q( $ ( _ ) = $ ( e' ) ) ← infer_type pr
                              return ( some ( e' , pr ) )
                        |
                          pi n bi d p
                          =>
                          if
                            p
                            then
                            do
                              let
                                  pr
                                    ←
                                    mk_app
                                      ` ` not_forall_eq [ lam n bi d ( expr.abstract_local p n ) ]
                                let q( $ ( _ ) = $ ( e' ) ) ← infer_type pr
                                return ( some ( e' , pr ) )
                            else
                            do
                              let pr ← mk_app ` ` not_implies_eq [ d , p ]
                                let q( $ ( _ ) = $ ( e' ) ) ← infer_type pr
                                return ( some ( e' , pr ) )
                        | _ => return none
              | _ => return none
#align auto.transform_negation_step auto.transform_negation_step

/-- given an expr `e`, returns a new expression and a proof of equality -/
private unsafe def transform_negation (cfg : AutoConfig) : expr → tactic (Option (expr × expr)) :=
  fun e => do
  let opr ← transform_negation_step cfg e
  match opr with
    | some (e', pr) => do
      let opr' ← transform_negation e'
      match opr' with
        | none => return (some (e', pr))
        | some (e'', pr') => do
          let pr'' ← mk_eq_trans pr pr'
          return (some (e'', pr''))
    | none => return none
#align auto.transform_negation auto.transform_negation

unsafe def normalize_negations (cfg : AutoConfig) (h : expr) : tactic Unit := do
  let t ← infer_type h
  let (_, e, pr) ←
    simplify_top_down ()
        (fun _ => fun e => do
          let oepr ← transform_negation cfg e
          match oepr with
            | some (e', pr) => return ((), e', pr)
            | none => do
              let pr ← mk_eq_refl e
              return ((), e, pr))
        t
  replace_hyp h e pr
  skip
#align auto.normalize_negations auto.normalize_negations

unsafe def normalize_hyp (cfg : AutoConfig) (simps : simp_lemmas) (h : expr) : tactic Unit :=
  (do
      let (h, _) ← simp_hyp simps [] h
      try (normalize_negations cfg h)) <|>
    try (normalize_negations cfg h)
#align auto.normalize_hyp auto.normalize_hyp

unsafe def normalize_hyps (cfg : AutoConfig) : tactic Unit := do
  let simps ← add_simps simp_lemmas.mk classicalNormalizeLemmaNames
  local_context >>= Monad.mapM' (normalize_hyp cfg simps)
#align auto.normalize_hyps auto.normalize_hyps

/-!
### Eliminate existential quantifiers
-/

/-- eliminate an existential quantifier if there is one -/
unsafe def eelim : tactic Unit := do
  let ctx ← local_context
  first <|
      ctx fun h => do
        let t ← infer_type h >>= whnf_reducible
        guard (is_app_of t `` Exists)
        let tgt ← target
        to_expr ``(@Exists.elim _ _ $(tgt) $(h)) >>= apply
        intros
        clear h
#align auto.eelim auto.eelim

/-- eliminate all existential quantifiers, fails if there aren't any -/
unsafe def eelims : tactic Unit :=
  eelim >> repeat eelim
#align auto.eelims auto.eelims

/-!
### Substitute if there is a hypothesis `x = t` or `t = x`
-/

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- carries out a subst if there is one, fails otherwise -/ unsafe
  def
    do_subst
    : tactic Unit
    :=
      do
        let ctx ← local_context
          first
            <|
            ctx
              fun
                h
                  =>
                  do
                    let t ← infer_type h >>= whnf_reducible
                      match t with | q( $ ( a ) = $ ( b ) ) => subst h | _ => failed
#align auto.do_subst auto.do_subst

unsafe def do_substs : tactic Unit :=
  do_subst >> repeat do_subst
#align auto.do_substs auto.do_substs

/-!
### Split all conjunctions
-/

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Assumes `pr` is a proof of `t`. Adds the consequences of `t` to the context
       and returns `tt` if anything nontrivial has been added. -/
    unsafe
  def
    add_conjuncts
    : expr → expr → tactic Bool
    :=
      fun
        pr t
          =>
          let
            assert_consequences e t := condM ( add_conjuncts e t ) skip ( note_anon t e >> skip )
            do
              let t' ← whnf_reducible t
                match
                  t'
                  with
                  |
                      q( $ ( a ) ∧ $ ( b ) )
                      =>
                      do
                        let e₁ ← mk_app ` ` And.left [ pr ]
                          assert_consequences e₁ a
                          let e₂ ← mk_app ` ` And.right [ pr ]
                          assert_consequences e₂ b
                          return tt
                    | q( True ) => do return tt
                    | _ => return ff
#align auto.add_conjuncts auto.add_conjuncts

/-- return `tt` if any progress is made -/
unsafe def split_hyp (h : expr) : tactic Bool := do
  let t ← infer_type h
  condM (add_conjuncts h t) (clear h >> return tt) (return ff)
#align auto.split_hyp auto.split_hyp

/-- return `tt` if any progress is made -/
unsafe def split_hyps_aux : List expr → tactic Bool
  | [] => return false
  | h :: hs => do
    let b₁ ← split_hyp h
    let b₂ ← split_hyps_aux hs
    return (b₁ || b₂)
#align auto.split_hyps_aux auto.split_hyps_aux

/-- fail if no progress is made -/
unsafe def split_hyps : tactic Unit :=
  local_context >>= split_hyps_aux >>= guardb
#align auto.split_hyps auto.split_hyps

/-!
### Eagerly apply all the preprocessing rules
-/

/-- Eagerly apply all the preprocessing rules -/
unsafe def preprocess_hyps (cfg : AutoConfig) : tactic Unit := do
  repeat (intro1 >> skip)
  preprocess_goal
  normalize_hyps cfg
  repeat (do_substs <|> split_hyps <|> eelim)
#align auto.preprocess_hyps auto.preprocess_hyps

/-!
### Terminal tactic
-/

--<|> self_simplify_hyps
/-- The terminal tactic, used to try to finish off goals:
- Call the contradiction tactic.
- Open an SMT state, and use ematching and congruence closure, with all the universal
  statements in the context.

TODO(Jeremy): allow users to specify attribute for ematching lemmas?
-/
unsafe def mk_hinst_lemmas : List expr → smt_tactic hinst_lemmas
  | [] =>-- return hinst_lemmas.mk
  do
    get_hinst_lemmas_for_attr `ematch
  | h :: hs => do
    let his ← mk_hinst_lemmas hs
    let t ← infer_type h
    match t with
      | pi _ _ _ _ => do
        let t' ← infer_type t
        if t' = q(Prop) then
            (do
                let new_lemma ← hinst_lemma.mk h
                return (hinst_lemmas.add his new_lemma)) <|>
              return his
          else return his
      | _ => return his
#align auto.mk_hinst_lemmas auto.mk_hinst_lemmas

private unsafe def report_invalid_em_lemma {α : Type} (n : Name) : smt_tactic α :=
  fail f! "invalid ematch lemma '{n}'"
#align auto.report_invalid_em_lemma auto.report_invalid_em_lemma

private unsafe def add_hinst_lemma_from_name (md : Transparency) (lhs_lemma : Bool) (n : Name)
    (hs : hinst_lemmas) (ref : pexpr) : smt_tactic hinst_lemmas := do
  let p ← resolve_name n
  match p with
    | expr.const n _ =>
      (do
          let h ← hinst_lemma.mk_from_decl_core md n lhs_lemma
          tactic.save_const_type_info n ref
          return <| hs h) <|>
        (do
            let hs₁ ← smt_tactic.mk_ematch_eqn_lemmas_for_core md n
            tactic.save_const_type_info n ref
            return <| hs hs₁) <|>
          report_invalid_em_lemma n
    | _ =>
      (do
          let e ← to_expr p
          let h ← hinst_lemma.mk_core md e lhs_lemma
          try (tactic.save_type_info e ref)
          return <| hs h) <|>
        report_invalid_em_lemma n
#align auto.add_hinst_lemma_from_name auto.add_hinst_lemma_from_name

private unsafe def add_hinst_lemma_from_pexpr (md : Transparency) (lhs_lemma : Bool)
    (hs : hinst_lemmas) : pexpr → smt_tactic hinst_lemmas
  | p@(expr.const c []) => add_hinst_lemma_from_name md lhs_lemma c hs p
  | p@(expr.local_const c _ _ _) => add_hinst_lemma_from_name md lhs_lemma c hs p
  | p => do
    let new_e ← to_expr p
    let h ← hinst_lemma.mk_core md new_e lhs_lemma
    return <| hs h
#align auto.add_hinst_lemma_from_pexpr auto.add_hinst_lemma_from_pexpr

private unsafe def add_hinst_lemmas_from_pexprs (md : Transparency) (lhs_lemma : Bool)
    (ps : List pexpr) (hs : hinst_lemmas) : smt_tactic hinst_lemmas :=
  List.foldlM (add_hinst_lemma_from_pexpr md lhs_lemma) hs ps
#align auto.add_hinst_lemmas_from_pexprs auto.add_hinst_lemmas_from_pexprs

/-- `done` first attempts to close the goal using `contradiction`. If this fails, it creates an
SMT state and will repeatedly use `ematch` (using `ematch` lemmas in the environment,
universally quantified assumptions, and the supplied lemmas `ps`) and congruence closure.
-/
unsafe def done (ps : List pexpr) (cfg : AutoConfig := { }) : tactic Unit := do
  trace_state_if_enabled `auto.done "entering done"
  contradiction <|>
      solve1 do
        revert_all
        using_smt do
            smt_tactic.intros
            let ctx ← local_context
            let hs ← mk_hinst_lemmas ctx
            let hs' ← add_hinst_lemmas_from_pexprs reducible ff ps hs
            smt_tactic.iterate_at_most cfg
                (smt_tactic.ematch_using hs' >> smt_tactic.try smt_tactic.close)
#align auto.done auto.done

/-!
### Tactics that perform case splits
-/

inductive CaseOption
  | force-- fail unless all goals are solved

  | at_most_one-- leave at most one goal

  | accept
  deriving DecidableEq, Inhabited
#align auto.case_option Auto.CaseOption

-- leave as many goals as necessary
private unsafe def case_cont (s : CaseOption) (cont : CaseOption → tactic Unit) : tactic Unit := do
  match s with
    | case_option.force => cont case_option.force >> cont case_option.force
    |
    case_option.at_most_one =>-- if the first one succeeds, commit to it, and try the second
          condM
          (cont case_option.force >> return tt) (cont case_option.at_most_one) skip <|>
        (-- otherwise, try the second
            swap >>
            cont case_option.force) >>
          cont case_option.at_most_one
    | case_option.accept => focus' [cont case_option.accept, cont case_option.accept]
#align auto.case_cont auto.case_cont

-- failed to format: unknown constant 'term.pseudo.antiquot'
unsafe
  def
    case_hyp
    ( h : expr ) ( s : CaseOption ) ( cont : CaseOption → tactic Unit ) : tactic Bool
    :=
      do
        let t ← infer_type h
          match
            t
            with
            | q( $ ( a ) ∨ $ ( b ) ) => ( cases h >> case_cont s cont ) >> return tt
              | _ => return ff
#align auto.case_hyp auto.case_hyp

unsafe def case_some_hyp_aux (s : CaseOption) (cont : CaseOption → tactic Unit) :
    List expr → tactic Bool
  | [] => return false
  | h :: hs => condM (case_hyp h s cont) (return true) (case_some_hyp_aux hs)
#align auto.case_some_hyp_aux auto.case_some_hyp_aux

unsafe def case_some_hyp (s : CaseOption) (cont : CaseOption → tactic Unit) : tactic Bool :=
  local_context >>= case_some_hyp_aux s cont
#align auto.case_some_hyp auto.case_some_hyp

/-!
### The main tactics
-/

/-- `safe_core s ps cfg opt` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `s`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `ps`) and congruence closure.

`safe_core` is complete for propositional logic. Depending on the form of `opt`
it will:

- (if `opt` is `case_option.force`) fail if it does not close the goal,
- (if `opt` is `case_option.at_most_one`) fail if it produces more than one goal, and
- (if `opt` is `case_option.accept`) ignore the number of goals it produces.
-/
unsafe def safe_core (s : simp_lemmas × List Name) (ps : List pexpr) (cfg : AutoConfig) :
    CaseOption → tactic Unit := fun co =>
  focus1 do
    trace_state_if_enabled `auto.finish "entering safe_core"
    if cfg then do
        trace_if_enabled `auto.finish "simplifying hypotheses"
        simp_all s.1 s.2 { failIfUnchanged := ff }
        trace_state_if_enabled `auto.finish "result:"
      else skip
    tactic.done <|> do
        trace_if_enabled `auto.finish "preprocessing hypotheses"
        preprocess_hyps cfg
        trace_state_if_enabled `auto.finish "result:"
        done ps cfg <|>
            condM (case_some_hyp co safe_core) skip
              (match co with
              | case_option.force => done ps cfg
              | case_option.at_most_one => try (done ps cfg)
              | case_option.accept => try (done ps cfg))
#align auto.safe_core auto.safe_core

/-- `clarify` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.at_most_one`.
-/
unsafe def clarify (s : simp_lemmas × List Name) (ps : List pexpr) (cfg : AutoConfig := { }) :
    tactic Unit :=
  safe_core s ps cfg CaseOption.at_most_one
#align auto.clarify auto.clarify

/-- `safe` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.accept`.
-/
unsafe def safe (s : simp_lemmas × List Name) (ps : List pexpr) (cfg : AutoConfig := { }) :
    tactic Unit :=
  safe_core s ps cfg CaseOption.accept
#align auto.safe auto.safe

/-- `finish` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.force`.
-/
unsafe def finish (s : simp_lemmas × List Name) (ps : List pexpr) (cfg : AutoConfig := { }) :
    tactic Unit :=
  safe_core s ps cfg CaseOption.force
#align auto.finish auto.finish

end Auto

/-! ### interactive versions -/

open Auto

namespace Tactic

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- `clarify [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`clarify` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`clarify` will fail if it produces more than one goal.
-/
unsafe def clarify (hs : parse simp_arg_list)
    (ps : parse (parser.optional (tk "using" *> pexpr_list_or_texpr))) (cfg : AutoConfig := { }) :
    tactic Unit := do
  let s ← mk_simp_set false [] hs
  auto.clarify s (ps []) cfg
#align tactic.interactive.clarify tactic.interactive.clarify

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- `safe [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`safe` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`safe` ignores the number of goals it produces, and should never fail.
-/
unsafe def safe (hs : parse simp_arg_list)
    (ps : parse (parser.optional (tk "using" *> pexpr_list_or_texpr))) (cfg : AutoConfig := { }) :
    tactic Unit := do
  let s ← mk_simp_set false [] hs
  auto.safe s (ps []) cfg
#align tactic.interactive.safe tactic.interactive.safe

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- `finish [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`finish` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`finish` will fail if it does not close the goal.
-/
unsafe def finish (hs : parse simp_arg_list)
    (ps : parse (parser.optional (tk "using" *> pexpr_list_or_texpr))) (cfg : AutoConfig := { }) :
    tactic Unit := do
  let s ← mk_simp_set false [] hs
  auto.finish s (ps []) cfg
#align tactic.interactive.finish tactic.interactive.finish

add_hint_tactic finish

/--
These tactics do straightforward things: they call the simplifier, split conjunctive assumptions,
eliminate existential quantifiers on the left, and look for contradictions. They rely on ematching
and congruence closure to try to finish off a goal at the end.

The procedures *do* split on disjunctions and recreate the smt state for each terminal call, so
they are only meant to be used on small, straightforward problems.

* `finish`:  solves the goal or fails
* `clarify`: makes as much progress as possible while not leaving more than one goal
* `safe`:    splits freely, finishes off whatever subgoals it can, and leaves the rest

All accept an optional list of simplifier rules, typically definitions that should be expanded.
(The equations and identities should not refer to the local context.) All also accept an optional
list of `ematch` lemmas, which must be preceded by `using`.
-/
add_tactic_doc
  { Name := "finish / clarify / safe"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.finish, `tactic.interactive.clarify, `tactic.interactive.safe]
    tags := ["logic", "finishing"] }

end Interactive

end Tactic


import data.list.pairwise
import data.list
import data.list.sort
import data.vector
import data.finset
import data.array.lemmas
import data.equiv.list
import data.equiv.fin
import data.equiv.fintype
import order.lexicographic
import data.hash_map
import data.nat.log

def arg_list (i n : ℕ) := {v : vector (fin i) n // v.to_list.nodup}

def arg_list.to_vector {i n} (a : arg_list i n) := a.val
def arg_list.to_list {i n} (a : arg_list i n) := a.to_vector.to_list
def arg_list.to_nodup {i n} (a : arg_list i n) : a.to_list.nodup := a.prop

inductive rcmd (i : ℕ) : Type
| tog (arg : fin i) : rcmd
-- | swap : fin 4 → fin 4 → cmd
| cnot (args : arg_list i 2) : rcmd
| toffoli : arg_list i 3 → rcmd
| fredkin : arg_list i 3 → rcmd

open rcmd
def rcmd.rank {i} : rcmd i → ℕ
  | (tog _) := 1
  | (cnot _) := 2
  | (toffoli _) := 3
  | (fredkin _) := 4

def rcmd4.repr : rcmd 4 → string
  | (tog a) :=
    "n" ++ repr a.val
  | (cnot a) :=
    "c" ++ repr a.to_vector.head ++ repr a.to_vector.tail.head
  | (toffoli a) :=
    "t" ++ repr a.to_vector.head ++ repr a.to_vector.tail.head ++ repr a.to_vector.tail.tail.head
  | (fredkin a) :=
    "f" ++ repr a.to_vector.head ++ repr a.to_vector.tail.head ++ repr a.to_vector.tail.tail.head

instance : has_repr (rcmd 4) := {
  repr := rcmd4.repr
}

@[simp] lemma rcmd.rank_tog (size : ℕ) (i : fin size) : rcmd.rank (tog i) = 1 := rfl
@[simp] lemma rcmd.rank_cnot (size : ℕ) (i) : rcmd.rank (cnot i : rcmd size) = 2 := rfl
@[simp] lemma rcmd.rank_toffoli (size : ℕ) (i) : rcmd.rank (toffoli i : rcmd size) = 3 := rfl
@[simp] lemma rcmd.rank_fredkin (size : ℕ) (i) : rcmd.rank (fredkin i : rcmd size) = 4 := rfl

def rcmd.args {i} : rcmd i → list (fin i)
  | (tog a) := [a]
  | (cnot a) := a.to_list
  | (toffoli a) := a.to_list
  | (fredkin a) := a.to_list

open function

def rcmd.to_nat_list {i} (x : rcmd i) : list ℕ := x.rank :: x.args.map (λ x, x.1)
def rcmd.le {i} (x y : rcmd i) := x.to_nat_list ≤ y.to_nat_list
lemma rcmd.le_refl {i} (x : rcmd i) : x.le x := le_refl x.to_nat_list
lemma rcmd.le_trans {i} (x y z : rcmd i) : x.le y → y.le z → x.le z :=
  @le_trans _ _ x.to_nat_list y.to_nat_list z.to_nat_list
lemma rcmd.to_pair_injective {i} (x y : rcmd i) : x.to_nat_list = y.to_nat_list → x = y := by {
  cases x; cases y; cases x; cases y; unfold rcmd.to_nat_list rcmd.args arg_list.to_list; simp; intros h;
    apply vector.eq; exact list.map_injective_iff.mpr fin.coe_injective h,
}
lemma rcmd.le_antisymm {i} (x y : rcmd i) : x.le y → y.le x → x = y := by {
  intros xy yx,
  apply rcmd.to_pair_injective x y,
  unfold rcmd.le at xy yx,
  apply le_antisymm; assumption,
}

def rcmd.le_decidable {i} : decidable_rel (rcmd.le : rcmd i → rcmd i → Prop) := fun x y,
  if h : x.to_nat_list ≤ y.to_nat_list
    then is_true h
    else is_false h

lemma rcmd.le_total {i} (x y : rcmd i) : x.le y ∨ y.le x := le_total x.to_nat_list y.to_nat_list

instance {i} : linear_order (rcmd i) := {
  le := rcmd.le,
  le_refl := rcmd.le_refl,
  le_trans := rcmd.le_trans,
  le_antisymm := rcmd.le_antisymm,
  decidable_le := rcmd.le_decidable,
  le_total := rcmd.le_total,
}

lemma nodup_tail {α} {x : α} {xs} : list.nodup (x :: xs) → list.nodup xs := list.nodup_of_nodup_cons
lemma nodup_3 {α} {x y z: α} [decidable_eq α] : [x,y,z].nodup ↔ (x ≠ y ∧ x ≠ z ∧ y ≠ z) := by {
  simp,
  rw ← and_assoc,
  have : (¬(x = y ∨ x = z) ∧ ¬y = z) = ((¬x = y ∧ ¬x = z) ∧ ¬y = z),
  {
    congr,
    apply propext,
    split; intros hyp_iff,
    split; intros hyp_not; apply hyp_iff,
    {left, exact hyp_not},
    {right, exact hyp_not},
    intros hyp_not,
    cases hyp_not,
    exact hyp_iff.left hyp_not,
    exact hyp_iff.right hyp_not,
  },
  rw this,
}

def rcmd.run {size : ℕ} : rcmd size → array size bool → array size bool
  | (tog i) := λ arr, arr.write i (not (arr.read i))
  | (cnot {val := ⟨[control, target], _⟩, property := _}) := λ arr,
    if arr.read control then (tog target).run arr else arr
  | (toffoli {val := ⟨[control_a, control_b, target], _⟩, property := d} ) := λ arr,
    if (arr.read control_a)
      then
        let d' := by {apply list.nodup_of_nodup_cons d} in
        (cnot ⟨⟨[control_b, target], rfl⟩, d'⟩ ).run arr
      else arr
  | (fredkin {val := ⟨[control, target_a, target_b], _⟩, property := _}) := λ arr,
    if arr.read control
      then (arr.write target_a (arr.read target_b)).write target_b (arr.read target_a)
      else arr
  using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf rcmd.rank⟩]}

lemma arr_write_read_neq
  (size : ℕ) (i : fin size) {α} (arr : array size α) {x : α} :
  (arr.write i x).read i = x := by {
    exact array.read_write arr i x
}

lemma rcmd.run_self (size : ℕ) : ∀ (c : rcmd size) (arr), c.run (c.run arr) = arr
  | (rcmd.tog c) := λ arr, by {
    unfold rcmd.run,
    simp,
    ext,
    have : decidable (c = i) := by apply_instance,
    cases this,
    {
      rw array.read_write_of_ne,
      rw array.read_write_of_ne,
      all_goals {apply this},
    },
    {
      rw this,
      rw array.read_write,
    }
  }
  | (cnot {val := ⟨[control, target], p⟩, property := p2}) := λ arr, by {
    have : (cnot {val := ⟨[control, target], p⟩, property := p2}).run =
      λ arr, if arr.read control then (rcmd.tog target).run arr else arr := by {
        unfold rcmd.run
      },
    rw this, clear this,
    have : decidable (arr.read control) := by apply_instance,
    cases this,
    {
      simp_rw if_neg this,
      rw if_neg,
      exact this,
    },
    {
      simp at p2,
      simp_rw if_pos this,
      rw if_pos,
      apply rcmd.run_self,
      unfold rcmd.run,
      rw array.read_write_of_ne,
      exact this,
      symmetry,
      exact p2,
    },
  }
  | (toffoli {val := ⟨[control, control_b, target], p⟩, property := d}) := λ arr, by {
    have : (toffoli {val := ⟨[control, control_b, target], p⟩, property := d}).run =
      λ arr,
        if (arr.read control)
          then
            let d' := by {apply list.nodup_of_nodup_cons d} in
            (cnot ⟨⟨[control_b, target], rfl⟩, d'⟩ ).run arr
          else arr
      := by unfold rcmd.run,
    simp at this,
    rw this, clear this,
    have : decidable (arr.read control) := by apply_instance,
    cases this,
    {
      simp_rw if_neg this,
      rw if_neg,
      exact this,
    },
    {
      simp at d,
      simp_rw if_pos this,
      simp_rw rcmd.run_self,
      have : (((cnot {val := ⟨[control_b, target], _⟩, property := _}).run arr).read control),
      {
        have : ∀ p₁ p₂,
          (((cnot {val := ⟨[control_b, target], p₁⟩, property := p₂}).run arr).read control)
            = arr.read control,
        {
          intros,
          unfold rcmd.run,
          split_ifs,
          apply array.read_write_of_ne,
          intros hyp,
          apply d.left,
          right,
          symmetry,
          assumption,
          refl,
        },
        rw this,
        clear this,
        exact this,
      },
      rw if_pos this,
    },
  }
  | (fredkin {val := ⟨[control, target_a, target_b], _⟩, property := d}) := λ arr, by {
    unfold vector.to_list at d,
    rw nodup_3 at d,
    obtain ⟨contro_ne_target_a, control_ne_target_b, target_a_ne_target_b⟩ := d,
    unfold rcmd.run,
    have : ((arr.write target_a (arr.read target_b)).write target_b (arr.read target_a)).read control =
      arr.read control,
    {
      rw array.read_write_of_ne,
      rw array.read_write_of_ne,
      symmetry,
      assumption,
      symmetry,
      assumption,
    },
    split_ifs; try {rw this}; clear this,
    {
      ext,
      have eq_a : decidable (i = target_a) := by apply_instance,
      cases eq_a with ne_a eq_a,
      {
        have eq_b : decidable (i = target_b) := by apply_instance,
        cases eq_b with ne_b eq_b,
        {
          repeat {rw array.read_write_of_ne},
          all_goals {symmetry, assumption},
        },
        {
          rw eq_b, clear ne_a eq_b i,
          rw array.read_write,
          rw array.read_write_of_ne _ _ target_a_ne_target_b.symm,
          rw array.read_write,
        }
      },
      {
          rw eq_a, clear eq_a i,
          rw array.read_write,
          rw array.read_write_of_ne _ _ target_a_ne_target_b.symm,
          rw array.read_write,
      }
    },
    {
      exfalso,
      apply h_1,
      rw array.read_write_of_ne,
      rw array.read_write_of_ne,
      exact h,
      all_goals {symmetry, assumption}
    },
    refl,
  }
  using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf rcmd.rank⟩]}

instance : monad_fail list := {
  fail := λ _ _, []
}

def mk_arg_list {i : ℕ} {m} [monad m] [monad_fail m] (get : m (fin i)) : ∀ {n : ℕ}, m (arg_list i n)
  | 0 := pure ⟨vector.nil, list.nodup_nil⟩
  | (k + 1) :=
    do
    x <- get,
    ⟨xs, p⟩ <- (mk_arg_list : m (arg_list i k)),
    if h : x ∈ xs.to_list
      then monad_fail.fail "duplicate argument -> cull"
      else pure ⟨x ::ᵥ xs, by {
        rw vector.to_list_cons x xs,
        apply list.nodup_cons.mpr ⟨h, p⟩
      }⟩

def list_out (α) [fintype α] [linear_order α] : list α :=
  multiset.sort (≤) (fintype.elems α).val

lemma mem_list_out (α) [fintype α] [linear_order α] (x : α) : x ∈ list_out α := by {
  unfold list_out,
  rw multiset.mem_sort,
  rw ← finset.mem_def,
  exact fintype.complete x
}

lemma list.mem_bind_op {α β} {b : β} {l : list α} {f : α → list β} :
  b ∈ (l >>= f) ↔ ∃ a ∈ l, b ∈ f a := by {
  unfold has_bind.bind,
  apply list.mem_bind
}

def mem_mk_arg_list {i n} {a : arg_list i n} :
  a ∈ (mk_arg_list (list_out (fin i)) : list (arg_list i n)) := by {
    obtain ⟨⟨l, l_length⟩, l_nodup⟩ := a,
    revert l l_length l_nodup,
    induction n; intros,
    {
      rw list.length_eq_zero at l_length,
      cases l,
      unfold mk_arg_list,
      rw list.mem_pure,
      refl,
      {cases l_length}
    },
    {
      unfold mk_arg_list,
      simp_rw list.mem_bind_op,
      cases l,
      {cases l_length},
      use l_hd,
      split,
      {apply mem_list_out},
      use l_tl,
      {
        rw list.length_cons at *,
        exact nat.succ.inj l_length
      },
      {exact list.nodup_of_nodup_cons l_nodup},
      {
        split,
        apply n_ih,
        unfold mk_arg_list._match_1,
        rw dif_neg,
        rw list.mem_pure,
        congr,
        simp at *,
        exact l_nodup.left,
      }
    },
  }

def list.sort {α} [linear_order α] : list α → list α := list.merge_sort (≤)
def multiset.sort' {α} [linear_order α] : multiset α → list α := multiset.sort (≤)

def rcmd.elems' {i} : ℕ → list (rcmd i)
  | 1 := (list_out (fin i)).map tog
  | 2 := cnot <$> (mk_arg_list (list_out (fin i)))
  | 3 := toffoli <$> (mk_arg_list (list_out (fin i)))
  | 4 := fredkin <$> (mk_arg_list (list_out (fin i)))
  | n := monad_fail.fail "ignore"

def rcmd.elems {i} : list (rcmd i) :=
  rcmd.elems' 1 ++ rcmd.elems' 2 ++ rcmd.elems' 3 ++ rcmd.elems' 4

lemma rcmd.mem_elems {i} (c : rcmd i) : c ∈ (rcmd.elems : list (rcmd i)) := by {
  cases c; unfold rcmd.elems,
  {
    repeat {apply list.mem_append_left},
    unfold rcmd.elems',
    rw list.mem_map,
    use c,
    split,
    apply mem_list_out,
    refl,
  },
  {
    apply list.mem_append_left,
    apply list.mem_append_left,
    apply list.mem_append_right,
    unfold rcmd.elems',
    rw list.map_eq_map,
    rw list.mem_map,
    use c,
    split,
    apply mem_mk_arg_list,
    refl
  },
  {
    apply list.mem_append_left,
    apply list.mem_append_right,
    unfold rcmd.elems',
    rw list.map_eq_map,
    rw list.mem_map,
    use c,
    split,
    apply mem_mk_arg_list,
    refl
  },
  {
    apply list.mem_append_right,
    unfold rcmd.elems',
    rw list.map_eq_map,
    rw list.mem_map,
    use c,
    split,
    apply mem_mk_arg_list,
    refl
  },
}

instance (i : ℕ) : fintype (rcmd i) := {
  elems := rcmd.elems.to_finset,
  complete := λ c, by { rw list.mem_to_finset, exact rcmd.mem_elems c},
}

-- this is just a type restricted version of function.comp
infix `∘∘`:90 := λ {i}, ((∘) : (array i bool → array i bool) → (array i bool → array i bool) → (array i bool → array i bool))

def list.run {i} := list.foldl (λ a (b : rcmd i), a ∘∘ b.run) id

def encode_bit_list : list bool → (ℕ → ℕ) :=
  flip (list.foldl (λ n (b : bool), if b then bit1 n else bit0 n))

def list_array : ∀ {i}, list (array i bool)
  | 0 := [array.nil]
  | (n+1) := do
    arr ← (list_array : list (array n bool)),
    value ← [tt, ff],
    pure $ array.push_back arr value

def encode_array_fun {i} : (array i bool → array i bool) → (ℕ → ℕ) :=
  λ f, encode_bit_list $
    do
    arr <- list_array,
    (f arr).read <$> list_out (fin i)

def pr_hash_map (i : ℕ) (n : fin 12) : Type := hash_map ℕ (λ _, vector (rcmd i) n)
def pr_hash_map.insert {i n} : pr_hash_map i n → vector (rcmd i) n → pr_hash_map i n
  | h v := hash_map.insert h (encode_array_fun v.to_list.run 0) v

def programs2 : pr_hash_map 4 2 :=
  list.foldl pr_hash_map.insert (mk_hash_map (2 ^ 16)) $ do
    (c0 : rcmd 4) <- rcmd.elems,
    (c1 : rcmd 4) <- rcmd.elems,
    pure ⟨[c0, c1], rfl⟩

def can_go_infront1' (c : rcmd 4) : list (rcmd 4) := (λ v : vector _ 2, v.head) <$>
  list.filter (λ v : vector _ 2, v.tail.head = c) ((λ s : Σ _ : ℕ, vector (rcmd 4) 2, s.2) <$> programs2.entries)

def can_go_infront : hash_map (rcmd 4) (λ _, list (rcmd 4)) :=
  hash_map.insert_all ((λ c, ⟨c, can_go_infront1' c⟩) <$> rcmd.elems) (mk_hash_map 64)

def programs3 : pr_hash_map 4 3 :=
  let p := programs2.entries in
  list.foldl pr_hash_map.insert (mk_hash_map (2 ^ 16)) $ do
    ⟨_, (p1 : vector (rcmd 4) 2)⟩ <- p,
    ⟨_, (p2 : vector (rcmd 4) 2)⟩ <- p,
    if p2.head = p1.tail.head
      then pure (p1.head ::ᵥ p2)
      else []

set_option profiler true
set_option timeout 0

#eval (rcmd.elems : list (rcmd 4)).length

#eval programs2.entries.length
#eval programs3.entries.length

def programs5 : pr_hash_map 4 5 :=
  list.foldl pr_hash_map.insert (mk_hash_map (2 ^ 16)) $ do
    ⟨_, (p2 : vector (rcmd 4) 2)⟩ <- programs2.entries,
    ⟨_, (p3 : vector (rcmd 4) 3)⟩ <- programs3.entries,
    pure (p2.append p3)

def programs10 : pr_hash_map 4 10 :=
  list.foldl pr_hash_map.insert (mk_hash_map (2 ^ 16)) $ do
    ⟨_, (p2 : vector (rcmd 4) 5)⟩ <- programs5.entries,
    ⟨_, (p3 : vector (rcmd 4) 5)⟩ <- programs5.entries,
    pure (p2.append p3)

#eval programs10.entries.length

#check pr_hash_map 4 11

def programs11 : pr_hash_map 4 (11 : fin 12) :=
  list.foldl pr_hash_map.insert (mk_hash_map (2 ^ 16)) $ do
    (c : rcmd 4) <- rcmd.elems,
    ⟨_, (p : vector (rcmd 4) 10)⟩ <- programs10.entries,
    pure (c ::ᵥ p)


theorem ex (h : 10000 = 100001) : False := by
  contradiction

#print ex


import ..mcrl2_basic.mcrl2_basic

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

/- This relation is used to prove congruence of communication. The proof requires helper lemmas that are further on.-/
inductive R_comm {x₁ x₂ y₁ y₂ : mcrl2 α} (R₁ R₂ : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R₁ {x y} (h : R₁ x y) : R_comm x y
| R₂ {x y} (h : R₂ x y) : R_comm x y
| basel : R_comm (x₁ ∣ y₁) (x₂ ∣ y₂)
| baser : R_comm (x₂ ∣ y₂) (x₁ ∣ y₁)
| stepl {a b x₁' x₂' y₁' y₂'} (hR₁ : R₁ x₁' x₂') (hR₂ : R₂ y₁' y₂' )
 (h₁x : transition x₁ a x₁') (h₂x : transition x₂ a x₂')
 (h₁y : transition y₁ b y₁') (h₂y : transition y₂ b y₂') :
R_comm (x₁' || y₁') (x₂' || y₂')
| stepr {a b x₁' x₂' y₁' y₂'} (hR₁ : R₁ x₁' x₂') (hR₂ : R₂ y₁' y₂' )
 (h₁x : transition x₁ a x₁') (h₂x : transition x₂ a x₂')
 (h₁y : transition y₁ b y₁') (h₂y : transition y₂ b y₂') :
R_comm (x₂' || y₂') (x₁' || y₁')
| par_l {x x' y y' a z z'} (hR : R_comm (x || y) (x' || y')) (hR' : R_comm (x' || y') (x || y))
  (hR₁ : R₁ x x') (hR₂ : R₂ y y')
  (hRz : R₁ z z')
  (ht : transition x a z) (ht' : transition x' a z') :
  R_comm (z || y) (z' || y')
| par_r {x x' y y' a z z'} (hR : R_comm (x || y) (x' || y')) (hR' : R_comm (x' || y') (x || y))
  (hR₁ : R₁ x x') (hR₂ : R₂ y y')
  (hRz : R₂ z z')
  (ht : transition y a z) (ht' : transition y' a z') :
  R_comm (x || z) (x' || z')
| comm {x x' y y' a b z₁ z₁' z₂ z₂'} (hR : R_comm (x || y) (x' || y')) (hR' : R_comm (x' || y') (x || y))
  (hRz₁ : R₁ z₁ z₁') (hRz₂ : R₂ z₂ z₂')
  (hR₁ : R₁ x x') (hR₂ : R₂ y y')
  (htx : transition x a z₁) (htx' : transition x' a z₁')
  (hty : transition y b z₂) (hty' : transition y' b z₂') :
  R_comm (z₁ || z₂) (z₁' || z₂')

lemma R_comm.symm {x₁ x₂ y₁ y₂ : mcrl2 α} {R₁ R₂ : mcrl2 α → mcrl2 α → Prop}
(h₁ : symmetric R₁) (h₂ : symmetric R₂):
symmetric (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) :=
begin
  intros x y h,
  cases h,
  { apply R_comm.R₁,
    apply h₁,
    assumption},
  { apply R_comm.R₂,
    apply h₂,
    assumption},
  { exact R_comm.baser},
  { exact R_comm.basel},
  { apply R_comm.stepr; assumption},
  { apply R_comm.stepl; assumption},
  { apply R_comm.par_l,
    repeat {assumption},
    exact h₁ h_hR₁,
    exact h₂ h_hR₂,
    exact h₁ h_hRz},
  { apply R_comm.par_r,
    repeat {assumption},
    exact h₁ h_hR₁,
    exact h₂ h_hR₂,
    apply h₂ h_hRz},
  { apply R_comm.comm,
    exact h_hR',
    repeat {assumption},
    exact h₁ h_hRz₁,
    exact h₂ h_hRz₂,
    exact h₁ h_hR₁,
    exact h₂ h_hR₂}
end

lemma bisim_exists_lift_comm_l {x₁ x₂ y₁ y₂ x x' y y' a z} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hxz : transition x a z)
 (hR₁ : R₁ x x') (hR₂ : R₂ y y')
 (hR : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x || y) (x' || y' ))
 (hR' : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x' || y' ) (x || y)) :
(∃z', transition x' a z' ∧ option.rel R₁ z z') → (∃z', transition x' a z' ∧ option.rel (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (par' z y) (par' z' y')) :=
begin
  intro h,
  rcases h with ⟨w, hwa, hRw⟩,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases hRw,
  { apply option.rel.some,
    apply R_comm.par_l,
    exact hR,
    repeat {assumption}},
  { apply option.rel.some,
    apply R_comm.R₂,
    assumption}
end

lemma bisim_exists_lift_comm_r {x₁ x₂ y₁ y₂ x x' y y' a z} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hxz : transition y a z)
 (hR₁ : R₁ x x') (hR₂ : R₂ y y')
 (hR : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x || y) (x' || y' ))
 (hR' : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x' || y' ) (x || y)) :
(∃z', transition y' a z' ∧ option.rel R₂ z z') → (∃z', transition y' a z' ∧ option.rel (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (par' x z) (par' x' z')) :=
begin
  intro h,
  rcases h with ⟨w, hwa, hRw⟩,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases hRw,
  { apply option.rel.some,
    apply R_comm.par_r,
    exact hR,
    repeat {assumption}},
  { apply option.rel.some,
    apply R_comm.R₁,
    assumption}
end

lemma bisim_exists_lift_comm_comm {x₁ x₂ y₁ y₂ x x' y y' a b z₁ z₂} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hxz : transition x a z₁) (hyz' : transition y b z₂) (hR₁ : R₁ x x') (hR₂ : R₂ y y')
 (hab : a * b ≠ 0)
 (hR : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x || y) (x' || y' ))
 (hR' : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x' || y' ) (x || y)) :
(∃z' , transition x' a z' ∧ option.rel R₁ z₁ z') → (∃z' , transition y' b z' ∧ option.rel R₂ z₂ z') →
(∃z', transition (x' || y') (a * b) z' ∧ option.rel (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (par' z₁ z₂) z') :=
begin
  intros h₁ h₂,
  rcases h₁ with ⟨w₁, hw₁a, hRw₁⟩,
  rcases h₂ with ⟨w₂, hw₂b, hRw₂⟩,
  simp only [transition.par_iff, exists_or_distrib, or_and_distrib_right, ←exists_and_distrib_right, and_assoc, exists_eq_left],
  apply or.inr,
  apply or.inr,
  apply exists.intro (par' w₁ w₂),
  apply exists.intro w₁,
  apply exists.intro w₂,
  apply and.intro,
  refl,
  apply exists.intro a,
  apply exists.intro b,
  apply and.intro,
  assumption,
  apply and.intro,
  refl,
  apply and.intro,
  assumption,
  apply and.intro,
  assumption,
  cases hRw₂,
  { cases hRw₁,
    { apply option.rel.some,
      apply R_comm.comm,
      repeat {assumption}},
    { apply option.rel.some,
      cases hRw₂,
      apply R_comm.R₂,
      assumption}},
  { cases hRw₁,
    { apply option.rel.some,
      apply R_comm.R₁,
      assumption},
    { apply option.rel.none}}
end

lemma bisim_exists_lift_comm {x₁ x₂ y₁ y₂ x x' y y' a z} {R₁ R₂ : mcrl2 α → mcrl2 α → Prop}
 (R₁_bisim : is_bisimulation R₁) (R₂_bisim : is_bisimulation R₂) (hR₁ : R₁ x x') (hR₂ : R₂ y y') (haz : transition (x || y) a z)
 (hR : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x || y) (x' || y' ))
 (hR' : (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) (x' || y' ) (x || y)) :
 (∃z', transition (x' || y') a z' ∧ option.rel (@R_comm _ _ x₁ x₂ y₁ y₂ R₁ R₂) z z') :=
begin
  cases R₁_bisim with R₁_bisim R₁_symm,
  cases R₂_bisim with R₂_bisim R₂_symm,
  cases haz,
  { specialize R₁_bisim x x' haz_x' a hR₁ haz_h,
    simp only [transition.par_iff, exists_or_distrib, or_and_distrib_right, ←exists_and_distrib_right, and_assoc, exists_eq_left],
    apply or.inl,
    simp only [exists_comm, exists_eq_left],
    exact bisim_exists_lift_comm_l haz_h hR₁ hR₂ hR hR' R₁_bisim,},
  { specialize R₂_bisim y y' haz_y' a hR₂ haz_h,
    simp only [transition.par_iff, exists_or_distrib, or_and_distrib_right, ←exists_and_distrib_right, and_assoc, exists_eq_left],
    apply or.inr,
    apply or.inl,
    simp only [exists_comm, exists_eq_left],
    exact bisim_exists_lift_comm_r haz_h hR₁ hR₂ hR hR' R₂_bisim},
  { specialize R₁_bisim x x' haz_x' haz_a hR₁ haz_h₁,
    specialize R₂_bisim y y' haz_y' haz_b hR₂ haz_h₂,
    exact bisim_exists_lift_comm_comm haz_h₁ haz_h₂ hR₁ hR₂ haz_h₃ hR hR' R₁_bisim R₂_bisim}
end

/- The main congruence theorem for |.-/
theorem bisim.comm {x₁ x₂ y₁ y₂: mcrl2 α} (h₁ : x₁ ≈ x₂) (h₂ : y₁ ≈ y₂) :
x₁ ∣ y₁ ≈ x₂ ∣ y₂ :=
begin
  rcases h₁ with ⟨R₁, R₁x, R₁_bisim⟩,
  rcases h₂ with ⟨R₂, R₂y, R₂_bisim⟩,
  apply exists.intro (R_comm R₁ R₂),
  apply and.intro,
  apply R_comm.basel,
  apply and.intro,
  { intros x y x' a Rxy xax',
    cases Rxy,
    { apply bisim_exists_lift,
      { intros v w, exact R_comm.R₁},
      { apply bisim_lift; assumption}},
    { apply bisim_exists_lift,
      { intros v w, exact R_comm.R₂},
      { apply bisim_lift; assumption}},
    { simp [transition.comm_iff, ←exists_and_distrib_right, and_assoc],
      cases xax',
      cases R₁_bisim with R₁_bisim R₁_symm,
      specialize R₁_bisim x₁ x₂ xax'_x' xax'_a R₁x xax'_h₁,
      rcases R₁_bisim with ⟨w, haw, Rw⟩,
      cases R₂_bisim with R₂_bisim R₂_symm,
      specialize R₂_bisim y₁ y₂ xax'_y' xax'_b R₂y xax'_h₂,
      rcases R₂_bisim with ⟨w', haw', Rw'⟩,
      apply exists.intro (par' w w'),
      apply exists.intro w,
      apply exists.intro w',
      apply and.intro,
      refl,
      apply exists.intro xax'_a,
      apply exists.intro xax'_b,
      apply and.intro,
      refl,
      apply and.intro,
      assumption,
      apply and.intro,
      assumption,
      apply and.intro,
      assumption,
      cases Rw,
      { cases Rw',
        { apply option.rel.some,
          apply R_comm.stepl; assumption},
        { apply option.rel.some,
          exact R_comm.R₁ Rw_ᾰ}},
      { cases Rw',
        { apply option.rel.some,
          apply R_comm.R₂,
          assumption},
        { exact option.rel.none}}},
    { simp [transition.comm_iff, ←exists_and_distrib_right, and_assoc],
      cases xax',
      cases R₁_bisim with R₁_bisim R₁_symm,
      specialize R₁_bisim x₂ x₁ xax'_x' xax'_a (R₁_symm R₁x) xax'_h₁,
      rcases R₁_bisim with ⟨w, haw, Rw⟩,
      cases R₂_bisim with R₂_bisim R₂_symm,
      specialize R₂_bisim y₂ y₁ xax'_y' xax'_b (R₂_symm R₂y) xax'_h₂,
      rcases R₂_bisim with ⟨w', haw', Rw'⟩,
      apply exists.intro (par' w w'),
      apply exists.intro w,
      apply exists.intro w',
      apply and.intro,
      refl,
      apply exists.intro xax'_a,
      apply exists.intro xax'_b,
      apply and.intro,
      refl,
      apply and.intro,
      assumption,
      apply and.intro,
      assumption,
      apply and.intro,
      assumption,
      cases Rw,
      { cases Rw',
        { apply option.rel.some,
          apply R_comm.stepr,
          exact R₁_symm Rw_ᾰ,
          exact R₂_symm Rw'_ᾰ,
          repeat {assumption}},
        { apply option.rel.some,
          exact R_comm.R₁ Rw_ᾰ}},
      { cases Rw',
        { apply option.rel.some,
          apply R_comm.R₂,
          assumption},
        { exact option.rel.none}}},
    { apply bisim_exists_lift_comm,
      repeat {assumption},
      exact R_comm.symm R₁_bisim.right R₂_bisim.right Rxy},
    { apply bisim_exists_lift_comm,
      repeat {assumption},
      exact R₁_bisim.right Rxy_hR₁,
      exact R₂_bisim.right Rxy_hR₂,
      exact R_comm.symm R₁_bisim.right R₂_bisim.right Rxy},
    { apply bisim_exists_lift_comm,
      repeat {assumption},
      exact R_comm.symm R₁_bisim.right R₂_bisim.right Rxy},
    { apply bisim_exists_lift_comm,
      repeat {assumption},
      exact R_comm.symm R₁_bisim.right R₂_bisim.right Rxy},
    { apply bisim_exists_lift_comm,
      repeat {assumption},
      exact R_comm.symm R₁_bisim.right R₂_bisim.right Rxy}},
  { exact R_comm.symm R₁_bisim.right R₂_bisim.right}
end


import tactic differentiablity
import analysis.calculus.fderiv

namespace tactic
namespace interactive

meta def analysis : tactic unit :=
do g ← tactic.target,
  match g with
  | `(differentiable_at _ _ _) := apply_rules [``(differentiability)]
  | `(continuous_at _ _) := apply_rules [``(continuity)]
  | _ := fail "error"
  end

end interactive
end tactic

open real

variables {E : Type*} [normed_group E] [normed_space ℝ E] {f : E → ℝ}
  {x : E}

@[differentiability] lemma differentiable_at.sin' (hc : differentiable_at ℝ f x) :
  differentiable_at ℝ (λx, real.sin (f x)) x := sorry

@[differentiability] lemma differentiable_at_id'' : differentiable_at ℝ (λ x, x) x :=
(has_fderiv_at_id x).differentiable_at

example {f : ℝ → ℝ} (x: ℝ) : differentiable_at ℝ (λx, real.sin (x)) x := by differentiability

example
    {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
    {E : Type*} [normed_group E] [normed_space 𝕜 E] {x : E} : differentiable_at 𝕜 id x :=
begin
  analysis, --diff
  sorry
end

example {α : Type*} [topological_space α] (x : α) : continuous_at id x :=
begin
  analysis, -- cts
  sorry
end

example : 1 + 1 = 2 :=
begin
  analysis, -- error
end


import Lean
import Lean.Meta
import Std.Data.HashMap
import Std.Data.HashSet

open Std

namespace List

def toHashSet {α} [BEq α] [Hashable α] (xs : List α) : HashSet α :=
xs.foldl HashSet.insert HashSet.empty

end List

namespace AssocList
open Std.AssocList Ordering

-- variable {α β : Type u}
variable (cmp : α → α → Ordering)

def insert (k : α) (v : β) : AssocList α β → AssocList α β
| nil => cons k v nil
| cons k' v' xs =>
  if cmp k k' == lt then
    cons k v $ cons k' v' xs
  else
    cons k' v' (insert k v xs)

def sort : AssocList α β -> AssocList α β
| nil => nil
| cons k v xs => insert cmp k v (sort xs)

end AssocList

namespace List
open Std.AssocList Ordering

-- variable {α β : Type u}
variable (cmp : α → α → Ordering)

def insert (k : α) : List α → List α
| nil => [k]
| k' :: xs =>
  if cmp k k' == Ordering.lt then
    k :: k' :: xs
  else
    k' :: insert k xs

def sort : List α → List α
| nil => nil
| k :: xs => insert cmp k (sort xs)

@[specialize]
protected def compare : List α → List α → Ordering
| [], [] => eq
| [], x :: xs => Ordering.lt
| x :: xs, [] => gt
| x :: xs, y :: ys =>
  let hd := cmp x y
  if hd == eq then List.compare xs ys
  else hd

instance [Ord α] : Ord (List α) where
  compare := List.compare compare

end List

namespace Std
-- namespace HashMapBucket

-- protected def map (f : β → β') :
--   HashMapBucket α β → HashMapBucket α β'
-- | ⟨ar, har⟩ => ⟨ar.map $ AssocList.mapVal f, by simp [Array.map] ⟩

-- end HashMapBucket
-- namespace HashMapImp
-- end HashMapImp
namespace HashMap

instance {α β} [BEq α] [Hashable α] [BEq β] :
    BEq (HashMap α β) where
  beq x y :=
     x.size == y.size &&
     x.fold (λ b k v => b && y.find? k == some v) true

variable [BEq κ] [Hashable κ]

protected def map (f : α → β) (m : HashMap κ α) : HashMap κ β :=
m.fold (λ m' k x => m'.insert k (f x)) {}

end HashMap

namespace HashSet

instance [BEq α] [Hashable α] :
    BEq (HashSet α) where
  beq x y :=
     x.size == y.size &&
     x.fold (λ b k => b && y.contains k) true

instance [Ord α] [BEq α] [Hashable α] :
    Hashable (HashSet α) where
  hash c :=
   let m := c.val.buckets.val.map (List.sort compare)
   let m := m.map ( List.foldl (λ acc k => mixHash acc (hash k)) 0)
   m.foldl mixHash 0

end HashSet

end Std

structure Clause where
mkClauseImpl ::
  atoms : HashMap Nat Bool
  hashCode : UInt64

namespace ClauseImpl

def hashCode (c : HashMap Nat Bool) : UInt64 :=
 let m := c.val.buckets.val.map (AssocList.sort compare)
 let m := m.map ( AssocList.foldl (λ acc k v => mixHash acc (hash (k, v))) 0)
 m.foldl mixHash 0

instance : Hashable Clause where
  hash := Clause.hashCode

instance : BEq Clause where
  beq x y := x.atoms == y.atoms

end ClauseImpl

namespace Clause

protected def mk (c : HashMap Nat Bool) : Clause :=
{ atoms := c,
  hashCode := ClauseImpl.hashCode c }

open Ordering

instance [Ord α] [Ord β] : Ord (α × β) where
  compare
   | ⟨x₀, x₁⟩, ⟨y₀, y₁⟩ =>
     let r := compare x₀ y₀
     if r == eq
       then compare x₁ y₁
       else r

instance : Ord Clause where
  compare x y :=
    match compare (hash x) (hash y) with
    | lt => lt
    | gt => gt
    | eq => compare x.atoms.toList y.atoms.toList

end Clause

abbrev CNF := HashSet Clause

structure SmtState where
mkImpl ::
  vars : Std.HashMap Lean.Expr Nat := {}
  clauses : Std.HashMap Lean.Expr CNF := {}
  defs : Std.HashMap CNF Nat := {}

def SmtState.mk : SmtState :=
{}
-- { vars := {},
--   clauses := {},
--   defs := {} }

open Lean (MetaM Expr)
open Lean.Expr

abbrev SmtM := StateT SmtState MetaM

def unitClause (v : Nat) (b : Bool) : Clause :=
  Clause.mk $ HashMap.empty.insert v b

def mkLit (i : Nat) : CNF :=
  HashSet.empty.insert
    $ unitClause i true

def Clause.negate (c : Clause) : CNF :=
  let x := c.atoms.toList
  x.foldl (λ s ⟨v,b⟩ => s.insert $ unitClause v !b) HashSet.empty

def Clause.join (c₀ c₁ : Clause) : OptionM Clause :=
let f c v b :=
  match c.find? v with
  | some b' =>
    if b == b' then some c
    else none
  | none => some $ c.insert v b
Clause.mk <$> c₀.atoms.foldM f HashMap.empty

def Lit.toString (v : Nat) : Bool -> String
| true => s!"x{v}"
| false => s!"¬ x{v}"
-- | false => "¬ x" ++ toString v

def Clause.toStringAux : List (Nat × Bool) → String
| [] => "false"
| [(v, b)] => Lit.toString v b
| (v, b) :: vs => Lit.toString v b ++ " ∨ " ++ toStringAux vs

def Clause.toString (c : Clause) : String :=
  let xs := c.atoms.toList
  let r := Clause.toStringAux xs
  if c.atoms.size > 1 then s!"({r})"
  else r

namespace CNF

def true : CNF :=
HashSet.empty.insert $ Clause.mk HashMap.empty

def false : CNF :=
HashSet.empty

open List (mapM)
-- #print notation |>.

protected def toString (f : CNF) : String :=
if f.isEmpty
  then "true"
  else String.intercalate " ∧ " (f.toList.map Clause.toString)

instance : ToString CNF where
  toString := CNF.toString

def mkAnd' (f₀ f₁ : CNF) : CNF :=
  f₀.fold HashSet.insert f₁

def mkDefStmt (v : Nat) (f : CNF) : CNF :=
  let f₀ : CNF := f.fold (λ f c =>
    f.insert $ Clause.mk $ c.atoms.insert v Bool.false) {}
  let f₁ : CNF := f.fold (λ f c =>
    f.insert $ Clause.mk $ c.atoms.map not |>.insert v Bool.true) {}
  mkAnd' f₀ f₁

def mkDef (f : CNF) : SmtM Nat := do
  let s ← get;
  match s.defs.find? f with
  | some v => return v
  | none => do
    let v := s.vars.size + s.defs.size
    set { s with defs := s.defs.insert f v }
    return v

def mkAnd (f₀ f₁ : CNF) : SmtM CNF :=
  return mkAnd' f₀ f₁

def mkOr (f₀ f₁ : CNF) : SmtM CNF := do
  let d ← mkDef f₁
  return f₀.fold (λ ϕ c =>
    ϕ.insert $ Clause.mk $
      c.atoms.insert d Bool.true) {}

def mkNot (f₀ : CNF) : SmtM CNF :=
  let f₁ := f₀.toList.map Clause.negate
  f₁.foldlM mkOr false

def mkImplies (f₀ f₁ : CNF) : SmtM CNF := do
  mkOr (← mkNot f₀) f₁

def mkIff (f₀ f₁ : CNF) : SmtM CNF := do
  mkAnd (← mkImplies f₀ f₁) (← mkImplies f₁ f₀)

def mkVar (e : Expr) : SmtM CNF := do
  let s ← get;
  match s.vars.find? e with
  | some i => return (mkLit i)
  | none =>
    let i := s.vars.size + s.defs.size
    set { s with vars := s.vars.insert e i }
    return (mkLit i)

def internalize (e : Lean.Expr) : SmtM CNF := do
  let s ← get;
  match s.clauses.find? e with
  | some ϕ => return ϕ
  | none =>
    let f ←
      match e with
      | app (app f x _) y _ =>
        if f.isConstOf ``And
          then mkAnd (← internalize x) (← internalize y)
        else if f.isConstOf ``Or
          then mkOr (← internalize x) (← internalize y)
        else if f.isConstOf ``Iff
          then mkIff (← internalize x) (← internalize y)
        else mkVar e
      | app f x _ =>
        if f.isConstOf ``Not
          then mkNot (← internalize x)
          else mkVar e
      | forallE _ d b _ =>
        let td ← liftM $ Lean.Meta.inferType d
        let tb ← liftM $ Lean.Meta.inferType b
        if td.isProp && tb.isProp
          then mkImplies (← internalize d) (← internalize b)
          else mkVar e
      | _ => mkVar e
    modify $ λ s => { s with clauses := s.clauses.insert e f }
    return f

def runSmtM (m : SmtM α) : MetaM α :=
  StateT.run' m {}

def evalSmtM (m : SmtM CNF) : MetaM CNF := do
  let ⟨x, s⟩ ← StateT.run m {}
  return s.defs.fold (λ ϕ d v => mkAnd' ϕ (mkDefStmt v d)) x

-- def smt (e : CNF -> SmtM Unit) : MetaM Unit := do

open Lean Meta
open Lean Elab Elab.Tactic PrettyPrinter Meta

-- #check Meta.Context

-- structure Filtered (m : Type u → Type u) (ρ : Type u) (α : Type u) where
-- filtered ::
--   pred : α → m (ULift Bool)
--   collection : ρ

-- instance (m : Type u → Type u) (ρ : Type u) (α : Type u) [ForIn m ρ α] :
--     ForIn m (Filtered m ρ α) α where
--   forIn

def getPropAsms : TacticM (List LocalDecl) := do
  let lctx ← getLCtx
  lctx.fvarIdToDecl.foldlM (λ acc id decl => do
           let t ← inferType (← inferType (mkFVar id))
           if t.isProp ∧ ¬ decl.isAuxDecl
             then return decl :: acc
             else acc ) []

instance : Repr LocalDecl where
  reprPrec x _ :=
    let val :=
      match x.value? with
      | some e => s!" := {e}"
      | none => ""
    s!"({x.fvarId.name}) {x.userName} {x.isAuxDecl}" ++ val

def myTac : TacticM Unit := do
  let lctx ← getPropAsms
  let ⟨vs,g⟩ ← liftMetaM $ revert (← getMainGoal) (List.toArray $ lctx.map LocalDecl.fvarId)
  replaceMainGoal [g]
  let p ← getMainTarget
  let c ← evalSmtM (internalize p)
  IO.println p
  IO.println c
  -- let g ← getMainGoal
  -- IO.println g
  -- let r ← liftMetaM read
  -- let lctx ← getLCtx
  -- IO.println $ repr lctx.fvarIdToDecl.toList
  -- IO.println (← getMainTag)
  -- let d ← getMainDecl
  -- IO.println d.userName
  -- let lctx ← getPropAsms
  -- IO.println $ repr lctx
  -- for x in lctx do
  --   IO.println x.userName
  --   let t ← inferType $ mkFVar x.fvarId
  --   IO.println t
  --   let t ← inferType t
  --   IO.println t

elab "myTac" : tactic => do myTac

-- macro "myTac" : tactic => `(CNF.myTac)

end CNF

-- open Tactic

-- namespace Mathlib.Tactic.Ext

-- theorem foo (p q r : Prop) (h : r ∨ q) :
--   p ∧ q ∨ r :=
-- by { myTac }

theorem foo' (p q r : Prop) :
  p ∧ ¬ q ∨ q :=
by { myTac; admit }

-- #check 3


--
-- A basic freer monad. Based on various haskell libraries including freer-simple and
-- the paper "Freer Monads, More Extensible Effects" by Oleg Kiselyov and Hiromi Ishii
--

-- The Freer monad doesn't contain actual executable code, but instead
-- stores either a result value (Pure) or an effect plus continuation (Impure).
--

-- The basic Effect type holds a type of the possible operations/commands (usually a sum type)
-- and the appropriate return type(s) for each possible operation.
structure Effect : Type 2 where
   (op : Type 1)
   (ret : op → Type)

namespace Effect

-- The "Open Union" contains one operation from a list of possible effects,
-- determined at run time. This means we have to peel off .Node constructors, similar
-- to walking a list data type.
inductive OU : List Effect → Type → Type 2 where
    | Leaf {eff : Effect} {effs : List Effect} : (c : eff.op) → OU (eff :: effs) (eff.ret c)
    | Node {eff : Effect} {effs : List Effect} : OU effs x → OU (eff :: effs) x

-- This is similar to Haseffect.project below, but instead of returning an (Option e.op) it
-- returns either an e.op or an OU with the relevant effect removed. Used when
-- running the handler for a specific effect.
def decompOU {e : Effect} {effs : List Effect} (ou : OU (e :: effs) x) : Sum (OU effs x) (e.op) :=
    match ou with
    | .Leaf x => Sum.inr x
    | .Node ou' => Sum.inl ou'

class HasEffect (e : Effect) (effs : List Effect) where
    inject : (c : e.op) → OU effs (e.ret c)
    project : OU effs a → Option e.op

instance : HasEffect e (e :: effs) where
    inject := fun c => @OU.Leaf e effs c
    project := fun ou => match ou with
                         | .Leaf c => Option.some c
                         | .Node ou' => Option.none

instance [HasEffect e effs] : HasEffect e (z :: effs) where
    inject := fun x => OU.Node (@HasEffect.inject e effs _ x)
    project := fun ou => match ou with
                         | .Leaf c => Option.none
                         | .Node ou' => HasEffect.project ou'

end Effect

inductive Freer (effs : List Effect) : Type → Type 2 where
    | Pure : a → Freer effs a
    | Impure : {x : Type} → Effect.OU effs x → (x → Freer effs a) → Freer effs a

namespace Freer

open Effect

-- lift into Freer
def send {e : Effect} {effs : List Effect} [HasEffect e effs] (sendop : e.op) : Freer effs (e.ret sendop) :=
    @Freer.Impure effs (e.ret sendop) _ (HasEffect.inject sendop) .Pure

-- Sometimes you have a monad with some effects but you need to pass it into a function
-- with additional effects (see the Catch/Throw higher-order effect for instance).
def weaken {g : Effect} {effs : List Effect} : Freer effs a → Freer (g :: effs) a
    | .Pure a => .Pure a
    | .Impure ou next => .Impure (OU.Node ou) (fun x => weaken (next x))

def FreerAlg (effs : List Effect) (a : Type) := {x : Type} → (OU effs x) → (x → a) → a

-- FreerAlg for a Type 1 result. We avoid "Type u" declarations since it complicates
-- a lot of the type inference.
def FreerAlg1 (effs : List Effect) (a : Type 1) := {x : Type} → (OU effs x) → (x → a) → a
def FreerAlg2 (effs : List Effect) (a : Type 2) := {x : Type} → (OU effs x) → (x → a) → a

def freerCata {a : Type} (alg : FreerAlg effs a) (w : Freer effs a) : a :=
    match w with
    | .Pure a => a
    | .Impure gx next => alg gx (fun x => freerCata alg (next x))

def freerMap {a b : Type} (f : a → b) (w : Freer effs a) : Freer effs b :=
    match w with
    | .Pure a => .Pure (f a)
    | .Impure gx next => .Impure gx (fun x => freerMap f (next x))

instance : Functor (Freer effs) :=
    { map := freerMap }

-- foldOver is basically freerCata + freerMap
def foldOver {a : Type} {b : Type} {effs : List Effect} (pf : a → b) (alg : FreerAlg effs b) : Freer effs a → b
    | .Pure a => pf a
    | @Freer.Impure _ a _ gx next => alg gx (fun x => @foldOver a b effs pf alg (next x))

def foldOver1 {a : Type} {b : Type 1} {effs : List Effect} (pf : a → b) (alg : FreerAlg1 effs b) : Freer effs a → b
    | .Pure a => pf a
    | @Freer.Impure _ a _ gx next => alg gx (fun x => @foldOver1 a b effs pf alg (next x))

def foldOver2 {a : Type} {b : Type 2} {effs : List Effect} (pf : a → b) (alg : FreerAlg2 effs b) : Freer effs a → b
    | .Pure a => pf a
    | @Freer.Impure _ a _ gx next => alg gx (fun x => @foldOver2 a b effs pf alg (next x))

/-
-- alternate implementation of bind using a fold, similar to the "Hefty Algebras" paper
--
-/
def bindFreer {a b : Type} (m : Freer effs a) (f : a → Freer effs b) : Freer effs b :=
    --@foldOver a (Freer effs b) effs f .Impure m
    match m with
    | .Pure a => f a
    | .Impure gx next => Freer.Impure gx (fun z => bindFreer (next z) f)

def pureFreer {α : Type} (a : α) : Freer effs α := Freer.Pure a

-- Handler is the handler for a specific effect: ret is for Pure constructors
-- and handle is for impure constructors. The result has an 'inp' type so that the  monad can
-- take inputs (a state monad for example). You can make inp Unit for no input.
--  - a is the type returned from a Pure
--  - b is the monad result type. It may be that a=b but not always.
structure Handler (a : Type) (b : Type) (e : Effect) (effs : List Effect) (inp : Type) where
   (ret : a → inp → Freer effs b)
   (handle : FreerAlg2 (e :: effs) (inp → Freer effs b))

-- Interpret a Freer monad. You must provide an "interpreter" which takes commands of type c
-- and produces monads of the final type n.  This runs the interpreter on a command
-- in the Impure constructor and combines it with the next chunk of the Freer monad
-- by using a definition of bind for the final monad n.
def handleFreer {a b : Type} {e : Effect} {effs : List Effect} {inp : Type}
    (handler : Handler a b e effs inp) (m : Freer (e :: effs) a) : inp → Freer effs b :=
    match m with
    | .Pure a => handler.ret a
    | .Impure gx next => handler.handle gx (fun x => handleFreer handler (next x))

-- After handling all effects, you'll have a Freer [] a left over, use
-- runEff at the end to extract the result.
-- example : runEff <| h2 <| h1 m

def runEff : Freer [] a → a
    | .Pure x => x
    -- shouldn't ever have an Impure constructed
    --| .Impure ou next => match ou with | .Leaf c => Fin.elim0 (ULift.down c)

end Freer

instance : Monad (Freer effs) where
    pure := Freer.pureFreer
    bind := Freer.bindFreer

instance : Pure (Freer effs) where
    pure := Freer.pureFreer

instance : Bind (Freer effs) where
    bind := Freer.bindFreer