-- This was written by Tim (who?) in 2017, but the codebase has moved on and I haven't
-- been able to maintain it.
-- In any case, there was never a clear main statement, and I think I'd prefer to do this
-- much more explicitly by giving an equivalence to a strictly monoidal category.

-- import .monoidal_category
-- import .util.data.nonempty_list
-- import .util.data.bin_tree
-- import .util.data.bin_tree.cong_clos

-- import tidy.congr_struct

-- open categories
-- open categories.monoidal_category
-- open util.data.nonempty_list
-- open util.data.bin_tree'
-- open util.data.bin_tree'.bin_tree'

-- namespace categories.monoidal_category.coherence_thm

-- universes u v

-- variable {α : Type u}

-- inductive reassoc_dir_single_step : bin_tree' α → bin_tree' α → Type u
-- | rotate_right : Π r s t, reassoc_dir_single_step (branch (branch r s) t) (branch r (branch s t))

-- namespace reassoc_dir_single_step

-- lemma respects_to_list : Π (s t : bin_tree' α), reassoc_dir_single_step s t → s.to_list = t.to_list
-- | ._ ._ (rotate_right _ _ _) :=
--     begin
--       unfold bin_tree'.to_list,
--       rewrite nonempty_list.append_assoc
--     end

-- end reassoc_dir_single_step

-- @[reducible] def reassoc_dir_step : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos_step reassoc_dir_single_step

-- namespace reassoc_dir_step

-- lemma respects_lopsided {s t : bin_tree' α} (p : reassoc_dir_step s t) : s.lopsided = t.lopsided :=
--   cong_clos_step.respects_lopsided reassoc_dir_single_step.respects_to_list p

-- end reassoc_dir_step

-- @[reducible] def reassoc_dir : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos reassoc_dir_single_step

-- @[reducible] def reassoc_dir' : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos' reassoc_dir_single_step

-- namespace reassoc_dir

-- @[reducible] def refl (t : bin_tree' α) : reassoc_dir t t := cong_clos.refl _ t

-- def rotate_right (r s t : bin_tree' α) : reassoc_dir (branch (branch r s) t) (branch r (branch s t)) :=
--   cong_clos.lift (reassoc_dir_single_step.rotate_right _ _ _)

-- def lopsided_combine : Π (xs ys : nonempty_list α),
--     reassoc_dir (branch (from_list_lopsided xs) (from_list_lopsided ys)) (from_list_lopsided (xs ++ ys))
-- | (nonempty_list.singleton x) ys := refl _
-- | (nonempty_list.cons x xs)   ys :=
--   begin
--     simp, unfold from_list_lopsided,
--     apply cong_clos.trans,
--       apply rotate_right,
--       apply cong_clos.cong,
--         apply reassoc_dir.refl,
--         apply lopsided_combine
--   end

-- def reassoc_lopsided : Π (t : bin_tree' α), reassoc_dir t t.lopsided
-- | (leaf x)     := refl _
-- | (branch l r) :=
--   begin
--     apply cong_clos.trans,
--       apply cong_clos.cong,
--         apply reassoc_lopsided,
--         apply reassoc_lopsided,
--     apply lopsided_combine
--   end

-- lemma reassoc_already_lopsided :
--     Π (l : nonempty_list α),
--     reassoc_lopsided (bin_tree'.from_list_lopsided l) == refl (bin_tree'.from_list_lopsided l)
-- | (nonempty_list.singleton x) := by reflexivity
-- | (nonempty_list.cons x xs)   :=
--     calc
--           cong_clos.trans
--             (cong_clos.inject_right _ (reassoc_lopsided (from_list_lopsided xs)))
--             (refl (branch (leaf x) (from_list_lopsided (to_list (from_list_lopsided xs)))))
--         = cong_clos.inject_right (leaf x) (reassoc_lopsided (from_list_lopsided xs))
--         : by apply cong_clos.trans_refl_right
--     ... == cong_clos.inject_right (leaf x) (refl (from_list_lopsided xs))
--         : begin
--             congr_args,
--               unfold lopsided, rewrite from_list_lopsided_to_list,
--               apply reassoc_already_lopsided
--           end
--     ... == refl (branch (leaf x) (from_list_lopsided xs))
--         : by reflexivity

-- lemma respects_to_list {s t : bin_tree' α} (p : reassoc_dir s t) : s.to_list = t.to_list :=
--   cong_clos.respects_to_list reassoc_dir_single_step.respects_to_list p

-- lemma respects_lopsided {s t : bin_tree' α} (p : reassoc_dir s t) : s.lopsided = t.lopsided :=
--   cong_clos.respects_lopsided reassoc_dir_single_step.respects_to_list p

-- end reassoc_dir

-- inductive reassoc_single_step : bin_tree' α → bin_tree' α → Type u
-- | rotate_left  : Π r s t, reassoc_single_step (branch r (branch s t)) (branch (branch r s) t)
-- | rotate_right : Π r s t, reassoc_single_step (branch (branch r s) t) (branch r (branch s t))

-- @[reducible] def reassoc_step : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos_step reassoc_single_step

-- @[reducible] def reassoc : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos reassoc_single_step

-- namespace reassoc_single_step

-- def sym : Π (x y : bin_tree' α), reassoc_single_step x y → reassoc_single_step y x
-- | ._ ._ (rotate_left  _ _ _) := rotate_right _ _ _
-- | ._ ._ (rotate_right _ _ _) := rotate_left  _ _ _

-- lemma respects_to_list : Π (s t : bin_tree' α), reassoc_single_step s t → s.to_list = t.to_list
-- | ._ ._ (rotate_left _ _ _) :=
--     begin
--       unfold bin_tree'.to_list,
--       rewrite nonempty_list.append_assoc
--     end
-- | ._ ._ (rotate_right _ _ _) :=
--     begin
--       unfold bin_tree'.to_list,
--       rewrite nonempty_list.append_assoc
--     end

-- end reassoc_single_step

-- def reassoc_dir_to_reassoc_single_step : Π (s t : bin_tree' α), reassoc_dir_single_step s t → reassoc_single_step s t
-- | ._ ._ (reassoc_dir_single_step.rotate_right s t u) := reassoc_single_step.rotate_right s t u

-- def reassoc_dir_to_reassoc : Π {s t : bin_tree' α}, reassoc_dir s t → reassoc s t :=
--   λ s t p, cong_clos.transport reassoc_dir_to_reassoc_single_step p

-- namespace reassoc

-- @[reducible] def refl (t : bin_tree' α) : reassoc_dir t t := cong_clos.refl _ t

-- def sym : Π {x y : bin_tree' α}, reassoc x y → reassoc y x :=
--   λ x y, cong_clos.sym reassoc_single_step.sym

-- lemma respects_to_list : Π {s t : bin_tree' α}, reassoc s t → s.to_list = t.to_list :=
--   λ x y, cong_clos.respects_to_list reassoc_single_step.respects_to_list

-- def reassoc_lopsided : Π (t : bin_tree' α), reassoc t t.lopsided :=
--   λ t, reassoc_dir_to_reassoc (reassoc_dir.reassoc_lopsided t)

-- -- TODO: more economical construction (with fewer rotations)
-- def reassoc_tree : Π (r t : bin_tree' α) (h : r.to_list = t.to_list), reassoc r t :=
-- begin
--   intros,
--   apply cong_clos.trans,
--   apply reassoc_lopsided,
--   -- TODO: doing `rewrite h` here doesn't work ~> report bug
--   apply sym,
--   unfold lopsided, rewrite h,
--   apply reassoc_lopsided
-- end

-- end reassoc

-- section interpretation

-- parameter (C : Category.{u v})
-- parameter (M : MonoidalStructure C)

-- @[reducible] def tensor : C.Obj → C.Obj → C.Obj := λ X Y, M.tensor (X, Y)

-- local infixl `⟩C⟩`:60 := C.compose

-- local infix `⊗`:60 := tensor

-- -- this is better behaved wrt type inference than `M.tensor.onMorphisms` because no tuple has to be inferred
-- @[reducible] def tensor_homs : Π {W X Y Z : C.Obj}, C.Hom W X → C.Hom Y Z → C.Hom (W ⊗ Y) (X ⊗ Z) :=
--   λ W X Y Z f g, M.tensor.onMorphisms (f, g)

-- local infix `⟨⊗⟩`:60 := tensor_homs

-- open cong_clos

-- @[reducible] def tensor_tree : bin_tree' C.Obj → C.Obj
-- | (bin_tree'.leaf A)     := A
-- | (bin_tree'.branch l r) := tensor_tree l ⊗ tensor_tree r

-- def interpret_cong_clos'
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π {Xs Ys : bin_tree' C.Obj}, cong_clos' R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (cong_clos'.lift _ _ p)       := I _ _ p
-- | ._ ._ (cong_clos'.refl ._ t)        := C.identity _
-- | ._ ._ (cong_clos'.trans _ _ _ p q)  := C.compose (interpret_cong_clos' p) (interpret_cong_clos' q)
-- | ._ ._ (cong_clos'.cong _ _ _ _ l r) := M.tensor.onMorphisms (interpret_cong_clos' l, interpret_cong_clos' r)

-- -- the equation compiler somehow can't handle the next definitions ~> turn it off
-- -- TODO(tim): report bug
-- set_option eqn_compiler.lemmas false

-- -- TODO(tim): factor out I as a variable
-- def interpret_cong_clos_step
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π {Xs Ys : bin_tree' C.Obj}, cong_clos_step R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (cong_clos_step.lift x y p)      := I x y p
-- | ._ ._ (cong_clos_step.left l₁ l₂ r l)  := interpret_cong_clos_step l ⟨⊗⟩ C.identity (tensor_tree r)
-- | ._ ._ (cong_clos_step.right l r₁ r₂ r) := C.identity (tensor_tree l) ⟨⊗⟩ interpret_cong_clos_step r

-- set_option eqn_compiler.lemmas true

-- def interpret_cong_clos
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π {Xs Ys : bin_tree' C.Obj}, cong_clos R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (cong_clos.refl ._ t)      := C.identity _
-- | ._ ._ (cong_clos.step _ _ _ p q) := C.compose (interpret_cong_clos_step I p) (interpret_cong_clos q)

-- lemma interpret_cong_clos_functoriality
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π (Xs Ys Zs : bin_tree' C.Obj) (ps : cong_clos R Xs Ys) (qs : cong_clos R Ys Zs),
--       interpret_cong_clos I ps ⟩C⟩ interpret_cong_clos I qs = interpret_cong_clos I (cong_clos.trans ps qs)
-- | ._ ._ _ (cong_clos.refl ._ t)       qs := C.left_identity _
-- | ._ ._ _ (cong_clos.step _ _ _ p ps) qs :=
--     begin
--       unfold cong_clos.trans,
--       unfold interpret_cong_clos,
--       rewrite C.associativity,
--       rewrite interpret_cong_clos_functoriality
--     end

-- -- TODO(tim): move this somewhere else?
-- lemma functoriality_left
--     (X Y Z A : C.Obj)
--     (f : C.Hom X Y) (g : C.Hom Y Z)
--     : (f ⟩C⟩ g) ⟨⊗⟩ C.identity A = (f ⟨⊗⟩ C.identity A) ⟩C⟩ (g ⟨⊗⟩ C.identity A) := ♯

-- lemma interpret_cong_clos_inject_left
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π (Xs Ys Zs : bin_tree' C.Obj) (ps : cong_clos R Xs Ys),
--       interpret_cong_clos I (inject_left Zs ps) = interpret_cong_clos I ps ⟨⊗⟩ C.identity (tensor_tree Zs)
-- | ._ ._ _ (cong_clos.refl ._ _)       := by {symmetry, apply M.tensor.identities}
-- | ._ ._ _ (cong_clos.step _ _ _ p ps) :=
--   begin
--     unfold inject_left,
--     unfold interpret_cong_clos,
--     rewrite functoriality_left,
--     rewrite (interpret_cong_clos_inject_left _ _ _ ps),
--     reflexivity
--   end

-- -- TODO(tim): it would be cool if interpretation were a real functor from a suitable formal category

-- def interpret_reassoc_dir_single_step : Π (Xs Ys : bin_tree' C.Obj), reassoc_dir_single_step Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (reassoc_dir_single_step.rotate_right s t u) := M.associator _ _ _

-- def interpret_reassoc_dir {Xs Ys : bin_tree' C.Obj} : reassoc_dir Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos interpret_reassoc_dir_single_step

-- lemma interpret_reassoc_dir_functoriality
--     {Xs Ys Zs : bin_tree' C.Obj} (ps : reassoc_dir Xs Ys) (qs : reassoc_dir Ys Zs)
--     : interpret_reassoc_dir ps ⟩C⟩ interpret_reassoc_dir qs = interpret_reassoc_dir (cong_clos.trans ps qs)
--   := by apply interpret_cong_clos_functoriality

-- def interpret_reassoc_dir' {Xs Ys : bin_tree' C.Obj} : reassoc_dir' Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos' interpret_reassoc_dir_single_step

-- def interpret_reassoc_dir_step {Xs Ys : bin_tree' C.Obj} : reassoc_dir_step Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos_step interpret_reassoc_dir_single_step

-- def interpret_reassoc_single_step : Π (Xs Ys : bin_tree' C.Obj), reassoc_single_step Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (reassoc_single_step.rotate_right s t u) := M.associator _ _ _
-- | ._ ._ (reassoc_single_step.rotate_left  s t u) := M.inverse_associator _ _ _

-- def interpret_reassoc {Xs Ys : bin_tree' C.Obj} : reassoc Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos interpret_reassoc_single_step

-- @[reducible] def to_lopsided (t : bin_tree' C.Obj) : C.Hom (tensor_tree t) (tensor_tree t.lopsided) :=
--   interpret_reassoc_dir (reassoc_dir.reassoc_lopsided t)

-- -- TODO: generalize to cong_clos
-- def rewrite_source : Π {s₁ s₂ t : bin_tree' α} (eq : s₁ = s₂), reassoc_dir s₁ t → reassoc_dir s₂ t
-- | _ ._ _ (eq.refl ._) p := p

-- -- TODO: generalize to cong_clos
-- def rewrite_target : Π {s t₁ t₂ : bin_tree' α} (eq : t₁ = t₂), reassoc_dir s t₁ → reassoc_dir s t₂
-- | _ ._ _ (eq.refl ._) p := p

-- -- TODO: generalize to cong_clos
-- def rewrite_target_cong : Π {s t₁ t₂ : bin_tree' α} (eq : t₁ = t₂) (p : reassoc_dir s t₁), rewrite_target eq p == p
-- | _ _ ._ (eq.refl ._) p := heq.refl _

-- @[reducible] def trans_lopsided' {s t : bin_tree' α} (p : reassoc_dir s t) : reassoc_dir s t.lopsided :=
--   cong_clos.trans p (reassoc_dir.reassoc_lopsided t)

-- -- all roads lead to rome
-- def trans_lopsided {s t : bin_tree' α} (p : reassoc_dir s t) : reassoc_dir s s.lopsided :=
--   rewrite_target (eq.symm (reassoc_dir.respects_lopsided p)) (trans_lopsided' p)

-- lemma trans_lopsided_heq {s t : bin_tree' α} (p : reassoc_dir s t) : trans_lopsided p == trans_lopsided' p :=
--   by apply rewrite_target_cong

-- lemma trans_lopsided_already_lopsided {s : bin_tree' α} (p : reassoc_dir s s.lopsided) : trans_lopsided p == p :=
--   calc
--          rewrite_target (eq.symm (reassoc_dir.respects_lopsided p)) (cong_clos.trans p (reassoc_dir.reassoc_lopsided s.lopsided))
--       == cong_clos.trans p (reassoc_dir.reassoc_lopsided s.lopsided)
--       : by apply rewrite_target_cong
--   ... == cong_clos.trans p (reassoc_dir.refl s.lopsided)
--       : begin
--           congr_args, rewrite lopsided_idempotent, apply reassoc_dir.reassoc_already_lopsided
--         end
--   ... = p
--       : by apply trans_refl_right

-- @[reducible] def step_lopsided' {s t : bin_tree' α} (p : reassoc_dir_step s t) : reassoc_dir s t.lopsided :=
--   cong_clos.step _ _ _ p (reassoc_dir.reassoc_lopsided t)

-- def step_lopsided {s t : bin_tree' α} (p : reassoc_dir_step s t) : reassoc_dir s s.lopsided :=
--   rewrite_target (eq.symm (reassoc_dir_step.respects_lopsided p)) (step_lopsided' p)

-- lemma step_lopsided_heq {s t : bin_tree' α} (p : reassoc_dir_step s t) : step_lopsided p == step_lopsided' p :=
--   by apply rewrite_target_cong

-- -- -- TODO(tim): use well-founded induction once lean supports it
-- -- -- TODO(tim): why does lean complain that there are missing cases???
-- -- meta lemma directed_associator_coherence_thm :
-- --     Π (Xs Ys : bin_tree' C.Obj) (e : Ys = Xs.lopsided)
-- --       (p q : reassoc_dir Xs Ys),
-- --       interpret_reassoc_dir p = interpret_reassoc_dir q
-- -- | (branch l r) ._ (eq.refl ._) (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lp ._ p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lq ._ q) qs) :=
-- --     have H : Π (l' : bin_tree' C.Obj) (f : reassoc_dir_step l l') (fs : reassoc_dir (branch l' r) (branch l r).lopsided),
-- --                interpret_reassoc_dir (step (branch l r) _ _ (cong_clos_step.left _ _ r f) fs) ==
-- --                (to_lopsided l ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ to_lopsided (branch l.lopsided r), from
-- --         λ l' f fs,
-- --         have e₀ : lopsided l = lopsided l', from
-- --           by {apply reassoc_dir_step.respects_lopsided, assumption},
-- --         have e₁ : lopsided (branch l r) = lopsided (branch l' r), from
-- --           by {apply reassoc_dir_step.respects_lopsided, apply cong_clos_step.left, assumption},
-- --         have e₂ : lopsided (branch l' r) = lopsided (branch (lopsided l') r), from
-- --           by {unfold lopsided, congr_args, unfold to_list, rewrite from_list_lopsided_to_list},
-- --         have e₃ : interpret_reassoc_dir fs == (interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r)), from
-- --             calc
-- --                   interpret_reassoc_dir fs
-- --                 == interpret_reassoc_dir (rewrite_target e₁ fs)
-- --                 :  by {congr_args, assumption, symmetry, apply rewrite_target_cong}
-- --             ... =  interpret_reassoc_dir (trans_lopsided (cong_clos.inject_left r (reassoc_dir.reassoc_lopsided l')))
-- --                 :  by apply directed_associator_coherence_thm (branch l' r) (branch l' r).lopsided (eq.refl _)
-- --             ... == interpret_reassoc_dir (trans_lopsided' (cong_clos.inject_left r (reassoc_dir.reassoc_lopsided l')))
-- --                 :  by {congr_args, assumption, apply trans_lopsided_heq}
-- --             ... =  interpret_reassoc_dir (cong_clos.inject_left r (reassoc_dir.reassoc_lopsided l')) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --                 :  by {symmetry, apply interpret_reassoc_dir_functoriality}
-- --             ... =  (interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --                 :  by {congr_args, apply interpret_cong_clos_inject_left},
-- --         calc
-- --                 (interpret_reassoc_dir_step f ⟨⊗⟩ C.identity _) ⟩C⟩ interpret_reassoc_dir fs
-- --             == (interpret_reassoc_dir_step f ⟨⊗⟩ C.identity _) ⟩C⟩ ((interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r)))
-- --             :  by {congr_args, cc, assumption}
-- --         ... == ((interpret_reassoc_dir_step f ⟨⊗⟩ C.identity _) ⟩C⟩ (interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r))) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --             :  ♮
-- --         ... == ((interpret_reassoc_dir_step f ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l')) ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --             :  by rewrite functoriality_left
-- --         ... == (interpret_reassoc_dir (cong_clos.step _ _ _ f (reassoc_dir.reassoc_lopsided l')) ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --             :  by reflexivity
-- --         ... == (interpret_reassoc_dir (step_lopsided f) ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l.lopsided r))
-- --             :  begin
-- --                  congr_args,
-- --                   {cc},
-- --                   {cc},
-- --                   {congr_args, cc, congr_args, cc, symmetry, apply step_lopsided_heq},
-- --                   {cc}
-- --                end
-- --         ... = (to_lopsided l ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ to_lopsided (branch l.lopsided r)
-- --             :  by {congr_args, congr_args, apply directed_associator_coherence_thm l l.lopsided (eq.refl _)},
-- --     eq_of_heq $
-- --     calc
-- --            interpret_reassoc_dir (step (branch l r) _ _ (cong_clos_step.left _ _ r p) ps)
-- --         == (to_lopsided l ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ to_lopsided (branch l.lopsided r)
-- --         :  by apply H
-- --     ... == interpret_reassoc_dir (step (branch l r) _ _ (cong_clos_step.left _ _ r q) qs)
-- --         :  by {symmetry, apply H}
-- -- | (branch l r) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rp p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rq q) qs) := sorry
-- -- | (branch l r) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lp ._ p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rq q) qs) := sorry
-- -- | (branch l r) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rp p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lq ._ q) qs) := sorry
-- -- | (branch (branch x y) z) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.lift ._ ._ (reassoc_dir_single_step.rotate_right ._ ._ ._)) _) (cong_clos.step ._ _ ._ _ _) := sorry
-- -- | (branch (branch x y) z) Ys e (cong_clos.step ._ _ ._ _ _) (cong_clos.step ._ ._ ._ (cong_clos_step.lift ._ ._ (reassoc_dir_single_step.rotate_right ._ ._ ._)) _) := sorry
-- -- | Xs ._ e (cong_clos.refl ._ ._) (cong_clos.step ._ t' ._ q _) := sorry
-- -- | Xs ._ e (cong_clos.step ._ t' ._ p _) (cong_clos.refl ._ ._) := sorry
-- -- | Xs ._ e (cong_clos.refl ._ ._) (cong_clos.refl ._ ._) := sorry

-- end interpretation

-- end categories.monoidal_category.coherence_thm


import rowround

import category_theory.category.basic
import category_theory.core

open params
open operations
open quarterround
open rowround
open utils

open category_theory

namespace columnround

variables [category (bitvec word_len)]

/-!
  # Columnround

  The `columnround` function and the relation with its inverse.
-/

/-!
  ## Definitions and lemmas
-/

/--  Without ordering for inputs, a `columnround` is exactly the same as a `rowround`. -/
@[simp] def columnround (M : matrixType) : matrixType := rowround M

/--  Without ordering for inputs, a `columnround_inv` is exactly the same as a `rowround_inv`. -/
@[simp] def columnround_inv (M : matrixType) : matrixType := rowround_inv M

/- Just some notation for inverses. -/
local notation `columnround⁻¹` := columnround_inv

/-- The `columnround` function is invertible. -/
lemma columnround_is_inv (I : columnround ≅ columnround⁻¹) : I.hom ≫ I.inv = 𝟙 columnround :=
  by rw [iso.hom_inv_id]

/-- This columnround call will sort all the elements of the input and the output to match salsa20.
-- It should be used in `doubleround`.-/
@[simp] def columnround_salsa20 (M : matrixType) := columnround_output (columnround (columnround_input M))

/-- This columnround inverse call will sort all the elements of the input and the output to match salsa20.
It should be used in `doubleround`. -/
@[simp] def columnround_salsa20_inv (M : matrixType) := columnround_output (columnround⁻¹ (columnround_input M))

/- Just some notation for inverses. -/
local notation `columnround_salsa20⁻¹` := columnround_salsa20_inv

/-- The `columnround` function is invertible. -/
lemma columnround_salsa20_is_inv (I : columnround_salsa20 ≅ columnround_salsa20⁻¹) :
  I.hom ≫ I.inv = 𝟙 columnround_salsa20 := by rw [iso.hom_inv_id]

end columnround


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin
-/
import category_theory.adjunction.basic
import category_theory.limits.creates

open opposite

namespace category_theory.adjunction
open category_theory
open category_theory.functor
open category_theory.limits

universes u₁ u₂ v

variables {C : Type u₁} [category.{v} C] {D : Type u₂} [category.{v} D]

variables {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
include adj

section preservation_colimits
variables {J : Type v} [small_category J] (K : J ⥤ C)

/--
The right adjoint of `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
def functoriality_right_adjoint : cocone (K ⋙ F) ⥤ cocone K :=
(cocones.functoriality _ G) ⋙
  (cocones.precompose (K.right_unitor.inv ≫ (whisker_left K adj.unit) ≫ (associator _ _ _).inv))

local attribute [reducible] functoriality_right_adjoint

/--
The unit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
@[simps] def functoriality_unit :
  𝟭 (cocone K) ⟶ cocones.functoriality _ F ⋙ functoriality_right_adjoint adj K :=
{ app := λ c, { hom := adj.unit.app c.X } }

/--
The counit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
@[simps] def functoriality_counit :
  functoriality_right_adjoint adj K ⋙ cocones.functoriality _ F ⟶ 𝟭 (cocone (K ⋙ F)) :=
{ app := λ c, { hom := adj.counit.app c.X } }

/-- The functor `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)` is a left adjoint. -/
def functoriality_is_left_adjoint :
  is_left_adjoint (cocones.functoriality K F) :=
{ right := functoriality_right_adjoint adj K,
  adj := mk_of_unit_counit
  { unit := functoriality_unit adj K,
    counit := functoriality_counit adj K } }

/--
A left adjoint preserves colimits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def left_adjoint_preserves_colimits : preserves_colimits F :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI
    { preserves := λ c hc, is_colimit.iso_unique_cocone_morphism.inv
        (λ s, @equiv.unique _ _ (is_colimit.iso_unique_cocone_morphism.hom hc _)
          (((adj.functoriality_is_left_adjoint _).adj).hom_equiv _ _)) } } }.

omit adj

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_preserves_colimits (E : C ⥤ D) [is_equivalence E] : preserves_colimits E :=
left_adjoint_preserves_colimits E.adjunction

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_reflects_colimits (E : D ⥤ C) [is_equivalence E] : reflects_colimits E :=
{ reflects_colimits_of_shape := λ J 𝒥, by exactI
  { reflects_colimit := λ K,
    { reflects := λ c t,
      begin
        have l := (is_colimit_of_preserves E.inv t).map_cocone_equiv E.as_equivalence.unit_iso.symm,
        refine (((is_colimit.precompose_inv_equiv K.right_unitor _).symm) l).of_iso_colimit _,
        tidy,
      end } } }

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_creates_colimits (H : D ⥤ C) [is_equivalence H] : creates_colimits H :=
{ creates_colimits_of_shape := λ J 𝒥, by exactI
  { creates_colimit := λ F,
    { lifts := λ c t,
      { lifted_cocone := H.map_cocone_inv c,
        valid_lift := H.map_cocone_map_cocone_inv c } } } }

-- verify the preserve_colimits instance works as expected:
example (E : C ⥤ D) [is_equivalence E]
  (c : cocone K) (h : is_colimit c) : is_colimit (E.map_cocone c) :=
preserves_colimit.preserves h

instance has_colimit_comp_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimit K] :
  has_colimit (K ⋙ E) :=
has_colimit.mk
{ cocone := E.map_cocone (colimit.cocone K),
  is_colimit := preserves_colimit.preserves (colimit.is_colimit K) }

lemma has_colimit_of_comp_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimit (K ⋙ E)] :
  has_colimit K :=
@has_colimit_of_iso _ _ _ _ (K ⋙ E ⋙ inv E) K
(@adjunction.has_colimit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) (inv E) _ _)
((functor.right_unitor _).symm ≪≫ iso_whisker_left K (E.as_equivalence.unit_iso))

/-- Transport a `has_colimits_of_shape` instance across an equivalence. -/
lemma has_colimits_of_shape_of_equivalence (E : C ⥤ D) [is_equivalence E]
  [has_colimits_of_shape J D] : has_colimits_of_shape J C :=
⟨λ F, by exactI has_colimit_of_comp_equivalence F E⟩

/-- Transport a `has_colimits` instance across an equivalence. -/
lemma has_colimits_of_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimits D] :
  has_colimits C :=
⟨λ J hJ, by exactI has_colimits_of_shape_of_equivalence E⟩

end preservation_colimits

section preservation_limits
variables {J : Type v} [small_category J] (K : J ⥤ D)

/--
The left adjoint of `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
def functoriality_left_adjoint : cone (K ⋙ G) ⥤ cone K :=
(cones.functoriality _ F) ⋙ (cones.postcompose
    ((associator _ _ _).hom ≫ (whisker_left K adj.counit) ≫ K.right_unitor.hom))

local attribute [reducible] functoriality_left_adjoint

/--
The unit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simps] def functoriality_unit' :
  𝟭 (cone (K ⋙ G)) ⟶ functoriality_left_adjoint adj K ⋙ cones.functoriality _ G :=
{ app := λ c, { hom := adj.unit.app c.X, } }

/--
The counit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simps] def functoriality_counit' :
  cones.functoriality _ G ⋙ functoriality_left_adjoint adj K ⟶ 𝟭 (cone K) :=
{ app := λ c, { hom := adj.counit.app c.X, } }

/-- The functor `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)` is a right adjoint. -/
def functoriality_is_right_adjoint :
  is_right_adjoint (cones.functoriality K G) :=
{ left := functoriality_left_adjoint adj K,
  adj := mk_of_unit_counit
  { unit := functoriality_unit' adj K,
    counit := functoriality_counit' adj K } }

/--
A right adjoint preserves limits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def right_adjoint_preserves_limits : preserves_limits G :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ K,
    by exactI
    { preserves := λ c hc, is_limit.iso_unique_cone_morphism.inv
        (λ s, @equiv.unique _ _ (is_limit.iso_unique_cone_morphism.hom hc _)
          (((adj.functoriality_is_right_adjoint _).adj).hom_equiv _ _).symm) } } }.

omit adj

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_preserves_limits (E : D ⥤ C) [is_equivalence E] : preserves_limits E :=
right_adjoint_preserves_limits E.inv.adjunction

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_reflects_limits (E : D ⥤ C) [is_equivalence E] : reflects_limits E :=
{ reflects_limits_of_shape := λ J 𝒥, by exactI
  { reflects_limit := λ K,
    { reflects := λ c t,
      begin
        have := (is_limit_of_preserves E.inv t).map_cone_equiv E.as_equivalence.unit_iso.symm,
        refine (((is_limit.postcompose_hom_equiv K.left_unitor _).symm) this).of_iso_limit _,
        tidy,
      end } } }

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_creates_limits (H : D ⥤ C) [is_equivalence H] : creates_limits H :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ F,
    { lifts := λ c t,
      { lifted_cone := H.map_cone_inv c,
        valid_lift := H.map_cone_map_cone_inv c } } } }

-- verify the preserve_limits instance works as expected:
example (E : D ⥤ C) [is_equivalence E]
  (c : cone K) [h : is_limit c] : is_limit (E.map_cone c) :=
preserves_limit.preserves h

instance has_limit_comp_equivalence (E : D ⥤ C) [is_equivalence E] [has_limit K] :
  has_limit (K ⋙ E) :=
has_limit.mk
{ cone := E.map_cone (limit.cone K),
  is_limit := preserves_limit.preserves (limit.is_limit K) }

lemma has_limit_of_comp_equivalence (E : D ⥤ C) [is_equivalence E] [has_limit (K ⋙ E)] :
  has_limit K :=
@has_limit_of_iso _ _ _ _ (K ⋙ E ⋙ inv E) K
(@adjunction.has_limit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) (inv E) _ _)
((iso_whisker_left K E.as_equivalence.unit_iso.symm) ≪≫ (functor.right_unitor _))

/-- Transport a `has_limits_of_shape` instance across an equivalence. -/
lemma has_limits_of_shape_of_equivalence (E : D ⥤ C) [is_equivalence E] [has_limits_of_shape J C] :
  has_limits_of_shape J D :=
⟨λ F, by exactI has_limit_of_comp_equivalence F E⟩

/-- Transport a `has_limits` instance across an equivalence. -/
lemma has_limits_of_equivalence (E : D ⥤ C) [is_equivalence E] [has_limits C] : has_limits D :=
⟨λ J hJ, by exactI has_limits_of_shape_of_equivalence E⟩

end preservation_limits

/-- auxiliary construction for `cocones_iso` -/
@[simps]
def cocones_iso_component_hom {J : Type v} [small_category J] {K : J ⥤ C}
  (Y : D) (t : ((cocones J D).obj (op (K ⋙ F))).obj Y) :
  (G ⋙ (cocones J C).obj (op K)).obj Y :=
{ app := λ j, (adj.hom_equiv (K.obj j) Y) (t.app j),
  naturality' := λ j j' f, by { erw [← adj.hom_equiv_naturality_left, t.naturality], dsimp, simp } }

/-- auxiliary construction for `cocones_iso` -/
@[simps]
def cocones_iso_component_inv {J : Type v} [small_category J] {K : J ⥤ C}
  (Y : D) (t : (G ⋙ (cocones J C).obj (op K)).obj Y) :
  ((cocones J D).obj (op (K ⋙ F))).obj Y :=
{ app := λ j, (adj.hom_equiv (K.obj j) Y).symm (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_left_symm, ← adj.hom_equiv_naturality_right_symm, t.naturality],
    dsimp, simp
  end }

/--
When `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/
-- Note: this is natural in K, but we do not yet have the tools to formulate that.
def cocones_iso {J : Type v} [small_category J] {K : J ⥤ C} :
  (cocones J D).obj (op (K ⋙ F)) ≅ G ⋙ ((cocones J C).obj (op K)) :=
nat_iso.of_components (λ Y,
{ hom := cocones_iso_component_hom adj Y,
  inv := cocones_iso_component_inv adj Y, })
(by tidy)

/-- auxiliary construction for `cones_iso` -/
@[simps]
def cones_iso_component_hom {J : Type v} [small_category J] {K : J ⥤ D}
  (X : Cᵒᵖ) (t : (functor.op F ⋙ (cones J D).obj K).obj X) :
  ((cones J C).obj (K ⋙ G)).obj X :=
{ app := λ j, (adj.hom_equiv (unop X) (K.obj j)) (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_right, ← t.naturality, category.id_comp, category.id_comp],
    refl
  end }

/-- auxiliary construction for `cones_iso` -/
@[simps]
def cones_iso_component_inv {J : Type v} [small_category J] {K : J ⥤ D}
  (X : Cᵒᵖ) (t : ((cones J C).obj (K ⋙ G)).obj X) :
  (functor.op F ⋙ (cones J D).obj K).obj X :=
{ app := λ j, (adj.hom_equiv (unop X) (K.obj j)).symm (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_right_symm, ← t.naturality, category.id_comp, category.id_comp]
  end }

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
/--
When `F ⊣ G`,
the functor associating to each `X` the cones over `K` with cone point `F.op.obj X`
is naturally isomorphic to
the functor associating to each `X` the cones over `K ⋙ G` with cone point `X`.
-/
def cones_iso {J : Type v} [small_category J] {K : J ⥤ D} :
  F.op ⋙ ((cones J D).obj K) ≅ (cones J C).obj (K ⋙ G) :=
nat_iso.of_components (λ X,
{ hom := cones_iso_component_hom adj X,
  inv := cones_iso_component_inv adj X, } )
(by tidy)

end category_theory.adjunction


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.tactic.lint.default
import Mathlib.PostPort

universes u v u_1 u_2 u_3 w

namespace Mathlib

/-!
# Functors

This module provides additional lemmas, definitions, and instances for `functor`s.

## Main definitions

* `const α` is the functor that sends all types to `α`.
* `add_const α` is `const α` but for when `α` has an additive structure.
* `comp F G` for functors `F` and `G` is the functor composition of `F` and `G`.
* `liftp` and `liftr` respectively lift predicates and relations on a type `α`
  to `F α`.  Terms of `F α` are considered to, in some sense, contain values of type `α`.

## Tags

functor, applicative
-/

theorem functor.map_id {F : Type u → Type v} {α : Type u} [Functor F] [is_lawful_functor F] : Functor.map id = id :=
  funext id_map

theorem functor.map_comp_map {F : Type u → Type v} {α : Type u} {β : Type u} {γ : Type u} [Functor F] [is_lawful_functor F] (f : α → β) (g : β → γ) : Functor.map g ∘ Functor.map f = Functor.map (g ∘ f) := sorry

theorem functor.ext {F : Type u_1 → Type u_2} {F1 : Functor F} {F2 : Functor F} [is_lawful_functor F] [is_lawful_functor F] (H : ∀ (α β : Type u_1) (f : α → β) (x : F α), f <$> x = f <$> x) : F1 = F2 := sorry

/-- Introduce the `id` functor. Incidentally, this is `pure` for
`id` as a `monad` and as an `applicative` functor. -/
def id.mk {α : Sort u} : α → id α :=
  id

namespace functor

/-- `const α` is the constant functor, mapping every type to `α`. When
`α` has a monoid structure, `const α` has an `applicative` instance.
(If `α` has an additive monoid structure, see `functor.add_const`.) -/
def const (α : Type u_1) (β : Type u_2) :=
  α

/-- `const.mk` is the canonical map `α → const α β` (the identity), and
it can be used as a pattern to extract this value. -/
def const.mk {α : Type u_1} {β : Type u_2} (x : α) : const α β :=
  x

/-- `const.mk'` is `const.mk` but specialized to map `α` to
`const α punit`, where `punit` is the terminal object in `Type*`. -/
def const.mk' {α : Type u_1} (x : α) : const α PUnit :=
  x

/-- Extract the element of `α` from the `const` functor. -/
def const.run {α : Type u_1} {β : Type u_2} (x : const α β) : α :=
  x

namespace const

protected theorem ext {α : Type u_1} {β : Type u_2} {x : const α β} {y : const α β} (h : run x = run y) : x = y :=
  h

/-- The map operation of the `const γ` functor. -/
protected def map {γ : Type u_1} {α : Type u_2} {β : Type u_3} (f : α → β) (x : const γ β) : const γ α :=
  x

protected instance functor {γ : Type u_1} : Functor (const γ) :=
  { map := const.map, mapConst := fun (α β : Type u_2) => const.map ∘ function.const β }

protected instance is_lawful_functor {γ : Type u_1} : is_lawful_functor (const γ) :=
  is_lawful_functor.mk (fun (α : Type u_2) (x : const γ α) => Eq.refl (id <$> x))
    fun (α β γ_1 : Type u_2) (g : α → β) (h : β → γ_1) (x : const γ α) => Eq.refl ((h ∘ g) <$> x)

protected instance inhabited {α : Type u_1} {β : Type u_2} [Inhabited α] : Inhabited (const α β) :=
  { default := Inhabited.default }

end const

/-- `add_const α` is a synonym for constant functor `const α`, mapping
every type to `α`. When `α` has a additive monoid structure,
`add_const α` has an `applicative` instance. (If `α` has a
multiplicative monoid structure, see `functor.const`.) -/
def add_const (α : Type u_1) (β : Type u_2) :=
  const α

/-- `add_const.mk` is the canonical map `α → add_const α β`, which is the identity,
where `add_const α β = const α β`. It can be used as a pattern to extract this value. -/
def add_const.mk {α : Type u_1} {β : Type u_2} (x : α) : add_const α β :=
  x

/-- Extract the element of `α` from the constant functor. -/
def add_const.run {α : Type u_1} {β : Type u_2} : add_const α β → α :=
  id

protected instance add_const.functor {γ : Type u_1} : Functor (add_const γ) :=
  const.functor

protected instance add_const.is_lawful_functor {γ : Type u_1} : is_lawful_functor (add_const γ) :=
  const.is_lawful_functor

protected instance add_const.inhabited {α : Type u_1} {β : Type u_2} [Inhabited α] : Inhabited (add_const α β) :=
  { default := Inhabited.default }

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) :=
  F (G α)

/-- Construct a term of `comp F G α` from a term of `F (G α)`, which is the same type.
Can be used as a pattern to extract a term of `F (G α)`. -/
def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : F (G α)) : comp F G α :=
  x

/-- Extract a term of `F (G α)` from a term of `comp F G α`, which is the same type. -/
def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : comp F G α) : F (G α) :=
  x

namespace comp

protected theorem ext {F : Type u → Type w} {G : Type v → Type u} {α : Type v} {x : comp F G α} {y : comp F G α} : run x = run y → x = y :=
  id

protected instance inhabited {F : Type u → Type w} {G : Type v → Type u} {α : Type v} [Inhabited (F (G α))] : Inhabited (comp F G α) :=
  { default := Inhabited.default }

/-- The map operation for the composition `comp F G` of functors `F` and `G`. -/
protected def map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v} {β : Type v} (h : α → β) : comp F G α → comp F G β :=
  sorry

protected instance functor {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] : Functor (comp F G) :=
  { map := comp.map, mapConst := fun (α β : Type v) => comp.map ∘ function.const β }

theorem map_mk {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v} {β : Type v} (h : α → β) (x : F (G α)) : h <$> mk x = mk (Functor.map h <$> x) :=
  rfl

@[simp] protected theorem run_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v} {β : Type v} (h : α → β) (x : comp F G α) : run (h <$> x) = Functor.map h <$> run x :=
  rfl

protected theorem id_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] [is_lawful_functor F] [is_lawful_functor G] {α : Type v} (x : comp F G α) : comp.map id x = x := sorry

protected theorem comp_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] [is_lawful_functor F] [is_lawful_functor G] {α : Type v} {β : Type v} {γ : Type v} (g' : α → β) (h : β → γ) (x : comp F G α) : comp.map (h ∘ g') x = comp.map h (comp.map g' x) := sorry

protected instance is_lawful_functor {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] [is_lawful_functor F] [is_lawful_functor G] : is_lawful_functor (comp F G) :=
  is_lawful_functor.mk comp.id_map comp.comp_map

theorem functor_comp_id {F : Type u_1 → Type u_2} [AF : Functor F] [is_lawful_functor F] : comp.functor = AF :=
  ext fun (α β : Type u_1) (f : α → β) (x : F α) => rfl

theorem functor_id_comp {F : Type u_1 → Type u_2} [AF : Functor F] [is_lawful_functor F] : comp.functor = AF :=
  ext fun (α β : Type u_1) (f : α → β) (x : F α) => rfl

end comp

namespace comp

/-- The `<*>` operation for the composition of applicative functors. -/
protected def seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] {α : Type v} {β : Type v} : comp F G (α → β) → comp F G α → comp F G β :=
  sorry

protected instance has_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] : Pure (comp F G) :=
  { pure := fun (_x : Type v) (x : _x) => mk (pure (pure x)) }

protected instance has_seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] : Seq (comp F G) :=
  { seq := fun (_x _x_1 : Type v) (f : comp F G (_x → _x_1)) (x : comp F G _x) => comp.seq f x }

@[simp] protected theorem run_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] {α : Type v} (x : α) : run (pure x) = pure (pure x) :=
  idRhs (run (pure x) = run (pure x)) rfl

@[simp] protected theorem run_seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] {α : Type v} {β : Type v} (f : comp F G (α → β)) (x : comp F G α) : run (f <*> x) = Seq.seq <$> run f <*> run x :=
  rfl

protected instance applicative {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] : Applicative (comp F G) :=
  { toFunctor := { map := comp.map, mapConst := fun (α β : Type v) => comp.map ∘ function.const β },
    toPure := { pure := pure }, toSeq := { seq := comp.seq },
    toSeqLeft :=
      { seqLeft := fun (α β : Type v) (a : comp F G α) (b : comp F G β) => comp.seq (comp.map (function.const β) a) b },
    toSeqRight :=
      { seqRight :=
          fun (α β : Type v) (a : comp F G α) (b : comp F G β) => comp.seq (comp.map (function.const α id) a) b } }

end comp

/-- If we consider `x : F α` to, in some sense, contain values of type `α`,
predicate `liftp p x` holds iff every value contained by `x` satisfies `p`. -/
def liftp {F : Type u → Type u} [Functor F] {α : Type u} (p : α → Prop) (x : F α) :=
  ∃ (u : F (Subtype p)), subtype.val <$> u = x

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`liftr r x y` relates `x` and `y` iff (1) `x` and `y` have the same shape and
(2) we can pair values `a` from `x` and `b` from `y` so that `r a b` holds. -/
def liftr {F : Type u → Type u} [Functor F] {α : Type u} (r : α → α → Prop) (x : F α) (y : F α) :=
  ∃ (u : F (Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p))),
    (fun (t : Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p)) => prod.fst (subtype.val t)) <$> u = x ∧
      (fun (t : Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p)) => prod.snd (subtype.val t)) <$> u = y

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`supp x` is the set of values of type `α` that `x` contains. -/
def supp {F : Type u → Type u} [Functor F] {α : Type u} (x : F α) : set α :=
  set_of fun (y : α) => ∀ {p : α → Prop}, liftp p x → p y

theorem of_mem_supp {F : Type u → Type u} [Functor F] {α : Type u} {x : F α} {p : α → Prop} (h : liftp p x) (y : α) (H : y ∈ supp x) : p y :=
  hy h

end functor

namespace ulift

protected instance functor : Functor ulift :=
  { map := fun (α β : Type u_1) (f : α → β) => up ∘ f ∘ down,
    mapConst := fun (α β : Type u_1) => (fun (f : β → α) => up ∘ f ∘ down) ∘ function.const β }


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.constructions.logging.query_log.basic

/-!
# Forking Operations for Query Logs

This file defines functions for forking a `query_log`, in the sense of removing
all queries after some specified query, leaving the ones before that as is.
-/

namespace query_log

variables {spec : oracle_spec} (log : query_log spec)

section fork_cache

/-- Remove parts of the cache after the query chosen to fork on.
Just wraps a call to `drop_at_index`, dropping everything if the input is `none`.
The result contains exactly the back `i` elements. The choice to drop everything given a `none`
input is just convention, but simplifies some proofs. -/
def fork_cache (log : query_log spec)
  (i : spec.ι) (n : option ℕ) : query_log spec :=
match n with
| none := query_log.init spec
| (some m) := log.drop_at_index i ((log i).length - m) -- The front values are most recent??
end

@[simp] lemma fork_cache_init (i : spec.ι) (n : option ℕ) :
  (query_log.init spec).fork_cache i n = query_log.init spec :=
begin
  induction n with n,
  { exact rfl },
  { exact drop_at_index_init _ i }
end

@[simp] lemma fork_cache_none (i : spec.ι) (log : query_log spec) :
  log.fork_cache i none = query_log.init spec := rfl

end fork_cache

section to_seed

/-- Wrapping function that just reverses every list in the given `query_log`.
  Intended to turn a log into something that can be used as a seed for a computation.
  Needed because the logging function adds the new queries to the front of the list  -/
def to_seed (log : query_log spec) :
  query_log spec :=
λ i, (log i).reverse

@[simp]
lemma to_seed_apply (log : query_log spec) (i : spec.ι) :
  log.to_seed i = (log i).reverse :=
rfl

@[simp]
lemma to_seed_init (spec : oracle_spec) :
  (init spec).to_seed = init spec :=
rfl

lemma to_seed_log_query (log : query_log spec)
  (i : spec.ι) (t : spec.domain i) (u : spec.range i) :
  (log.log_query i t u).to_seed = λ j, if hi : i = j
    then log.to_seed j ++ [hi.rec_on (t, u)] else log.to_seed j :=
begin
  refine ext (λ j, _),
  split_ifs,
  { induction h,
    exact trans (congr_arg list.reverse $ log.log_query_apply_same_index i t u)
      (list.reverse_cons (t, u) (log i)) },
  { exact congr_arg list.reverse (log.log_query_apply_of_index_ne h t u) }
end

end to_seed

end query_log


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Instances on punit.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.PostPort

universes u_1 u

namespace Mathlib

namespace punit

protected instance comm_group : comm_group PUnit :=
  comm_group.mk (fun (_x _x : PUnit) => PUnit.unit) sorry PUnit.unit sorry sorry (fun (_x : PUnit) => PUnit.unit)
    (fun (_x _x : PUnit) => PUnit.unit) sorry sorry

protected instance comm_ring : comm_ring PUnit :=
  comm_ring.mk add_comm_group.add add_comm_group.add_assoc add_comm_group.zero add_comm_group.zero_add
    add_comm_group.add_zero add_comm_group.neg add_comm_group.sub add_comm_group.add_left_neg add_comm_group.add_comm
    comm_group.mul comm_group.mul_assoc comm_group.one comm_group.one_mul comm_group.mul_one sorry sorry
    comm_group.mul_comm

protected instance complete_boolean_algebra : complete_boolean_algebra PUnit :=
  complete_boolean_algebra.mk (fun (_x _x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => True)
    (fun (_x _x : PUnit) => False) sorry sorry sorry sorry sorry sorry (fun (_x _x : PUnit) => PUnit.unit) sorry sorry
    sorry sorry PUnit.unit sorry PUnit.unit sorry (fun (_x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => PUnit.unit)
    sorry sorry sorry (fun (_x : set PUnit) => PUnit.unit) (fun (_x : set PUnit) => PUnit.unit) sorry sorry sorry sorry
    sorry sorry

protected instance canonically_ordered_add_monoid : canonically_ordered_add_monoid PUnit :=
  canonically_ordered_add_monoid.mk comm_ring.add comm_ring.add_assoc comm_ring.zero comm_ring.zero_add comm_ring.add_zero
    comm_ring.add_comm complete_boolean_algebra.le complete_boolean_algebra.lt complete_boolean_algebra.le_refl
    complete_boolean_algebra.le_trans complete_boolean_algebra.le_antisymm sorry sorry complete_boolean_algebra.bot
    complete_boolean_algebra.bot_le sorry

protected instance linear_ordered_cancel_add_comm_monoid : linear_ordered_cancel_add_comm_monoid PUnit :=
  linear_ordered_cancel_add_comm_monoid.mk canonically_ordered_add_monoid.add canonically_ordered_add_monoid.add_assoc
    sorry canonically_ordered_add_monoid.zero canonically_ordered_add_monoid.zero_add
    canonically_ordered_add_monoid.add_zero canonically_ordered_add_monoid.add_comm sorry
    canonically_ordered_add_monoid.le canonically_ordered_add_monoid.lt canonically_ordered_add_monoid.le_refl
    canonically_ordered_add_monoid.le_trans canonically_ordered_add_monoid.le_antisymm
    canonically_ordered_add_monoid.add_le_add_left sorry sorry (fun (_x _x : PUnit) => decidable.true) punit.decidable_eq
    fun (_x _x : PUnit) => decidable.false

protected instance semimodule (R : Type u) [semiring R] : semimodule R PUnit :=
  semimodule.of_core (semimodule.core.mk (has_scalar.mk fun (_x : R) (_x : PUnit) => PUnit.unit) sorry sorry sorry sorry)

@[simp] theorem zero_eq : 0 = PUnit.unit :=
  rfl

@[simp] theorem one_eq : 1 = PUnit.unit :=
  rfl

@[simp] theorem add_eq (x : PUnit) (y : PUnit) : x + y = PUnit.unit :=
  rfl

@[simp] theorem mul_eq (x : PUnit) (y : PUnit) : x * y = PUnit.unit :=
  rfl

@[simp] theorem sub_eq (x : PUnit) (y : PUnit) : x - y = PUnit.unit :=
  rfl

@[simp] theorem neg_eq (x : PUnit) : -x = PUnit.unit :=
  rfl

@[simp] theorem inv_eq (x : PUnit) : x⁻¹ = PUnit.unit :=
  rfl

theorem smul_eq (x : PUnit) (y : PUnit) : x • y = PUnit.unit :=
  rfl

@[simp] theorem top_eq : ⊤ = PUnit.unit :=
  rfl

@[simp] theorem bot_eq : ⊥ = PUnit.unit :=
  rfl

@[simp] theorem sup_eq (x : PUnit) (y : PUnit) : x ⊔ y = PUnit.unit :=
  rfl

@[simp] theorem inf_eq (x : PUnit) (y : PUnit) : x ⊓ y = PUnit.unit :=
  rfl

@[simp] theorem Sup_eq (s : set PUnit) : Sup s = PUnit.unit :=
  rfl

@[simp] theorem Inf_eq (s : set PUnit) : Inf s = PUnit.unit :=
  rfl

@[simp] protected theorem le (x : PUnit) (y : PUnit) : x ≤ y :=
  trivial

@[simp] theorem not_lt (x : PUnit) (y : PUnit) : ¬x < y :=
  not_false


import for_mathlib.coprod.free_group_subgroup
import .functor
import neat.cyclically_reduce
import neat.initial
import tactic

noncomputable theory

notation `C∞` := multiplicative ℤ

universe u

variables {ι : Type} [decidable_eq ι] (r : free_group ι) (T : set ι) [decidable_pred T]

open free_group P semidirect_product multiplicative

def mul_subscript : C∞ →* free_group (ι × C∞) ≃* free_group (ι × C∞) :=
{ to_fun := λ n, free_group.equiv (equiv.prod_congr (equiv.refl _) (mul_left n)),
  map_one' := sorry,
  map_mul' := sorry }

def add_subscript (t : ι) : free_group ι →* free_group (ι × C∞) ⋊[mul_subscript] C∞ :=
free_group.lift' (λ j,
  if t = j
  then semidirect_product.inr
  else semidirect_product.inl.comp (of' (j, 1)))

def remove_subscript (t : ι) : free_group (ι × C∞) →* free_group ι :=
free_group.lift' (λ g, (mul_aut.conj (of' t g.2)).to_monoid_hom.comp (of' g.1))

@[simp] lemma remove_subscript_comp_mul_subscript (t : ι) (n : C∞) :
  (remove_subscript t).comp (@mul_subscript ι _ n).to_monoid_hom =
  (mul_aut.conj (of' t n)).to_monoid_hom.comp (remove_subscript t) :=
free_group.hom_ext
  (by simp [remove_subscript, mul_subscript, lift'_eq_lift, of'_eq_of_pow, gpow_add, mul_assoc])

@[simp] lemma remove_subscript_mul_subscript (t : ι) (n : C∞) (x) : remove_subscript t
  (mul_subscript n x) =  of' t n * remove_subscript t x * of' t n⁻¹ :=
by simpa [-remove_subscript_comp_mul_subscript] using monoid_hom.ext_iff.1
  (remove_subscript_comp_mul_subscript t n) x

@[simp] lemma remove_subscript_mul_subscript_inv (t : ι) (n : C∞) (x) : remove_subscript t
  ((mul_subscript n)⁻¹ x) = of' t n⁻¹ * remove_subscript t x * of' t n :=
by rw [← monoid_hom.map_inv, remove_subscript_mul_subscript, inv_inv, mul_assoc]

@[simp] lemma remove_subscript_of' (t : ι) (l : ι × C∞) (n : C∞) : remove_subscript t (of' l n) =
  (mul_aut.conj (of' t l.2)) (of' l.1 n) :=
free_group.lift'_of' _ _ _

def remove_subscript_SD (t : ι) : free_group (ι ×C∞) ⋊[mul_subscript] C∞ →* free_group ι :=
semidirect_product.lift (remove_subscript t) (of' t)
  (λ g, hom_ext (λ j, by simp [mul_aut.conj_apply, mul_assoc]))

include r

lemma lhs_eq_of_mem {n : solver r T}
  {x : free_group ι} {y : P (free_group ι)}
  (h : y ∈ n x) : lhs r y = x := sorry

lemma lhs_inl_eq_of_mem {n : solver r T}
  {x : free_group ι} {y : P (free_group ι)}
  (h : y ∈ n x) : lhs r (inl y.left) = x * y.right⁻¹ :=
by rw [eq_mul_inv_iff_mul_eq, ← lhs_inr y.right, ← monoid_hom.map_mul,
    inl_left_mul_inr_right, lhs_eq_of_mem r T h]

variable {ι}

omit r

noncomputable def normalize_cons
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (old1 : free_group (ι × C∞)) --contains no t
  (old2 : P (free_group (ι × C∞))),
  P (free_group (ι × C∞))
| old1 ⟨w, ⟨[], _⟩⟩     := ⟨mul_free old1 w, old1⟩
| old1 ⟨w, ⟨i :: l, _⟩⟩ :=
  if i.1.1 = t
  then if i.2 ≤ 1
    then option.elim (hA old1)
      (inr old1 * ⟨w, ⟨i :: l, sorry⟩⟩)
      (λ a, inr (of (t, 1))⁻¹ *
        normalize_cons (mul_subscript (of_add 1) (right_hom a))
          ⟨mul_free (of (t, 1)) (mul_free a.right⁻¹ a.left * w),
            of' (t, 1) (of_add 1 * i.2) * ⟨l, sorry⟩⟩)
    else option.elim (hB old1)
      (inr old1 * ⟨w, ⟨i :: l, sorry⟩⟩)
      (λ a, inr (of (t, 1)) *
        normalize_cons (mul_subscript (of_add (-1)) (right_hom a))
          ⟨mul_free (of (t, 1))⁻¹ (mul_free a.right⁻¹ a.left * w), of' i.1 (of_add (-1) * i.2) *⟨l, sorry⟩⟩)
  else normalize_cons ⟨old1.1 ++ [i], sorry⟩ ⟨(mul_free (of' i.1 i.2))⁻¹ w, ⟨l, sorry⟩⟩
using_well_founded { rel_tac := λ _ _, `[exact ⟨λ _ _, true, sorry⟩], dec_tac := `[trivial] }

set_option timeout 10000000

-- @[simp] lemma remove_subscript_lhs_normalize_cons
--   (t : ι) (r' : free_group (ι × C∞))
--   {A B : set (ι × C∞)}
--   [decidable_pred A] [decidable_pred B]
--   (hA : solver r' A)
--   (hB : solver r' B) :
--   Π (old1 : free_group (ι × C∞))
--   (old2 : P (free_group (ι × C∞))),
--   remove_subscript t (lhs r' (normalize_cons t r' hA hB old1 old2)) =
--     remove_subscript t (old1 * lhs r' old2)
-- | old1 ⟨w, ⟨[], _⟩⟩     := by rw normalize_cons; simp [inl_aut]
-- | old1 ⟨w, ⟨i :: l, _⟩⟩ := begin
--   rw [normalize_cons],
--   split_ifs,
--   { cases h1 : hA old1,
--     { simp [remove_subscript_lhs_normalize_cons, inl_aut_inv, mul_assoc] },
--     { have : i.1.2 = of_add 1, from sorry,
--       simp [remove_subscript_lhs_normalize_cons, mul_assoc, inl_aut_inv,
--         lhs_inl_eq_of_mem _ _ h1, inl_aut, this, h, of_eq_of',
--         lhs_eq_of_mem _ _ h1], } },
--   { cases h2 : hB old1,
--     { simp [remove_subscript_lhs_normalize_cons, inl_aut_inv, mul_assoc] },
--     { have : i.1.2 = of_add 1, from sorry,
--       simp [remove_subscript_lhs_normalize_cons, mul_assoc, inl_aut_inv,
--         lhs_inl_eq_of_mem _ _ h2, inl_aut, this, h, of_eq_of',
--         lhs_eq_of_mem _ _ h2] } },
--   { simp [remove_subscript_lhs_normalize_cons, inl_aut_inv, mul_assoc] },
-- end
-- using_well_founded { rel_tac := λ _ _, `[exact ⟨λ _ _, true, sorry⟩], dec_tac := `[trivial] }

noncomputable def normalize_with_subscript_aux
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (w : list (Σ i : ι, C∞)) (hw : coprod.pre.reduced w),
  P (free_group (ι × C∞))
| []       _ := 1
| (i :: l) h := normalize_cons t r' hA hB (of' (i.1, 1) i.2)
  (normalize_with_subscript_aux l (coprod.pre.reduced_of_reduced_cons h))

noncomputable def normalize_with_subscript
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B)
  (w : free_group ι) :
  P (free_group (ι × C∞)) :=
normalize_with_subscript_aux t r' hA hB w.1 w.2

-- lemma remove_subscript_lhs_normalize_with_subscript_aux
--   (t : ι) (r' : free_group (ι × C∞))
--   {A B : set (ι × C∞)}
--   [decidable_pred A] [decidable_pred B]
--   (hA : solver r' A) (hB : solver r' B) :
--   Π (w : list (Σ i : ι, C∞)) (hw : coprod.pre.reduced w),
--   remove_subscript t (lhs r' (normalize_with_subscript_aux t r' hA hB w hw)) = ⟨w, hw⟩
-- | []       _ := by simp [normalize_with_subscript_aux]
-- | (i :: l) _ := begin
--   rw [normalize_with_subscript_aux, remove_subscript_lhs_normalize_cons,
--     monoid_hom.map_mul, remove_subscript_lhs_normalize_with_subscript_aux],
--   simp
-- end

-- @[simp] lemma remove_subscript_lhs_normalize_with_subscript
--   (t : ι) (r' : free_group (ι × C∞)) {A B : set (ι × C∞)}
--   [decidable_pred A] [decidable_pred B]
--   (hA : solver r' A) (hB : solver r' B) (w : free_group ι) :
--   remove_subscript t (lhs r' (normalize_with_subscript t r' hA hB w)) = w :=
-- by cases w; apply remove_subscript_lhs_normalize_with_subscript_aux

-- def exp_sum_eq_zero (t x : ι)
--   (hs : Π (r : free_group (ι × C∞)) (T : set (ι × C∞)) [decidable_pred T], solver r T)
--   (cyc_r : free_group ι):
--   solver cyc_r T := λ w,
-- let (c₂, conj_r) := cyclically_conjugate x cyc_r in
-- let r' := (add_subscript t conj_r).left in
-- let (a, b) := min_max_subscript x r' in
-- let p := normalize_with_subscript t r'
--   (hs r' (Icc_prod x a (b * (of_add 1)⁻¹)))
--   (hs r' (Icc_prod x (a * of_add 1) b))
--   w in
-- let T' : set (ι × C∞) :=
--   if t ∈ T
--     then { i : ι × C∞ | i.1 ∈ T }
--     else { i : ι × C∞ | i.1 ∈ T ∧ i.2 = 1 } in
-- let dT' : decidable_pred T' := by dsimp [T']; split_ifs; apply_instance in
-- do np ← @hs r' T' dT' p.right,
-- return (change_r (c₂⁻¹) (P.map (remove_subscript t) sorry (P.trans p np)))


import Lean.Data.PersistentHashMap

open Lean
def m : PersistentHashMap Nat Nat :=
let m : PersistentHashMap Nat Nat := {};
m.insert 1 1

def natDiffHash : Hashable Nat :=
⟨fun n => UInt64.ofNat $ n+10⟩

-- The following example should fail since the `Hashable` instance used to create `m` is not `natDiffHash`
#eval @PersistentHashMap.find? Nat Nat _ natDiffHash m 1


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BoundedLattice
import order.category.DistribLattice

/-!
# The category of bounded distributive lattices

This defines `BoundedDistribLattice`, the category of bounded distributive lattices.

Note that this category is sometimes called [`DistLat`][https://ncatlab.org/nlab/show/DistLat] when
being a lattice is understood to entail having a bottom and a top element.
-/

universes u

open category_theory

/-- The category of bounded distributive lattices with bounded lattice morphisms. -/
structure BoundedDistribLattice :=
(to_DistribLattice : DistribLattice)
[is_bounded_order : bounded_order to_DistribLattice]

namespace BoundedDistribLattice

instance : has_coe_to_sort BoundedDistribLattice Type* := ⟨λ X, X.to_DistribLattice⟩
instance (X : BoundedDistribLattice) : distrib_lattice X := X.to_DistribLattice.str

attribute [instance] BoundedDistribLattice.is_bounded_order

/-- Construct a bundled `BoundedDistribLattice` from a `bounded_order` `distrib_lattice`. -/
def of (α : Type*) [distrib_lattice α] [bounded_order α] : BoundedDistribLattice := ⟨⟨α⟩⟩

@[simp] lemma coe_of (α : Type*) [distrib_lattice α] [bounded_order α] : ↥(of α) = α := rfl

instance : inhabited BoundedDistribLattice := ⟨of punit⟩

/-- Turn a `BoundedDistribLattice` into a `BoundedLattice` by forgetting it is distributive. -/
def to_BoundedLattice (X : BoundedDistribLattice) : BoundedLattice := BoundedLattice.of X

@[simp] lemma coe_to_BoundedLattice (X : BoundedDistribLattice) : ↥X.to_BoundedLattice = ↥X := rfl

instance : large_category.{u} BoundedDistribLattice := induced_category.category to_BoundedLattice

instance : concrete_category BoundedDistribLattice :=
induced_category.concrete_category to_BoundedLattice

instance has_forget_to_DistribLattice : has_forget₂ BoundedDistribLattice DistribLattice :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_lattice_hom } }

instance has_forget_to_BoundedLattice : has_forget₂ BoundedDistribLattice BoundedLattice :=
induced_category.has_forget₂ to_BoundedLattice

lemma forget_BoundedLattice_Lattice_eq_forget_DistribLattice_Lattice :
  forget₂ BoundedDistribLattice BoundedLattice ⋙ forget₂ BoundedLattice Lattice =
    forget₂ BoundedDistribLattice DistribLattice ⋙ forget₂ DistribLattice Lattice := rfl

/-- Constructs an equivalence between bounded distributive lattices from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : BoundedDistribLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : BoundedDistribLattice ⥤ BoundedDistribLattice :=
{ obj := λ X, of (order_dual X), map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `BoundedDistribLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BoundedDistribLattice ≌ BoundedDistribLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BoundedDistribLattice

lemma BoundedDistribLattice_dual_comp_forget_to_DistribLattice :
  BoundedDistribLattice.dual ⋙ forget₂ BoundedDistribLattice DistribLattice =
    forget₂ BoundedDistribLattice DistribLattice ⋙ DistribLattice.dual := rfl


import .homotopy_classes

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
open homotopy_theory.cylinder

section C
parameters {C : Type u} [category.{v} C]
  [has_initial_object.{v} C] [has_coproducts.{v} C] [I_category.{v} C]

parameters {a b : C} {j : a ⟶ b} (hj : is_cof j)

section
/-

Suppose f₀ : b → x is a map and G is a homotopy from u = f₀ ∘ j to
some other map u' : a → x. Using the homotopy extension property of j,
we obtain a homotopy f₀ ≃ f₁ extending G to a map f₁ with f₁ ∘ j = u'.
We show below that this construction is well-defined up to homotopy
rel j and defines a bijection between homotopy classes rel j of maps
extending u and homotopy classes rel j of maps extending u'.

This correspondence is not constructive in either direction since we
need to use the HEP, which is a mere existence statement. Therefore we
describe it as a relation and show that a homotopy class on either
side is related to a unique homotopy class on the other side.

We call this the "drag" relation induced by G, and imagine dragging
the restriction of f₀ to a along the homotopy G, with the rest of f₀
following along. A familiar example is the isomorphism πₙ(X, x) ≃
πₙ(X, y) induced by a path γ : x ↝ y in X.

-/

parameters {x : C}
include hj

section dir
-- Abstract over the direction of "dragging": f₀ to f₁ or f₁ to f₀.
parameters (u : endpoint → (a ⟶ x))
parameters (ε : endpoint) (G : homotopy_dir ε (u ε) (u ε.v))
include G

def drag_rel_dir : maps_extending hj (u ε) → maps_extending hj (u ε.v) → Prop :=
λ fε fεv, ∃ H : homotopy_dir ε fε.val fεv.val, H.H ∘ I &> j = G.H

lemma total (fε : maps_extending hj (u ε)) : ∃ fεv, drag_rel_dir fε fεv :=
let ⟨E, h₁, h₂⟩ := I_category.hep_cof j hj ε x fε.val G.H $
  by rw [fε.property, G.Hiε] in
⟨⟨E ∘ i ε.v @> b, by rw [i_nat_assoc, ←G.Hiεv, h₂]⟩,
 ⟨homotopy_dir.mk ε E h₁ rfl, by clear _let_match; cases ε; exact h₂⟩⟩

end dir

parameters {u u' : a ⟶ x}
parameters (G : homotopy u u')
include G

def drag_rel : maps_extending hj u → maps_extending hj u' → Prop :=
λ f₀ f₁, ∃ H : homotopy f₀.val f₁.val, H.H ∘ I &> j = G.H

local notation f₀ ` ~G `:50 f₁:50 := drag_rel f₀ f₁
local notation `[` b `,` x `]^` u:60 := homotopy_classes_extending_rel j hj u

-- The relation ~G does not descend to the quotient: given a homotopy
-- f₀ ≃ f₀' rel u and a homotopy f₀ ≃ f₁ extending G, we may not be
-- able to find a homotopy f₀' ≃ f₁ extending G. Rather, two homotopy
-- classes are related when they have representatives which are
-- related by ~G.
def drag_rel_homotopy : [b, x]^u → [b, x]^u' → Prop :=
λ g₀ g₁, ∃ f₀ f₁, ⟦f₀⟧ = g₀ ∧ ⟦f₁⟧ = g₁ ∧ f₀ ~G f₁

private def uu' : endpoint → (a ⟶ x) := λ ε, endpoint.cases_on ε u u'

lemma drag_rel_homotopy_total₀ (g₀) : ∃ g₁, drag_rel_homotopy g₀ g₁ :=
quotient.induction_on g₀ $ assume f₀,
  let ⟨f₁, h⟩ := total uu' 0 G f₀ in ⟨⟦f₁⟧, ⟨f₀, f₁, rfl, rfl, h⟩⟩

lemma drag_rel_homotopy_total₁ (g₁) : ∃ g₀, drag_rel_homotopy g₀ g₁ :=
quotient.induction_on g₁ $ assume f₁,
  let ⟨f₀, h⟩ := total uu' 1 G f₁ in ⟨⟦f₀⟧, ⟨f₀, f₁, rfl, rfl, h⟩⟩

lemma drag_rel_homotopy_unique₀ {g₀ g₁ g₁'} :
  drag_rel_homotopy g₀ g₁ → drag_rel_homotopy g₀ g₁' → g₁ = g₁' :=
assume ⟨f₀, f₁, hf₀, hf₁, ⟨H, h⟩⟩ ⟨f₀', f₁', hf₀', hf₁', ⟨H', h'⟩⟩,
  have f₀.val ≃ f₀'.val rel j, from quotient.exact (hf₀.trans hf₀'.symm),
  let ⟨H₀, h₀⟩ := this in
  hf₁.symm.trans $
    (quotient.sound (equiv_private.f₁_f₂ j hj h₀ 0 h h') : ⟦f₁⟧ = ⟦f₁'⟧).trans hf₁'

lemma drag_rel_homotopy_unique₁ {g₀ g₀' g₁} :
  drag_rel_homotopy g₀ g₁ → drag_rel_homotopy g₀' g₁ → g₀ = g₀' :=
assume ⟨f₀, f₁, hf₀, hf₁, ⟨H, h⟩⟩ ⟨f₀', f₁', hf₀', hf₁', ⟨H', h'⟩⟩,
  have f₁.val ≃ f₁'.val rel j, from quotient.exact (hf₁.trans hf₁'.symm),
  let ⟨H₁, h₁⟩ := this in
  hf₀.symm.trans $
    (quotient.sound (equiv_private.f₁_f₂ j hj h₁ 1 h h') : ⟦f₀⟧ = ⟦f₀'⟧).trans hf₀'

parameters {hj u u'}

-- TODO: General theory of bijective relations
-- FIXME: collision between homotopy ≃ and equiv ≃
noncomputable def drag_equiv : equiv ([b, x]^u) ([b, x]^u') :=
{ to_fun := λ g₀, classical.some (drag_rel_homotopy_total₀ g₀),
  inv_fun := λ g₁, classical.some (drag_rel_homotopy_total₁ g₁),
  left_inv := assume g₀,
    let g₁ := classical.some (drag_rel_homotopy_total₀ g₀),
        g₀' := classical.some (drag_rel_homotopy_total₁ g₁) in
    show g₀' = g₀, from
    have e' : drag_rel_homotopy g₀' g₁, from classical.some_spec (drag_rel_homotopy_total₁ g₁),
    have e : drag_rel_homotopy g₀ g₁, from classical.some_spec (drag_rel_homotopy_total₀ g₀),
    drag_rel_homotopy_unique₁ e' e,
  right_inv := assume g₁,
    let g₀ := classical.some (drag_rel_homotopy_total₁ g₁),
        g₁' := classical.some (drag_rel_homotopy_total₀ g₀) in
    show g₁' = g₁, from
    have e' : drag_rel_homotopy g₀ g₁', from classical.some_spec (drag_rel_homotopy_total₀ g₀),
    have e : drag_rel_homotopy g₀ g₁, from classical.some_spec (drag_rel_homotopy_total₁ g₁),
    drag_rel_homotopy_unique₀ e' e }

lemma drag_equiv_apply {g₀ g₁} : drag_equiv g₀ = g₁ ↔ drag_rel_homotopy g₀ g₁ :=
iff.intro
  (assume h, by rw ←h; exact classical.some_spec (drag_rel_homotopy_total₀ _ _ _))
  (assume h,
    have h' : drag_rel_homotopy g₀ (drag_equiv g₀) :=
      classical.some_spec (drag_rel_homotopy_total₀ _),
    drag_rel_homotopy_unique₀ h' h)

end

parameters {hj}

lemma drag_rel_homotopy_induced {x y : C} {u u' : a ⟶ x} (G : homotopy u u') (g : x ⟶ y)
  (g₀ : homotopy_classes_extending_rel j hj u) (g₁ : homotopy_classes_extending_rel j hj u') :
  drag_rel_homotopy G g₀ g₁ →
  drag_rel_homotopy (G.congr_left g) (hcer_induced g g₀) (hcer_induced g g₁) :=
assume ⟨f₀, f₁, hf₀, hf₁, H, hH⟩,
⟨⟨g ∘ f₀.val, by rw [←assoc, f₀.property]⟩,
 ⟨g ∘ f₁.val, by rw [←assoc, f₁.property]⟩,
 by rw ←hf₀; refl, by rw ←hf₁; refl,
 H.congr_left g,
 by unfold homotopy.congr_left; rw [←assoc, hH]⟩

lemma drag_equiv_induced {x y : C} {u u' : a ⟶ x} (G : homotopy u u') (g : x ⟶ y)
  (g₀ : homotopy_classes_extending_rel j hj u) :
  hcer_induced g (drag_equiv G g₀) = drag_equiv (G.congr_left g) (hcer_induced g g₀) :=
begin
  symmetry,
  rw drag_equiv_apply,
  apply drag_rel_homotopy_induced,
  rw ←drag_equiv_apply
end

-- Now we can state and prove the fact that homotopic maps g ≃ g'
-- induce the same map on homotopy classes extending u, up to the drag
-- identification.

variables {x y : C} {u : a ⟶ x} {g g' : x ⟶ y} (h : homotopy g g')
lemma hcer_induced_homotopic (f : homotopy_classes_extending_rel j hj u) :
  drag_equiv (h.congr_right u) (hcer_induced g f) = hcer_induced g' f :=
quotient.induction_on f $ λ f, begin
  dsimp [hcer_induced],
  rw drag_equiv_apply,
  existsi [_, _],
  split, exact rfl,
  split, exact rfl,
  existsi h.congr_right f.val,
  dsimp only [homotopy.congr_right],
  rw [←assoc, ←I.map_comp, f.property]
end

end C

end homotopy_theory.cofibrations


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.rat.default
import Mathlib.data.semiquot
import Mathlib.PostPort

universes l u_1

namespace Mathlib

/-!
# Implementation of floating-point numbers (experimental).
-/

def int.shift2 (a : ℕ) (b : ℕ) : ℤ → ℕ × ℕ := sorry

namespace fp

structure rmode where
  NE ::

class float_cfg where
  prec : ℕ
  emax : ℕ
  prec_pos : 0 < prec
  prec_max : prec ≤ emax

def prec [C : float_cfg] : ℕ := float_cfg.prec

def emax [C : float_cfg] : ℕ := float_cfg.emax

def emin [C : float_cfg] : ℤ := 1 - ↑float_cfg.emax

def valid_finite [C : float_cfg] (e : ℤ) (m : ℕ) :=
  emin ≤ e + ↑prec - 1 ∧ e + ↑prec - 1 ≤ ↑emax ∧ e = max (e + ↑(nat.size m) - ↑prec) emin

protected instance dec_valid_finite [C : float_cfg] (e : ℤ) (m : ℕ) :
    Decidable (valid_finite e m) :=
  eq.mpr sorry and.decidable

inductive float [C : float_cfg] where
| inf : Bool → float
| nan : float
| finite : Bool → (e : ℤ) → (m : ℕ) → valid_finite e m → float

def float.is_finite [C : float_cfg] : float → Bool := sorry

def to_rat [C : float_cfg] (f : float) : ↥(float.is_finite f) → ℚ := sorry

theorem float.zero.valid [C : float_cfg] : valid_finite emin 0 := sorry

def float.zero [C : float_cfg] (s : Bool) : float := float.finite s emin 0 sorry

protected instance float.inhabited [C : float_cfg] : Inhabited float := { default := float.zero tt }

protected def float.sign' [C : float_cfg] : float → semiquot Bool := sorry

protected def float.sign [C : float_cfg] : float → Bool := sorry

protected def float.is_zero [C : float_cfg] : float → Bool := sorry

protected def float.neg [C : float_cfg] : float → float := sorry

def div_nat_lt_two_pow [C : float_cfg] (n : ℕ) (d : ℕ) : ℤ → Bool := sorry

-- TODO(Mario): Prove these and drop 'meta'

namespace float

protected instance has_neg [C : float_cfg] : Neg float := { neg := float.neg }

end Mathlib


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam
-/
prelude
import init.meta.tactic init.meta.congr_lemma init.meta.relation_tactics init.function

namespace tactic

meta def apply_congr_core (clemma : congr_lemma) : tactic unit :=
do assert `H_congr_lemma clemma.type,
   exact clemma.proof,
   get_local `H_congr_lemma >>= apply,
   all_goals' $ do
     try (applyc `heq_of_eq),
     get_local `H_congr_lemma >>= clear

meta def apply_eq_congr_core (tgt : expr) : tactic unit :=
do (lhs, rhs) ← match_eq tgt,
   guard lhs.is_app,
   clemma ← mk_specialized_congr_lemma lhs,
   apply_congr_core clemma

meta def apply_heq_congr_core : tactic unit :=
do try (applyc `eq_of_heq),
   (α, lhs, β, rhs) ← target >>= match_heq,
   guard lhs.is_app,
   clemma ← mk_hcongr_lemma lhs.get_app_fn lhs.get_app_num_args,
   apply_congr_core clemma

meta def congr_core : tactic unit :=
do tgt ← target,
   apply_eq_congr_core tgt
   <|> apply_heq_congr_core
   <|> fail "congr tactic failed"

meta def congr : tactic unit :=
do focus1 (try assumption >> congr_core >> all_goals' (try reflexivity >> try congr))

end tactic


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Floris van Doorn
-/
import category_theory.limits.shapes.products
import category_theory.discrete_category

universes v u

noncomputable theory

open category_theory
open category_theory.functor
open opposite

namespace category_theory.limits

variables {C : Type u} [category.{v} C]
variables {J : Type v} [small_category J]
variable (F : J ⥤ Cᵒᵖ)

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a colimit, we can construct a limit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_limit_of_has_colimit_left_op [has_colimit F.left_op] : has_limit F :=
has_limit.mk
{ cone := cone_of_cocone_left_op (colimit.cocone F.left_op),
  is_limit :=
  { lift := λ s, (colimit.desc F.left_op (cocone_left_op_of_cone s)).op,
    fac' := λ s j,
    begin
      rw [cone_of_cocone_left_op_π_app, colimit.cocone_ι, ←op_comp,
          colimit.ι_desc, cocone_left_op_of_cone_ι_app, quiver.hom.op_unop],
      refl, end,
    uniq' := λ s m w,
    begin
      -- It's a pity we can't do this automatically.
      -- Usually something like this would work by limit.hom_ext,
      -- but the opposites get in the way of this firing.
      have u := (colimit.is_colimit F.left_op).uniq (cocone_left_op_of_cone s) (m.unop),
      convert congr_arg (λ f : _ ⟶ _, f.op) (u _), clear u,
      intro j,
      rw [cocone_left_op_of_cone_ι_app, colimit.cocone_ι],
      convert congr_arg (λ f : _ ⟶ _, f.unop) (w (unop j)), clear w,
      rw [cone_of_cocone_left_op_π_app, colimit.cocone_ι, quiver.hom.unop_op],
      refl,
    end } }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_limits_of_shape_op_of_has_colimits_of_shape [has_colimits_of_shape Jᵒᵖ C] :
  has_limits_of_shape J Cᵒᵖ :=
{ has_limit := λ F, has_limit_of_has_colimit_left_op F }

local attribute [instance] has_limits_of_shape_op_of_has_colimits_of_shape

/--
If `C` has colimits, we can construct limits for `Cᵒᵖ`.
-/
lemma has_limits_op_of_has_colimits [has_colimits C] : has_limits Cᵒᵖ := {}

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a limit, we can construct a colimit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_colimit_of_has_limit_left_op [has_limit F.left_op] : has_colimit F :=
has_colimit.mk
{ cocone := cocone_of_cone_left_op (limit.cone F.left_op),
  is_colimit :=
  { desc := λ s, (limit.lift F.left_op (cone_left_op_of_cocone s)).op,
    fac' := λ s j,
    begin
      rw [cocone_of_cone_left_op_ι_app, limit.cone_π, ←op_comp,
          limit.lift_π, cone_left_op_of_cocone_π_app, quiver.hom.op_unop],
      refl, end,
    uniq' := λ s m w,
    begin
      have u := (limit.is_limit F.left_op).uniq (cone_left_op_of_cocone s) (m.unop),
      convert congr_arg (λ f : _ ⟶ _, f.op) (u _), clear u,
      intro j,
      rw [cone_left_op_of_cocone_π_app, limit.cone_π],
      convert congr_arg (λ f : _ ⟶ _, f.unop) (w (unop j)), clear w,
      rw [cocone_of_cone_left_op_ι_app, limit.cone_π, quiver.hom.unop_op],
      refl,
    end } }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_colimits_of_shape_op_of_has_limits_of_shape [has_limits_of_shape Jᵒᵖ C] :
  has_colimits_of_shape J Cᵒᵖ :=
{ has_colimit := λ F, has_colimit_of_has_limit_left_op F }

local attribute [instance] has_colimits_of_shape_op_of_has_limits_of_shape

/--
If `C` has limits, we can construct colimits for `Cᵒᵖ`.
-/
lemma has_colimits_op_of_has_limits [has_limits C] : has_colimits Cᵒᵖ := {}

variables (X : Type v)
/--
If `C` has products indexed by `X`, then `Cᵒᵖ` has coproducts indexed by `X`.
-/
lemma has_coproducts_opposite [has_products_of_shape X C] :
  has_coproducts_of_shape X Cᵒᵖ :=
begin
  haveI : has_limits_of_shape (discrete X)ᵒᵖ C :=
    has_limits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

/--
If `C` has coproducts indexed by `X`, then `Cᵒᵖ` has products indexed by `X`.
-/
lemma has_products_opposite [has_coproducts_of_shape X C] :
  has_products_of_shape X Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape (discrete X)ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

end category_theory.limits


import data.nat.basic tactic data.nat.parity
open nat expr tactic

universes u v

lemma let_congr {α : Type u} {β : Type v} (assignment₁ assignment₂ : α) (body : β)
  (h : assignment₁ = assignment₂) : let a := assignment₁ in body = let a := assignment₂ in body :=
h ▸ rfl

meta def reduce : expr → tactic (expr × expr)
| (elet n t v b) :=
  do (v', p) ← reduce v,
  T ← infer_type (elet n t v b),
  let eq' := `(@eq.{1} (%%T) (%%(elet n t (var 0) b)) (%%(elet n t v b))),
  --eq' ← tactic.mk_mapp `eq [T, elet n t v b, elet n t (var 0) b],
  let motive : expr := lam `x default t eq',
  let
  p' ← tactic.mk_mapp `eq.rec [t, v, motive, p, v'],
  return (elet n t v' b, p')
| `((1 : ℕ) + (1 : ℕ)) := return (`(2 : ℕ), `(eq.refl (2 : ℕ)))
| e := do eq' ← tactic.mk_app `eq.refl [e], return (e, eq')

set_option trace.app_builder true
#eval reduce `(let n := 1 + 1 in n)

meta def blah : tactic unit :=
do (e₁, e₂) ← reduce `(let n := 1 + 1 in n), tactic.exact e₂

example : let n := 1 + 1 in n = let n := 2 in n := by blah

#eval


import .core

namespace tts ------------------------------------------------------------------
namespace sch ------------------------------------------------------------------
variables {V : Type} [_root_.decidable_eq V] -- Type of variable names
variables {vs : list V} -- List of variable names
variables {nd : vs.nodup} -- No duplicate variables names
variables {x x₁ x₂ : tagged V} -- Variables
variables {xs : list (tagged V)} -- List of variable names
variables {t tx t₁ t₂ : typ V} -- Types
variables {ts txs : list (typ V)} -- Lists of types
variables {s : sch V} -- Type schemes

open list

/-- Substitute a free variable for a type in a scheme -/
def subst (x : tagged V) (t : typ V) (s : sch V) : sch V :=
⟨s.vars, typ.subst x t s.type, s.vars_nodup⟩

@[simp] theorem subst_mk : subst x tx (mk vs t nd) = mk vs (typ.subst x tx t) nd :=
rfl

/-- Substitute a list of free variables for a list of types in a scheme -/
def subst_list (xs : list (tagged V)) (ts : list (typ V)) (s : sch V) : sch V :=
⟨s.vars, typ.subst_list xs ts s.type, s.vars_nodup⟩

@[simp] theorem subst_list_mk :
  subst_list xs txs (mk vs t nd) = mk vs (typ.subst_list xs txs t) nd :=
rfl

-- Substitution with a fresh name is the identity
@[simp] theorem subst_fresh (h : x ∉ fv s) : subst x t s = s :=
eq_of_veq rfl $ typ.subst_fresh h

-- Fold typ.subst into sch.subst
theorem subst_fold : mk vs (typ.subst x t₂ t₁) nd = subst x t₂ (mk vs t₁ nd) :=
rfl

-- Substitution distributes over open
theorem subst_open_typs (l : typ.lc t) :
  typ.subst x t (open_typs ts s) = open_typs (map (typ.subst x t) ts) (subst x t s) :=
by cases s; simp [typ.subst_open_typs l]

-- Substitution distributes over open_vars
theorem subst_open_vars (h : x ∉ xs) (l : typ.lc t) :
  open_vars xs (subst x t s) = typ.subst x t (open_vars xs s) :=
by cases s; simp [typ.subst_open_vars h l]

@[simp] theorem subst_arity : (subst x t s).arity = s.arity :=
by unfold subst arity

@[simp] theorem subst_type : (subst x t s).type = typ.subst x t s.type :=
by unfold subst

-- A scheme substituted with a type is well-formed if the scheme is well-formed
-- and the type is locally-closed.
theorem subst_well_formed (lt : typ.lc t) (ls : lc s) : lc (subst x t s) :=
begin
  cases ls with L ls,
  existsi insert x L,
  intros xs d ln_eq F,
  simp [not_or_distrib] at F,
  have h₁ : x ∉ xs := λ h, absurd (eq.refl x) (F h).1,
  have h₂ : ∀ x ∈ xs, x ∉ L := λ _ h, (F h).2,
  simp [typ.subst_open_vars h₁ lt, typ.subst_lc lt (ls d ln_eq h₂)],
end

-- Opening up a scheme `s` with `ts` is the same as opening up `s` with fresh
-- names `xs` and then substituting `xs` for `ts`.
theorem subst_list_intro
  (d : xs.nodup)
  (ln_eq : xs.length = ts.length)
  (F : ∀ x ∈ xs, x ∉ fv s ∪ typ.fv_list ts)
  (l : ∀ t ∈ ts, typ.lc t) :
  open_typs ts s = typ.subst_list xs ts (open_vars xs s) :=
by rw [open_typs, open_vars, typ.subst_list_intro d ln_eq F l]

end /- namespace -/ sch --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


import data.finsupp

universes u v
variable (α : Type u)
variable [ring α]
variable [decidable_eq α]

@[simp] lemma ite.map (P : Prop) [decidable P] {β γ : Type*} (a b : β) (f : β → γ) :
  f (ite P a b) = ite P (f a) (f b) :=
begin
  split_ifs; refl
end

@[simp] lemma ite.mul_right (P : Prop) [decidable P] (a b c : α) :
  (ite P a b) * c = ite P (a * c) (b * c) := ite.map P a b (λ x, x * c)

-- theorem ite_single {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [add_comm_monoid β] (f : α → β) :

def finsupp_of_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [decidable_eq β] [add_comm_monoid β] (f : α → β) : finsupp α β :=
begin
  by_cases h₁ : f a₀ ≠ 0,
  { constructor,
    show α → β,
    from (λ a, ite (a₀ = a) (f a) 0),
    show finset α,
    from finset.singleton a₀,
    intros,
    simp,
    split_ifs,
    rw ←h,
    simp[h₁],
    simp[h],
    from λ h₂, h (eq.symm h₂),
  },
  exact 0
end

-- finsupp of double ite
def finsupp_of_double_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) : finsupp α β :=
begin
  constructor,
  show α → β,
  from (λ a, ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)),
  show finset α,
  from finset.singleton a₀ ∪ finset.singleton a₁,
  intros,
  simp,
  split_ifs,
  rw ←h,
  simp[h₁],
  rw ←h_1,
  simp[h₂],
  simp,
  intros h_n,
  cases h_n,
  from h (eq.symm h_n),
  from h_1 (eq.symm h_n),
end

@[simp] lemma finsupp_of_double_ite_eq_double_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) : (λ a, ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = (finsupp_of_double_ite a₀ a₁ f g h₁ h₂).to_fun :=
begin
  funext,
  by_cases h₁ : (a₀ = a),
  simp[h₁],
  unfold finsupp_of_double_ite,
  simp,
  unfold finsupp_of_double_ite,
end

@[simp] lemma coe_to_fun_to_fun {α : Type*} {β : Type*} [add_comm_monoid β] {fs : finsupp α β} : ⇑(fs) = fs.to_fun := rfl

lemma temp {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) (h_neq : a₀ ≠ a₁) (a : α) (h_p : a = a₀) : (a ∈ ((finsupp.single a₀ (f a₀)).support).val ∧
      ¬(finsupp.single a₀ (f a₀)).to_fun a + (finsupp.single a₁ (g a₁)).to_fun a = 0 ∨
    a ∈ ((finsupp.single a₁ (g a₁)).support).val ∧
      ¬(finsupp.single a₀ (f a₀)).to_fun a + (finsupp.single a₁ (g a₁)).to_fun a = 0) :=
begin
  simp[h_p],
  constructor,
  constructor,

  simp[finsupp.single, h₁],

  intros h_q,
  --(by simp[finsupp.single,h₂, h_neq])
  have H₁ : (finsupp.single a₁ (g a₁)).to_fun a₀ = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₁ (g a₁)) a₀) (by simp[finsupp.single,h₂, h_neq]),
  -- rw ←h_p at H₁,
  simp[H₁] at h_q,

  have H₂ : (finsupp.single a₀ (f a₀)).to_fun a₀ ≠ 0,
  from iff.elim_left (@finsupp.mem_support_iff α β _ (finsupp.single a₀ (f a₀)) a₀) (by simp[finsupp.single, h₁]),
  from H₂ h_q,
end

@[simp] lemma finsupp_of_double_ite_zip_singles {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) (h_neq : a₀ ≠ a₁) : (finsupp_of_double_ite a₀ a₁ f g h₁ h₂) = (finsupp.single a₀ (f a₀)) + (finsupp.single a₁ (g a₁)) :=
begin

  -- congr,
  unfold finsupp_of_double_ite,
  -- unfold finsupp.zip_with,
  congr,
  show (λ a, _) = (λ a, _),
  funext,
  by_cases h_t : (a₀ = a);
  simp[h_t],
  rw ←h_t,
  have H₁ : (finsupp.single a₁ (g a₁)).to_fun a₀ = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₁ (g a₁)) a₀) (by
  simp[finsupp.single,h₂, h_neq]),
  rw H₁,
  simp,
  simp[finsupp.single],
  simp,

  by_cases h_t₀ : (a₁ = a),
  simp[h_t₀],
  rw ←h_t₀,
  have H₁ : (finsupp.single a₀ (f a₀)).to_fun a₁ = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₀ (f a₀)) a₁) (by simp[finsupp.single,h₁, λ x, h_neq (eq.symm x)]),
  rw H₁,
  simp,
  simp[finsupp.single],
  simp,

  simp[h_t₀],
  have H₁ : (finsupp.single a₁ (g a₁)).to_fun a = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₁ (g a₁)) a) (by simp[finsupp.single, h₂, (λ x, h_t₀ (eq.symm x))]),
  have H₂ : (finsupp.single a₀ (f a₀)).to_fun a = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₀ (f a₀)) a) (by simp[finsupp.single, h₁, (λ x, h_t (eq.symm x))]),
  rw H₁,
  rw H₂,
  simp,

  -- simp[finset.singleton],
  ext,
  constructor,
  intros h_p,
  simp at h_p,
  cases h_p with h_p h_p,
{
  simp,
  apply temp; assumption,
},
{simp,
apply or.swap,
rw add_comm,
apply temp,
assumption,
assumption,
from λ x, h_neq (eq.symm x),
assumption,
},

intros h_p,
simp at h_p,
cases h_p with h_p h_p,
have H₁, from and.elim_left h_p,

simp,
constructor,
-- by_contra,
-- have H₄ :
have H₃ : ((finsupp.single a₀ (f a₀)).support) = finset.singleton a₀,
simp[finsupp.single, h₁],
rw H₃ at H₁,
-- ext,
simp[finsupp.single, finsupp.support, finset.val] at H₁,
-- constructor,
from H₁,

simp,
apply or.swap,
constructor,
have H₃ : ((finsupp.single a₁ (g a₁)).support) = finset.singleton a₁,
simp[finsupp.single, h₂],
-- simp[H₃] at h_p,
rw H₃ at h_p,
simp[finsupp.single, finsupp.support, finset.val] at h_p,
from and.elim_left h_p,
end

@[simp] lemma finsupp_of_ite_single {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f : α → β) : (finsupp_of_ite a₀ f) = finsupp.single a₀ (f a₀) :=
begin
  simp[finsupp.single],
  simp[finsupp_of_ite],
  simp[finset.singleton],
  by_cases h₁ : f a₀ ≠ 0,
  { simp[h₁],
    funext,
    -- congr,
    by_cases h₂ : (a₀ = a);
    simp[h₂], },
  simp at h₁,
  simp [h₁],
  refl,
end

@[simp] lemma finsupp_of_ite_eq_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [decidable_eq β] [add_comm_monoid β] (f : α → β) : (λ a, ite (a₀ = a) (f a) 0) = (finsupp_of_ite a₀ f).to_fun :=
begin
  funext,
  by_cases h₂ : (a₀ = a),
  simp[h₂],
  dsimp [finsupp.single],
  simp,
  unfold finsupp_of_ite,
  simp,
  simp[h₂],
  by_cases h₁ : f a₀ ≠ 0,
  simp[h₁],
  simp[h₂],
  simp[h₁],
  refl,
end

section
open finset
-- open finsupp
lemma finsupp_sum_support_subset {α : Type*} [fintype α] [decidable_eq α] {β : Type*} [add_comm_monoid β] (fs : finsupp α β) : Π (S : finset α), fs.support ⊆ S → S.sum (fs.to_fun) = fs.sum (λ x y, y) := begin
  intros S hS,
  by_cases hT : (S ⊆ fs.support),
  congr,
  apply finset.subset.antisymm; assumption,
  unfold finsupp.sum,
  simp,
  -- have h₇ : ⇑fs = (fs).to_fun,
  -- refl,
  have h₄, from eq.symm (@finset.sum_sdiff α β fs.support S fs.to_fun _ _ hS),
  apply eq.trans,
  from h₄,
  have h₅ : sum (S \ fs.support) (fs.to_fun) = 0,
  apply @finset.sum_eq_zero α β _ _ fs.to_fun (S \ fs.support),
  intros x,
  have h₆, from iff.elim_left ((@finsupp.not_mem_support_iff α β _ fs) x),
  -- simp at h₆,
  intros h₈,
  apply h₆,
  intros h₉,
  simp at h₈,
  simp at h₉,
  apply h₈.elim_right,
  from h₉,
  -- rw h₇,
  rw h₅,
  simp,
end
end

lemma finset.sum_ite_zero {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f : α → β):
  finset.sum finset.univ (λ a, ite (a₀ = a) (f a) 0) = f a₀ := begin

    -- TODO update: cases have been moved earlier.
    -- Outline of proof:  ⊢ finset.sum finset.univ (λ (a : α), ite (a₀ = a) (f a) 0) = f a₀
    /-
        Two cases, h : (f a₀ = 0):

        Case 1: If (f a₀ = 0) :
          The goal is:
          ⊢ finset.sum finset.univ (λ (a : α), ite (a₀ = a) (f a) 0) = 0
          We may show that (λ (a : α), ite (a₀ = a) (f a) 0) = (λ (a : α), 0) by cases.
          ⊢ finset.sum finset.univ (λ (a : α), 0) = 0
          which is resolved by the fact that summation over constant zero is zero.

        Case 2: If (f a₀ ≠ 0) :
          Then (λ (a : α), ite (a₀ = a) (f a) 0) is a finitely-supported (single) function : α →₀ β
          We then have
          ⊢ finset.sum finset.univ ((finsupp.single a₀ (f a₀)).to_fun) = f a₀
          Then summing over the entire finset with a single-supported function is the same
          as summing the result of the function mapped over the support of that function, so
          ⊢ finsupp.sum (finsupp.single a₀ (f a₀)) (λ (x : α) (y : β), y) = f a₀
          Then we may apply the fact that summing over a (single) supported function just picks the value at the point of interest, so
          ⊢ (λ (x : α) (y : β), y) a₀ (f a₀) = f a₀
          which is resolved by refl
    -/

    -- by_cases h : (f a₀ ≠ 0),
    -- Case 1: --------------------------------
    rw finsupp_of_ite_eq_ite,
    rw finsupp_of_ite_single,
    apply eq.trans (@finsupp_sum_support_subset α _ _ β _ (finsupp.single a₀ (f a₀)) finset.univ (by apply finset.subset_univ)),
    -- from H₃,
    -- show f a₀ ≠ 0, by assumption,

    apply eq.trans (@finsupp.sum_single_index α β β _ _ _ _ a₀ (f a₀) (λ x y, y) (by refl)),
    -- from @finsupp.sum_single_index α β β _ _ _ _ a₀ (f a₀) (λ x y, y) (by refl),
    simp,

    -- Case 2: --------------------------------
    -- simp at h,
    -- simp[h],
    -- have H₅ : (λ (a : α), ite (a₀ = a) (f a) 0) = (λ (a : α), 0),
    -- funext,
    -- by_cases h₁ : (a₀ = a); simp[h₁],
    -- subst h₁, assumption,
    -- rw H₅,
    -- from @finset.sum_const_zero α β finset.univ _,
  end

-- set_option pp.proofs true

-- lemma finset.sum_ite : finset.sum X (λ a, ite (a₀ = a) (f a) (g a)) = ite (a₀ ∈ X) (f a₀) 0 + finset.sum (sorry) g

lemma finset.sum_ite_zero₂ {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f g : α → β) (h_ne : a₀ ≠ a₁):
  finset.sum finset.univ (λ a, ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = f a₀ + g a₁ := begin
  by_cases h₁ : (g a₁ = 0),
    -- Case 1:
    have H₁ : (λ (a : α), ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = (λ (a : α), ite (a₀ = a) (f a) 0),
    funext,
    by_cases h_t : (a₀ = a); simp[h_t],
    by_cases h_t₀ : (a₁ = a), {subst h_t₀, simp[h_t, h₁]}, simp[h_t₀],
    rw H₁,
    rw finset.sum_ite_zero,
    simp[h₁],

    -- Case 2:
    by_cases h₂ : (f a₀ = 0),
    have H₁ : (λ (a : α), ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = (λ (a : α), ite (a₁ = a) (g a) 0),
    funext,
    by_cases h_t : (a₀ = a); simp[h_t],
    by_cases h_t₀ : (a₁ = a),
    subst h_t₀,
    exfalso, from h_ne h_t,
    simp[h_t₀],
    subst h_t,
    from h₂,
    rw H₁,
    -- rw h₂,
    rw finset.sum_ite_zero,
    simp[h₂],

    -- Case 3:
    rw finsupp_of_double_ite_eq_double_ite,
    rw finsupp_of_double_ite_zip_singles,
    repeat{show _ ≠ _, by assumption},

    apply eq.trans (@finsupp_sum_support_subset α _ _ β _ (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)) finset.univ (by apply finset.subset_univ)),

    unfold finsupp.sum,

    have H₄ : disjoint ((finsupp.single a₀ (f a₀)).support) ((finsupp.single a₁ (g a₁)).support),
    dsimp[finsupp.single],
    -- simp[finsupp.single],

    -- simp[finsupp.single],
    simp[h₁, h₂],
    from λ x, h_ne (eq.symm x),

    have H₂, from @finsupp.support_add_eq α β _ _ _ (finsupp.single a₀ (f a₀)) (finsupp.single a₁ (g a₁)) H₄,

    have H₃ : finset.sum ((finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).support)
      (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a) = finset.sum (((finsupp.single a₀ (f a₀)).support) ∪ ((finsupp.single a₁ (g a₁)).support))
      (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a),
    simp,
    congr,
    from H₂,
    simp,
    rw H₃,
    clear H₃ H₂,
    have H₅, from @finset.sum_union α β (finsupp.single a₀ (f a₀)).support (finsupp.single a₁ (g a₁)).support (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a) _ _ ((iff.elim_left finset.disjoint_iff_inter_eq_empty)  H₄),
    apply eq.trans,
    from H₅,
    clear H₅,

    -- have H₁ : finset.sum ((finsupp.single a₀ (f a₀)).support)
    --     (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a) = f a₀,

    have H₄, from @finsupp.add_apply α β _ _ _ (finsupp.single a₀ (f a₀)) (finsupp.single a₁ (g a₁)),
    rw ←coe_to_fun_to_fun,
    have H₅ :
      (λ (x : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun x) =
      (λ (x : α), (finsupp.single a₀ (f a₀)).to_fun x + (finsupp.single a₁ (g a₁)).to_fun x),
    funext,
    have H₄_temp, from @H₄ x,
    simp at H₄_temp,
    from H₄_temp,
    simp,
    rw H₅,
    clear H₄,

    have H₁ : finset.sum ((finsupp.single a₀ (f a₀)).support)
        (λ (x : α), (finsupp.single a₀ (f a₀)).to_fun x + (finsupp.single a₁ (g a₁)).to_fun x) = f a₀,
    -- simp,

    dsimp[finsupp.single],
    simp[h₁, h₂, λ x, h_ne (eq.symm x)],
    simp[H₁],

    clear H₁,
    have H₁ : finset.sum ((finsupp.single a₁ (g a₁)).support)
        (λ (x : α), (finsupp.single a₀ (f a₀)).to_fun x + (finsupp.single a₁ (g a₁)).to_fun x) = g a₁,
    dsimp[finsupp.single],
    simp[h₁, h₂, h_ne],

    simp[H₁],
end