/-
## Pattern matching against MLIR programs

This file implements support for a basic matching system. This system is used
in the framework to concisely express syntactic constraints on operations that
can be resolved by unification. While this cannot express anywhere near all the
constraints, it simplifies the most common ones a great deal.

TODO: Provide the matcher
-/

import MLIR.Semantics.Types
import MLIR.Dialects.BuiltinModel
import MLIR.AST
import MLIR.EDSL
open MLIR.AST

/-
### Match term syntax

We have different sorts (operations, values, types, attributes, etc) with typed
variables. This allows us to know types everywhere in terms, and thus avoid
typing mishaps due to bugs (which would be hard to debug), even if we only have
one type for all terms.

Unlike usual first-order matching and unification, we don't have a deeply
recursive structure, and instead mostly rely on having independent equations to
match complex patterns.

We assign *substitution priority levels* to variables in the form of natural
numbers. Lower values indicate variables that have been introduced by the user,
while higher values are assigned to automatically-generated variables. When a
substitution occurs, we always substitute variables with higher priority so
that user-assigned names are preserved.
-/

inductive MSort :=
  -- An MLIR operation. Matches against [Op δ]
  | MOp
  -- An operation parameter. Matches against (SSAVal × MLIRType δ)
  | MOperand
  -- An MLIR type. Matches against [MLIRType δ]
  | MMLIRType
  -- A value. Matches against [SSAVal]
  | MSSAVal
  -- An attribute. Matches against [AttrVal δ]
  | MAttrValue
  -- A natural number (typically int/float bit size). Matches against [Nat]
  | MNat
  -- A string (in operation names). Matches against [String]
  | MString
  -- A dimension (in a vector/tensor). Matches against [Dimension]
  | MDimension
  -- A signedness specification (in integers). Matches against [Signedness]
  | MSignedness
  -- A homogeneous list of objects
  | MList (s: MSort)

inductive MCtor: List MSort → MSort → Type :=
  -- Integer type
  | INT: MCtor [.MSignedness, .MNat] .MMLIRType
  -- Tensor type
  | TENSOR: MCtor [.MList .MDimension, .MMLIRType] .MMLIRType
  -- Operation with known or unknown mnemonic (TODO: MCtor.OP: unfinished)
  | OP: MCtor [.MString, .MList .MOperand, .MList .MOperand] .MOp
  -- Operation argument of return value
  | OPERAND: MCtor [.MSSAVal, .MMLIRType] .MOperand

  -- SPECIAL CASE: We treat LIST specially in inferSort, to allow variadic
  -- arguments without specifying it here
  | LIST (s: MSort): MCtor [] (.MList s)

inductive MTerm (δ: Dialect α σ ε) :=
  -- A typed variable
  | Var (priority: Nat := 0) (name: String) (s: MSort)
  -- A constructor. We allow building mistyped terms (but check them later)
  | App {args_sort: List MSort} {ctor_sort: MSort}
        (ctor: MCtor args_sort ctor_sort) (args: List (MTerm δ))
  -- Constants
  | ConstMLIRType (τ: MLIRType δ)
  | ConstNat (n: Nat)
  | ConstString (s: String)
  | ConstDimension (d: Dimension)
  | ConstSignedness (sgn: Signedness)

-- Accessors

def MCtor.name {s₁ s₂}: MCtor s₁ s₂ → String
  | LIST _  => "LIST"
  | INT     => "INT"
  | TENSOR  => "TENSOR"
  | OP      => "OP"
  | OPERAND => "OPERAND"

-- Common instances

deriving instance Inhabited for MSort
deriving instance Inhabited for MTerm

deriving instance DecidableEq for MCtor
deriving instance DecidableEq for MSort

def MCtor.eq {args_sort₁ ctor_sort₁ args_sort₂ ctor_sort₂}:
    MCtor args_sort₁ ctor_sort₁ → MCtor args_sort₂ ctor_sort₂ → Bool :=
  fun c₁ c₂ =>
    if H: args_sort₁ = args_sort₂ ∧ ctor_sort₁ = ctor_sort₂ then
      cast (by simp [H.1, H.2]) c₁ = c₂
    else
      false

mutual
def MTerm.eq (t₁ t₂: MTerm δ): Bool :=
  match t₁, t₂ with
  | Var _ name₁ s₁, Var _ name₂ s₂ =>
      name₁ = name₂ && s₁ = s₂
  | App ctor₁ args₁, App ctor₂ args₂ =>
      MCtor.eq ctor₁ ctor₂ && eqList args₁ args₂
  | _, _ => false

def MTerm.eqList (l₁ l₂: List (MTerm δ)): Bool :=
  match l₁, l₂ with
  | [], [] => true
  | t₁::l₁, t₂::l₂ => eq t₁ t₂ && eqList l₁ l₂
  | _, _ => false
end
termination_by
  MTerm.eq t1 t2 => sizeOf t1 + sizeOf t2
  MTerm.eqList t1 t2 => sizeOf t1 + sizeOf t2

instance: BEq (MTerm δ) where
  beq := MTerm.eq

def MSort.str: MSort → String
  | .MOp         => "Op"
  | .MOperand    => "Operand"
  | .MMLIRType   => "MLIRType"
  | .MSSAVal     => "SSAVal"
  | .MAttrValue  => "AttrValue"
  | .MNat        => "Nat"
  | .MString     => "String"
  | .MDimension  => "Dimension"
  | .MSignedness => "Signedness"
  | .MList s     => "[" ++ s.str ++ "]"

mutual
def MTerm.str: MTerm δ → String
  -- Short notations for common sorts of variables
  | .Var _ name .MMLIRType => "!" ++ name
  | .Var _ name .MSSAVal => "%" ++ name
  -- General notation
  | .Var _ name s => "name:" ++ s.str
  | .App ctor args => ctor.name ++ " [" ++ MTerm.strList args ++ "]"
  -- Constants
  | ConstMLIRType c
  | ConstNat c
  | ConstString c
  | ConstDimension c
  | ConstSignedness c =>
      toString c

protected def MTerm.strList: List (MTerm δ) → String
  | [] => ""
  | [t] => str t
  | t::ts => str t ++ ", " ++ MTerm.strList ts
end
termination_by
  MTerm.str t  => sizeOf t
  MTerm.strList ts => sizeOf ts

instance: ToString MSort where
  toString := MSort.str
instance: ToString (MTerm δ) where
  toString := MTerm.str

-- Collect variables in a term
def MTerm.vars: MTerm δ → List String
  | .Var _ name _ => [name]
  | .App ctor [] => []
  | .App ctor (arg::args) =>
      vars arg ++ vars (.App ctor args)
  | _ => []

-- Collect variables and their sorts
def MTerm.varsWithSorts: MTerm δ → List (String × MSort)
  | .Var _ name sort => [(name, sort)]
  | .App ctor [] => []
  | .App ctor (arg::args) =>
      varsWithSorts arg ++ varsWithSorts (.App ctor args)
  | _ => []

-- Check whether a variable occurs in a term. We don't check typing here since
-- we have a common pool of unique variable names.
def MTerm.occurs (name: String): MTerm δ→ Bool
  | .Var _ name' _ => name' = name
  | .App ctor [] => false
  | .App ctor (arg::args) =>
      occurs name arg || occurs name (.App ctor args)
  | _ => false

-- Substitute a variable in a term
mutual
def MTerm.subst (t: MTerm δ) (name: String) (repl: MTerm δ): MTerm δ :=
  match t with
  | .Var _ name' _ => if name' = name then repl else t
  | .App ctor args => .App ctor (MTerm.substList args name repl)
  | t => t

protected def MTerm.substList (l: List (MTerm δ)) (name: String)
                              (repl: MTerm δ) : List (MTerm δ) :=
  match l with
  | [] => []
  | t::ts => subst t name repl :: MTerm.substList ts name repl
end
termination_by
  MTerm.subst t name repl  => sizeOf t
  MTerm.substList ts name repl => sizeOf ts

-- Substitue a set of variables in a term
def MTerm.substVars (t: MTerm δ) (repl: List (String × MTerm δ)): MTerm δ :=
  repl.foldl (fun t (name, repl) => t.subst name repl) t

/-
### Sort inference

In order to ensure we only manipulate well typed match terms and equalities
despite mixing constructors, we aggressively check typing during matching and
unification.
-/

mutual
variable {δ: Dialect α σ ε} -- We need this for termination somehow

def MTerm.inferSort: MTerm δ → Option MSort
  | Var _ _ s => some s
  | App (.LIST s) args => do
      let l ← inferSortList args
      if l.all (· = s) then some (.MList s) else none
  | @App _ _ _ _ args_sort ctor_sort ctor args =>
      if args.length != args_sort.length then
        none
      else if inferSortList args |>.isEqSome args_sort then
        some ctor_sort
      else
        none
  | ConstMLIRType _     => some .MMLIRType
  | ConstNat _          => some .MNat
  | ConstString _       => some .MString
  | ConstDimension _    => some .MDimension
  | ConstSignedness _   => some .MSignedness

def MTerm.inferSortList: List (MTerm δ) → Option (List MSort)
  | [] => some []
  | t::l => do return (← inferSort t) :: (← inferSortList l)
end
termination_by
  MTerm.inferSort t => sizeOf t
  MTerm.inferSortList ts => sizeOf ts

