{-# OPTIONS --safe #-}
{-
  This is inspired by/copied from:
  https://github.com/agda/agda-stdlib/blob/master/src/Tactic/MonoidSolver.agda

  Boilerplate code for calling the ring solver is constructed automatically
  with agda's reflection features.
-}
module Cubical.Algebra.RingSolver.ReflectionSolving where

open import Cubical.Foundations.Prelude hiding (Type)
open import Cubical.Functions.Logic

open import Agda.Builtin.Reflection hiding (Type)
open import Agda.Builtin.String

open import Cubical.Reflection.Base

open import Cubical.Data.Maybe
open import Cubical.Data.Sigma
open import Cubical.Data.List
open import Cubical.Data.Nat.Literals
open import Cubical.Data.Int.Base hiding (abs)
open import Cubical.Data.Int using (fromNegℤ; fromNatℤ)
open import Cubical.Data.Nat using (ℕ) renaming (_+_ to _+ℕ_)
open import Cubical.Data.FinData using () renaming (zero to fzero; suc to fsuc)
open import Cubical.Data.Bool
open import Cubical.Data.Bool.SwitchStatement
open import Cubical.Data.Vec using (Vec) renaming ([] to emptyVec; _∷_ to _∷vec_) public

open import Cubical.Algebra.RingSolver.AlgebraExpression
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.RingSolver.RawAlgebra
open import Cubical.Algebra.RingSolver.IntAsRawRing
open import Cubical.Algebra.RingSolver.CommRingSolver renaming (solve to ringSolve)

private
  variable
    ℓ : Level

  _==_ = primQNameEquality
  {-# INLINE _==_ #-}

  record VarInfo : Type ℓ-zero where
    field
      varName : String
      varType : Arg Term
      index : ℕ

  {-
    `getLastTwoArgsOf` maps a term 'def n (z₁ ∷ … ∷ zₙ ∷ x ∷ y ∷ [])' to the pair '(x,y)'
    non-visible arguments are ignored.
  -}
  getLastTwoArgsOf : Name → Term → Maybe (Term × Term)
  getLastTwoArgsOf n' (def n xs) =
    if n == n'
    then go xs
    else nothing
      where
      go : List (Arg Term) → Maybe (Term × Term)
      go (varg x ∷ varg y ∷ []) = just (x , y)
      go (x ∷ xs)               = go xs
      go _                      = nothing
  getLastTwoArgsOf n' _ = nothing

  {-
    `getArgs` maps a term 'x ≡ y' to the pair '(x,y)'
  -}
  getArgs : Term → Maybe (Term × Term)
  getArgs = getLastTwoArgsOf (quote PathP)

  firstVisibleArg : List (Arg Term) → Maybe Term
  firstVisibleArg [] = nothing
  firstVisibleArg (varg x ∷ l) = just x
  firstVisibleArg (x ∷ l) = firstVisibleArg l

  {-
    If the solver needs to be applied during equational reasoning,
    the right hand side of the equation to solve cannot be given to
    the solver directly. The folllowing function extracts this term y
    from a more complex expression as in:
      x ≡⟨ solve ... ⟩ (y ≡⟨ ... ⟩ z ∎)
  -}
  getRhs : Term → Maybe Term
  getRhs reasoningToTheRight@(def n xs) =
    if n == (quote _∎)
    then firstVisibleArg xs
    else (if n == (quote _≡⟨_⟩_)
         then firstVisibleArg xs
         else nothing)
  getRhs _ = nothing

  private
    solverCallAsTerm : Term → Arg Term → Term → Term → Term
    solverCallAsTerm R varList lhs rhs =
      def
         (quote ringSolve)
         (varg R ∷ varg lhs ∷ varg rhs
           ∷ varList
           ∷ varg (def (quote refl) []) ∷ [])

  solverCallWithLambdas : ℕ → List VarInfo → Term → Term → Term → Term
  solverCallWithLambdas n varInfos R lhs rhs =
    encloseWithIteratedLambda
      (map VarInfo.varName varInfos)
      (solverCallAsTerm R (variableList (rev varInfos)) lhs rhs)
    where
      encloseWithIteratedLambda : List String → Term → Term
      encloseWithIteratedLambda (varName ∷ xs) t = lam visible (abs varName (encloseWithIteratedLambda xs t))
      encloseWithIteratedLambda [] t = t

      variableList : List VarInfo → Arg Term
      variableList [] = varg (con (quote emptyVec) [])
      variableList (varInfo ∷ varInfos)
        = varg (con (quote _∷vec_) (varg (var (VarInfo.index varInfo) []) ∷ (variableList varInfos) ∷ []))

  solverCallByVarIndices : ℕ → List ℕ → Term → Term → Term → Term
  solverCallByVarIndices n varIndices R lhs rhs =
      solverCallAsTerm R (variableList (rev varIndices)) lhs rhs
      where
        variableList : List ℕ → Arg Term
        variableList [] = varg (con (quote emptyVec) [])
        variableList (varIndex ∷ varIndices)
          = varg (con (quote _∷vec_) (varg (var (varIndex) []) ∷ (variableList varIndices) ∷ []))

module pr (R : CommRing ℓ) {n : ℕ} where
  private
    νR = CommRing→RawℤAlgebra R

  open CommRingStr (snd R)

  0' : Expr ℤAsRawRing (fst R) n
  0' = K 0

  1' : Expr ℤAsRawRing (fst R) n
  1' = K 1

module _ (cring : Term) where
  private
    νR = def (quote CommRing→RawℤAlgebra) (varg cring ∷ [])

  open pr

  `0` : List (Arg Term) → Term
  `0` [] = def (quote 0') (varg cring ∷ [])
  `0` (varg fstcring ∷ xs) = `0` xs
  `0` (harg _ ∷ xs) = `0` xs
  `0` _ = unknown

  `1` : List (Arg Term) → Term
  `1` [] = def (quote 1') (varg cring ∷ [])
  `1` (varg fstcring ∷ xs) = `1` xs
  `1` (harg _ ∷ xs) = `1` xs
  `1` _ = unknown

  mutual

    `_·_` : List (Arg Term) → Term
    `_·_` (harg _ ∷ xs) = `_·_` xs
    `_·_` (varg _ ∷ varg x ∷ varg y ∷ []) =
      con
        (quote _·'_) (varg (buildExpression x) ∷ varg (buildExpression y) ∷ [])
    `_·_` _ = unknown

    `_+_` : List (Arg Term) → Term
    `_+_` (harg _ ∷ xs) = `_+_` xs
    `_+_` (varg _ ∷ varg x ∷ varg y ∷ []) =
      con
        (quote _+'_) (varg (buildExpression x) ∷ varg (buildExpression y) ∷ [])
    `_+_` _ = unknown

    `-_` : List (Arg Term) → Term
    `-_` (harg _ ∷ xs) = `-_` xs
    `-_` (varg _ ∷ varg x ∷ []) =
      con
        (quote -'_) (varg (buildExpression x) ∷ [])
    `-_` _ = unknown

    K' : List (Arg Term) → Term
    K' xs = con (quote K) xs

    finiteNumberAsTerm : ℕ → Term
    finiteNumberAsTerm ℕ.zero = con (quote fzero) []
    finiteNumberAsTerm (ℕ.suc n) = con (quote fsuc) (varg (finiteNumberAsTerm n) ∷ [])

    buildExpression : Term → Term
    buildExpression (var index _) = con (quote ∣) (varg (finiteNumberAsTerm index) ∷ [])
    buildExpression t@(def n xs) =
      switch (n ==_) cases
        case (quote CommRingStr.0r)  ⇒ `0` xs     break
        case (quote CommRingStr.1r)  ⇒ `1` xs     break
        case (quote CommRingStr._·_) ⇒ `_·_` xs   break
        case (quote CommRingStr._+_) ⇒ `_+_` xs   break
        case (quote (CommRingStr.-_))  ⇒ `-_` xs    break
        default⇒ (K' xs)
    buildExpression t@(con n xs) =
      switch (n ==_) cases
        case (quote CommRingStr.0r)  ⇒ `0` xs     break
        case (quote CommRingStr.1r)  ⇒ `1` xs     break
        case (quote CommRingStr._·_) ⇒ `_·_` xs   break
        case (quote CommRingStr._+_) ⇒ `_+_` xs   break
        case (quote (CommRingStr.-_))  ⇒ `-_` xs    break
        default⇒ (K' xs)
    buildExpression t = unknown

  toAlgebraExpression : Maybe (Term × Term) → Maybe (Term × Term)
  toAlgebraExpression nothing = nothing
  toAlgebraExpression (just (lhs , rhs)) = just (buildExpression lhs , buildExpression rhs)

private
  adjustDeBruijnIndex : (n : ℕ) → Term → Term
  adjustDeBruijnIndex n (var k args) = var (k +ℕ n) args
  adjustDeBruijnIndex n _ = unknown

  extractVarIndices : Maybe (List Term) → Maybe (List ℕ)
  extractVarIndices (just ((var index _) ∷ l)) with extractVarIndices (just l)
  ... | just indices = just (index ∷ indices)
  ... | nothing = nothing
  extractVarIndices (just []) = just []
  extractVarIndices _ = nothing

  getVarsAndEquation : Term → Maybe (List VarInfo × Term)
  getVarsAndEquation t =
    let
      (rawVars , equationTerm) = extractVars t
      maybeVars = addIndices (length rawVars) rawVars
    in map-Maybe (_, equationTerm) maybeVars
    where
          extractVars : Term → List (String × Arg Term) × Term
          extractVars (pi argType (abs varName t)) with extractVars t
          ...                                         | xs , equation
                                                        = (varName , argType) ∷ xs , equation
          extractVars equation = [] , equation

          addIndices : ℕ → List (String × Arg Term) → Maybe (List VarInfo)
          addIndices ℕ.zero         []        = just []
          addIndices (ℕ.suc countVar) ((varName , argType) ∷ list) =
            map-Maybe (λ varList → record { varName = varName ; varType = argType ; index = countVar }
                                   ∷ varList)
                      (addIndices countVar list)
          addIndices _ _ = nothing

  toListOfTerms : Term → Maybe (List Term)
  toListOfTerms (con c []) = if (c == (quote [])) then just [] else nothing
  toListOfTerms (con c (varg t ∷ varg s ∷ args)) with toListOfTerms s
  ... | just terms = if (c == (quote _∷_)) then just (t ∷ terms) else nothing
  ... | nothing = nothing
  toListOfTerms (con c (harg t ∷ args)) = toListOfTerms (con c args)
  toListOfTerms _ = nothing

  solve-macro : Term → Term → TC Unit
  solve-macro cring hole =
    do
      hole′ ← inferType hole >>= normalise
      just (varInfos , equation) ← returnTC (getVarsAndEquation hole′)
        where
          nothing
            → typeError (strErr "Something went wrong when getting the variable names in "
                           ∷ termErr hole′ ∷ [])
      {-
        The call to the ring solver will be inside a lamba-expression.
        That means, that we have to adjust the deBruijn-indices of the variables in 'cring'
      -}
      adjustedCring ← returnTC (adjustDeBruijnIndex (length varInfos) cring)
      just (lhs , rhs) ← returnTC (toAlgebraExpression adjustedCring (getArgs equation))
        where
          nothing
            → typeError(
                strErr "Error while trying to build ASTs for the equation " ∷
                termErr equation ∷ [])
      let solution = solverCallWithLambdas (length varInfos) varInfos adjustedCring lhs rhs
      unify hole solution

  solveInPlace-macro : Term → Term → Term → TC Unit
  solveInPlace-macro cring varsToSolve hole =
    do
      equation ← inferType hole >>= normalise
      just varIndices ← returnTC (extractVarIndices (toListOfTerms varsToSolve))
        where
          nothing
            → typeError(
                strErr "Error reading variables to solve " ∷
                termErr varsToSolve ∷ [])
      just (lhs , rhs) ← returnTC (toAlgebraExpression cring (getArgs equation))
        where
          nothing
            → typeError(
                strErr "Error while trying to build ASTs for the equation " ∷
                termErr equation ∷ [])
      let solution = solverCallByVarIndices (length varIndices) varIndices cring lhs rhs
      unify hole solution

  solveEqReasoning-macro : Term → Term → Term → Term → Term → TC Unit
  solveEqReasoning-macro lhs cring varsToSolve reasoningToTheRight hole =
    do
      just varIndices ← returnTC (extractVarIndices (toListOfTerms varsToSolve))
        where
          nothing
            → typeError(
                strErr "Error reading variables to solve " ∷
                termErr varsToSolve ∷ [])
      just rhs ← returnTC (getRhs reasoningToTheRight)
        where
          nothing
            → typeError(
                strErr "Failed to extract right hand side of equation to solve from " ∷
                termErr reasoningToTheRight ∷ [])
      just (lhsAST , rhsAST) ← returnTC (toAlgebraExpression cring (just (lhs , rhs)))
        where
          nothing
            → typeError(
                strErr "Error while trying to build ASTs from " ∷
                termErr lhs ∷ strErr " and " ∷ termErr rhs ∷ [])
      let solverCall = solverCallByVarIndices (length varIndices) varIndices cring lhsAST rhsAST
      unify hole (def (quote _≡⟨_⟩_) (varg lhs ∷ varg solverCall ∷ varg reasoningToTheRight ∷ []))

macro
  solve : Term → Term → TC _
  solve = solve-macro

  solveInPlace : Term → Term → Term → TC _
  solveInPlace = solveInPlace-macro

  infixr 2 _≡⟨solveIn_withVars_⟩_
  _≡⟨solveIn_withVars_⟩_ : Term → Term → Term → Term → Term → TC Unit
  _≡⟨solveIn_withVars_⟩_ = solveEqReasoning-macro

fromℤ : (R : CommRing ℓ) → ℤ → fst R
fromℤ = scalar


postulate
  Nat : Set
  succ : Nat → Nat
  Le : Nat → Nat → Set
  Fin : Nat → Set
  low : ∀ {m n} → Le m n → Fin n → Fin m
  instance
    Le-refl : ∀ {n} → Le n n
    Le-succ : ∀ {m n} ⦃ _ : Le m n ⦄ → Le m (succ n)
  Chk1 : ∀ {n} → Fin n → Set
  Chk2 : ∀ {n} → Fin n → Fin n → Set
  Chk3 : ∀ {m n} ⦃ _ : Le m n ⦄ → Fin m → Fin n → Set

variable
  le : Le _ _
  X G : Fin _

postulate

  works : Chk1 G
        → Chk2 (low le G) X
        → Chk3 X G
  -- WAS: Instance argument got solved with `Le-refl`, which is not
  -- type-correct.
  -- SHOULD: result in a failed instance search

  fails : Chk2 (low le G) X
        → Chk3 X G


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Everything where

import Cubical.Data.BinNat
import Cubical.Data.Bool
import Cubical.Data.Empty
import Cubical.Data.Equality
import Cubical.Data.Fin
import Cubical.Data.Nat
import Cubical.Data.Nat.Algebra
import Cubical.Data.Nat.Order
import Cubical.Data.NatMinusOne
import Cubical.Data.NatMinusTwo
import Cubical.Data.NatPlusOne
import Cubical.Data.Int
import Cubical.Data.Sum
import Cubical.Data.Prod
import Cubical.Data.Unit
import Cubical.Data.Sigma
import Cubical.Data.DiffInt
import Cubical.Data.Group
import Cubical.Data.HomotopyGroup
import Cubical.Data.List
import Cubical.Data.Graph
import Cubical.Data.InfNat
import Cubical.Data.Queue


{-# OPTIONS --allow-unsolved-metas #-}

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

test : (x y : Nat) → x ≡ y → x ≡ 1 → y ≡ 1 → Nat
test (suc zero) (suc zero) refl refl refl = {!!}


{-# OPTIONS --without-K --safe #-}

-- This module shows that D<: typing is undecidable.
module DsubTermUndec where

open import Data.List as List
open import Data.List.All as All
open import Data.Nat as ℕ
open import Data.Maybe as Maybe
open import Data.Product
open import Data.Sum
open import Data.Empty renaming (⊥ to False)
open import Data.Vec as Vec renaming (_∷_ to _‼_ ; [] to nil) hiding (_++_)
open import Function

open import Data.Maybe.Properties as Maybeₚ
open import Data.Nat.Properties as ℕₚ
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as ≡

open import DsubDef
open import DsubFull
open import DsubReduced
open import Dsub renaming (_⊢_<:_ to _⊢′_<:_)
open import Utils
open import DsubEquivSimpler

module DifferentProof where

  open import FsubMinus
  open FsubMinus.FsubMinus hiding (_↑_)
  open FsubMinusToDsubR
  open Undecidability′

  F<:⇒typing′ : ∀ {Γ S U} →
                  Γ ⊢F S <: U →
                  ⟪ Γ ⟫ ⊢ val ⟨A= ⟦ S ⟧ ⟩ ∶ ⟨A: ⊥ ⋯ ⟦ U ⟧ ⟩
  F<:⇒typing′ S<:U = <∶ ⟨A⟩-I (bnd ⊥<: (<:′⇒<: $ F<:⇒D<: S<:U))

  bnd<:⇒F<:′ : ∀ {Γ S U} →
                  ⟪ Γ ⟫ ⊢″ ⟨A: ⟦ S ⟧ ⋯ ⟦ S ⟧ ⟩ <: ⟨A: ⊥ ⋯ ⟦ U ⟧ ⟩ →
                  Γ ⊢F S <: U
  bnd<:⇒F<:′ {Γ} {S} {U} bnd<: = helper
    where open DsubInvProperties contraInvertible
          cΓ = ⟪⟫-contraEnv Γ
          helper : Γ ⊢F S <: U
          helper with ⟨A:⟩<:⟨A:⟩ (<:⇒<:ᵢ (<:″⇒<: bnd<:) cΓ) cΓ
          ... | _ , S<:U = D<:⇒F<: $ <:ᵢ⇒<: S<:U

  typing⇒F<:′ : ∀ {Γ S U} →
                  ⟪ Γ ⟫ ⊢ val ⟨A= ⟦ S ⟧ ⟩ ∶ ⟨A: ⊥ ⋯ ⟦ U ⟧ ⟩ →
                  Γ ⊢F S <: U
  typing⇒F<:′ typ = bnd<:⇒F<:′ $ <:⇒<:″ $ <:⇒<:′ (helper typ refl refl)
    where helper : ∀ {Γ Γ′ S S′ T} →
                     Γ′ ⊢ val ⟨A= S′ ⟩ ∶ T →
                     Γ′ ≡ ⟪ Γ ⟫ → S′ ≡ ⟦ S ⟧ →
                     ⟪ Γ ⟫ ⊢ ⟨A: ⟦ S ⟧ ⋯ ⟦ S ⟧ ⟩ <: T
          helper ⟨A⟩-I eqΓ refl = refl
          helper (<∶ typ x) refl eqS = tran _ (helper typ refl eqS) x


------------------------------------------------------------------------------
-- A stronger (maybe invalid) principle for ≈-coind
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Relation.Binary.Bisimilarity.Type where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Relation.Binary.Bisimilarity.Type

------------------------------------------------------------------------------
-- A stronger (maybe invalid) principle for ≈-coind.
postulate
  ≈-stronger-coind :
    ∀ (B : D → D → Set) {xs ys} →
    (B xs ys → ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
      xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ B xs' ys') →
    B xs ys → xs ≈ ys


-- Andreas, 2012-01-12
module Common.Irrelevance where

open import Common.Level

postulate
  .irrAxiom : ∀ {a}{A : Set a} → .A → A
{-# BUILTIN IRRAXIOM irrAxiom #-}

record Squash {a}(A : Set a) : Set a where
  constructor squash
  field
    .unsquash : A

open Squash public


-- Andreas, 2012-03-15, example by Ulf
-- {-# OPTIONS -v tc.meta:20 #-}
module Issue479 where

import Common.Level
open import Common.Equality

data ⊥ : Set where
data Bool : Set where true false : Bool

X       : Bool
X=true  : X ≡ true
X≠false : X ≡ false → ⊥
X = _
X≠false ()
X=true = refl

-- The emptyness check for X ≡ false should be postponed until
-- X has been solved to true.


{-# OPTIONS --without-K --rewriting #-}

open import PathInduction
open import Pushout

module JamesSecondComposite {i} (A : Type i) (⋆A : A) where

open import JamesTwoMaps A ⋆A public

-- Second composite

to-ε∞ : to ε∞ == εJ
to-ε∞ = idp

to-α∞-in∞ : (a : A) (n : ℕ) (x : J n) → to (α∞ a (in∞ n x)) == αJ a (inJ n x)
to-α∞-in∞ a n x = inJS-α n a x

to-α∞-push∞ : (a : A) (n : ℕ) (x : J n) → Square (ap to (ap (α∞ a) (push∞ n x))) (inJS-α n a x) idp (ap (αJ a) (ap to (push∞ n x)))
to-α∞-push∞ = λ a n x → & coh (ap-shape-∙! to (push∞-β  {in∞* = α∞-in∞ a} {push∞* = α∞-push∞ a} n x))
                              (to-push∞-S n (α n a x))
                              (ap-δJ (inJS-α n a x))
                              (∘-ap _ _ _)
                              (inJSS-γ n a x)
                              (ap-square (αJ a) (to-push∞ n x))  module Toα∞Push∞ where

  coh : Coh ({A : Type i} {a c : A} {q : a == c} {d : A} {r : a == d}
             {b : A} {s : b == d} {p : a == b} (p= : p == r ∙ ! s)
             {r' : a == d} (y= : r == r') {g : A} {w : d == g}
             {v : c == g} (sq : Square r' q w v) {e : A} {u : c == e}
             {s' : b == d} (s= : s == s') {t : b == e} (u= : Square s' t w (! u ∙ v))
             {x : c == b} (x= : Square x idp t u)
      → Square p q idp x)
  coh = path-induction

to-α∞ : (a : A) (x : J∞A) → to (α∞ a x) == αJ a (to x)
to-α∞ a = J∞A-elim (to-α∞-in∞ a) (λ n x → ↓-='-from-square (ap-∘ to (α∞ a) (push∞ n x)) (ap-∘ (αJ a) to (push∞ n x)) (square-symmetry (to-α∞-push∞ a n x)))

to-δ∞-in∞ : (n : ℕ) (x : J n) → Square (ap to (δ∞ (in∞ n x))) idp (to-α∞ ⋆A (in∞ n x)) (δJ (to (in∞ n x)))
to-δ∞-in∞ = λ n x → & coh (∘-ap _ _ _) (ap-square to (δ∞-in∞-β n x)) (to-push∞ n x) (inJS-β n x)  module Toδ∞In where

  coh : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {r r' : b == c} (r= : r == r')
             {s : a == c} (sq1 : Square p idp r s) {d : A} {t : c == d}
             {u : a == d} (sq2 : Square s idp t u)
             {rt : b == d} (rt= : Square r' rt t idp)
             → Square p idp rt u)
  coh = path-induction

module _ (n : ℕ) (x : J n) where

  side1 : Square (ap to (push∞ (S n) (α n ⋆A x))) (inJS-α n ⋆A x) (ap (αJ ⋆A) (inJS-α n ⋆A x)) (δJ (αJ ⋆A (inJ n x)))
  side1 = to-push∞-S n (α n ⋆A x) |∙ idp |∙ ap-δJ (inJS-α n ⋆A x)

  side2 : Square (ap to (ap (in∞ (S n)) (β n x))) (inJS-α n ⋆A x) (inJS-ι n x) idp
  side2 = idp |∙ ∘-ap to (in∞ (S n)) (β n x) |∙ inJS-β n x

  side3 : Square (ap to (ap (in∞ (S (S n))) (ap inr (β n x)))) (ap (αJ ⋆A) (inJS-α n ⋆A x)) (ap (αJ ⋆A) (inJS-ι n x)) (ap (αJ ⋆A) idp)
  side3 = idp |∙ (∘-ap to (in∞ (S (S n))) _ ∙ ap-inJSS-ι n (β n x)) |∙ ap-square (αJ ⋆A) (inJS-β n x)

  side4 : Square (ap to (push∞ (S n) (ι n x))) (inJS-ι n x) (ap (λ z → αJ ⋆A z) (inJS-ι n x)) (δJ (αJ ⋆A (inJ n x)))
  side4 = to-push∞-S n (ι n x) |∙ idp |∙ ap-δJ (inJS-ι n x)

  side5 : Square (ap to (ap (in∞ (S (S n))) (γ n ⋆A x))) (ap (αJ ⋆A) (inJS-ι n x)) (ap (αJ ⋆A) (inJS-α n ⋆A x)) (γJ ⋆A (inJ n x))
  side5 = ∘-ap to (in∞ (S (S n))) (γ n ⋆A x) |∙ inJSS-γ n ⋆A x

  side6 : Square (ap to (ap (in∞ (S (S n))) (β (S n) (ι n x)))) (ap (αJ ⋆A) (inJS-ι n x)) (ap (αJ ⋆A) (inJS-ι n x)) idp
  side6 = ∘-ap to (in∞ (S (S n))) _ |∙ inJS-βS n (ι n x) |∙ vid-square

  side7 : Square (ap to (ap (α∞ ⋆A) (push∞ n x))) (inJS-α n ⋆A x) (ap (αJ ⋆A) (inJS-ι n x)) (ap (αJ ⋆A) (δJ (inJ n x)))
  side7 = adapt-square (to-α∞-push∞ ⋆A n x ∙□ ap-square (αJ ⋆A) (to-push∞ n x)) ∙idp idp∙

  to-push∞-βn : Cube (ap-square to (natural-square (push∞ (S n)) (β n x) idp (ap-∘ (in∞ (S (S n))) inr (β n x))))
                    hid-square
                    side1
                    side2
                    side3
                    side4
  to-push∞-βn = & (ap-square-natural-square to) (β n x) (push∞ (S n)) ∙idp idp
               -∙³ & natural-square-homotopy (to-push∞-S n) (β n x)
               |∙³ & (natural-square-∘ (β n x) (inJS n)) δJ idp idp
               -∙³ & natural-square= δJ idp (coh1 to (in∞ (S n)) (β n x)) (coh2 to (in∞ (S (S n))) inr (β n x) (ap-∘ (αJ ⋆A) (inJS n) (β n x)))
               |∙³ & natural-cube2 δJ (inJS-β n x) (ap-square-idf (inJS-β n x)) (hid-flatcube _)  where

    coh1 : {A B C : Type i} (g : B → C) (f : A → B) {x y : A} (p : x == y) → Square idp (∘-ap (λ z → z) (g ∘ f) p ∙ ap-∘ g f p) (ap-idf _) (∘-ap g f p)
    coh1 g f idp = ids

    coh2 : {A B C D : Type i} (h : C → D) (g : B → C) (f : A → B) {x y : A} (p : x == y) {z : h (g (f x)) == h (g (f y))} (q : ap (h ∘ g ∘ f) p == z)
         → Square idp (! q ∙ ap-∘ h (g ∘ f) p ∙ ap (ap h) (ap-∘ g f p)) idp (∘-ap h g (ap f p) ∙ ∘-ap (h ∘ g) f p ∙ q)
    coh2 h g f idp idp = ids

  to-in∞-η : Cube (ap-square to (ap-square (in∞ (S (S n))) (η n x)))
                  (horiz-degen-square (ηJ (inJ n x)))
                  side5
                  vid-square
                  side3
                  side6
  to-in∞-η = adapt-cube-idp (∘-ap-square to (in∞ (S (S n))) (η n x)
                            |∙³ inJSS-η n x)
                            idp (& coh1) (& coh2) idp  where

    coh1 : Coh ({A : Type i} {a b : A} {p : a == b} → idp |∙ vid-square {p = p} == vid-square)
    coh1 = path-induction

    coh2 : Coh ({A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} {sq : Square p q r s}
                {p' : a == b} {p= : p' == p} {p'' : a == b} {p=' : p'' == p'} → p=' |∙ p= |∙ sq == idp |∙ (p=' ∙ p=) |∙ sq)
    coh2 = path-induction

  coh-last-one : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : a == c} → p == q ∙ ! (! p ∙ q))
  coh-last-one = path-induction

  last-one : Cube (horiz-degen-square (ap-shape-∙! to (push∞-β {in∞* = α∞-in∞ ⋆A} {push∞* = α∞-push∞ ⋆A} n x)))
                  (horiz-degen-square (& coh-last-one))
                  side7
                  vid-square
                  vid-square
                  (vcomp! side1 side5)
  last-one = & coh  where

    coh : Coh ({A : Type i} {a : A}
               {c : A} {q : a == c} {d : A} {r : a == d} {b : A} {s : b == d}
               {p : a == b} {p= : p == r ∙ ! s}
               {r' : a == d} {y= : r == r'}
               {g : A} {w : d == g} {v : c == g} {sq : Square r' q w v}
               {e : A} {u : c == e} {s' : b == d} {s= : s == s'}
               {t : b == e} {u= : Square s' t w (! u ∙ v)}
               {x : c == b} {x= : Square x idp t u}
               → Cube (horiz-degen-square p=) (horiz-degen-square (& coh-last-one)) (adapt-square (& Toα∞Push∞.coh p= y= sq s= u= x= ∙□ x=) ∙idp idp∙) vid-square vid-square (vcomp! (y= |∙ idp |∙ sq) (s= |∙ u=)))
    coh = path-induction

  δ∞Push∞Coh-coh : Coh ({A : Type i} {a b : A} {p : a == b} {d : A} {s : d == b}
        {c : A} {r : b == c} {f : A} {u : f == c} {e : A} {t : e == c}
        {w : f == e} {eta : Square w idp t u}
        {v : d == e} {nat : Square v s t r}
        {vw : d == f} {vw-eq : vw == v ∙ ! w}
        {a' : _} {a= : a == a'}
        {b' : _} {b= : b == b'}
        {p' : _} {p= : Square p a= b= p'}
        {d' : _} {d= : d == d'}
        {s' : _} {s= : Square s d= b= s'}
        {c' : _} {c= : c == c'}
        {r' : _} {r= : Square r b= c= r'}
        {f' : _} {f= : f == f'}
        {u' : _} {u= : Square u f= c= u'}
        {e' : _} {e= : e == e'}
        {t' : _} {t= : Square t e= c= t'}
        {w' : _} {w= : Square w f= e= w'}
        {eta' : _} (eta= : Cube eta eta' w= vid-square t= u=)
        {v' : _} {v= : Square v d= e= v'}
        {nat' : _} (nat= : Cube nat nat' v= s= t= r=)
        {vw' : _} {vw= : Square vw d= f= vw'}
        {vw-eq' : _} (vw-eq= : Cube (horiz-degen-square vw-eq) (horiz-degen-square vw-eq') vw= vid-square vid-square (vcomp! v= w=))
        → Cube (& δ∞Push∞.coh p eta nat vw-eq) (& δ∞Push∞.coh p' eta' nat' vw-eq') (vcomp! p= s=) p= vw= (vcomp! r= u=))
  δ∞Push∞Coh-coh = path-induction

  piece1 : FlatCube (ap-square to (& δ∞Push∞.coh (push∞ n x) (ap-square (in∞ (S (S n))) (η n x))
                                                (natural-square (push∞ (S n)) (β n x) idp (ap-∘ _ _ _))
                                                (push∞-β {in∞* = α∞-in∞ ⋆A} {push∞* = α∞-push∞ ⋆A} n x)))
                    (& δ∞Push∞.coh (ap to (push∞ n x))
                                  (ap-square to (ap-square (in∞ (S (S n))) (η n x)))
                                  (ap-square to
                                    (natural-square (push∞ (S n)) (β n x) idp
                                                    (ap-∘ (in∞ (S (S n))) (ι (S n)) (β n x))))
                                  (ap-shape-∙! to (push∞-β {in∞* = α∞-in∞ ⋆A} {push∞* = α∞-push∞ ⋆A} n x)))
                    (ap-∙! _ _ _) idp idp (ap-∙! _ _ _)
  piece1 = & (δ∞Push∞.ap-coh to) {b = in∞ (S n) (ι n x)} {d = in∞ (S n) (α n ⋆A x)}

  piece2 : Cube (& δ∞Push∞.coh (ap to (push∞ n x))
                              (ap-square to (ap-square (in∞ (S (S n))) (η n x)))
                              (ap-square to (natural-square (push∞ (S n)) (β n x) idp (ap-∘ (in∞ (S (S n))) inr (β n x))))
                              (ap-shape-∙! to (push∞-β {in∞* = α∞-in∞ ⋆A} {push∞* = α∞-push∞ ⋆A} n x)))
                (& δ∞Push∞.coh (δJ (inJ n x)) (horiz-degen-square (ηJ (inJ n x))) hid-square (& coh-last-one))
                (vcomp! (to-push∞ n x) side2)
                (to-push∞ n x)
                side7
                (vcomp! side4 side6)
  piece2 = & δ∞Push∞Coh-coh to-in∞-η to-push∞-βn last-one

  piece3 : FlatCube (& δ∞Push∞.coh (δJ (inJ n x)) (horiz-degen-square (ηJ (inJ n x))) hid-square (& coh-last-one))
                    (ap-δJ (δJ (inJ n x)))
                    ∙idp idp idp ∙idp
  piece3 = & coh where

    coh : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q q' : b == c} {sq : Square p p q q'}
              → FlatCube (& δ∞Push∞.coh p (horiz-degen-square (& (ηIfy.coh αJ δJ) sq)) hid-square (& coh-last-one)) sq ∙idp idp idp ∙idp)
    coh = path-induction

  piece4 : Cube (ap-δJ (ap to (push∞ n x)))
                (ap-δJ (δJ (inJ n x)))
                hid-square (to-push∞ n x) (ap-square (αJ ⋆A) (to-push∞ n x)) (ap-δJ (inJS-ι n x))
  piece4 = & natural-cube2 δJ (to-push∞ n x) (ap-square-idf _) (hid-flatcube _)

  to-δ∞-push∞ : Cube (ap-square to (natural-square δ∞ (push∞ n x) (ap-idf _) idp))
                    (ap-δJ (ap to (push∞ n x)))
                    (to-δ∞-in∞ n x)
                    hid-square
                    (to-α∞-push∞ ⋆A n x)
                    (to-δ∞-in∞ (S n) (ι n x))
  to-δ∞-push∞ = adapt-cube (ap (ap-square to) (natural-square-β δ∞ (push∞ n x) (push∞-βd n x))
                          -∙³ piece1
                          |∙³ piece2
                          ∙³x piece3
                          |∙³ !³ piece4)
                 idp ∙idp !-inv-r !-inv-r
                 (& coh1 (& (coh-flat to) {b = in∞ (S n) (α n ⋆A x)})) (& coh2) (& coh3) (& coh4 (& (coh-flat to) {a = in∞ (S n) (ι n x)})) where

    flat : Coh ({A : Type i} {a c : A} {s : a == c} {b : A} {r : b == c} {p : a == b} (sq : Square p idp r s) → p == s ∙ ! r)
    flat = path-induction

    coh-flat : {A B : Type i} (f : A → B) → Coh ({a c : A} {s : a == c} {b : A} {r : b == c} → & flat (ap-square f (& δ∞Inβ.coh)) == ap-∙! f s r)
    coh-flat f = path-induction

    coh1 : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {r r' : b == c} {r= : r == r'}
                {s : a == c} {sq1 : Square p idp r s} {d : A} {t : c == d}
                {u : a == d} {sq2 : Square s idp t u}
                {rt : b == d} {sq3 : Square r' rt t idp}
                {p= : p == s ∙ ! r} (p== : & flat sq1 == p=)
               → adapt-square (p= |∙ vcomp! sq2 (idp |∙ r= |∙ sq3) ∙□ ∙idp |∙ !² hid-square) idp ∙idp == & Toδ∞In.coh r= sq1 sq2 sq3)
    coh1 = path-induction

    coh2 : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {r : b == c} {s : a == c} {sq : Square p idp r s}
               → adapt-square (idp |∙ sq ∙□ idp |∙ !² sq) idp !-inv-r == hid-square)
    coh2 = path-induction

    coh3 : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : a == c} {s : c == b} {sq1 : Square p q idp s} {d : A} {t : b == d} {u : c == d} {sq2 : Square s idp t u}
                → adapt-square (idp |∙ adapt-square (sq1 ∙□ sq2) ∙idp idp∙ ∙□ idp |∙ !² sq2) ∙idp !-inv-r == sq1)
    coh3 = path-induction

    coh4 : Coh ({A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} {sq : Square p q r s}
                {p' : a == b} {p=□ : Square p' idp idp p} {t : b == b} {t=□ : t == idp} {t' : b == b} {t=' : t' == t}
                {pt' : a == b} {pt=2 : Square pt' idp t' p'} {pt= : pt' == p' ∙ ! t'} (pt== : & flat pt=2 == pt=)
               → adapt-square (pt= |∙ vcomp! (horiz-degen-path p=□ |∙ idp |∙ sq) (t=' |∙ t=□ |∙ vid-square) ∙□ ∙idp |∙ !² sq) !-inv-r !-inv-r
               == & Toδ∞In.coh t=' pt=2 p=□ (horiz-degen-square t=□))
    coh4 = path-induction

natural-square-idp-symm : {A B : Type i} {f : A → B} {x y : A} {p : x == y} → natural-square (λ a → idp {a = f a}) p idp idp == square-symmetry hid-square
natural-square-idp-symm {p = idp} = idp

to-δ∞ : (x : J∞A) → Square (ap to (δ∞ x)) idp (to-α∞ ⋆A x) (δJ (to x))
to-δ∞ = J∞A-elim to-δ∞-in∞ (λ n x → cube-to-↓-path idp (ap-∘ _ _ _) idp (ap-∘ _ _ _)
  (adapt-cube-idp (cube-rotate (to-δ∞-push∞ n x))
                  (& (ap-square-natural-square to) (push∞ n x) δ∞ coh ∙idp)
                  (! natural-square-idp-symm)
                  (! (natural-square-β (to-α∞ ⋆A) (push∞ n x) (push∞-βd n x)))
                  (! (& (natural-square-∘ (push∞ n x) to) δJ coh2 (!-inv-l)))))  where

  coh : {A B : Type i} {f : A → B} {x y : A} {p : x == y} → ap-∘ f (λ z → z) p ∙ ap (ap f) (ap-idf p) == idp
  coh {p = idp} = idp

  coh2 : {A B : Type i} {f : A → B} {x y : A} {p : x == y} → ∘-ap (λ z → z) f p ∙ idp == ap-idf (ap f p)
  coh2 {p = idp} = idp

to-from : (x : JA) → to (from x) == x
to-from = JA-elim to-ε∞
                   (λ a x y → to-α∞ a (from x) ∙ ap (αJ a) y)
                   (λ x y → ↓-='-from-square (ap-∘ to from (δJ x) ∙ ap (ap to) (δJ-β x)) (ap-idf (δJ x))
                     (square-symmetry (adapt-square (to-δ∞ (from x) ∙□ ap-δJ y) idp∙ idp)))


module WrongNumberOfConstructorArguments where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

f : Nat -> Nat
f (zero n) = n
f suc      = zero


{-
This second-order term syntax was created from the following second-order syntax description:

syntax UTLC | Λ

type
  * : 0-ary

term
  app  : *  *  ->  * | _$_ l20
  lam  : *.*  ->  * | ƛ_ r10

theory
  (ƛβ) b : *.*  a : * |> app (lam (x.b[x]), a) = b[a]
  (ƛη) f : *          |> lam (x.app (f, x))    = f
  (lβ) b : *.*  a : * |> letd (a, x. b) = b[a]
-}

module UTLC.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import UTLC.Signature

private
  variable
    Γ Δ Π : Ctx
    α : *T
    𝔛 : Familyₛ

-- Inductive term declaration
module Λ:Terms (𝔛 : Familyₛ) where

  data Λ : Familyₛ where
    var  : ℐ ⇾̣ Λ
    mvar : 𝔛 α Π → Sub Λ Π Γ → Λ α Γ

    _$_  : Λ * Γ → Λ * Γ → Λ * Γ
    ƛ_   : Λ * (* ∙ Γ) → Λ * Γ

  infixl 20 _$_
  infixr 10 ƛ_

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  Λᵃ : MetaAlg Λ
  Λᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (appₒ  ⋮ a , b) → _$_  a b
      (lamₒ  ⋮ a)     → ƛ_   a
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module Λᵃ = MetaAlg Λᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : Λ ⇾̣ 𝒜
    𝕊 : Sub Λ Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞 (_$_  a b) = 𝑎𝑙𝑔 (appₒ  ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞 (ƛ_   a)   = 𝑎𝑙𝑔 (lamₒ  ⋮ 𝕤𝕖𝕞 a)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ Λᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ Λ α Γ) → 𝕤𝕖𝕞 (Λᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (appₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (lamₒ  ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ Λ ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : Λ ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ Λᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : Λ α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub Λ Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (_$_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (ƛ_ a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
Λ:Syn : Syntax
Λ:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = Λ:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open Λ:Terms 𝔛 in record
    { ⊥ = Λ ⋉ Λᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax Λ:Syn public
open Λ:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands Λᵃ public
open import SOAS.Metatheory Λ:Syn public

-- Derived operations
letd : Λ 𝔛 * Γ → Λ 𝔛 * (* ∙ Γ) → Λ 𝔛 * Γ
letd a b = (ƛ b) $ a


{-# OPTIONS --no-unicode #-} -- turn off automatic unicode insertion

module 02-agda-start where

-------------------------------------------------------------------------------------------------------
-- ADDITIONAL RESOURCES |
-------------------------
-- допълнителни ресурси:
-- https://github.com/pigworker/CS410-17 - курс (има и домашни) с видео лекции, добър лектор
-- ^ има още много repo-та които си струват разглеждане
-- един от хората измислили Applicative бтв, както и with-abstraction, което ще видим по-късно

-- https://plfa.github.io/ - книга с подробни обяснения и описания, има и упражнения, втората част се занимава с имплементиране на ламбда смятане

-------------------------------------------------------------------------------------------------------
-- CHEATSHEETS |
----------------
-- SPACEMACS CHEATSHEET:
-- <SPC> h <SPC> -- search for help, including agda's help

-- <SPC> <TAB> - go to previous buffer -- helpful to go back after looking at help
-- <SPC> z x -/= - decrease/increase font size

-- normal emacs agda bindings:
-- https://agda.readthedocs.io/en/v2.6.1/tools/emacs-mode.html#keybindings
-- spacemacs agda layer bindings (but also can open them with <SPC> h <SPC> inside spacemacs):
-- https://github.com/syl20bnr/spacemacs/tree/master/layers/%2Blang/agda#key-bindings

-- AGDA CHEATSHEET (descending importance):
-- <SPC> m l - reload file

-- <SPC> m , - (in goal) show context and goal

-- <SPC> m . - (in goal) show type of expression in goal. if goal is empty agda will ask for an expression to type

-- <SPC> m c - case split on goal contents
--             if goal is empty, will ask for what to split on

-- <SPC> m r - introduce constructor (if non-ambiguous)
--             can also introduce constructors, lambdas, record constructors
--             if there's a function in the goal it will "introduce" it with its arguments as new goals

-- <SPC> m <SPC> - when in a goal, replace the goal with the expression currently in the goal
--               if the goal is empty, agda will ask for an expression to insert
--               obviously only works if types match

-- <SPC> m a - (invoke "agsy") agda try your best to figure this out!
--             you can add names to a goal to give hints to agda, e.g. if you want to use a function "f"

-- <SPC> m x r - restart agda

-- <SPC> u <SPC> u <other-command> - kindly ask agda to evaluate and desugar everything as much as it can when executing <other-command>

-- <SPC> m f - go to next goal

-- <SPC> m n - compute an expression

-- <SPC> m h - when in a hole, compute what the type of a helper function you need here would be

-------------------------------------------------------------------------------------------------------
-- EXERCISE |
-------------

-- a haskell type declaration
--data List a
--  = Nil
--  | Cons a (List a)
--

-- same thing but in agda
--data List (A : Set) : Set where
--  Nil : List A
--  Cons : A -> List A -> List A

-- X : Y - "X is of type Y"
-- Set is the "kind" of types
-- it's safe to just read it as "Type" instead

-- identity function, with an explicit type as an argument
-- in agda we don't have (and don't need) "implicit polymorphic types"
-- like how in haskell when we write a -> a we actually mean "for all a (a -> a)"
-- so instead we "simulate" it by taking a type as an argument
id' : (A : Set) -> A -> A
id' _ x = x

-- we can also have it implicitly inferred, by using {} to specify the argument
-- agda doesn't have global type inference (because it's not decidable in general) - you always need to write top level signatures
id : {A : Set} -> A -> A
id x = x

-- a data type definition
-- it has no constructors
-- therefore it cannot be constructed!
-- this is an encoding of "falsity" exactly because you can't make values (proofs) of it
-- called Zero because it contains 0 values
data Zero : Set where -- ⊥

-- therefore if you are handed something of Zero
-- you can try to inspect it, to show that it's not possible for it to exist!
-- this is "efq"
naughtE : {A : Set} -> Zero -> A
naughtE ()
--      ^ this bit is special syntax for "impossible case" - not the same thing as () in haskell

-- a record type - "dual" in some sense to a data type
-- very similar to a struct in C:
-- in order to construct a record type, you need to give values for all its fields
-- this record has *no* fields, therefore to construct it you need to give *no values*
-- and it is therefore very easy to construct
-- it encodes "trivial truth" in logic, exactly because you don't need any assumptions to create it
-- the "constructor <>" syntax introduces a convenient way to create values from this type, instead of using record syntax
-- called One because it contains one value
record One : Set where -- unit/top/⊤
  constructor <>

-- an example value from One
one : One
one = <>

-- an example value constructed with record syntax
one' : One
one' = record {} -- no values to give!

-- example of a record type with some actual fields!
--record Student : Set where
--  field
--    fn : Number -- these types don't actually exist yet, but let's assume they do
--    name : String
--
--georgi : Student
--georgi =
--  record
--    { fn = {!81248!}
--    ; name = {!"Georgi"!}
--    }

-- boolean values - to construct a Two we either use the ff or the tt constructor
-- called Two because it has two values
data Two : Set where
  ff : Two
  tt : Two

-- an example of "mixfix" syntax
-- we can define a function with three arguments
-- the _s are where we would place arguments
if_then_else_ : {A : Set} -> Two -> A -> A -> A
if ff then t else e = e
if tt then t else e = t

-- we can write ordinary functions that return types, based on some value!
-- this function "promotes" the boolean *values* to their "corresponding" *logical types*
-- e.g. we convert the boolean "false" to our encoding of falsity - the type Zero
IsTrue : Two -> Set
IsTrue ff = Zero
IsTrue tt = One

_ : IsTrue tt
_ = <>

-- a sum type - it's either the left thing or the right thing
-- Either in haskell
-- as a logical construction it's a proof of either a or either b
data _+_ (A B : Set) : Set where -- A || B
  inl : A -> A + B
  inr : B -> A + B

_ : Zero + One
_ = inr <>

-- two-tuples defined as a record
-- a logical encoding for proof of *both* a *and* b
-- (a, b) in haskell
-- we will instead get this as a special case from our next construction
--record _*_ (A B : Set) : Set where -- A && B
--  constructor _,_
--  field
--    fst : A
--    snd : B

-- a **dependent two-tuple** - called a sigma type in books
-- **the type of the second field can depend on the value of the first**
-- this is an encoding of "exists" quantifiers-
-- to prove (constructively) ∃x.P(x), you must give me a x₀, and then prove that P(x₀)
-- which is effectively a two-tuple of a value x, and a proof P x
record _><_ (A : Set) (P : A -> Set) : Set where
  constructor _,_
  field
    fst : A
    snd : P fst

infixr 15 _><_
open _><_

-- an example of a dependent tuple
-- we give a value, and then show proof that the value satisfies our predicate "IsTrue"
-- ofcourse, if we give the value ff, we would not be able to construct this, because we cannot prove Zero
_ : Two >< IsTrue
_ = tt , <>

-- another example of construction of a sigma type
--data Nat : Set where
--  zero : Nat
--  suc : Nat -> Nat
--
--three : Nat
--three = suc (suc (suc zero))
--
--Even : Nat -> Set
--Even zero = One
--Even (suc zero) = Zero
--Even (suc (suc x)) = Even x
--
--twoIsEven : Nat >< Even
--twoIsEven = (suc (suc zero)) , <>

-- and now we can get our regular 2-tuples for free as a special case of sigma types
-- in which the second argument doesn't depend on the first (notice how our lambda ignores its argument)
_*_ : (A B : Set) -> Set
A * B = A >< \_ -> B
infixr 15 _*_

-- we can encode Either using a sigma type with Two as our left type!
-- to construct an Either
-- you must either use tt (the "left" constructor) in which case our if then else will compute to A, therefore we must give an A
-- or you must either use ff (the "right" constructor) in which case our if then else will compute to B, therefore we must give a B
Either : (A B : Set) -> Set
Either A B = Two >< \b -> if b then A else' B
  where
  -- note: I used another version of if_then_else, because our original one had arguments that are **values of some type**, i.e. (x : A), for some A : Set,
  -- but here we're actually using the **A itself** as an argument, and our original function handle this
  -- this one is **polymorphic over levels** (similar to kind polymorphism in haskell) - it works for both (x : A) and for (A : Set) and for a lot of other stuff
  if_then_else'_ : forall {l} -> {A : Set l} -> Two -> A -> A -> A
  if ff then t else' e = e
  if tt then t else' e = t

-- an example of a function using _*_
-- and a theorem at the same time
-- if you know that A * B is true, then you can also prove B * A (so some kind of symmetry/commutativity)
*-theorem1 : {A B : Set} -> A * B -> B * A
*-theorem1 (x , y) = y , x

-- peano-encoded natural numbers
data Nat : Set where
  zero : Nat
  suc : Nat -> Nat -- a recursive case in a constructor
{-# BUILTIN NATURAL Nat #-} -- pragma allows us to write literals, e.g. 2 to mean (suc (suc zero)), and also to compile these to Integer, if we compile to haskell

-- traditional left-recursive peano nat addition
-- how you define your functions has great repercussions!
-- because all your proofs will now have to look at the left argument of n +N m in order to proceed!
_+N_ : Nat -> Nat -> Nat
zero +N m = m
suc n +N m = suc (n +N m)

infixr 30 _+N_

-- an equality type
-- to show that x == y for some values x and y
-- you can do only one thing: show that x and y are actually the same value (by using the refl constructor)
-- this "syntactic equality" is internal to agda, but you can think of it as basically "the same structure" (when you look at e.g. constructors)
data _==_ {A : Set} : A -> A -> Set where
  refl : {x : A} -> x == x

infix 20 _==_
{-# BUILTIN EQUALITY _==_ #-} -- allows us to use rewrites for this equality type

-- a proof that 2 is equal to 2
-- since 2 is the same syntactic object (suc (suc zero)) as itself, we can use refl
twoIsTwo : 2 == 2
twoIsTwo = refl

-- similarly, in this case 1 +N 1 is not immediately the same thing as 2
-- but agda automatically applies (beta-reduces) the definition of +N as much as possible,
-- and can calculate that they are actually the same!
onePlusOneIsTwo : (1 +N 1) == 2
onePlusOneIsTwo = refl

-- another way to define == where the x is a parameter instead
--data _=='_ {A : Set} (x : A) -> A -> Set where
--  refl : x == x

-- a proof demonstrating how to use ==
-- this states that if you have two proofs of x and y being equal
-- then the proofs themselves are equal to one another!
==-unique : {A : Set} {x y : A} (p1 p2 : x == y) -> p1 == p2
==-unique refl refl = refl
-- note that this is not always true, and it is an active area of research (homotopy type theory),
-- which might provide solutions to problems in constructive mathematics
-- in it, you cannot prove this theorem, and indeed, there are p1 and p2 there, which *are not* equal to each other

-- ap allows us to "apply a function to both sides of an equality"
-- i.e. on a piece of paper we automatically assume this, because f is a function
ap : {A B : Set} {x y : A} (f : A -> B) -> x == y -> f x == f y
ap f refl = refl

-- this proof doesn't need to look at n at all, because we have a case for 0 +N _ in the definition of +N
-- and agda can automatically compute it
+N-left-zero : (n : Nat) -> 0 +N n == n
+N-left-zero n = refl

-- but it is not the same in this case!
-- and thus we use recursion to prove this
+N-right-zero : (n : Nat) -> n +N 0 == n
+N-right-zero zero = refl
+N-right-zero (suc n') = ap suc (+N-right-zero n')
-- another alternative to the last case would be to use "rewrite"
-- the rewrite declaration allows us to "rewrite" our goal by using an equality provided by us
-- i.e. if we have a goal that has some x's in it, and we have a proof (p : x == y)
-- then rewrite p will change all the x's into y's in our goal

+N-assoc : (n m k : Nat) -> (n +N m) +N k == n +N (m +N k)
+N-assoc zero m k = refl
+N-assoc (suc n) m k rewrite +N-assoc n m k = refl

---- EXERCISES ==
--
---- EXERCISE: == is symmetric
--==-symm : {A : Set} {x y : A} -> x == y -> y == x
--==-symm = ?
--
---- EXERCISE: == is transitive
--==-trans : {A : Set} {x y z : A} -> x == y -> y == z -> x == z
--==-trans = ?
--
---- EXERCISES Nats
--
---- EXERCISE: suc is injective
--suc-inj : {n m : Nat} -> suc n == suc m -> n == m
--suc-inj = ?

data _<=_ : Nat -> Nat -> Set where
  ozero : {n : Nat} -> zero <= n
  osuc : {n m : Nat} -> n <= m -> suc n <= suc m

-- TODO: show some inequalities

---- EXERCISE: <=-refl
--<=-refl : (n : Nat) -> n <= n
--<=-refl n = ?
--
---- EXERCISE: <=-trans
--<=-trans : {n m k : Nat} -> n <= m -> m <= k -> n <= k
--<=-trans = ?
--
---- EXERCISE: suc n is not less than or equal to n
--suc-suc-not-<= : {n : Nat} -> suc n <= n -> Zero
--suc-suc-not-<= = ?
--
---- EXERCISE: <= proofs are unique
---- use ap or rewrite!
--<=-unique : {n m : Nat} -> (p1 p2 : n <= m) -> p1 == p2
--<=-unique = ?
--
---- lists
--
--data List (A : Set) : Set where
--  [] : List A
--  _,-_ : A -> List A -> List A
--
--infixr 50 _,-_
--
---- EXERCISE:
---- Define list appending
---- HINT: look at +N if you haven't done this before
--_+L_ : {A : Set} -> List A -> List A -> List A
--xs +L ys = ?
--
--infixr 30 _+L_
--
---- EXERCISE:
---- +L is a monoid - with what left and right unit?
---- i.e. for what x is it true that for any xs:
---- x +L xs == xs and xs +L x == xs
---- TODO: delete []
--+L-left-id : {A : Set} (xs : List A) -> [] +L xs == xs
--+L-left-id = ?
--
--+L-right-id : {A : Set} (xs : List A) -> xs +L [] == xs
--+L-right-id = ?
--
---- EXERCISE:
---- +L is associative
---- HINT: look at +N-assoc
--+L-assoc : {A : Set} (xs ys zs : List A) -> (xs +L ys) +L zs == xs +L (ys +L zs)
--+L-assoc = ?
--
---- EXERCISE: list map
---- define map for lists - apply a function to every argument
--map : {A B : Set} -> (A -> B) -> List A -> List B
--map = ?
--
---- EXERICSE: mapping id is the same as just id
--map-id-is-id : {A : Set} -> (xs : List A) -> map id xs == xs
--map-id-is-id = ?
---- Note: we apply the argument to avoid extensionality issues
--
---- left-to-right composition
--_<<_ : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C
--(f << g) x = ?
--
---- EXERCISE: mapping a composition is the same as composing mappings
---- <SPC> u <SPC> u <other-command>
---- might be useful here
--map-compose : {A B C : Set} (f : B -> C) (g : A -> B) (xs : List A) -> map (f << g) xs == (map f << map g) xs
--map-compose = ?
--
---- EXERCISE: mapping after appending is the same as first mapping and then appending
--map-distrib-+L : {A B : Set} (f : A -> B) (xs ys : List A) -> map f (xs +L ys) == map f xs +L map f ys
--map-distrib-+L = ?
--
---- EXERCISE: length-indexed lists - vectors
---- "lists that know their length"
--
--data Vector (A : Set) : Nat -> Set where
--  [] : Vector A zero -- the empty vector has a length of 0
--  _,-_ : {n : Nat} -> A -> Vector A n -> Vector A (suc n) -- if we cons an element to a vector of length n, we get a vector of length (suc n)
--
---- EXERCISE: We can now define a safe head and tail - you can't call them with []
---- Compare this to the default ones in haskell, that can throw exceptions
--vhead : {A : Set} {n : Nat} -> Vector A (suc n) -> A
--vhead = ?
--
--vtail : {A : Set} {n : Nat} -> Vector A (suc n) -> Vector A n
--vtail = ?
--
---- EXERCISE: We can also define "safe" take, that does not "overshoot"
---- Note how we don't need to pass n explicitly, because n <= m holds this information already
--vtake : {A : Set} {n m : Nat} -> n <= m -> Vector A m -> Vector A n
--vtake = ?
--
---- EXERCISE: Our zip is also "safe" in that we don't lose any information from either vector
--vzip : {A B : Set} {n : Nat} -> Vector A n -> Vector B n -> Vector (A * B) n
--vzip = ?
--
---- EXERCISE: Append vectors
---- What type should this function have?
---- _+V_ : ?
--
---- EXERCISE: We can split a vector if we know its size is a sum of two numbers
---- N.B.! you need to pattern match on the left number here, because otherwise agda doesn't know
---- what cases could be possible for the vector
--vsplit : {A : Set} (n m : Nat) -> Vector A (n +N m) -> Vector A n * Vector A m
--vsplit = ?
--
---- EXERCISE: Appending two vectors and then splitting them should yield the original two vectors!
---- What type should this have?
---- vsplit-+V-id : ?
--
---- EXERCISE: you can also suc on the right in +N
--+N-right-suc : (n m : Nat) -> suc (n +N m) == n +N suc m
--+N-right-suc = ?
--
---- EXERCISE: +N is commutative
---- prove lemmas if something seems too hard!
---- you'll need to prove a lemma for the recursive case
---- HINT:
---- use ==-symm and +N-right-zero in the base case
---- and +N-right-suc in the recursive case (+ rewrite or ap + ==-trans)
--+N-commut : (n m : Nat) -> n +N m == m +N n
--+N-commut = ?
--
---- EXERCISE: multiplication
---- use addition
--_*N_ : Nat -> Nat -> Nat
--n *N m = ?
--infixr 40 _*N_
--
---- EXERCISE: multiplication right identity
--*N-right-id : (n : Nat) -> n *N 1 == n
--*N-right-id = ?
--
---- EXERCISE: multiplication distributes over addition
---- HINT: use rewrite and ==-symm + +N-assoc in the recursive case
--*N-distrib-+N : (n m k : Nat) -> (n +N m) *N k == n *N k +N m *N k
--*N-distrib-+N = ?
--
---- EXERCISE: multiplication is associative
---- HINT: user *N-+N-distrib and rewrite
--*N-assoc : (n m k : Nat) -> (n *N m) *N k == n *N (m *N k)
--*N-assoc = ?


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Lists.Lists
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Decidable.Sets
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Semiring

module Computability.LambdaCalculus.Definition where

open import UnorderedSet.Definition (ℕDecideEquality)

data Term : Set where
  var : (v : ℕ) → Term
  lam : (x : ℕ) → Term → Term
  apply : Term → Term → Term


-- Andreas, 2014-09-23, later changed by someone else
-- Issue 1194, reported by marco.vax91, 2014-06-13

module _ where

module A where

  data D₁ : Set where
    b : D₁
    c : D₁ → D₁

  infix 19 c

  syntax c x = ! x

module B where

  data D₂ : Set where
    _+_ : D₂ → D₂ → D₂
    c   : A.D₁ → D₂

  infix 10 _+_
  infix 20 c

  syntax c x = ! x

open A
open B

test : D₂
test = ! b + ! b


{-# OPTIONS --without-K --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Reducibility {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped hiding (_∷_)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties

open import Tools.Nat
open import Tools.Product

private
  variable
    n : Nat
    Γ : Con Term n

-- Valid types are reducible.
reducibleᵛ : ∀ {A l}
             ([Γ] : ⊩ᵛ Γ)
           → Γ ⊩ᵛ⟨ l ⟩ A / [Γ]
           → Γ ⊩⟨ l ⟩ A
reducibleᵛ [Γ] [A] =
  let ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevance′ (subst-id _) (proj₁ ([A] ⊢Γ [id]))

-- Valid type equality is reducible.
reducibleEqᵛ : ∀ {A B l}
               ([Γ] : ⊩ᵛ Γ)
               ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
             → Γ ⊩ᵛ⟨ l ⟩ A ≡ B / [Γ] / [A]
             → Γ ⊩⟨ l ⟩ A ≡ B / reducibleᵛ [Γ] [A]
reducibleEqᵛ {A = A} [Γ] [A] [A≡B] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceEq″ (subst-id _) (subst-id _)
                      (proj₁ ([A] ⊢Γ [id])) [σA] ([A≡B] ⊢Γ [id])

-- Valid terms are reducible.
reducibleTermᵛ : ∀ {t A l}
                 ([Γ] : ⊩ᵛ Γ)
                 ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
               → Γ ⊩ᵛ⟨ l ⟩ t ∷ A / [Γ] / [A]
               → Γ ⊩⟨ l ⟩ t ∷ A / reducibleᵛ [Γ] [A]
reducibleTermᵛ {A = A} [Γ] [A] [t] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceTerm″ (subst-id _) (subst-id _)
                        (proj₁ ([A] ⊢Γ [id])) [σA] (proj₁ ([t] ⊢Γ [id]))

-- Valid term equality is reducible.
reducibleEqTermᵛ : ∀ {t u A l}
                   ([Γ] : ⊩ᵛ Γ)
                   ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
                 → Γ ⊩ᵛ⟨ l ⟩ t ≡ u ∷ A / [Γ] / [A]
                 → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / reducibleᵛ [Γ] [A]
reducibleEqTermᵛ {A = A} [Γ] [A] [t≡u] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceEqTerm″ (subst-id _) (subst-id _) (subst-id _)
                          (proj₁ ([A] ⊢Γ [id])) [σA] ([t≡u] ⊢Γ [id])


import      Lvl
open import Type

module Structure.Logic.Constructive.BoundedPredicate
  {ℓₗ}  {Formula : Type{ℓₗ}}
  {ℓₘₗ} (Proof : Formula → Type{ℓₘₗ})
  {ℓₚ}  {Predicate : Type{ℓₚ}}
  {ℓₒ}  {Domain : Type{ℓₒ}}
  (_$_ : Predicate → (x : Domain) → ∀{B : Domain → Formula} → Proof(B(x)) → Formula)
  where

import      Logic.Predicate as Meta
open import Type.Dependent using (Σ)
open import Type.Properties.Inhabited using (◊)
import      Structure.Logic.Constructive.Propositional as Propositional
open import Syntax.Function

private variable P : Predicate
private variable X Y Q : Formula
private variable x y z : Domain
private variable B : Domain → Formula

-- Rules of universal quantification (for all).
record BoundedUniversal(∀ₗ : (Domain → Formula) → Predicate → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    intro : (∀{x} → (bx : Proof(B(x))) → Proof((P $ x) {B} bx)) → Proof(∀ₗ B P)
    elim  : Proof(∀ₗ B P) → ∀{x} → (bx : Proof(B(x))) → Proof((P $ x) {B} bx)
∀ₗ = \ ⦃(Meta.[∃]-intro ▫) : Meta.∃(BoundedUniversal)⦄ → ▫
module ∀ₛ {▫} ⦃ p ⦄ = BoundedUniversal {▫} p

-- Rules of existential quantification (exists).
record BoundedExistential(∃ : (Domain → Formula) → Predicate → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    intro : (bx : Proof(B(x))) → Proof((P $ x) {B} bx) → Proof(∃ B P)
    elim  : (∀{x} → (bx : Proof(B(x))) → Proof((P $ x) {B} bx) → Proof(Q)) → (Proof(∃ B P) → Proof(Q))
∃ = \ ⦃(Meta.[∃]-intro ▫) : Meta.∃(BoundedExistential)⦄ → ▫
module ∃ₛ {▫} ⦃ p ⦄ = BoundedExistential {▫} p

record BoundedExistentialWitness(∃ : (Domain → Formula) → Predicate → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    witness : Proof(∃ B P) → Domain
    bound   : (p : Proof(∃ B P)) → Proof(B(witness p))
    proof   : (p : Proof(∃ B P)) → Proof((P $ witness p) {B} (bound p))

record Logic : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    ⦃ propositional ⦄ : Propositional.Logic(Proof)
    ⦃ universal ⦄     : Meta.∃(BoundedUniversal)
    ⦃ existential ⦄   : Meta.∃(BoundedExistential)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.FiniteMultiset.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Nat
open import Cubical.Data.Empty as ⊥
open import Cubical.Relation.Nullary
open import Cubical.HITs.FiniteMultiset.Base
open import Cubical.Structures.MultiSet
open import Cubical.Relation.Nullary.DecidableEq

private
  variable
    ℓ : Level
    A : Type ℓ

infixr 30 _++_

_++_ : ∀ (xs ys : FMSet A) → FMSet A
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ xs ++ ys
comm x y xs i ++ ys = comm x y (xs ++ ys) i
trunc xs zs p q i j ++ ys =
  trunc (xs ++ ys) (zs ++ ys) (cong (_++ ys) p) (cong (_++ ys) q) i j

unitl-++ : ∀ (xs : FMSet A) → [] ++ xs ≡ xs
unitl-++ xs = refl

unitr-++ : ∀ (xs : FMSet A) → xs ++ [] ≡ xs
unitr-++ = ElimProp.f (trunc _ _) refl (λ x p → cong (_∷_ x) p)

assoc-++ : ∀ (xs ys zs : FMSet A) → xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs
assoc-++ = ElimProp.f (isPropΠ2 (λ _ _ → trunc _ _))
                      (λ ys zs → refl)
                      (λ x p ys zs → cong (_∷_ x) (p ys zs))

cons-++ : ∀ (x : A) (xs : FMSet A) → x ∷ xs ≡ xs ++ [ x ]
cons-++ x = ElimProp.f (trunc _ _)
  refl
  (λ y {xs} p → comm x y xs ∙ cong (_∷_ y) p)

comm-++ : ∀ (xs ys : FMSet A) → xs ++ ys ≡ ys ++ xs
comm-++ = ElimProp.f (isPropΠ (λ _ → trunc _ _))
  (λ ys → sym (unitr-++ ys))
  (λ x {xs} p ys → cong (x ∷_) (p ys)
                 ∙ cong (_++ xs) (cons-++ x ys)
                 ∙ sym (assoc-++ ys [ x ] xs))

module FMSetUniversal {ℓ} {M : Type ℓ} (MSet : isSet M)
  (e : M) (_⊗_ : M → M → M)
  (comm-⊗ : ∀ x y → x ⊗ y ≡ y ⊗ x) (assoc-⊗ : ∀ x y z → x ⊗ (y ⊗ z) ≡ (x ⊗ y) ⊗ z)
  (unit-⊗ : ∀ x → e ⊗ x ≡ x)
  (f : A → M) where

  f-extend : FMSet A → M
  f-extend = Rec.f MSet e (λ x m → f x ⊗ m)
         (λ x y m → comm-⊗ (f x) (f y ⊗ m) ∙ sym (assoc-⊗ (f y) m (f x)) ∙ cong (f y ⊗_) (comm-⊗ m (f x)))

  f-extend-nil : f-extend [] ≡ e
  f-extend-nil = refl

  f-extend-cons : ∀ x xs → f-extend (x ∷ xs) ≡ f x ⊗ f-extend xs
  f-extend-cons x xs = refl

  f-extend-sing : ∀ x → f-extend [ x ] ≡ f x
  f-extend-sing x = comm-⊗ (f x) e ∙ unit-⊗ (f x)

  f-extend-++ : ∀ xs ys → f-extend (xs ++ ys) ≡ f-extend xs ⊗ f-extend ys
  f-extend-++ = ElimProp.f (isPropΠ λ _ → MSet _ _)
    (λ ys → sym (unit-⊗ (f-extend ys)))
    (λ x {xs} p ys → cong (f x ⊗_) (p ys) ∙ assoc-⊗ (f x) (f-extend xs) (f-extend ys))

  module _ (h : FMSet A → M) (h-nil : h [] ≡ e) (h-sing : ∀ x → h [ x ] ≡ f x)
           (h-++ : ∀ xs ys → h (xs ++ ys) ≡ h xs ⊗ h ys) where

    f-extend-unique : h ≡ f-extend
    f-extend-unique = funExt (ElimProp.f (MSet _ _)
                              h-nil
                              (λ x {xs} p → (h-++ [ x ] xs) ∙ cong (_⊗ h xs) (h-sing x) ∙ cong (f x ⊗_) p))

-- We want to construct a multiset-structure on FMSet A, the empty set and insertion are given by the constructors,
-- for the count part we use the recursor

-- If A has decidable equality we can define the count-function:
module _(discA : Discrete A) where
 FMScount-∷* : A → A → ℕ → ℕ
 FMScount-∷* a x n with discA a x
 ... | yes a≡x = suc n
 ... | no  a≢x = n

 FMScount-comm* :  (a x y : A) (n : ℕ)
                  →  FMScount-∷* a x (FMScount-∷* a y n)
                   ≡ FMScount-∷* a y (FMScount-∷* a x n)
 FMScount-comm* a x y n with discA a x | discA a y
 ... | yes a≡x | yes a≡y = refl
 ... | yes a≡x | no  a≢y = refl
 ... | no  a≢x | yes a≡y = refl
 ... | no  a≢x | no  a≢y = refl

 FMScount : A → FMSet A → ℕ
 FMScount a = Rec.f isSetℕ 0 (FMScount-∷* a) (FMScount-comm* a)

 FMS-with-str : MultiSet A (Discrete→isSet discA)
 FMS-with-str = (FMSet A , [] , _∷_ , FMScount)

 -- We prove some useful properties of the FMScount function
 FMScount-≡-lemma : ∀ {a} {x} xs → a ≡ x → FMScount a (x ∷ xs) ≡ suc (FMScount a xs)
 FMScount-≡-lemma {a} {x} xs a≡x with discA a x
 ...                         | yes _   = refl
 ...                         | no  a≢x = ⊥.rec (a≢x a≡x)

 FMScount-≡-lemma-refl : ∀ {x} xs → FMScount x (x ∷ xs) ≡ suc (FMScount x xs)
 FMScount-≡-lemma-refl {x} xs = FMScount-≡-lemma xs refl

 FMScount-≢-lemma : ∀ {a} {x} xs → ¬ a ≡ x → FMScount a (x ∷ xs) ≡ FMScount a xs
 FMScount-≢-lemma {a} {x} xs a≢x with discA a x
 ...                         | yes a≡x = ⊥.rec (a≢x a≡x)
 ...                         | no  _   = refl

 FMScount-0-lemma : ∀ xs → (∀ a → FMScount a xs ≡ 0) → xs ≡ []
 FMScount-0-lemma = ElimProp.f (isPropΠ λ _ → trunc _ _) (λ _ → refl) θ
  where
  θ : ∀ x {xs} → ((∀ a → FMScount a xs ≡ 0) → xs ≡ [])
               → ((∀ a → FMScount a (x ∷ xs) ≡ 0) → (x ∷ xs) ≡ [])
  θ x {xs} _ p = ⊥.rec (snotz (sym (FMScount-≡-lemma-refl xs) ∙ p x))

 -- we define a function that removes an element a from a finite multiset once
 -- by simultaneously defining two lemmas about it
 remove1 : A → FMSet A → FMSet A
 remove1 a [] = []
 remove1 a (x ∷ xs) with (discA a x)
 ...               | yes _ = xs
 ...               | no  _ = x ∷ remove1 a xs
 remove1 a (comm x y xs i) with discA a x with discA a y
 ... | yes a≡x      | yes a≡y = ((sym a≡y ∙ a≡x) i) ∷ xs
 ... | yes a≡x      | no  _   = y ∷ (eq i)
   where
     eq : xs ≡ remove1 a (x ∷ xs)
     eq with discA a x
     eq | yes _   = refl
     eq | no  a≢x = ⊥.rec (a≢x a≡x)
 remove1 a (comm x y xs i) | no  _        | yes a≡y = x ∷ (eq i)
   where
   eq : remove1 a (y ∷ xs) ≡ xs
   eq with discA a y
   eq | yes _   = refl
   eq | no  a≢y = ⊥.rec (a≢y a≡y)
 remove1 a (comm x y xs i) | no  a≢x      | no  a≢y = ((λ i → x ∷ (p i)) ∙∙ comm x y (remove1 a xs) ∙∙ (λ i → y ∷ (sym q i))) i
   where
    p : remove1 a (y ∷ xs) ≡ y ∷ (remove1 a xs)
    p with discA a y
    p | yes a≡y = ⊥.rec (a≢y a≡y)
    p | no  _   = refl
    q : remove1 a (x ∷ xs) ≡ x ∷ (remove1 a xs)
    q with discA a x
    q | yes a≡x = ⊥.rec (a≢x a≡x)
    q | no  _   = refl
 remove1 a (trunc xs ys p q i j) = trunc (remove1 a xs) (remove1 a ys) (cong (remove1 a) p) (cong (remove1 a) q) i j

 remove1-≡-lemma : ∀ {a} {x} xs → a ≡ x → xs ≡ remove1 a (x ∷ xs)
 remove1-≡-lemma {a} {x} xs a≡x with discA a x
 ...                            | yes _   = refl
 ...                            | no  a≢x = ⊥.rec (a≢x a≡x)

 remove1-≢-lemma : ∀ {a} {x} xs → ¬ a ≡ x → remove1 a (x ∷ xs) ≡ x ∷ remove1 a xs
 remove1-≢-lemma {a} {x} xs a≢x with discA a x
 ...                            | yes a≡x = ⊥.rec (a≢x a≡x)
 ...                            | no  _   = refl

 remove1-predℕ-lemma : ∀ a xs → FMScount a (remove1 a xs) ≡ predℕ (FMScount a xs)
 remove1-predℕ-lemma a = ElimProp.f (isSetℕ _ _) refl θ
  where
  θ : ∀ x {xs} → FMScount a (remove1 a xs) ≡ predℕ (FMScount a xs)
               → FMScount a (remove1 a (x ∷ xs)) ≡ predℕ (FMScount a (x ∷ xs))
  θ x {xs} p with discA a x
  ...        | yes _   = refl
  ...        | no  a≢x = FMScount-≢-lemma (remove1 a xs) a≢x ∙ p

 remove1-zero-lemma : ∀ a xs → FMScount a xs ≡ zero → xs ≡ remove1 a xs
 remove1-zero-lemma a = ElimProp.f (isPropΠ λ _ → trunc _ _) (λ _ → refl) θ
  where
  θ : ∀ x {xs} → (FMScount a xs ≡ zero → xs ≡ remove1 a xs)
               → FMScount a (x ∷ xs) ≡ zero → x ∷ xs ≡ remove1 a (x ∷ xs)
  θ x {xs} hyp p with discA a x
  ...            | yes _ = ⊥.rec (snotz p)
  ...            | no  _ = cong (x ∷_) (hyp p)

 remove1-suc-lemma : ∀ a n xs → FMScount a xs ≡ suc n → xs ≡ a ∷ (remove1 a xs)
 remove1-suc-lemma a n = ElimProp.f (isPropΠ λ _ → trunc _ _) (λ p → ⊥.rec (znots p)) θ
  where
  θ : ∀ x {xs} → (FMScount a xs ≡ suc n → xs ≡ a ∷ (remove1 a xs))
               → FMScount a (x ∷ xs) ≡ suc n → x ∷ xs ≡ a ∷ (remove1 a (x ∷ xs))
  θ x {xs} hyp p with discA a x
  ...            | yes a≡x = (λ i → (sym a≡x i) ∷ xs)
  ...            | no  a≢x = cong (x ∷_) (hyp p) ∙ comm x a (remove1 a xs)

 FMScount-remove1-≢-lemma : ∀ {a} {x} xs → ¬ a ≡ x → FMScount a (remove1 x xs) ≡ FMScount a xs
 FMScount-remove1-≢-lemma {a} {x} xs a≢x with discreteℕ (FMScount x xs) zero
 ...                     | yes p = cong (FMScount a) (sym (remove1-zero-lemma x xs p))
 ...                     | no ¬p = sym (FMScount-≢-lemma (remove1 x xs) a≢x) ∙ cong (FMScount a) eq₁
   where
   eq₁ : (x ∷ remove1 x xs) ≡ xs
   eq₁ = sym (remove1-suc-lemma x (predℕ (FMScount x xs)) xs (suc-predℕ (FMScount x xs) ¬p))


{-# OPTIONS --without-K #-}

module Swaps where

-- Intermediate representation of permutations to prove soundness and
-- completeness

open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; subst; subst₂; cong; cong₂; setoid;
        inspect; [_]; proof-irrelevance; module ≡-Reasoning)
open import Relation.Binary.PropositionalEquality.TrustMe
  using (trustMe)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Data.Nat.Properties
  using (m≢1+m+n; i+j≡0⇒i≡0; i+j≡0⇒j≡0; n≤m+n)
open import Data.Nat.Properties.Simple
  using (+-right-identity; +-suc; +-assoc; +-comm;
        *-assoc; *-comm; *-right-zero; distribʳ-*-+)
open import Data.Nat.DivMod using (_mod_)
open import Relation.Binary using (Rel; Decidable; Setoid)
open import Relation.Binary.Core using (Transitive)

open import Data.String using (String)
  renaming (_++_ to _++S_)
open import Data.Nat.Show using (show)
open import Data.Bool using (Bool; false; true; T)
open import Data.Nat using (ℕ; suc; _+_; _∸_; _*_; _<_; _≮_; _≤_; _≰_;
  z≤n; s≤s; _≟_; _≤?_; module ≤-Reasoning)
open import Data.Fin
  using (Fin; zero; suc; toℕ; fromℕ; _ℕ-_; _≺_;
         raise; inject+; inject₁; inject≤; _≻toℕ_)
  renaming (_+_ to _F+_)
open import Data.Fin.Properties using (bounded; inject+-lemma)
open import Data.Vec.Properties
  using (lookup∘tabulate; tabulate∘lookup; lookup-allFin; tabulate-∘;
         tabulate-allFin; map-id; allFin-map)

open import Data.List
  using (List; []; _∷_; _∷ʳ_; foldl; replicate; reverse; downFrom;
         concatMap; gfilter; initLast; InitLast; _∷ʳ'_)
  renaming (_++_ to _++L_; map to mapL; concat to concatL; zip to zipL)
open import Data.List.NonEmpty
  using (List⁺; module List⁺; [_]; _∷⁺_; head; last; _⁺++_)
  renaming (toList to nonEmptyListtoList; _∷ʳ_ to _n∷ʳ_; tail to ntail)
open List⁺ public
open import Data.List.Any using (Any; here; there; any; module Membership)
open import Data.Maybe using (Maybe; nothing; just; maybe′)
open import Data.Vec
  using (Vec; tabulate; []; _∷_; tail; lookup; zip; zipWith; splitAt;
         _[_]≔_; allFin; toList)
  renaming (_++_ to _++V_; map to mapV; concat to concatV)
open import Function using (id; _∘_; _$_)

open import Data.Empty   using (⊥; ⊥-elim)
open import Data.Unit    using (⊤; tt)
open import Data.Sum     using (_⊎_; inj₁; inj₂)
open import Data.Product using (Σ; _×_; _,_; proj₁; proj₂)

open import Cauchy
open import Perm
open import Proofs
open import CauchyProofs
open import CauchyProofsT
open import CauchyProofsS
open import Groupoid
open import PiLevel0

------------------------------------------------------------------------------
-- Representation of a permutation as a product of "transpositions."
-- This product is not commutative; we apply it from left to
-- right. Because we eventually want to normalize permutations to some
-- canonical representation, we insist that the first component of a
-- transposition is always ≤ than the second

infix 90 _X_

data Transposition (n : ℕ) : Set where
  _X_ : (i j : Fin n) → {p : toℕ i ≤ toℕ j} → Transposition n

i≰j→j≤i : (i j : ℕ) → (i ≰ j) → (j ≤ i)
i≰j→j≤i i 0 p = z≤n
i≰j→j≤i 0 (suc j) p with p z≤n
i≰j→j≤i 0 (suc j) p | ()
i≰j→j≤i (suc i) (suc j) p with i ≤? j
i≰j→j≤i (suc i) (suc j) p | yes p' with p (s≤s p')
i≰j→j≤i (suc i) (suc j) p | yes p' | ()
i≰j→j≤i (suc i) (suc j) p | no p' = s≤s (i≰j→j≤i i j p')

mkTransposition : {n : ℕ} → (i j : Fin n) → Transposition n
mkTransposition {n} i j with toℕ i ≤? toℕ j
... | yes p = _X_ i j {p}
... | no p  = _X_ j i {i≰j→j≤i (toℕ i) (toℕ j) p}

Transposition* : ℕ → Set
Transposition* n = List (Transposition n)

-- Representation of a permutation as a product of cycles where each
-- cycle is a non-empty sequence of indices

Cycle : ℕ → Set
Cycle n = List⁺ (Fin n)

Cycle* : ℕ → Set
Cycle* n = List (Cycle n)

-- Convert cycles to products of transpositions

cycle→transposition* : ∀ {n} → Cycle n → Transposition* n
cycle→transposition* c = mapL (mkTransposition (head c)) (reverse (ntail c))

cycle*→transposition* : ∀ {n} → Cycle* n → Transposition* n
cycle*→transposition* cs = concatMap cycle→transposition* cs

-- Convert from Cauchy representation to product of cycles

-- Helper that checks if there is a cycle that starts at i
-- Returns the cycle containing i and the rest of the permutation
-- without that cycle

findCycle : ∀ {n} → Fin n → Cycle* n →  Maybe (Cycle n × Cycle* n)
findCycle i [] = nothing
findCycle i (c ∷ cs) with toℕ i ≟ toℕ (head c)
findCycle i (c ∷ cs) | yes _ = just (c , cs)
findCycle i (c ∷ cs) | no _ =
  maybe′ (λ { (c' , cs') → just (c' , c ∷ cs') }) nothing (findCycle i cs)

-- Another helper that repeatedly tries to merge smaller cycles

{-# NO_TERMINATION_CHECK #-}
mergeCycles : ∀ {n} → Cycle* n → Cycle* n
mergeCycles [] = []
mergeCycles (c ∷ cs) with findCycle (last c) cs
mergeCycles (c ∷ cs) | nothing = c ∷ mergeCycles cs
mergeCycles (c ∷ cs) | just (c' , cs') = mergeCycles ((c ⁺++ ntail c') ∷ cs')

-- To convert a Cauchy representation to a product of cycles, just create
-- a cycle of size 2 for each entry and then merge the cycles

cauchy→cycle* : ∀ {n} → Cauchy n → Cycle* n
cauchy→cycle* {n} perm =
  mergeCycles
    (toList (zipWith (λ i j → i ∷⁺ Data.List.NonEmpty.[ j ]) (allFin n) perm))

-- Cauchy to product of transpostions

cauchy→transposition* : ∀ {n} → Cauchy n → Transposition* n
cauchy→transposition* = cycle*→transposition* ∘ cauchy→cycle*

------------------------------------------------------------------------------
-- Main functions

-- A permutation between t₁ and t₂ has three components in the Cauchy
-- representation: the map π of each element to a new position and a
-- proof that the sizes of the domain and range are the same and that
-- the map is injective.

TPermutation : U → U → Set
TPermutation t₁ t₂ = size t₁ ≡ size t₂ × Permutation (size t₁)

-- A view of (t : U) as normalized types.
-- Let size t be n then the normalized version of t is the type
-- (1 + (1 + (1 + (1 + ... 0)))) i.e. Fin n.

fromSize : ℕ → U
fromSize 0       = ZERO
fromSize (suc n) = PLUS ONE (fromSize n)

canonicalU : U → U
canonicalU = fromSize ∘ size

size+ : (n₁ n₂ : ℕ) → PLUS (fromSize n₁) (fromSize n₂) ⟷ fromSize (n₁ + n₂)
size+ 0        n₂ = unite₊
size+ (suc n₁) n₂ = assocr₊ ◎ (id⟷ ⊕ size+ n₁ n₂)

size* : (n₁ n₂ : ℕ) → TIMES (fromSize n₁) (fromSize n₂) ⟷ fromSize (n₁ * n₂)
size* 0        n₂ = absorbr
size* (suc n₁) n₂ = dist ◎ (unite⋆ ⊕ size* n₁ n₂) ◎ size+ n₂ (n₁ * n₂)

normalizeC : (t : U) → t ⟷ canonicalU t
normalizeC ZERO = id⟷
normalizeC ONE  = uniti₊ ◎ swap₊
normalizeC (PLUS t₀ t₁) =
  (normalizeC t₀ ⊕ normalizeC t₁) ◎ size+ (size t₀) (size t₁)
normalizeC (TIMES t₀ t₁) =
  (normalizeC t₀ ⊗ normalizeC t₁) ◎ size* (size t₀) (size t₁)

-- Given a normalized type Fin n and two indices 'a' and 'b' generate the code
-- to swap the two indices. Ex:
-- swapFin {3} "0" "1" should produce the permutation:
-- assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊ :
-- PLUS ONE (PLUS ONE (PLUS ONE ZERO)) ⟷ PLUS ONE (PLUS ONE (PLUS ONE ZERO))

swapFin : {n : ℕ} → (a b : Fin n) → (leq : toℕ a ≤ toℕ b) → fromSize n ⟷ fromSize n
swapFin zero zero z≤n = id⟷
swapFin zero (suc zero) z≤n = assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊
swapFin zero (suc (suc b)) z≤n =
  (assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊) ◎
  (id⟷ ⊕ swapFin zero (suc b) z≤n) ◎
  (assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊)
swapFin (suc a) zero ()
swapFin (suc a) (suc b) (s≤s leq) = id⟷ ⊕ swapFin a b leq

-- permutation to combinator

transposition*2c : (m n : ℕ) (m≡n : m ≡ n) → Transposition* m →
                   (fromSize m ⟷ fromSize n)
transposition*2c m n m≡n [] rewrite m≡n = id⟷
transposition*2c m n m≡n (_X_ i j {leq} ∷ π) rewrite m≡n =
  swapFin i j leq ◎ transposition*2c n n refl π

perm2c : {t₁ t₂ : U} → TPermutation t₁ t₂ → (t₁ ⟷ t₂)
perm2c {t₁} {t₂} (s₁≡s₂ , (π , inj)) =
  normalizeC t₁ ◎
  transposition*2c (size t₁) (size t₂) s₁≡s₂ (cauchy→transposition* π) ◎
  (! (normalizeC t₂))

------------------------------------------------------------------------------


-- Andreas, 2016-11-19 issue #2309
-- No-eta-equality needs to be respected in pattern matching
-- also before the clause compiler.

record Unit : Set where
  constructor unit
  no-eta-equality

record R : Set₁ where
  field Fst : Unit → Set
        Snd : (x : Unit) → Fst x
open R

Test : (A : Set) (a : A) → R
Fst (Test A a) unit = A
Snd (Test A a) x    = a  -- should not be accepted


import Agda.Builtin.Size

postulate
  F : (A : Set) (B : A → Set) → ((x : A) → B x) → Set

variable
  A : Set
  P : A → Set

postulate
  f : (r : (x : _) → P x) → F _ P (λ x → r x)


{-# OPTIONS --without-K #-}

open import lib.Basics
open import lib.types.Bool
open import lib.types.Coproduct
open import lib.types.Truncation
open import lib.types.Sigma
open import lib.types.Pi
open import lib.types.Fin
open import lib.types.Nat
open import lib.types.Empty
open import lib.NConnected
open import lib.NType2
open import lib.Equivalence2

{- Some miscellaneous lemmas about coproducts. -}
module Util.Coproducts where

⊔-fmap-is-equiv : {i j i' j' : ULevel} {A : Type i} {B : Type j} {A' : Type i'} {B' : Type j'}
  (f : A → A') (g : B → B') (f-eq : is-equiv f) (g-eq : is-equiv g) → is-equiv (⊔-fmap f g)

⊔-fmap-is-equiv f g f-eq g-eq =
  record { g = ⊔-fmap Feq.g Geq.g
         ; f-g = Coprod-elim (λ a → ap inl (Feq.f-g a)) λ b → ap inr (Geq.f-g b)
         ; g-f = Coprod-elim (λ a → ap inl (Feq.g-f a)) (λ b → ap inr (Geq.g-f b))
         ; adj = Coprod-elim (λ a → ∘-ap (⊔-fmap f g) inl _ ∙ ap-∘ _ _ _ ∙ ap (ap inl) (Feq.adj a))
                             λ b →  ∘-ap (⊔-fmap f g) _ _ ∙ ap-∘ _ _ _ ∙ ap (ap inr) (Geq.adj b)  }
  where
    module Feq = is-equiv f-eq
    module Geq = is-equiv g-eq

⊔-emap : {i i' j j' : ULevel} {A : Type i} {A' : Type i'} {B : Type j} {B' : Type j'}
  (e : A ≃ A') (e' : B ≃ B') → (A ⊔ B ≃ A' ⊔ B')

⊔-emap {A = A} {A' = A'} {B = B} {B' = B'} e e' = (f , record { g = g ; f-g = f-g ; g-f = g-f ; adj = adj })
  where
    f : A ⊔ B → A' ⊔ B'
    f = ⊔-fmap (–> e) (–> e')

    g : A' ⊔ B' → A ⊔ B
    g = ⊔-fmap (<– e) (<– e')

    f-g : (z : A' ⊔ B') → (f (g z) == z)
    f-g (inl x) = ap inl (<–-inv-r e x)
    f-g (inr x) = ap inr (<–-inv-r e' x)

    g-f : (z : A ⊔ B) → (g (f z) == z)
    g-f (inl x) = ap inl (<–-inv-l e x)
    g-f (inr x) = ap inr (<–-inv-l e' x)

    adj : (a : A ⊔ B) → ap f (g-f a) == f-g (f a)
    adj (inl a) =
      ap f (g-f (inl a))
        =⟨ idp ⟩
      ap f (ap inl (<–-inv-l e a))
        =⟨ ∘-ap f inl _ ⟩
      ap (f ∘ inl) (<–-inv-l e a)
        =⟨ idp ⟩
      ap (inl ∘ –> e) ((<–-inv-l e a))
        =⟨ ap-∘ inl (–> e) _ ⟩
      ap inl (ap (–> e) (<–-inv-l e a))
        =⟨ ap (ap inl) (<–-inv-adj e a) ⟩
      ap inl (<–-inv-r e (–> e a))
        =⟨ idp ⟩
      f-g (f (inl a))
        =∎
    adj (inr b) =
      ap f (g-f (inr b))
        =⟨ idp ⟩
      ap f (ap inr (<–-inv-l e' b))
        =⟨ ∘-ap f inr _ ⟩
      ap (f ∘ inr) (<–-inv-l e' b)
        =⟨ idp ⟩
      ap (inr ∘ –> e') ((<–-inv-l e' b))
        =⟨ ap-∘ inr (–> e') _ ⟩
      ap inr (ap (–> e') (<–-inv-l e' b))
        =⟨ ap (ap inr) (<–-inv-adj e' b) ⟩
      ap inr (<–-inv-r e' (–> e' b))
        =⟨ idp ⟩
      f-g (f (inr b))
        =∎

⊔-cancel-l : {i j : ULevel} {A : Type i} {B : Type j} → (A ⊔ B) → (¬ A) → B
⊔-cancel-l (inl a) na = ⊥-elim (na a)
⊔-cancel-l (inr b) _ = b

⊔-cancel-r : {i j : ULevel} {A : Type i} {B : Type j} → (A ⊔ B) → (¬ B) → A
⊔-cancel-r (inl a) _ = a
⊔-cancel-r (inr b) nb = ⊥-elim (nb b)

⊔-assoc : {i j k : ULevel} {A : Type i} {B : Type j} {C : Type k} → (A ⊔ B) ⊔ C ≃ A ⊔ B ⊔ C
⊔-assoc {A = A} {B = B} {C = C} = f , record { g = g ; f-g = f-g ; g-f = g-f ; adj = adj }
  where
    f : (A ⊔ B) ⊔ C → A ⊔ B ⊔ C
    f (inl (inl x)) = inl x
    f (inl (inr x)) = inr (inl x)
    f (inr x) = inr (inr x)

    g : A ⊔ B ⊔ C → (A ⊔ B) ⊔ C
    g (inl x) = inl (inl x)
    g (inr (inl x)) = inl (inr x)
    g (inr (inr x)) = inr x

    f-g : (z : A ⊔ B ⊔ C) → (f (g z) == z)
    f-g (inl x) = idp
    f-g (inr (inl x)) = idp
    f-g (inr (inr x)) = idp

    g-f : (z : (A ⊔ B) ⊔ C) → (g (f z) == z)
    g-f (inl (inl x)) = idp
    g-f (inl (inr x)) = idp
    g-f (inr x) = idp

    adj : (a : (A ⊔ B) ⊔ C) → ap f (g-f a) == f-g (f a)
    adj (inl (inl x)) = idp
    adj (inl (inr x)) = idp
    adj (inr x) = idp

⊔-sym : {i j : ULevel} {A : Type i} {B : Type j} → (A ⊔ B) ≃ (B ⊔ A)
⊔-sym = (λ {(inl a) → inr a ; (inr b) → inl b} ) ,
  record { g = λ { (inl b) → inr b ; (inr a) → inl a}
         ; f-g = λ { (inl x) → idp ; (inr x) → idp}
         ; g-f = λ { (inl x) → idp ; (inr x) → idp}
         ; adj = λ { (inl x) → idp ; (inr x) → idp} }


------------------------------------------------------------------------------
-- Testing Agda internal term: @Var Nat Args@ when @Args ≠ []@
------------------------------------------------------------------------------

{-# OPTIONS --exact-split                    #-}
{-# OPTIONS --no-universe-polymorphism       #-}
{-# OPTIONS --universal-quantified-functions #-}
{-# OPTIONS --without-K                      #-}

module NonFOLAgdaInternalTermsVarNonEmptyArgumentsTerm where

postulate
  D   : Set
  _≡_ : D → D → Set

-- TODO: 2012-04-29. Are we using Koen's approach in the translation?
postulate f-refl : (f : D → D) → ∀ x → f x ≡ f x
{-# ATP prove f-refl #-}


module IPC.Metatheory.Gentzen-BasicTarski where

open import IPC.Syntax.Gentzen public
open import IPC.Semantics.BasicTarski public

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)      γ = lookup i γ
eval (lam t)      γ = λ a → eval t (γ , a)
eval (app t u)    γ = eval t γ $ eval u γ
eval (pair t u)   γ = eval t γ , eval u γ
eval (fst t)      γ = π₁ (eval t γ)
eval (snd t)      γ = π₂ (eval t γ)
eval unit         γ = ∙
eval (boom t)     γ = elim𝟘 (eval t γ)
eval (inl t)      γ = ι₁ (eval t γ)
eval (inr t)      γ = ι₂ (eval t γ)
eval (case t u v) γ = elim⊎ (eval t γ)
                        (λ a → eval u (γ , a))
                        (λ b → eval v (γ , b))

-- Correctness of evaluation with respect to conversion.

-- FIXME: How to show this?
postulate
  oops₁ : ∀ {{_ : Model}} {A B Γ} {t : Γ , A ⊢ B} {u : Γ ⊢ A}
          → eval ([ top ≔ u ] t) ≡ (λ γ → eval t (γ , eval u γ))
  oops₂ : ∀ {{_ : Model}} {A B Γ} {t : Γ ⊢ A ▻ B}
          → eval t ≡ (λ γ a → eval (mono⊢ (weak⊆ {A = A}) t) (γ , a) a)
  oops₃ : ∀ {{_ : Model}} {A B C Γ} {t : Γ ⊢ A} {u : Γ , A ⊢ C} {v : Γ , B ⊢ C}
          → eval ([ top ≔ t ] u) ≡ (λ γ → eval u (γ , eval t γ))
  oops₄ : ∀ {{_ : Model}} {A B C Γ} {t : Γ ⊢ B} {u : Γ , A ⊢ C} {v : Γ , B ⊢ C}
          → eval ([ top ≔ t ] v) ≡ (λ γ → eval v (γ , eval t γ))
  oops₅ : ∀ {{_ : Model}} {A B Γ} {t : Γ ⊢ A ∨ B}
          → eval t ≡ (λ γ → elim⊎ (eval t γ) (λ a → ι₁ a) (λ b → ι₂ b))

eval✓ : ∀ {{_ : Model}} {A Γ} {t t′ : Γ ⊢ A} → t ⋙ t′ → eval t ≡ eval t′
eval✓ refl⋙                             = refl
eval✓ (trans⋙ p q)                      = trans (eval✓ p) (eval✓ q)
eval✓ (sym⋙ p)                          = sym (eval✓ p)
eval✓ (conglam⋙ {A} {B} p)              = cong (⟦λ⟧ {A} {B}) (eval✓ p)
eval✓ (congapp⋙ {A} {B} p q)            = cong² (_⟦$⟧_ {A} {B}) (eval✓ p) (eval✓ q)
eval✓ (congpair⋙ {A} {B} p q)           = cong² (_⟦,⟧_ {A} {B}) (eval✓ p) (eval✓ q)
eval✓ (congfst⋙ {A} {B} p)              = cong (⟦π₁⟧ {A} {B}) (eval✓ p)
eval✓ (congsnd⋙ {A} {B} p)              = cong (⟦π₂⟧ {A} {B}) (eval✓ p)
eval✓ (congboom⋙ {C} p)                 = cong (⟦elim𝟘⟧ {C}) (eval✓ p)
eval✓ (conginl⋙ {A} {B} p)              = cong (⟦ι₁⟧ {A} {B}) (eval✓ p)
eval✓ (conginr⋙ {A} {B} p)              = cong (⟦ι₂⟧ {A} {B}) (eval✓ p)
eval✓ (congcase⋙ {A} {B} {C} p q r)     = cong³ (⟦elim⊎⟧ {A} {B} {C}) (eval✓ p) (eval✓ q) (eval✓ r)
eval✓ (beta▻⋙ {A} {B} {t} {u})          = sym (oops₁ {A} {B} {_} {t} {u})
eval✓ (eta▻⋙ {A} {B} {t})               = oops₂ {A} {B} {_} {t}
eval✓ beta∧₁⋙                           = refl
eval✓ beta∧₂⋙                           = refl
eval✓ eta∧⋙                             = refl
eval✓ eta⊤⋙                            = refl
eval✓ (beta∨₁⋙ {A} {B} {C} {t} {u} {v}) = sym (oops₃ {A} {B} {C} {_} {t} {u} {v})
eval✓ (beta∨₂⋙ {A} {B} {C} {t} {u} {v}) = sym (oops₄ {A} {B} {C} {_} {t} {u} {v})
eval✓ (eta∨⋙ {A} {B} {t})               = oops₅ {A} {B} {_} {t}


module Main where

-- Ensure that the entire library is compiled.
import README

open import Coinduction
open import Data.String
open import Data.Unit using (⊤)
open import IO
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

-- Check that trustMe works.

testTrustMe : IO ⊤
testTrustMe with "apa" ≟ "apa"
... | yes refl = putStrLn "Yes!"
... | no  _    = putStrLn "No."

-- Check that ∞ can be used as an "expression".

testInf : Set → Set
testInf = ∞

main = run testTrustMe


{-# OPTIONS --without-K --safe #-}

module PlainPi where

open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.PropositionalEquality

infixr 70 _×ᵤ_
infixr 60 _+ᵤ_
infixr 50 _⊚_

------------------------------------------------------------------------------
-- Pi

data 𝕌 : Set
⟦_⟧ : (A : 𝕌) → Set
data _⟷_ : 𝕌 → 𝕌 → Set
eval : {A B : 𝕌} → (A ⟷ B) → ⟦ A ⟧ → ⟦ B ⟧

data 𝕌 where
  𝟘       : 𝕌
  𝟙       : 𝕌
  _+ᵤ_    : 𝕌 → 𝕌 → 𝕌
  _×ᵤ_    : 𝕌 → 𝕌 → 𝕌

⟦ 𝟘 ⟧ = ⊥
⟦ 𝟙 ⟧ = ⊤
⟦ t₁ +ᵤ t₂ ⟧ = ⟦ t₁ ⟧ ⊎ ⟦ t₂ ⟧
⟦ t₁ ×ᵤ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧

data _⟷_ where
  unite₊l : {t : 𝕌} → 𝟘 +ᵤ t ⟷ t
  uniti₊l : {t : 𝕌} → t ⟷ 𝟘 +ᵤ t
  unite₊r : {t : 𝕌} → t +ᵤ 𝟘 ⟷ t
  uniti₊r : {t : 𝕌} → t ⟷ t +ᵤ 𝟘
  swap₊   : {t₁ t₂ : 𝕌} → t₁ +ᵤ t₂ ⟷ t₂ +ᵤ t₁
  assocl₊ : {t₁ t₂ t₃ : 𝕌} → t₁ +ᵤ (t₂ +ᵤ t₃) ⟷ (t₁ +ᵤ t₂) +ᵤ t₃
  assocr₊ : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) +ᵤ t₃ ⟷ t₁ +ᵤ (t₂ +ᵤ t₃)
  unite⋆l : {t : 𝕌} → 𝟙 ×ᵤ t ⟷ t
  uniti⋆l : {t : 𝕌} → t ⟷ 𝟙 ×ᵤ t
  unite⋆r : {t : 𝕌} → t ×ᵤ 𝟙 ⟷ t
  uniti⋆r : {t : 𝕌} → t ⟷ t ×ᵤ 𝟙
  swap⋆   : {t₁ t₂ : 𝕌} → t₁ ×ᵤ t₂ ⟷ t₂ ×ᵤ t₁
  assocl⋆ : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ ×ᵤ t₃) ⟷ (t₁ ×ᵤ t₂) ×ᵤ t₃
  assocr⋆ : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₂) ×ᵤ t₃ ⟷ t₁ ×ᵤ (t₂ ×ᵤ t₃)
  absorbr : {t : 𝕌} → 𝟘 ×ᵤ t ⟷ 𝟘
  absorbl : {t : 𝕌} → t ×ᵤ 𝟘 ⟷ 𝟘
  factorzr : {t : 𝕌} → 𝟘 ⟷ t ×ᵤ 𝟘
  factorzl : {t : 𝕌} → 𝟘 ⟷ 𝟘 ×ᵤ t
  dist    : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) ×ᵤ t₃ ⟷ (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃)
  factor  : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃) ⟷ (t₁ +ᵤ t₂) ×ᵤ t₃
  distl   : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ +ᵤ t₃) ⟷ (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃)
  factorl : {t₁ t₂ t₃ : 𝕌 } → (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃) ⟷ t₁ ×ᵤ (t₂ +ᵤ t₃)
  id⟷     : {t : 𝕌} → t ⟷ t
  _⊚_     : {t₁ t₂ t₃ : 𝕌} → (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
  _⊕_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (t₁ +ᵤ t₂ ⟷ t₃ +ᵤ t₄)
  _⊗_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (t₁ ×ᵤ t₂ ⟷ t₃ ×ᵤ t₄)

eval unite₊l (inj₂ v) = v
eval uniti₊l v  = inj₂ v
eval unite₊r (inj₁ v) = v
eval uniti₊r v  = inj₁ v
eval swap₊ (inj₁ v) = inj₂ v
eval swap₊ (inj₂ v) = inj₁ v
eval assocl₊ (inj₁ v) = inj₁ (inj₁ v)
eval assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
eval assocl₊ (inj₂ (inj₂ v)) = inj₂ v
eval assocr₊ (inj₁ (inj₁ v)) = inj₁ v
eval assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
eval assocr₊ (inj₂ v) = inj₂ (inj₂ v)
eval unite⋆l (tt , v) = v
eval uniti⋆l v = (tt , v)
eval unite⋆r (v , tt) = v
eval uniti⋆r v = (v , tt)
eval swap⋆ (v₁ , v₂)          = (v₂ , v₁)
eval assocl⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
eval assocr⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
eval absorbl ()
eval absorbr ()
eval factorzl ()
eval factorzr ()
eval dist (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
eval dist (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
eval factor (inj₁ (v₁ , v₃)) = (inj₁ v₁ , v₃)
eval factor (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)
eval distl (v , inj₁ v₁) = inj₁ (v , v₁)
eval distl (v , inj₂ v₂) = inj₂ (v , v₂)
eval factorl (inj₁ (v , v₁)) = (v , inj₁ v₁)
eval factorl (inj₂ (v , v₂)) = (v , inj₂ v₂)
eval id⟷ v = v
eval (c₁ ⊚ c₂) v = eval c₂ (eval c₁ v)
eval (c₁ ⊕ c₂) (inj₁ v) = inj₁ (eval c₁ v)
eval (c₁ ⊕ c₂) (inj₂ v) = inj₂ (eval c₂ v)
eval (c₁ ⊗ c₂) (v₁ , v₂) = (eval c₁ v₁ , eval c₂ v₂)


module Issue620 where

module A where
  postulate _+_*_ : Set → Set → Set → Set

postulate X : Set

2X : Set
2X = X A.+ X * X