@[reducible]
def MSort.toType (δ: Dialect α σ ε): MSort -> Type
| .MOp => Bool -- TODO MLIR.AST.BasicBlockStmt δ
| .MOperand => MLIR.AST.SSAVal × MLIR.AST.MLIRType δ
| .MMLIRType => MLIR.AST.MLIRType δ
| .MSSAVal => MLIR.AST.SSAVal
| .MAttrValue => Bool -- TODO MLIR.AST.AttrValue δ
| .MNat => Nat
| .MString => String
| .MDimension => Dimension
| .MSignedness => MLIR.AST.Signedness
| .MList mTerm => List (mTerm.toType δ)

def MSort_toType_decEq {δ: Dialect α σ ε} (s: MSort)
    : DecidableEq (s.toType δ) :=
  match s with
  | .MOp => decEq
  | .MOperand => decEq
  | .MMLIRType => decEq
  | .MSSAVal => decEq
  | .MAttrValue => decEq
  | .MNat => decEq
  | .MString => decEq
  | .MDimension => decEq
  | .MSignedness => decEq
  | .MList term => @List.hasDecEq _ (MSort_toType_decEq term)

instance {δ: Dialect α σ ε} (s: MSort): DecidableEq (s.toType δ) :=
  MSort_toType_decEq s

/-
### Variable context for MTerms

This structure contains an assignment from MTerm variables to concrete
structures. It is used both for matching, and for concretizing MTerms into
concrete strucctures.
-/

-- Matching context. Contains the assignment of matching variables.
abbrev VarCtx (δ: Dialect α σ ε) :=
  List ((s: MSort) × List (String × (s.toType δ)))

-- Get the assignment of a variable.
def VarCtx.get (ctx: VarCtx δ) (s: MSort) (name: String) :
    Option (s.toType δ) :=
  match ctx with
  | ⟨so, sortCtx⟩::ctx' =>
    match H: so == s with
    | false => get ctx' s name
    | true => do
      let res ← List.find? (·.fst == name) ((of_decide_eq_true H) ▸ sortCtx)
      return res.snd
  | [] => none

-- Assign a variable.
def VarCtx.set (ctx: VarCtx δ) (s: MSort) (name: String) (value: s.toType δ):
    VarCtx δ :=
  match ctx with
  | ⟨so, sortCtx⟩::ctx' =>
    match H: so == s with
    | false => ⟨so, sortCtx⟩::(set ctx' s name value)
    | true => ⟨so, (name, (of_decide_eq_true H) ▸ value)::sortCtx⟩::ctx'
  | [] => [{fst := s, snd := [(name, value)]}]

/-
### Concretization of MTerm

This section defines some functions to transform a MTerm into some
concrete structure, given a variable context.
-/

-- We provide an expected sort, since we do not want to carry the
-- proof that terms are well typed.
def MTerm.concretizeVariable (m: MTerm δ) (s: MSort) (ctx: VarCtx δ) :
    Option (s.toType δ) :=
  match m with
  | Var _ name sort =>
    if s == sort then ctx.get s name else none
  | _ => none

def MTerm.concretizeSign (m: MTerm δ) (ctx: VarCtx δ) : Option Signedness :=
  match m with
  | Var _ _ _ => m.concretizeVariable .MSignedness ctx
  | ConstSignedness s => some s
  | _ => none

def MTerm.concretizeNat (m: MTerm δ) (ctx: VarCtx δ) : Option Nat :=
  match m with
  | Var _ _ _ => m.concretizeVariable .MNat ctx
  | ConstNat n => some n
  | _ => none

def MTerm.concretizeDim (m: MTerm δ) (ctx: VarCtx δ) : Option Dimension :=
  match m with
  | Var _ _ _ => m.concretizeVariable .MDimension ctx
  | ConstDimension d => some d
  | _ => none

def MTerm.concretizeType (m: MTerm δ) (ctx: VarCtx δ) :
    Option (MLIR.AST.MLIRType δ) :=
  match m with
  | Var _ _ _ => m.concretizeVariable .MMLIRType ctx
  | .App .INT [mSign, mNat] => do
    let sign ← mSign.concretizeSign ctx
    let nat ← mNat.concretizeNat ctx
    return MLIRType.int sign nat
  | _ => none

def MTerm.concretizeOperand (m: MTerm δ) (ctx: VarCtx δ) :
    Option (MLIR.AST.SSAVal × MLIR.AST.MLIRType δ) :=
  match m with
  | Var _ _ _ => m.concretizeVariable .MOperand ctx
  | .App .OPERAND [mVal, mType] => do
    let val ← mVal.concretizeVariable .MSSAVal ctx
    let type ← mType.concretizeType ctx
    return (val, type)
  | _ => none

def MTerm.concretizeOperands (m: MTerm δ) (ctx: VarCtx δ) :
    Option (List (MLIR.AST.TypedSSAVal δ)) :=
  match m with
  | .App (.LIST .MOperand) l => l.mapM (fun m' => m'.concretizeOperand ctx)
  | _ => none

def MTerm.concretizeOp (m: MTerm δ) (ctx: VarCtx δ) : Option (Op δ) :=
  match m with
  | .App .OP [ .ConstString mName, mOperands, mRes ] => do
    let operands ← MTerm.concretizeOperands mOperands ctx
    let res ← MTerm.concretizeOperands mRes ctx
    match res with
    | [resVal] =>
      return .mk mName [resVal] operands [] (AttrDict.mk [])
    | _ => none
  | _ => none

def MTerm.concretizeProg (m: List (MTerm δ)) (ctx: VarCtx δ) :
    Option (List (Op δ)) :=
  m.mapM (fun m' => m'.concretizeOp ctx)

/-
### Simple MTerm matching

This section defines functions to match an MTerm with a concrete structure.
Note that here, the matching does not match recursively inside the concrete
structure.
-/

-- Match a MTerm variable.
def matchVariable {δ: Dialect α σ ε} (s: MSort) (name: String)
                  (val: s.toType δ) (ctx: VarCtx δ) : Option (VarCtx δ) :=
  match ctx.get s name with
  | some matchedVal => if val == matchedVal then some ctx else none
  | none => some (ctx.set s name val)

-- Match a signedness with a MTerm.
def matchMSignedness {δ: Dialect α σ ε} (mSgn: MTerm δ) (sgn: Signedness)
                     (ctx: VarCtx δ): Option (VarCtx δ) :=
  match mSgn with
  | .Var _ name .MSignedness => matchVariable .MSignedness name sgn ctx
  | .ConstSignedness mSgn => if sgn == mSgn then some ctx else none
  | _ => none

-- Match a dimension with a MTerm.
def matchMDimension {δ: Dialect α σ ε} (mDim: MTerm δ) (dim: Dimension)
                    (ctx: VarCtx δ): Option (VarCtx δ) :=
  match mDim with
  | .Var _ name .MDimension => matchVariable .MDimension name dim ctx
  | .ConstDimension mDim => if dim == mDim then some ctx else none
  | _ => none

-- Match a string with a MTerm.
def matchMString {δ: Dialect α σ ε} (mStr: MTerm δ) (str: String)
                 (ctx: VarCtx δ): Option (VarCtx δ) :=
  match mStr with
  | .Var _ name .MString => matchVariable .MString name str ctx
  | .ConstString mStr => if str == mStr then some ctx else none
  | _ => none

-- Match a nat with a MTerm.
def matchMNat {δ: Dialect α σ ε} (mNat: MTerm δ) (nat: Nat)
              (ctx: VarCtx δ): Option (VarCtx δ) :=
  match mNat with
  | .Var _ name .MNat => matchVariable .MNat name nat ctx
  | .ConstNat mNat => if nat == mNat then some ctx else none
  | _ => none

-- Match a type with a MTerm.
def matchMType (mType: MTerm δ) (type: MLIRType δ)
               (ctx: VarCtx δ): Option (VarCtx δ) :=
  match mType, type with
  | .Var _ name .MMLIRType, _ => matchVariable .MMLIRType name type ctx
  | .ConstMLIRType mType, _ => if type == mType then some ctx else none
  | .App .INT [mSgn, mNat], MLIRType.int sgn nat =>
    (matchMSignedness mSgn sgn ctx).bind (matchMNat mNat nat ·)
  | _, _ => none

-- Match a type SSA value with a MTerm.
def matchMSSAVal (mOperand: MTerm δ) (operand: TypedSSAVal δ)
                  (ctx: VarCtx δ) : Option (VarCtx δ) :=
  match mOperand with
  | .App .OPERAND [.Var _ ssaName .MSSAVal, mType] => do
    let ctx' ← matchMType mType operand.snd ctx
    matchVariable MSort.MSSAVal ssaName operand.fst ctx'
  | _ => none

-- Match a list of typed SSA values with a list of MTerm.
def matchMSSAVals (operands: List (TypedSSAVal δ)) (mOperands: List (MTerm δ))
    (ctx: VarCtx δ): Option (VarCtx δ) :=
  match operands, mOperands with
  | [], [] => some ctx
  | operand::operands, mOperand::mOperands => do
    let ctx' ← matchMSSAVal mOperand operand ctx
    matchMSSAVals operands mOperands ctx'
  | _, _ => none

-- Match a basic block statement with an MTerm.
def matchMOp (op: Op δ) (mterm: MTerm δ) (ctx: VarCtx δ) : Option (VarCtx δ) :=
  match op, mterm with
  | Op.mk name res operands [] (AttrDict.mk []),
    .App .OP [ .ConstString mName, .App (.LIST .MOperand) mOperands,
      .App (.LIST .MOperand) mRes ] =>
    if name != mName then
      none
    else
      (matchMSSAVals operands mOperands ctx).bind
      (matchMSSAVals res mRes ·)
  | _, _ => none

/-
### Recursive MTerm op matching

This section defines functions to match an op MTerm inside a concrete
structure. Here, the matching is done recursively inside the regions/BBs/Ops.

We first define functions that match all possible ops in the IR. Then, we use
this to match a program in an IR.
-/

mutual
-- Get all possible operations matching an MTerm in an op.
def matchAllMOpInOp (op: Op δ) (mOp: MTerm δ) (ctx: VarCtx δ)
    : List (Op δ × VarCtx δ) :=
  match op with
  | .mk _ _ _ regions _ =>
    let nextMatches := matchAllMOpInRegions regions mOp ctx
    match matchMOp op mOp ctx with
    | some ctx' => (op, ctx')::nextMatches
    | none => nextMatches

-- Get all possible operations matching an MTerm in a list of ops.
def matchAllMOpInOps (ops: List (Op δ)) (mOp: MTerm δ)
                     (ctx: VarCtx δ) : List (Op δ × VarCtx δ) :=
  match ops with
  | op::ops' => (matchAllMOpInOp op mOp ctx).append
    (matchAllMOpInOps ops' mOp ctx)
  | [] => []

-- Get all possible operations matching an MTerm in a basic block.
def matchAllMOpInRegion (rgn: Region δ) (mOp: MTerm δ)
                    (ctx: VarCtx δ) : List (Op δ × VarCtx δ) :=

  match rgn with
  | .mk _ _ ops => matchAllMOpInOps ops mOp ctx

-- Get all possible operations matching an MTerm in a list of regions.
def matchAllMOpInRegions (regions: List (Region δ)) (mOp: MTerm δ)
                         (ctx: VarCtx δ) :
    List (Op δ × VarCtx δ) :=
  match regions with
  | region::regions' => (matchAllMOpInRegion region mOp ctx).append
    (matchAllMOpInRegions regions' mOp ctx)
  | [] => []
end
termination_by
  matchAllMOpInOp op _ _ => sizeOf op
  matchAllMOpInOps ops _ _ => sizeOf ops
  matchAllMOpInRegion region _ _ => sizeOf region
  matchAllMOpInRegions regions _ _ => sizeOf regions

mutual
variable {δ: Dialect α σ ε} -- We need this for termination somehow

#check Preorder
-- Match a program defined by a list of MTerm (one Operation per MTerm) in
-- an operation.
def matchMProgInOp (op: Op δ) (mOps: List (MTerm δ)) (ctx: VarCtx δ) :
    Option ((List (Op δ)) × VarCtx δ) :=
  match mOps with
  -- Try all matches of the first operation.
  | mOp::mOps' =>
    matchMProgInOpAux op mOps' (matchAllMOpInOp op mOp ctx)
  | [] => some ([], ctx)

-- Match a program defined by a list of MTerm (one Operation per MTerm) in
-- an operation. `matchOps` correspond to the possible matches of the current
-- MTerm being matched.
def matchMProgInOpAux (op: Op δ) (mOps: List (MTerm δ))
                      (matchOps: List (Op δ × VarCtx δ))
                      : Option (List (Op δ) × VarCtx δ) :=
  -- For all possible match, we check if we can match the remaining of the
  -- program with the match assignment
  match matchOps with
  | (matchOp, ctx')::matchOps' =>
    match matchMProgInOp op mOps ctx' with
    -- If we do match the remaining of the program, we are finished.
    | some (matchedOps, ctx'') => some (matchOp::matchedOps, ctx'')
    -- Otherwise, we check the next match for the current operation.
    | none => matchMProgInOpAux op mOps matchOps'
  | [] => none
end
-- TODO: how to use lex ordering for termination? Proof of termination: lex ordering on (mOps, matchOps)
decreasing_by sorry
/-
termination_by
  matchMProgInOpAux _ mOps matchOps => sizeOf (mOps, matchOps)
  matchMProgInOp _ mOps ctx  =>
    sizeOf (mOps, let t : List (Op δ × VarCtx δ) := []; t)
-/

-- variable type
def MTerm.buildTypeVar (name: String) : MTerm δ := .Var 2 name .MMLIRType
-- constant type

def MTerm.buildTypeConst (type: MLIRType δ) : MTerm δ := .ConstMLIRType type

-- operand. For now, assume monomorhpic types.
def MTerm.buildOperand (name: String) (type: MLIRType δ): MTerm δ :=
  .App .OPERAND [ .Var (priority := 2) name .MSSAVal,
                  MTerm.buildTypeConst type ]

def MTerm.buildOp (name: String) (args: List (MTerm δ)) (res: List (MTerm δ)) :
    MTerm δ :=
  .App .OP [ .ConstString name, .App (.LIST .MOperand) args,
    .App (.LIST .MOperand) res ]

private def test_addi_multiple_pattern: List (MTerm δ) :=
  [.App .OP [
    .ConstString "std.addi",
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 2 "op_x" .MSSAVal, .Var 2 "T" .MMLIRType],
      .App .OPERAND [.Var 2 "op_y" .MSSAVal, .Var 2 "T" .MMLIRType]],
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 2 "op_res" .MSSAVal, .Var 2 "T" .MMLIRType]]
  ],
  .App .OP [
    .ConstString "std.addi",
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 2 "op_res" .MSSAVal, .Var 2 "T" .MMLIRType],
      .App .OPERAND [.Var 2 "op_res" .MSSAVal, .Var 2 "T" .MMLIRType]],
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 2 "op_res2" .MSSAVal, .Var 2 "T" .MMLIRType]]
  ]]

private def multiple_example: Op builtin := [mlir_op|
  "builtin.module"() ({
    ^entry:
    %r2 = "std.addi"(%t2, %t3): (i32, i32) -> i32
    %r = "std.addi"(%t0, %t1): (i32, i32) -> i32
    %r3 = "std.addi"(%r, %r): (i32, i32) -> i32
  }) : () -> ()
]

private def test_addi_one: MTerm δ :=
  (.App .OP [
    .ConstString "std.addi",
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 2 "op_x" .MSSAVal, .Var 2 "T" .MMLIRType],
      .App .OPERAND [.Var 2 "op_y" .MSSAVal, .Var 2 "T" .MMLIRType]],
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 2 "op_res" .MSSAVal, .Var 2 "T" .MMLIRType]]
  ])

private def one_example: Op builtin := [mlir_op|
    %r2 = "std.addi"(%t2, %t3): (i32, i32) -> i32
]

-- Match an MTerm program in some IR, then concretize
-- the MTerm using the resulting matching context.
def multiple_example_result : Option (List (Op builtin)) := do
  let (_, ctx) ←
    matchMProgInOp multiple_example test_addi_multiple_pattern []
  let res ← MTerm.concretizeProg test_addi_multiple_pattern ctx
  res

#eval multiple_example_result

/-
### Exact program matching
This section defines functions to check if an operation, or SSA values
definitions/uses are inside a bigger program.

The operation to match should not have any regions or attributes.
-/

def eqOp (op1 op2: Op δ) : Bool :=
  match op1, op2 with
  | .mk name res args [] (.mk []), .mk name' res' args' [] (.mk []) =>
    name == name' && res == res' && args == args'
  | _, _ => false

mutual
variable (mOp: Op δ)

def isOpInOp (op: Op δ) : Bool :=
  eqOp op mOp ||
    (match op with
     | .mk _ _ _ regions _ => isOpInRegions regions)

def isOpInRegions (regions: List (Region δ)) : Bool :=
  match regions with
  | [] => False
  | region::regions' => isOpInRegion region || isOpInRegions regions'

def isOpInRegion (rgn: Region δ) : Bool :=
  match rgn with
  | .mk _ _ ops => isOpInOps ops

def isOpInOps (ops: List (Op δ)) : Bool :=
  match ops with
  | [] => False
  | op::ops' => isOpInOp op || isOpInOps ops'
end
 termination_by
  isOpInOp op => sizeOf op
  isOpInRegions rgns => sizeOf rgns
  isOpInRegion rgn => sizeOf rgn
  isOpInOps ops => sizeOf ops


theorem ex6 (f : Nat → Nat) (x y z : Nat) (h : (x, z).1 = (fun x => x) y) : f x = f y := by
  simp (config := { beta := false }) at h
  trace_state
  simp at h
  trace_state
  simp [h]


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.basic
import Mathlib.PostPort

universes u_1 u_2 l

namespace Mathlib

/-!
# Extended norm

In this file we define a structure `enorm 𝕜 V` representing an extended norm (i.e., a norm that can
take the value `∞`) on a vector space `V` over a normed field `𝕜`. We do not use `class` for
an `enorm` because the same space can have more than one extended norm. For example, the space of
measurable functions `f : α → ℝ` has a family of `L_p` extended norms.

We prove some basic inequalities, then define

* `emetric_space` structure on `V` corresponding to `e : enorm 𝕜 V`;
* the subspace of vectors with finite norm, called `e.finite_subspace`;
* a `normed_space` structure on this space.

The last definition is an instance because the type involves `e`.

## Implementation notes

We do not define extended normed groups. They can be added to the chain once someone will need them.

## Tags

normed space, extended norm
-/

/-- Extended norm on a vector space. As in the case of normed spaces, we require only
`∥c • x∥ ≤ ∥c∥ * ∥x∥` in the definition, then prove an equality in `map_smul`. -/
structure enorm (𝕜 : Type u_1) (V : Type u_2) [normed_field 𝕜] [add_comm_group V] [vector_space 𝕜 V]
    where
  to_fun : V → ennreal
  eq_zero' : ∀ (x : V), to_fun x = 0 → x = 0
  map_add_le' : ∀ (x y : V), to_fun (x + y) ≤ to_fun x + to_fun y
  map_smul_le' : ∀ (c : 𝕜) (x : V), to_fun (c • x) ≤ ↑(nnnorm c) * to_fun x

namespace enorm

protected instance has_coe_to_fun {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] : has_coe_to_fun (enorm 𝕜 V) :=
  has_coe_to_fun.mk (fun (x : enorm 𝕜 V) => V → ennreal) to_fun

theorem injective_coe_fn {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] : function.injective fun (e : enorm 𝕜 V) (x : V) => coe_fn e x :=
  sorry

theorem ext {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V] [vector_space 𝕜 V]
    {e₁ : enorm 𝕜 V} {e₂ : enorm 𝕜 V} (h : ∀ (x : V), coe_fn e₁ x = coe_fn e₂ x) : e₁ = e₂ :=
  injective_coe_fn (funext h)

theorem ext_iff {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V] [vector_space 𝕜 V]
    {e₁ : enorm 𝕜 V} {e₂ : enorm 𝕜 V} : e₁ = e₂ ↔ ∀ (x : V), coe_fn e₁ x = coe_fn e₂ x :=
  { mp := fun (h : e₁ = e₂) (x : V) => h ▸ rfl, mpr := ext }

@[simp] theorem coe_inj {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] {e₁ : enorm 𝕜 V} {e₂ : enorm 𝕜 V} : ⇑e₁ = ⇑e₂ ↔ e₁ = e₂ :=
  function.injective.eq_iff injective_coe_fn

@[simp] theorem map_smul {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (c : 𝕜) (x : V) :
    coe_fn e (c • x) = ↑(nnnorm c) * coe_fn e x :=
  sorry

@[simp] theorem map_zero {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) : coe_fn e 0 = 0 :=
  sorry

@[simp] theorem eq_zero_iff {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) {x : V} : coe_fn e x = 0 ↔ x = 0 :=
  { mp := eq_zero' e x, mpr := fun (h : x = 0) => Eq.symm h ▸ map_zero e }

@[simp] theorem map_neg {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : V) : coe_fn e (-x) = coe_fn e x :=
  sorry

theorem map_sub_rev {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : V) (y : V) : coe_fn e (x - y) = coe_fn e (y - x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn e (x - y) = coe_fn e (y - x))) (Eq.symm (neg_sub y x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn e (-(y - x)) = coe_fn e (y - x))) (map_neg e (y - x))))
      (Eq.refl (coe_fn e (y - x))))

theorem map_add_le {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : V) (y : V) :
    coe_fn e (x + y) ≤ coe_fn e x + coe_fn e y :=
  map_add_le' e x y

theorem map_sub_le {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : V) (y : V) :
    coe_fn e (x - y) ≤ coe_fn e x + coe_fn e y :=
  sorry

protected instance partial_order {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] : partial_order (enorm 𝕜 V) :=
  partial_order.mk (fun (e₁ e₂ : enorm 𝕜 V) => ∀ (x : V), coe_fn e₁ x ≤ coe_fn e₂ x)
    (preorder.lt._default fun (e₁ e₂ : enorm 𝕜 V) => ∀ (x : V), coe_fn e₁ x ≤ coe_fn e₂ x) sorry
    sorry sorry

/-- The `enorm` sending each non-zero vector to infinity. -/
protected instance has_top {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] : has_top (enorm 𝕜 V) :=
  has_top.mk (mk (fun (x : V) => ite (x = 0) 0 ⊤) sorry sorry sorry)

protected instance inhabited {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] : Inhabited (enorm 𝕜 V) :=
  { default := ⊤ }

theorem top_map {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V] [vector_space 𝕜 V]
    {x : V} (hx : x ≠ 0) : coe_fn ⊤ x = ⊤ :=
  if_neg hx

protected instance semilattice_sup_top {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜]
    [add_comm_group V] [vector_space 𝕜 V] : semilattice_sup_top (enorm 𝕜 V) :=
  semilattice_sup_top.mk ⊤ LessEq Less sorry sorry sorry sorry
    (fun (e₁ e₂ : enorm 𝕜 V) =>
      mk (fun (x : V) => max (coe_fn e₁ x) (coe_fn e₂ x)) sorry sorry sorry)
    sorry sorry sorry

@[simp] theorem coe_max {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e₁ : enorm 𝕜 V) (e₂ : enorm 𝕜 V) :
    ⇑(e₁ ⊔ e₂) = fun (x : V) => max (coe_fn e₁ x) (coe_fn e₂ x) :=
  rfl

theorem max_map {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V] [vector_space 𝕜 V]
    (e₁ : enorm 𝕜 V) (e₂ : enorm 𝕜 V) (x : V) :
    coe_fn (e₁ ⊔ e₂) x = max (coe_fn e₁ x) (coe_fn e₂ x) :=
  rfl

/-- Structure of an `emetric_space` defined by an extended norm. -/
def emetric_space {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) : emetric_space V :=
  emetric_space.mk sorry sorry (map_sub_rev e) sorry
    (uniform_space_of_edist (fun (x y : V) => coe_fn e (x - y)) sorry (map_sub_rev e) sorry)

/-- The subspace of vectors with finite enorm. -/
def finite_subspace {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) : subspace 𝕜 V :=
  submodule.mk (set_of fun (x : V) => coe_fn e x < ⊤) sorry sorry sorry

/-- Metric space structure on `e.finite_subspace`. We use `emetric_space.to_metric_space_of_dist`
to ensure that this definition agrees with `e.emetric_space`. -/
protected instance finite_subspace.metric_space {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜]
    [add_comm_group V] [vector_space 𝕜 V] (e : enorm 𝕜 V) : metric_space ↥(finite_subspace e) :=
  let _inst : emetric_space V := emetric_space e;
  emetric_space.to_metric_space_of_dist
    (fun (x y : ↥(finite_subspace e)) => ennreal.to_real (edist x y)) sorry sorry

theorem finite_dist_eq {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : ↥(finite_subspace e)) (y : ↥(finite_subspace e)) :
    dist x y = ennreal.to_real (coe_fn e (↑x - ↑y)) :=
  rfl

theorem finite_edist_eq {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : ↥(finite_subspace e)) (y : ↥(finite_subspace e)) :
    edist x y = coe_fn e (↑x - ↑y) :=
  rfl

/-- Normed group instance on `e.finite_subspace`. -/
protected instance finite_subspace.normed_group {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜]
    [add_comm_group V] [vector_space 𝕜 V] (e : enorm 𝕜 V) : normed_group ↥(finite_subspace e) :=
  normed_group.mk sorry

theorem finite_norm_eq {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜] [add_comm_group V]
    [vector_space 𝕜 V] (e : enorm 𝕜 V) (x : ↥(finite_subspace e)) :
    norm x = ennreal.to_real (coe_fn e ↑x) :=
  rfl

/-- Normed space instance on `e.finite_subspace`. -/
protected instance finite_subspace.normed_space {𝕜 : Type u_1} {V : Type u_2} [normed_field 𝕜]
    [add_comm_group V] [vector_space 𝕜 V] (e : enorm 𝕜 V) : normed_space 𝕜 ↥(finite_subspace e) :=
  normed_space.mk sorry

end Mathlib


import tactic
import data.list.func

universe u

def list2d (α : Type u) := list (list α)

namespace list2d

open list.func

variables {α : Type} {β : Type}
variables [inhabited α] [inhabited β]

@[simp] def get2d (xy : ℕ × ℕ) (l : list2d α) : α
  := let (x,y) := xy in get x (get y l)
@[simp] def set2d (a : α) (l : list2d α) (xy : ℕ × ℕ) : list2d α
  := let (x,y) := xy in set (set a (get y l) x) l y
@[simp] def dfzip2d (l1 : list2d α) (l2 : list2d β) : list2d (α × β)
  := (pointwise (pointwise prod.mk) l1 l2)
@[simp] def add_to_line1 (a : α) : list2d α -> list2d α
| [] := [[a]]
| (h::t) := (a::h)::t

@[simp] def transpose : list2d α → list2d α := (list.foldr (pointwise list.cons)) []

instance [has_repr α] : has_repr (list2d α) := ⟨λ l, list.repr (l : list (list α))⟩

#eval transpose [[1, 2], [3, 4, 5], [6]]

end list2d

inductive direction : Type
| up
| down
| left
| right

namespace direction

def opposite : direction -> direction
| up := down
| down := up
| left := right
| right := left

def shift : direction -> (ℕ × ℕ) -> option (ℕ × ℕ)
| up (_, 0)     := none
| up (x, y+1)   := some (x, y)
| down (x, y)   := some (x, y+1)
| left (0, _)   := none
| left (x+1, y) := some (x, y)
| right (x, y)   := some (x+1, y)

end direction

structure sokoban :=
(available : list2d bool)
(boxes : list2d bool)
(storages : list2d bool)
(storekeeper : ℕ × ℕ)

namespace sokoban
open list2d

instance : inhabited sokoban
:= ⟨{ available := [[tt]], boxes := [], storages := [], storekeeper := (0,0) }⟩

def move (d : direction) (s : sokoban) : sokoban :=
  match (d.shift s.storekeeper) with none := s
  | some sk2 :=
  if get2d sk2 s.available = false then s else
  if get2d sk2 s.boxes = false then
    { storekeeper := sk2, ..s}
  else
    match (d.shift sk2) with none := s
    | some box2 :=
    if (get2d box2 s.available = false)
      ∨ (get2d box2 s.boxes = true) then s else
    {
      boxes := (s.boxes.set2d ff sk2).set2d tt box2,
      storekeeper := sk2, ..s
    }
    end
  end

def move_up := move direction.up
def move_down := move direction.down
def move_left := move direction.left
def move_right := move direction.right

def add_newline (s : sokoban) : sokoban := {
  available := []::s.available,
  boxes := []::s.boxes,
  storages := []::s.storages,
  storekeeper := match s.storekeeper with (x,y) := (x,y+1) end
}
def add_newsquare (av box stor sk : bool) (s : sokoban) : sokoban := {
  available := add_to_line1 av s.available,
  boxes := add_to_line1 box s.boxes,
  storages := add_to_line1 stor s.storages,
  storekeeper := if sk then (0, 0) else match s.storekeeper with
    | (x,0) := (x+1,0)
    | xy := xy
  end
}

def from_string_aux : list char → option (sokoban × bool)
| [] := some (sokoban.mk [] [] [] (0,0), ff)
| (c::str) := match (from_string_aux str), c with
  | none, _ := none
  | (some (s, sk_set)), '\n' := some (add_newline s, sk_set)
  | (some (s, sk_set)), ' ' := some (add_newsquare tt ff ff ff s, sk_set)
  | (some (s, sk_set)), '#' := some (add_newsquare ff ff ff ff s, sk_set)
  | (some (s, sk_set)), '.' := some (add_newsquare tt ff tt ff s, sk_set)
  | (some (s, sk_set)), '$' := some (add_newsquare tt tt ff ff s, sk_set)
  | (some (s, sk_set)), '*' := some (add_newsquare tt tt tt ff s, sk_set)
  | (some (s, ff)), '@' := some (add_newsquare tt ff ff tt s, tt)
  | (some (s, ff)), '+' := some (add_newsquare tt ff tt tt s, tt)
  | (some _), _ := none
  end

def from_string (str : string) : sokoban :=
  match (from_string_aux str.to_list) with
  | none := default sokoban
  | some (_, ff) := default sokoban
  | some (level, tt) := level
  end

def square_to_char : bool → bool → bool → bool → char
| tt ff ff ff := ' '
| ff ff ff ff := '#'
| tt ff tt ff := '.'
| tt tt ff ff := '$'
| tt tt tt ff := '*'
| tt ff ff tt := '@'
| tt ff tt tt := '+'
| _ _ _ _ := '?'

def to_string_aux1 (str : list char) : list (bool × bool × bool × bool) → list char
| [] := str
| ((av,box,stor,sk)::t) := (square_to_char av box stor sk)::(to_string_aux1 t)

def to_string_aux2 : list2d (bool × bool × bool × bool) → list char
| [] := []
| (h::t) := to_string_aux1 ('\n'::(to_string_aux2 t)) h

instance : has_to_string sokoban := ⟨λ s,
  list.as_string (to_string_aux2
  (dfzip2d s.available (dfzip2d s.boxes (dfzip2d s.storages (set2d true [] s.storekeeper)))))
⟩

instance : has_repr sokoban
:= ⟨λ s, (string.append (string.append "sokoban.from_string \"" (to_string s)) "\"")⟩

inductive solvable : sokoban -> Prop
| solved (s : sokoban) (H : s.boxes = s.storages) : solvable s
| move (d : direction) (s : sokoban) (H : solvable (s.move d)) : solvable s

def solvable.move_up := solvable.move direction.up
def solvable.move_down := solvable.move direction.down
def solvable.move_left := solvable.move direction.left
def solvable.move_right := solvable.move direction.right

meta def soko_simp_root (e : expr) : tactic unit :=
do
  soko ← tactic.eval_expr sokoban e,
  tactic.trace (to_string soko),
  let p : pexpr := ``(%%e = sokoban.mk
    %%soko.available %%soko.boxes %%soko.storages %%soko.storekeeper),
  eq ← tactic.to_expr p,
  name ← tactic.get_unused_name,
  H ← tactic.assert name eq,
  tactic.reflexivity,
  tactic.rewrite_target H,
  tactic.clear H

meta def soko_simp_expr : expr → tactic unit := assume e : expr,
soko_simp_root e <|> match e with
| expr.app e1 e2 := soko_simp_expr e1 >> soko_simp_expr e2
| _ := return ()
end

meta def soko_simp : tactic unit :=
do
  goal ← tactic.target,
  soko_simp_expr goal

#check tactic.apply

meta def solve_up : tactic unit := tactic.apply `(solvable.move_up) >> soko_simp
meta def solve_down : tactic unit := tactic.apply `(solvable.move_down) >> soko_simp
meta def solve_left : tactic unit := tactic.apply `(solvable.move_left) >> soko_simp
meta def solve_right : tactic unit := tactic.apply `(solvable.move_right) >> soko_simp
meta def solve_finish : tactic unit := tactic.apply `(sokoban.solvable.solved) >> tactic.reflexivity

end sokoban

def soko_level := sokoban.from_string "
#######
#. . .#
# $$$ #
#.$@$.#
# $$$ #
#. . .#
#######
"

example : soko_level.solvable :=
begin
  sokoban.soko_simp,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_right,
  sokoban.solve_right,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_down,
  sokoban.solve_left,
  sokoban.solve_right,
  sokoban.solve_right,
  sokoban.solve_up,
  sokoban.solve_right,
  sokoban.solve_up,
  sokoban.solve_down,
  sokoban.solve_left,
  sokoban.solve_left,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_right,
  sokoban.solve_up,
  sokoban.solve_up,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_right,
  sokoban.solve_down,
  sokoban.solve_right,
  sokoban.solve_right,
  sokoban.solve_right,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_down,
  sokoban.solve_down,
  sokoban.solve_right,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_up,
  sokoban.solve_up,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_down,
  sokoban.solve_down,
  sokoban.solve_down,
  sokoban.solve_right,
  sokoban.solve_right,
  sokoban.solve_up,
  sokoban.solve_up,
  sokoban.solve_left,
  sokoban.solve_down,
  sokoban.solve_up,
  sokoban.solve_up,
  sokoban.solve_finish
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Instances of `traversable` for types from the core library
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.forall2
import Mathlib.data.set.lattice
import Mathlib.control.traversable.lemmas
import Mathlib.PostPort

universes u_1 u

namespace Mathlib

theorem option.id_traverse {α : Type u_1} (x : Option α) : option.traverse id.mk x = x :=
  option.cases_on x (Eq.refl (option.traverse id.mk none)) fun (x : α) => Eq.refl (option.traverse id.mk (some x))

theorem option.comp_traverse {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u_1} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → G β) (x : Option α) : option.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x = functor.comp.mk (option.traverse f <$> option.traverse g x) := sorry

theorem option.traverse_eq_map_id {α : Type u_1} {β : Type u_1} (f : α → β) (x : Option α) : traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
  option.cases_on x (Eq.refl (traverse (id.mk ∘ f) none)) fun (x : α) => Eq.refl (traverse (id.mk ∘ f) (some x))

theorem option.naturality {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] (η : applicative_transformation F G) {α : Type u_1} {β : Type u} (f : α → F β) (x : Option α) : coe_fn η (Option β) (option.traverse f x) = option.traverse (coe_fn η β ∘ f) x := sorry

protected instance option.is_lawful_traversable : is_lawful_traversable Option :=
  is_lawful_traversable.mk option.id_traverse option.comp_traverse option.traverse_eq_map_id option.naturality

namespace list

protected theorem id_traverse {α : Type u_1} (xs : List α) : list.traverse id.mk xs = xs := sorry

protected theorem comp_traverse {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u_1} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → G β) (x : List α) : list.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x = functor.comp.mk (list.traverse f <$> list.traverse g x) := sorry

protected theorem traverse_eq_map_id {α : Type u_1} {β : Type u_1} (f : α → β) (x : List α) : list.traverse (id.mk ∘ f) x = id.mk (f <$> x) := sorry

protected theorem naturality {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] (η : applicative_transformation F G) {α : Type u_1} {β : Type u} (f : α → F β) (x : List α) : coe_fn η (List β) (list.traverse f x) = list.traverse (coe_fn η β ∘ f) x := sorry

protected instance is_lawful_traversable : is_lawful_traversable List :=
  is_lawful_traversable.mk list.id_traverse list.comp_traverse list.traverse_eq_map_id list.naturality

@[simp] theorem traverse_nil {F : Type u → Type u} [Applicative F] {α' : Type u} {β' : Type u} (f : α' → F β') : traverse f [] = pure [] :=
  rfl

@[simp] theorem traverse_cons {F : Type u → Type u} [Applicative F] {α' : Type u} {β' : Type u} (f : α' → F β') (a : α') (l : List α') : traverse f (a :: l) = (fun (_x : β') (_y : List β') => _x :: _y) <$> f a <*> traverse f l :=
  rfl

@[simp] theorem traverse_append {F : Type u → Type u} [Applicative F] {α' : Type u} {β' : Type u} (f : α' → F β') [is_lawful_applicative F] (as : List α') (bs : List α') : traverse f (as ++ bs) = append <$> traverse f as <*> traverse f bs := sorry

theorem mem_traverse {α' : Type u} {β' : Type u} {f : α' → set β'} (l : List α') (n : List β') : n ∈ traverse f l ↔ forall₂ (fun (b : β') (a : α') => b ∈ f a) n l := sorry

end list

namespace sum

protected theorem traverse_map {σ : Type u} {G : Type u → Type u} [Applicative G] {α : Type u} {β : Type u} {γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) : sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x := sorry

protected theorem id_traverse {σ : Type u_1} {α : Type u_1} (x : σ ⊕ α) : sum.traverse id.mk x = x :=
  sum.cases_on x (fun (x : σ) => Eq.refl (sum.traverse id.mk (inl x))) fun (x : α) => Eq.refl (sum.traverse id.mk (inr x))

protected theorem comp_traverse {σ : Type u} {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u_1} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) : sum.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x = functor.comp.mk (sum.traverse f <$> sum.traverse g x) := sorry

protected theorem traverse_eq_map_id {σ : Type u} {α : Type u} {β : Type u} (f : α → β) (x : σ ⊕ α) : sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) := sorry

protected theorem map_traverse {σ : Type u} {G : Type u → Type u} [Applicative G] [is_lawful_applicative G] {α : Type u_1} {β : Type u} {γ : Type u} (g : α → G β) (f : β → γ) (x : σ ⊕ α) : Functor.map f <$> sum.traverse g x = sum.traverse (Functor.map f ∘ g) x := sorry

protected theorem naturality {σ : Type u} {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] (η : applicative_transformation F G) {α : Type u_1} {β : Type u} (f : α → F β) (x : σ ⊕ α) : coe_fn η (σ ⊕ β) (sum.traverse f x) = sum.traverse (coe_fn η β ∘ f) x := sorry

protected instance is_lawful_traversable {σ : Type u} : is_lawful_traversable (sum σ) :=
  is_lawful_traversable.mk sum.id_traverse sum.comp_traverse sum.traverse_eq_map_id sum.naturality


/-
Copyright (c) 2021 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Classes.SetNotation
import Std.Classes.LawfulMonad
import Std.Tactic.NoMatch

namespace Option

/-- An elimination principle for `Option`. It is a nondependent version of `Option.recOn`. -/
@[simp] protected def elim : Option α → β → (α → β) → β
  | some x, _, f => f x
  | none, y, _ => y

instance : Membership α (Option α) := ⟨fun a b => b = some a⟩

@[simp] theorem mem_def {a : α} {b : Option α} : a ∈ b ↔ b = some a := .rfl

theorem isNone_iff_eq_none {o : Option α} : o.isNone ↔ o = none :=
  ⟨Option.eq_none_of_isNone, fun e => e.symm ▸ rfl⟩

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

/--
`o = none` is decidable even if the wrapped type does not have decidable equality.
This is not an instance because it is not definitionally equal to `instance : DecidableEq Option`.
Try to use `o.isNone` or `o.isSome` instead.
-/
@[inline] def decidable_eq_none {o : Option α} : Decidable (o = none) :=
  decidable_of_decidable_of_iff isNone_iff_eq_none

instance {p : α → Prop} [DecidablePred p] : ∀ o : Option α, Decidable (∀ a ∈ o, p a)
| none => isTrue (by simp)
| some a =>
  if h : p a then isTrue fun o e => some_inj.1 e ▸ h
  else isFalse <| mt (· _ rfl) h

instance {p : α → Prop} [DecidablePred p] : ∀ o : Option α, Decidable (∃ a ∈ o, p a)
| none => isFalse fun.
| some a => if h : p a then isTrue ⟨_, rfl, h⟩ else isFalse fun ⟨_, ⟨rfl, hn⟩⟩ => h hn

/-- Extracts the value `a` from an option that is known to be `some a` for some `a`. -/
def get {α : Type u} : (o : Option α) → isSome o → α
  | some x, _ => x

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [DecidablePred p] (a : α) : Option α := if p a then some a else none

/--
Cast of `Option` to `List`. Returns `[a]` if the input is `some a`, and `[]` if it is `none`.
-/
def toList : Option α → List α
  | none => []
  | some a => [a]

/--
Cast of `Option` to `Array`. Returns `[a]` if the input is `some a`, and `[]` if it is `none`.
-/
def toArray : Option α → Array α
  | none => #[]
  | some a => #[a]

/--
Two arguments failsafe function. Returns `f a b` if the inputs are `some a` and `some b`, and
"does nothing" otherwise.
-/
def liftOrGet (f : α → α → α) : Option α → Option α → Option α
  | none, none => none
  | some a, none => some a
  | none, some b => some b
  | some a, some b => some (f a b)

/-- Lifts a relation `α → β → Prop` to a relation `Option α → Option β → Prop` by just adding
`none ~ none`. -/
inductive Rel (r : α → β → Prop) : Option α → Option β → Prop
  /-- If `a ~ b`, then `some a ~ some b` -/
  | some {a b} : r a b → Rel r (some a) (some b)
  /-- `none ~ none` -/
  | none : Rel r none none

/--
Partial bind. If for some `x : Option α`, `f : Π (a : α), a ∈ x → Option β` is a
partial function defined on `a : α` giving an `Option β`, where `some a = x`,
then `pbind x f h` is essentially the same as `bind x f`
but is defined only when all `x = some a`, using the proof to apply `f`.
-/
@[simp]
def pbind : ∀ x : Option α, (∀ a : α, a ∈ x → Option β) → Option β
  | none, _ => none
  | some a, f => f a rfl

/--
Partial map. If `f : Π a, p a → β` is a partial function defined on `a : α` satisfying `p`,
then `pmap f x h` is essentially the same as `map f x` but is defined only when all members of `x`
satisfy `p`, using the proof to apply `f`.
-/
@[simp] def pmap {p : α → Prop} (f : ∀ a : α, p a → β) : ∀ x : Option α, (∀ a ∈ x, p a) → Option β
  | none, _ => none
  | some a, H => f a (H a rfl)

/-- Flatten an `Option` of `Option`, a specialization of `joinM`. -/
@[simp, inline] def join (x : Option (Option α)) : Option α := x.bind id

/-- Map a monadic function which returns `Unit` over an `Option`. -/
protected def forM [Pure m] : Option α → (α → m PUnit) → m PUnit
  | none  , _ => pure ()
  | some a, f => f a

instance : ForM m (Option α) α :=
  ⟨Option.forM⟩

instance : ForIn' m (Option α) α inferInstance where
  forIn' x init f := do
    match x with
    | none => return init
    | some a =>
      match ← f a rfl init with
      | .done r | .yield r => return r

/-- Like `Option.mapM` but for applicative functors. -/
protected def mapA [Applicative m] {α β} (f : α → m β) : Option α → m (Option β)
  | none => pure none
  | some x => some <$> f x

/--
If you maybe have a monadic computation in a `[Monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result.
-/
def sequence [Monad m] {α : Type u} : Option (m α) → m (Option α)
  | none => pure none
  | some fn => some <$> fn

/-- A monadic analogue of `Option.elim`. -/
@[inline] def elimM [Monad m] (x : m (Option α)) (y : m β) (z : α → m β) : m β :=
  do (← x).elim y z

/-- A monadic analogue of `Option.getD`. -/
@[inline] def getDM [Monad m] (x : Option α) (y : m α) : m α :=
  match x with
  | some a => pure a
  | none => y


import C0deine.AuxDefs

namespace C0deine.Utils.CliFormat

structure Rect where
  (width height : Nat)
  lines : List String
  h_height : lines.length = height
  h_width : ∀ l, l ∈ lines → l.length = width

def Rect.ofLines (lines : List String) : Rect :=
  let width := lines.foldr (max ·.length) 0
  have : ∀ l, l ∈ lines → l.length ≤ width := by
    intro l hl
    induction lines
    . simp at hl
    . simp at hl ⊢
      cases hl
      . simp [*, Nat.le_max_left]
      . apply Nat.le_trans _ (Nat.le_max_right ..)
        simp [*] at *
  { width, height := lines.length
  , lines := lines.map (fun l => l.pushn ' ' (width - l.length))
  , h_height := by simp, h_width := by
      intro l h
      rw [List.mem_map] at h
      rcases h with ⟨l',hl',rfl⟩
      simp; rw [Nat.add_comm]
      apply Nat.sub_add_cancel
      apply this _ hl'
  }

def Rect.ofString (s : String) : Rect :=
  have lines := s.splitOn "\n"
  Rect.ofLines lines

instance : Coe Char Rect where
  coe c := .ofString c.toString

instance : Coe String Rect where
  coe s := .ofString s

instance : Coe (List String) Rect where
  coe l := .ofLines l

instance : Coe Rect String where
  coe r := String.intercalate "\n" r.lines

inductive HAlign | left | center | right
inductive VAlign | top | center | bottom

def Rect.padHeight (r : Rect) (height : Nat) (h_height : r.height ≤ height)
                  (align : VAlign) : Rect :=
  { height, width := r.width
  , lines :=
    match align with
    | .top    => r.lines ++ List.replicate (height - r.height) ("".pushn ' ' r.width)
    | .bottom => List.replicate (height - r.height) ("".pushn ' ' r.width) ++ r.lines
    | .center => let top := (height - r.height)/2
                 List.replicate top ("".pushn ' ' r.width) ++ r.lines ++
                 List.replicate (height - r.height - top) ("".pushn ' ' r.width)
  , h_height := by
      split <;> simp [r.h_height]
      . apply Nat.add_sub_cancel' h_height
      . apply Nat.sub_add_cancel h_height
      . rw [← Nat.add_assoc, Nat.sub_sub, Nat.add_comm r.height]
        apply Nat.add_sub_cancel'
        apply Nat.add_le_of_le_sub h_height
        apply Nat.div_le_self
  , h_width := by
      intro l h
      cases align <;> (
        simp at h
        cases h <;> (try rename _ ∨ _ => h; cases h) <;>
          first
          | (apply r.h_width; assumption)
          | (have := List.mem_replicate.mp (by assumption) |>.2
             cases this; simp; simp [String.length])
        )
  }

def Rect.padWidth (r : Rect) (width : Nat) (h_width : r.width ≤ width)
                  (align : HAlign) : Rect :=
  { width, height := r.height
  , lines := r.lines.map (fun l =>
    match align with
    | .left   => l.pushn ' ' (width - l.length)
    | .right  => "".pushn ' ' (width - l.length) ++ l
    | .center => let left := (width - l.length)/2
                 "".pushn ' ' left ++ l |>.pushn ' ' (width-l.length-left)
    )
  , h_height := by simp [r.h_height], h_width := by
      intros; have := List.mem_map.mp (by assumption)
      match this with
      | ⟨line,hmem,_⟩ =>
      have := r.h_width _ hmem
      cases align <;> simp [*]
      . apply Nat.add_sub_cancel' h_width
      . simp [String.length]; rw [Nat.sub_sub, Nat.add_comm r.width]
        apply Nat.add_sub_cancel'
        apply Nat.add_le_of_le_sub h_width
        apply Nat.div_le_self
      . simp [String.length]; apply Nat.sub_add_cancel h_width
  }

def Rect.joinVert (top bottom : Rect) (h : top.width = bottom.width) : Rect :=
  { width := top.width, height := top.height + bottom.height
  , lines := top.lines ++ bottom.lines
  , h_height := by simp [top.h_height, bottom.h_height]
  , h_width := by simp (config := {contextual := true}) [or_imp, h, top.h_width, bottom.h_width]}

def Rect.joinHorz (left right : Rect) (h : left.height = right.height) : Rect :=
  { height := left.height, width := left.width + right.width
  , lines := List.zipWith (· ++ ·) left.lines right.lines
  , h_height := by simp [left.h_height, right.h_height, h]; apply Nat.min_eq_left (Nat.le_refl _)
  , h_width := by intro l hl; have := List.mem_zipWith hl
                  rcases this with ⟨y,z, rfl, hy, hz⟩
                  simp [left.h_width _ hy, right.h_width _ hz]}

def empty : Rect := { width := 0, height := 0, lines := [], h_width := by simp, h_height := by simp }

def fill (c : Char) (width height : Nat) : Rect :=
  { width, height, lines := List.replicate height ("".pushn c width)
  , h_width := by intro l hl; have := List.mem_replicate.mp hl; simp [this]; simp [String.length]
  , h_height := by simp }

def space (width height : Nat) : Rect :=
  fill ' ' width height

@[simp] theorem space.width_eq : (space w h).width = w := by
  simp [space, fill]

@[simp] theorem space.height_eq : (space w h).height = h := by
  simp [space, fill]

def Rect.trimHeight (height : Nat) (r : Rect) : Rect :=
  { width := r.width, height := min r.height height
  , lines := r.lines.take height
  , h_width := by intro l hl; have := List.mem_take hl; apply r.h_width _ this
  , h_height := by simp [r.h_height, Nat.min_comm] }

def Rect.trimWidth (width : Nat) (r : Rect) : Rect :=
  { width := min r.width width, height := r.height
  , lines := r.lines.map (·.take width)
  , h_width := by intro l hl; have := List.mem_map.mp hl
                  rcases this with ⟨a, ha, rfl⟩
                  simp [r.h_width _ ha]
  , h_height := by simp [r.h_height, Nat.min_comm] }

def Rect.dropLeft (n : Nat)  (r : Rect): Rect :=
  { width := r.width - n, height := r.height
  , lines := r.lines.map (·.drop n)
  , h_width := by intro l hl; have := List.mem_map.mp hl
                  rcases this with ⟨a,ha,rfl⟩
                  simp [r.h_width _ ha]
  , h_height := by simp [r.h_height]}

def Rect.tileVert (height : Nat) (r : Rect) (hr : r.height > 0) : Rect :=
  { width := r.width, height
  , lines := List.replicate (height / r.height + 1) r.lines |>.join.take height
  , h_width   := by intro l hl
                    have := List.mem_join.mp <| List.mem_take hl
                    rcases this with ⟨l',hl',h⟩
                    rw [List.mem_replicate] at hl'
                    simp at hl'; cases hl'
                    simp [r.h_width _ h]
  , h_height  := by simp [-List.replicate, -List.join]
                    apply Nat.min_eq_left
                    simp [r.h_height]
                    conv => lhs; rw [← Nat.div_add_mod (m := height) (n := r.height)]
                    conv => rhs; rw [Nat.mul_comm _ r.height, Nat.mul_add, Nat.mul_one]
                    apply Nat.add_le_add_left
                    apply Nat.le_of_lt; apply Nat.mod_lt _ hr }

def Rect.tileHorz (width : Nat) (r : Rect) (hr : r.width > 0) : Rect :=
  { width, height := r.height
  , lines := r.lines.map (List.replicate (width / r.width + 1) · |> String.join |>.take width)
  , h_width   := by intro l hl
                    have := List.mem_map.mp hl
                    rcases this with ⟨l',hl',rfl⟩
                    simp
                    apply Nat.min_eq_right
                    sorry
  , h_height  := by simp [r.h_height] }

def vbox (children : List Rect) (align : HAlign := .left)
          (sep : Rect := space 1 0) (hsep : sep.width > 0 := by simp) : Rect :=
  let width := children.foldr (max ·.width) 0
  have : ∀ c, c ∈ children → c.width ≤ width := by
    intro l hl
    induction children
    . simp at hl
    . simp at hl ⊢
      cases hl
      . simp [*, Nat.le_max_left]
      . apply Nat.le_trans _ (Nat.le_max_right ..)
        simp [*] at *
  match children with
  | [] => space width 0
  | c::cs =>
    aux width cs (fun c hc => this c (List.Mem.tail _ hc))
      (c.padWidth width (this c (List.Mem.head _)) align)
      (by simp [Rect.padWidth])
      (sep.tileHorz width hsep)
      (by simp [Rect.tileHorz])
where aux width children (h : ∀ c, c ∈ children → c.width ≤ width)
          acc (hacc : acc.width = width)
          sep (hsep : sep.width = width) :=
  match children with
  | [] => acc
  | c::cs =>
    have := h c (List.Mem.head _)
    aux width cs (fun c hc => h c (List.Mem.tail _ hc))
      (acc.joinVert sep (by simp [hacc, hsep])
        |>.joinVert
          (c.padWidth width this align)
          (by simp [Rect.joinVert, Rect.padWidth, hacc]))
      (by simp [Rect.joinVert, hacc])
      sep hsep

def hbox (children : List Rect) (align : VAlign := .top)
          (sep : Rect := space 0 1) (hsep : sep.height > 0 := by simp) : Rect :=
  let height := children.foldr (max ·.height) 0
  have : ∀ c, c ∈ children → c.height ≤ height := by
    intro l hl
    induction children
    . simp at hl
    . simp at hl ⊢
      cases hl
      . simp [*, Nat.le_max_left]
      . apply Nat.le_trans _ (Nat.le_max_right ..)
        simp [*] at *
  match children with
  | [] => space 0 height
  | c::cs =>
    aux height cs (fun c hc => this c (List.Mem.tail _ hc))
      (c.padHeight height (this c (List.Mem.head _)) align)
      (by simp [Rect.padHeight])
      (sep.tileVert height hsep)
      (by simp [Rect.tileVert])
where aux height children (h : ∀ c, c ∈ children → c.height ≤ height)
          acc (hacc : acc.height = height) sep (hsep : sep.height = height) :=
  match children with
  | [] => acc
  | c::cs =>
    have := h c (List.Mem.head _)
    aux height cs (fun c hc => h c (List.Mem.tail _ hc))
      (acc.joinHorz sep (by simp [hacc, hsep])
        |>.joinHorz
          (c.padHeight height this align)
          (by simp [Rect.joinHorz, Rect.padHeight, hacc]))
      (by simp [Rect.joinHorz, hacc])
      sep hsep


import ground_zero.support ground_zero.theorems.functions ground_zero.types.dep_path

namespace ground_zero.types

structure {u v} product (α : Sort u) (β : Sort v) :=
intro :: (pr₁ : α) (pr₂ : β)
attribute [pp_using_anonymous_constructor] product

reserve infix ` × `
infix ` × ` := product

namespace equiv
  universes u v

  def homotopy {α : Sort u} {π : α → Sort v}
    (f g : Π (x : α), π x) :=
  Π (x : α), f x = g x :> π x
  infix ` ~ ` := homotopy

  @[refl] def homotopy.id {α : Sort u} {π : α → Sort v}
    (f : Π (x : α), π x) : f ~ f :=
  begin simp [homotopy], intro x, reflexivity end

  def homotopy.eq {α : Sort u} {π : α → Sort v}
    {f g : Π (x : α), π x} (h : f = g :> Π (x : α), π x) : f ~ g :=
  begin induction h, reflexivity end

  @[symm] def homotopy.symm {α : Sort u} {π : α → Sort v}
    (f g : Π (x : α), π x) (h : f ~ g) : g ~ f := begin
    simp [homotopy] at *, intros,
    apply eq.symm, apply h
  end

  @[trans] def homotopy.trans {α : Sort u} {π : α → Sort v}
    (f g h : Π (x : α), π x) (r₁ : f ~ g) (r₂ : g ~ h) : f ~ h := begin
    simp [homotopy] at *, intros, transitivity,
    apply r₁, apply r₂
  end

  def linv {α : Sort u} {β : Sort v} (f : α → β) :=
  Σ' (g : β → α), g ∘ f ~ id

  def rinv {α : Sort u} {β : Sort v} (f : α → β) :=
  Σ' (g : β → α), f ∘ g ~ id

  def biinv {α : Sort u} {β : Sort v} (f : α → β) :=
  linv f × rinv f

  def homotopy_sqaure {α : Sort u} {β : Sort v}
    {f g : α → β} (H : f ~ g) {x y : α}
    (p : x = y :> α) :
    H x ⬝ (g # p) = (f # p) ⬝ H y :> f x = g y :> β := begin
    induction p, transitivity,
    apply eq.refl_right,
    apply eq.refl_left
  end
end equiv

def {u v} equiv (α : Sort u) (β : Sort v) :=
Σ' (f : α → β), equiv.biinv f
infix ` ≃ `:25 := equiv

namespace equiv
  universes u v w

  instance forward_coe {α : Sort u} {β : Sort v} :
    has_coe (α ≃ β) (α → β) :=
  ⟨begin intro e, cases e with f H, exact f end⟩

  @[refl] def id (α : Sort u) : α ≃ α := begin
    existsi id, split,
    repeat {
      existsi id, intro, reflexivity
    }
  end

  @[trans] def trans {α : Sort u} {β : Sort v} {γ : Sort w}
    (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ := begin
    cases e₁ with f₁ H₁,
    cases H₁ with linv₁ rinv₁,
    cases linv₁ with g₁ α₁,
    cases rinv₁ with h₁ β₁,

    cases e₂ with f₂ H₂,
    cases H₂ with linv₂ rinv₂,
    cases linv₂ with g₂ α₂,
    cases rinv₂ with h₂ β₂,

    existsi (f₂ ∘ f₁), split,
    { existsi (g₁ ∘ g₂),
      intro x, simp, transitivity,
      exact g₁ # (α₂ (f₁ x)), exact α₁ x },
    { existsi (h₁ ∘ h₂),
      intro x, simp, transitivity,
      exact f₂ # (β₁ (h₂ x)), exact β₂ x }
  end

  def idtoeqv {α β : Sort u} (p : α = β :> _) : α ≃ β :=
  begin induction p, apply id end

  def transportconst {α β : Sort u} : (α = β :> _) → (α → β) :=
  psigma.fst ∘ idtoeqv

  def subst {α : Sort u} {π : α → Sort v} {a b : α}
    (p : a = b :> α) : π a → π b :=
  begin induction p, exact ground_zero.theorems.functions.idfun end

  reserve infix ` ▸ `
  infix [parsing_only] ` ▸ ` := subst

  def apd {α : Sort u} {β : α → Sort v} {a b : α}
    (f : Π (x : α), β x) (p : a = b :> α) :
    subst p (f a) = f b :> β b :=
  begin induction p, reflexivity end

  def subst_sqr {α : Sort u} {π : α → Sort v} {a b : α}
    {p q : a = b :> α} (r : p = q :> a = b :> α) (u : π a) :
    subst p u = subst q u :> π b :=
  begin induction r, reflexivity end
  notation `subst²` := subst_sqr

  lemma dep_path_map {α : Sort u}
    {π : α → Sort v} {δ : α → Sort w}
    {a b : α}
    {p : a = b :> α} {u : π a} {v : π b} (q : u =[p] v)
    (g : Π {x : α}, π x → δ x) :
    g u =[p] g v :=
  begin induction q, induction p, trivial end

  def subst_comp {α : Sort u}
    {π : α → Sort v} {a b c : α}
    (p : a = b :> α) (q : b = c :> α) (x : π a) :
    subst (p ⬝ q) x = subst q (subst p x) :> π c :=
  begin induction p, induction q, trivial end

  -- subst with explicit π
  abbreviation transport {α : Sort u}
    (π : α → Sort v) {a b : α}
    (p : a = b :> α) : π a → π b := subst p

  abbreviation transport_sqr {α : Sort u} (π : α → Sort v) {a b : α}
    {p q : a = b :> α} (r : p = q :> a = b :> α) (u : π a) :
    subst p u = subst q u :> π b := subst_sqr r u
  notation `transport²` := transport_sqr

  --notation u ` =[` P `,` p `] ` v := transport P p u = v :> _

  lemma transport_comp {α : Sort u} {β : Sort v}
    (π : β → Sort w) {x y : α}
    (f : α → β) (p : x = y :> α) (u : π (f x)) :
    @subst _ (π ∘ f) _ _ p u =
    subst (f # p) u :> π (f y) :=
  begin induction p, trivial end

  def transport_composition {α : Sort u} {a x₁ x₂ : α}
    (p : x₁ = x₂ :> α) (q : a = x₁ :> α) :
    transport (ground_zero.types.eq a) p q = q ⬝ p :> _ := begin
    induction p, symmetry, transitivity,
    apply eq.refl_right, trivial
  end

  lemma transport_over_family {α : Sort u}
    {x y : α} {π δ : α → Sort v}
    (f : Π (x : α), π x → δ x)
    (p : x = y :> α) (u : π x) :
    subst p (f x u) = f y (subst p u) :> δ y :=
  begin induction p, trivial end

  def apd_sqr {α : Sort u} {β γ : α → Sort v} {a b : α}
    {u : β a} {v : β b} {p : a = b :> α}
    (f : Π {x : α} (u : β x), γ x) (q : u =[p] v) :
    f u =[p] f v :=
  begin induction q, reflexivity end

  def apd₂ {α : Sort u} {β : α → Sort v} {a b : α}
    {p q : a = b :> α} (f : Π (x : α), β x)
    (r : p = q :> a = b :> α) :
    dep_path.apd f p =[r] dep_path.apd f q :=
  begin induction r, reflexivity end

  def rewrite_comp {α : Sort u} {a b c : α}
    {p : a = b :> α} {q : b = c :> α} {r : a = c :> α}
    (h : r = p ⬝ q :> a = c :> α) :
    p⁻¹ ⬝ r = q :> b = c :> α := begin
    induction p, unfold eq.symm, transitivity,
    exact eq.refl_left r, exact h ⬝ eq.refl_left q
  end

  def path_over_subst {α : Sort u} {β : α → Sort v}
    {a b : α} {p : a = b :> α} {u : β a} {v : β b}
    (q : subst p u = v :> β b) : u =[p] v :=
  begin induction q, induction p, reflexivity end

  def subst_from_pathover {α : Sort u} {β : α → Sort v}
    {a b : α} {p : a = b :> α} {u : β a} {v : β b}
    (q : u =[p] v) : subst p u = v :> β b :=
  begin induction q, reflexivity end

  def pathover_from_trans {α : Sort u} {a b c : α}
    (p : b = c :> α) (q : a = b :> α) (r : a = c :> α) :
    (q ⬝ p = r :> a = c :> α) → (q =[p] r) := begin
    intro h, induction h,
    apply path_over_subst, apply transport_composition
  end
end equiv

def {u v} is_qinv {α : Sort u} {β : Sort v} (f : α → β) (g : β → α) :=
(f ∘ g ~ id) × (g ∘ f ~ id)

class {u v} has_qinv {α : Sort u} {β : Sort v} (f : α → β) :=
(inv : β → α) (lawful : is_qinv f inv)
postfix ⁻¹ := has_qinv.inv

def {u v} qinv {α : Sort u} {β : Sort v} (f : α → β) :=
Σ' (g : β → α), is_qinv f g

namespace qinv
  universes u v w

  def equiv (α : Sort u) (β : Sort v) :=
  Σ' (f : α → β), qinv f

  def q2b {α : Sort u} {β : Sort v} (f : α → β) (q : qinv f) :
    equiv.biinv f := begin
    cases q with g H,
    cases H with α β,
    split; existsi g,
    exact β, exact α
  end

  def b2q {α : Sort u} {β : Sort v} (f : α → β) (b : equiv.biinv f) :
    qinv f := begin
    cases b with linv rinv,
    cases rinv with g α,
    cases linv with h β,

    existsi g, split,
    exact α, intro x,

    have γ₁ := β (g (f x)),
    have γ₂ := h # (α (f x)),
    exact γ₁⁻¹ ⬝ γ₂ ⬝ β x
  end
end qinv

namespace equiv
  universes u v

  @[symm] def symm {α : Sort u} {β : Sort v}
    (e : α ≃ β) : β ≃ α := begin
    cases e with f H, have q := qinv.b2q f H,
    cases q with g qinv, cases qinv with α β,
    existsi g, split; existsi f,
    exact α, exact β
  end
end equiv

-- half adjoint equivalence
def {u v} ishae {α : Sort u} {β : Sort v} (f : α → β) :=
Σ' (g : β → α) (η : g ∘ f ~ id) (ϵ : f ∘ g ~ id) (x : α),
  f # (η x) = ϵ (f x) :> f (g (f x)) = f x :> β

def {u v} fib {α : Sort u} {β : Sort v} (f : α → β) (y : β) :=
Σ' (x : α), f x = y :> β

end ground_zero.types