------------------------------------------------------------------------
-- A combination of the delay monad (with the possibility of crashing)
-- and a kind of writer monad yielding colists
------------------------------------------------------------------------

module Lambda.Delay-crash-trace where

open import Equality.Propositional as E using (_≡_; refl)
open import Prelude
open import Prelude.Size

open import Colist E.equality-with-J as C
  using (Colist; []; _∷_; force)
open import Monad E.equality-with-J
  using (Raw-monad; return; _>>=_; _⟨$⟩_)

open import Delay-monad using (now; later; force)
open import Delay-monad.Bisimilarity as D using (now; later; force)

open import Lambda.Delay-crash using (Delay-crash)

------------------------------------------------------------------------
-- The monad

mutual

  -- A kind of delay monad with the possibility of crashing that also
  -- yields a trace (colist) of values.

  data Delay-crash-trace (A B : Type) (i : Size) : Type where

    -- A result is returned now.

    now : B → Delay-crash-trace A B i

    -- The computation crashes now.

    crash : Delay-crash-trace A B i

    -- A result is possibly returned later. This constructor also
    -- functions as a coinductive cons constructor for the resulting
    -- trace.

    later : A → Delay-crash-trace′ A B i → Delay-crash-trace A B i

    -- An inductive cons constructor for the resulting trace.

    tell : A → Delay-crash-trace A B i → Delay-crash-trace A B i

  record Delay-crash-trace′ (A B : Type) (i : Size) : Type where
    coinductive
    field
      force : {j : Size< i} → Delay-crash-trace A B j

open Delay-crash-trace′ public

------------------------------------------------------------------------
-- Extracting or deleting the trace

-- Returns the trace.

trace : ∀ {A B i} → Delay-crash-trace A B i → Colist A i
trace (now x)     = []
trace crash       = []
trace (later x m) = x ∷ λ { .force → trace (m .force) }
trace (tell x m)  = x ∷ λ { .force → trace m }

-- Erases the trace.

delay-crash :
  ∀ {A B i} → Delay-crash-trace A B i → Delay-crash B i
delay-crash (now x)     = now (just x)
delay-crash crash       = now nothing
delay-crash (later x m) = later λ { .force → delay-crash (m .force) }
delay-crash (tell x m)  = delay-crash m

------------------------------------------------------------------------
-- Delay-crash-trace is a raw monad

-- Bind.

bind : ∀ {i A B C} →
       Delay-crash-trace A B i →
       (B → Delay-crash-trace A C i) →
       Delay-crash-trace A C i
bind (now x)     f = f x
bind crash       f = crash
bind (later x m) f = later x λ { .force → bind (force m) f }
bind (tell x m)  f = tell x (bind m f)

-- Delay-crash-trace is a raw monad.

instance

  raw-monad : ∀ {A i} → Raw-monad (λ B → Delay-crash-trace A B i)
  Raw-monad.return raw-monad = now
  Raw-monad._>>=_  raw-monad = bind

------------------------------------------------------------------------
-- Strong bisimilarity for Delay-crash-trace

module _ {A B : Type} where

  mutual

    -- Strong bisimilarity.

    infix 4 [_]_∼_ [_]_∼′_

    data [_]_∼_ (i : Size) :
           Delay-crash-trace A B ∞ →
           Delay-crash-trace A B ∞ → Type where
      now   : ∀ {x} → [ i ] now x ∼ now x
      crash : [ i ] crash ∼ crash
      later : ∀ {v x y} →
              [ i ] force x ∼′ force y →
              [ i ] later v x ∼ later v y
      tell  : ∀ {v x y} →
              [ i ] x ∼ y →
              [ i ] tell v x ∼ tell v y

    record [_]_∼′_ (i : Size)
             (x : Delay-crash-trace A B ∞)
             (y : Delay-crash-trace A B ∞) : Type where
      coinductive
      field
        force : {j : Size< i} → [ j ] x ∼ y

  open [_]_∼′_ public

  -- Reflexivity.

  reflexive : ∀ {i} x → [ i ] x ∼ x
  reflexive (now _)     = now
  reflexive crash       = crash
  reflexive (later v x) = later λ { .force → reflexive (force x) }
  reflexive (tell v x)  = tell (reflexive x)

  -- Symmetry.

  symmetric : ∀ {i x y} → [ i ] x ∼ y → [ i ] y ∼ x
  symmetric now       = now
  symmetric crash     = crash
  symmetric (later p) = later λ { .force → symmetric (force p) }
  symmetric (tell p)  = tell (symmetric p)

  -- Transitivity.

  transitive : ∀ {i x y z} → [ i ] x ∼ y → [ i ] y ∼ z → [ i ] x ∼ z
  transitive now       now       = now
  transitive crash     crash     = crash
  transitive (later p) (later q) = later λ { .force →
                                     transitive (force p) (force q) }
  transitive (tell p)  (tell q)  = tell (transitive p q)

  -- Equational reasoning combinators.

  infix  -1 _∎
  infixr -2 step-∼ step-≡ _∼⟨⟩_

  _∎ : ∀ {i} x → [ i ] x ∼ x
  _∎ = reflexive

  step-∼ : ∀ {i} x {y z} → [ i ] y ∼ z → [ i ] x ∼ y → [ i ] x ∼ z
  step-∼ _ y∼z x∼y = transitive x∼y y∼z

  syntax step-∼ x y∼z x∼y = x ∼⟨ x∼y ⟩ y∼z

  step-≡ : ∀ {i} x {y z} → [ i ] y ∼ z → x ≡ y → [ i ] x ∼ z
  step-≡ _ y∼z refl = y∼z

  syntax step-≡ x y∼z x≡y = x ≡⟨ x≡y ⟩ y∼z

  _∼⟨⟩_ : ∀ {i} x {y} → [ i ] x ∼ y → [ i ] x ∼ y
  _ ∼⟨⟩ x∼y = x∼y

----------------------------------------------------------------------
-- Monad laws

left-identity :
  ∀ {A B C : Type} x (f : B → Delay-crash-trace A C ∞) →
  [ ∞ ] return x >>= f ∼ f x
left-identity x f = reflexive (f x)

right-identity :
  ∀ {i} {A B : Type} (x : Delay-crash-trace A B ∞) →
  [ i ] x >>= return ∼ x
right-identity (now x)     = now
right-identity crash       = crash
right-identity (later v x) = later λ { .force →
                               right-identity (force x) }
right-identity (tell v x)  = tell (right-identity x)

associativity :
  ∀ {i} {A B C D : Type} →
  (x : Delay-crash-trace A B ∞)
  (f : B → Delay-crash-trace A C ∞)
  (g : C → Delay-crash-trace A D ∞) →
  [ i ] x >>= (λ x → f x >>= g) ∼ x >>= f >>= g
associativity (now x)     f g = reflexive (f x >>= g)
associativity crash       f g = crash
associativity (later v x) f g = later λ { .force →
                                  associativity (force x) f g }
associativity (tell v x)  f g = tell (associativity x f g)

----------------------------------------------------------------------
-- Some preservation lemmas

infixl 5 _>>=-cong_

_>>=-cong_ :
  ∀ {i} {A B C : Type}
    {x y : Delay-crash-trace A B ∞}
    {f g : B → Delay-crash-trace A C ∞} →
  [ i ] x ∼ y → (∀ z → [ i ] f z ∼ g z) →
  [ i ] x >>= f ∼ y >>= g
now     >>=-cong q = q _
crash   >>=-cong q = crash
later p >>=-cong q = later λ { .force → force p >>=-cong q }
tell p  >>=-cong q = tell (p >>=-cong q)

trace-cong :
  ∀ {i} {A B : Type} {x y : Delay-crash-trace A B ∞} →
  [ i ] x ∼ y → C.[ i ] trace x ∼ trace y
trace-cong now       = []
trace-cong crash     = []
trace-cong (later p) = refl ∷ λ { .force → trace-cong (force p) }
trace-cong (tell p)  = refl ∷ λ { .force → trace-cong p }

delay-crash-cong :
  ∀ {i} {A B : Type} {x y : Delay-crash-trace A B ∞} →
  [ i ] x ∼ y → D.[ i ] delay-crash x ∼ delay-crash y
delay-crash-cong now       = now
delay-crash-cong crash     = now
delay-crash-cong (later p) = later λ { .force →
                               delay-crash-cong (force p) }
delay-crash-cong (tell p)  = delay-crash-cong p

------------------------------------------------------------------------
-- More lemmas

-- The delay-crash function commutes with _>>=_ (in a certain sense).

delay-crash->>= :
  ∀ {i A B C} (x : Delay-crash-trace A B ∞)
    {f : B → Delay-crash-trace A C ∞} →
  D.[ i ] delay-crash (x >>= f) ∼
          delay-crash x >>= delay-crash ∘ f
delay-crash->>= (now x)     = D.reflexive _
delay-crash->>= crash       = D.reflexive _
delay-crash->>= (later x m) = later λ { .force →
                                delay-crash->>= (force m) }
delay-crash->>= (tell x m)  = delay-crash->>= m

-- Use of _⟨$⟩_ does not affect the trace.

trace-⟨$⟩ :
  ∀ {i} {A B C : Type} {f : B → C}
  (x : Delay-crash-trace A B ∞) →
  C.[ i ] trace (f ⟨$⟩ x) ∼ trace x
trace-⟨$⟩ (now x)     = []
trace-⟨$⟩ crash       = []
trace-⟨$⟩ (later _ x) = refl ∷ λ { .force → trace-⟨$⟩ (force x) }
trace-⟨$⟩ (tell _ x)  = refl ∷ λ { .force → trace-⟨$⟩ x }


-- Andreas, 2012-04-20
{-# OPTIONS --show-implicit #-}
module SkipParametersInConstructorReification where

data Bool : Set where
  true false : Bool

data D (A : Set) : Set where
  c : {regArg : A} -> D A

data P : {A : Set} → D A → Set where
  p : P (c {regArg = true})

bla : Set
bla with c {regArg = true}
bla | _ = Bool

fail : P (c {regArg = false})
fail = true

-- What counts here is the error message!
--
--   Bool !=< P {Bool} (c {regArg = false}) of type Set
--
-- the parameter argument of c should be skipped, but the
-- regular argument should show up


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

syntax PropLog | PR

type
  * : 0-ary

term
  false : * | ⊥
  or    : *  *  ->  * | _∨_ l20
  true  : * | ⊤
  and   : *  *  ->  * | _∧_ l30
  not   : *  ->  * | ¬_ r50

theory
  (⊥U∨ᴸ) a |> or (false, a) = a
  (⊥U∨ᴿ) a |> or (a, false) = a
  (∨A) a b c |> or (or(a, b), c) = or (a, or(b, c))
  (∨C) a b |> or(a, b) = or(b, a)
  (⊤U∧ᴸ) a |> and (true, a) = a
  (⊤U∧ᴿ) a |> and (a, true) = a
  (∧A) a b c |> and (and(a, b), c) = and (a, and(b, c))
  (∧D∨ᴸ) a b c |> and (a, or (b, c)) = or (and(a, b), and(a, c))
  (∧D∨ᴿ) a b c |> and (or (a, b), c) = or (and(a, c), and(b, c))
  (⊥X∧ᴸ) a |> and (false, a) = false
  (⊥X∧ᴿ) a |> and (a, false) = false
  (¬N∨ᴸ) a |> or (not (a), a) = false
  (¬N∨ᴿ) a |> or (a, not (a)) = false
  (∧C) a b |> and(a, b) = and(b, a)
  (∨I) a |> or(a, a) = a
  (∧I) a |> and(a, a) = a
  (¬²) a |> not(not (a)) = a
  (∨D∧ᴸ) a b c |> or (a, and (b, c)) = and (or(a, b), or(a, c))
  (∨D∧ᴿ) a b c |> or (and (a, b), c) = and (or(a, c), or(b, c))
  (∨B∧ᴸ) a b |> or (and (a, b), a) = a
  (∨B∧ᴿ) a b |> or (a, and (a, b)) = a
  (∧B∨ᴸ) a b |> and (or (a, b), a) = a
  (∧B∨ᴿ) a b |> and (a, or (a, b)) = a
  (⊤X∨ᴸ) a |> or (true, a) = true
  (⊤X∨ᴿ) a |> or (a, true) = true
  (¬N∧ᴸ) a |> and (not (a), a) = false
  (¬N∧ᴿ) a |> and (a, not (a)) = false
  (DM∧) a b |> not (and (a, b)) = or  (not(a), not(b))
  (DM∨) a b |> not (or  (a, b)) = and (not(a), not(b))
-}

module PropLog.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 PropLog.Signature

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

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

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

    ⊥   : PR * Γ
    _∨_ : PR * Γ → PR * Γ → PR * Γ
    ⊤   : PR * Γ
    _∧_ : PR * Γ → PR * Γ → PR * Γ
    ¬_  : PR * Γ → PR * Γ

  infixl 20 _∨_
  infixl 30 _∧_
  infixr 50 ¬_

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  PRᵃ : MetaAlg PR
  PRᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (falseₒ ⋮ _)     → ⊥
      (orₒ    ⋮ a , b) → _∨_ a b
      (trueₒ  ⋮ _)     → ⊤
      (andₒ   ⋮ a , b) → _∧_ a b
      (notₒ   ⋮ a)     → ¬_  a
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module PRᵃ = MetaAlg PRᵃ

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

    open MetaAlg 𝒜ᵃ

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

    𝕤𝕖𝕞  ⊥        = 𝑎𝑙𝑔 (falseₒ ⋮ tt)
    𝕤𝕖𝕞 (_∨_ a b) = 𝑎𝑙𝑔 (orₒ    ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞  ⊤        = 𝑎𝑙𝑔 (trueₒ  ⋮ tt)
    𝕤𝕖𝕞 (_∧_ a b) = 𝑎𝑙𝑔 (andₒ   ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞 (¬_  a)   = 𝑎𝑙𝑔 (notₒ   ⋮ 𝕤𝕖𝕞 a)

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

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

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

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : PR α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub PR Π Γ)(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 ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! ⊥ = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (_∨_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! ⊤ = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (_∧_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (¬_ a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩

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

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

-- Derived operations
_⟹_ : PR 𝔛 * Γ → PR 𝔛 * Γ → PR 𝔛 * Γ
p ⟹ q = ¬ p ∨ q


-- {-# OPTIONS -v tc.proj.like:30 #-}

open import Common.Bool
open import Common.Equality

abstract
  Id : Set → Set
  Id A = A

f : ∀ A → Id A → Id A
f A x = x

postulate
  foo : ∀{X : Set} (x y : X) → x ≡ y → Set

abstract
  bla : Set
  bla = foo (f Bool true) false refl

-- WAS:
-- true != false of type Bool
-- when checking that the expression refl has type f _ true ≡ false

-- EXPECTED:
-- true != false of type Bool
-- when checking that the expression refl has type f Bool true ≡ false


open import Structures

open import Data.String using (String; _≈?_)
open import Data.List as L using (List; []; _∷_; [_])
open import Data.List.Categorical
open import Data.Nat as ℕ using (ℕ; zero; suc; _+_)
import Data.Nat.Properties as ℕ
open import Data.Nat.DivMod
open import Agda.Builtin.Nat using (div-helper; mod-helper)
open import Data.Nat.Show using () renaming (show to showNat)
open import Data.Vec as V using (Vec; []; _∷_)
open import Data.Fin as F using (Fin; zero; suc; #_)

open import Category.Monad
open import Category.Monad.State

open import Data.Product as Σ
open import Data.Unit
open import Data.Bool using (Bool; true; false; if_then_else_)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Fin using (Fin; zero; suc; fromℕ<)

open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; sym; subst)
open import Relation.Nullary

open import Reflection hiding (return; _>>=_; _>>_)
open import Reflection.Term
import      Reflection.Name as RN
open import Function
open import Strict

open RawMonad ⦃ ... ⦄

Id = String

data Op : Set where
  Plus Minus Times Divide Eq Neq And Gt Lt : Op

data Expr : Set where
  Nat : ℕ → Expr
  BinOp : Op → Expr → Expr → Expr
  Var : String → Expr
  Call : Id → List Expr → Expr
  Function : Id → List Id → Expr → Expr
  Extern : Id → List Id → Expr
  Let : Id → Expr → Expr → Expr
  Assert : Expr → Expr
  If : Expr → Expr → Expr → Expr

op-to-string : Op → String
op-to-string Plus = "+"
op-to-string Minus = "-"
op-to-string Times = "*"
op-to-string Divide = "/"
op-to-string Eq = "=="
op-to-string Neq = "!="
op-to-string And = "&&"
op-to-string Gt = ">"
op-to-string Lt = "<"

indent : ℕ → String
indent n = "" ++/ L.replicate n "  "

flatten-lets : List Expr → List (Id × Expr) × List Expr

-- Lift all the assigns from the (potentially) nested let
flatten-let : Expr → List (Id × Expr) × Expr
flatten-let (Let x e e₁) = let a₁ , e = flatten-let e
                               a₂ , e₁ = flatten-let e₁
                           in (a₁ ++ [(x , e)] ++ a₂) , e₁
flatten-let e@(Nat _) = [] , e
flatten-let (BinOp x e e₁) = let a  , e = flatten-let e
                                 a₁ , e₁ = flatten-let e₁
                             in (a ++ a₁) , BinOp x e e₁
flatten-let e@(Var _) = [] , e
flatten-let (Call x es) = let as , es' = flatten-lets es
                          in as , Call x es'
flatten-let (Function x args e) = let a , e = flatten-let e
                                  in [] , (Function x args $ L.foldr (uncurry Let) e a)
flatten-let e@(Extern _ _) = [] , e
flatten-let (Assert e) = let a , e = flatten-let e in a , Assert e

flatten-let (If e e₁ e₂) = let a , e = flatten-let e
                               a₁ , e₁ = flatten-let e₁
                               a₂ , e₂ = flatten-let e₂
                               e₁' = L.foldr (uncurry Let) e₁ a₁
                               e₂' = L.foldr (uncurry Let) e₂ a₂
                           in a , (If e e₁' e₂')

flatten-lets [] = [] , []
flatten-lets (e ∷ es) = let a , e = flatten-let e
                            a₁ , es = flatten-lets es
                        in (a ++ a₁) , (e ∷ es)

{-# TERMINATING #-}
expr-to-string : ℕ → Expr → String
expr-to-string ind (Nat x) = indent ind
                          ++ showNat x
expr-to-string ind (BinOp op e e₁) = indent ind ++ "(" ++ expr-to-string 0 e ++ ") " ++ op-to-string op ++ " (" ++ expr-to-string 0 e₁ ++ ")"
expr-to-string ind (Var x) = indent ind
                          ++ x
expr-to-string ind (Call f args) = indent ind
                                ++ f ++ " (" ++ (", " ++/ L.map (expr-to-string 0) args) ++ ")"
expr-to-string ind (Function n ids e) = indent ind
                                     ++ "def " ++ n ++ "(" ++ (", " ++/ ids) ++ "):\n" ++ expr-to-string (ind + 1) e
expr-to-string ind (Extern n ids) = indent ind
                                 ++ "extern def " ++ n ++ " (" ++ (", " ++/ ids) ++ ")"

expr-to-string ind (Let x e@(If _ _ _) e₁) = indent ind
                               ++ "let " ++ x ++ " =\n"
                               ++ expr-to-string (ind + 1) e ++ "\n"
                               ++ expr-to-string ind e₁
expr-to-string ind (Let x e e₁) = indent ind
                               ++ "let " ++ x ++ " = " ++ expr-to-string 0 e ++ "\n"
                               ++ expr-to-string ind e₁
expr-to-string ind (Assert e) = indent ind
                             ++ "assert (" ++ expr-to-string 0 e ++ ")"
expr-to-string ind (If e e₁ e₂) = indent ind
                               ++ "if " ++ expr-to-string 0 e ++ ":\n"
                               ++ expr-to-string (ind + 1) e₁ ++ "\n"
                               ++ indent ind ++ "else:\n"
                               ++ expr-to-string (ind + 1) e₂ ++ "\n"

-- Glorified sigma type for variable-assertion pairs
record Assrt : Set where
  constructor mk
  field v : Id
        a : Expr

Assrts = List Assrt

-- The state used when traversing a Pi type.
record PS : Set where
  field
    cnt : ℕ           -- The source of unique variable names
    cur : Id      -- Current variable name (used to collect assertions from its type)
    ctx : Telescope -- Names in the telscopes to resolve deBruijn indices
    ret : Id      -- Variable that the function returns as a result.
                      -- We assume that there is always a single variable and its name
                      -- is known upfront.  We need this to generate assertions from the
                      -- return type.
    assrts : Assrts   -- Assertions that we generate per each variable.
    kst : KS          -- Compilation state (in case we have to extract some functions used in types)

defaultPS : PS
defaultPS = record { cnt = 1
                   ; cur = ""
                   ; ctx = []
                   ; ret = "__ret"
                   ; assrts = []
                   ; kst = defaultKS
                   }

record PatSt : Set where
  constructor mk
  field
    vars    : List (String × ℕ) --Strings
    assigns : List (Id × Expr)
    conds   : List Expr
    cnt     : ℕ

defaultPatSt : PatSt
defaultPatSt = mk [] [] [] 1

SPS = State PS

kompile-fun    : Type → Term → Name → SKS $ Err Expr
kompile-pi     : Type → SPS $ Err ⊤
--{-# TERMINATING #-}
kompile-cls    : Clauses → (vars : Strings) → (ret : String) → SKS $ Err Expr
kompile-clpats : Telescope → (pats : List $ Arg Pattern) → (exprs : List Expr) → PatSt → Err PatSt
--{-# TERMINATING #-}
kompile-term   : Term → Telescope → SKS $ Err Expr

kompile-funp   : Type → Term → Name → SKS Prog
kompile-funp ty te n = do
  (ok e) ← kompile-fun ty te n where (error x) → return $ error x
  let a , e = flatten-let e
      e = case a of λ where
            [] → e
            a  → L.foldr (uncurry Let) e a
  return $ ok $ expr-to-string 0 e ++ "\n"

private
  kf : String → Err Expr
  kf x = error $ "kompile-fun: " ++ x

  module R = RawMonadState (StateMonadState KS)

kompile-fun ty (pat-lam [] []) n =
  return $ kf "got zero clauses in a lambda term"
kompile-fun ty (pat-lam cs []) n = do
  kst ← R.get
  let (_ , ps) = kompile-pi ty $ record defaultPS{ kst = kst }
      rv = PS.ret ps
      ns = showName n
      vars = L.map proj₁ $ PS.ctx ps
      args = ok $ ", " ++/ vars
      ret-assrts = list-filter (λ where (mk v _) → v ≈? rv) $ PS.assrts ps
      arg-assrts = list-filter (dec-neg λ where (mk v _) → v ≈? rv) $ PS.assrts ps
  R.put $ PS.kst ps
  (ok b) ← kompile-cls cs vars rv where (error x) → return $ error x
  return $! ok $ Function ns vars
              $ flip (L.foldr (λ where (mk v a) → Let (v ++ "_assrt") $ Assert a)) arg-assrts
              $ Let rv b
              $ flip (L.foldr (λ where (mk v a) → Let (v ++ "_assrt") $ Assert a)) ret-assrts
              $ Var rv

kompile-fun _ _ _ =
  return $ kf "expected pattern-matching lambda"

private
  kp : ∀ {X} → String → SPS (Err X)
  kp x = return $ error $ "kompile-pi: " ++ x

  ke : ∀ {X} → String → SPS (Err X)
  ke x = return $ error x

  module P = RawMonadState (StateMonadState PS)

  infixl 10 _p+=c_ _p+=a_
  _p+=c_ : PS → ℕ → PS
  ps p+=c n = record ps{ cnt = PS.cnt ps + n }

  _p+=a_ : PS → Assrt → PS
  ps p+=a a = record ps{ assrts = a ∷ PS.assrts ps }

  ps-fresh : String → SPS String
  ps-fresh x = do
    ps ← P.get
    P.modify (_p+=c 1)
    return $ x ++ showNat (PS.cnt ps)

  lift-ks : ∀ {X} → SKS X → SPS X
  lift-ks xf sps = let (x , sks) = xf (PS.kst sps) in x , record sps {kst = sks}

  sps-kompile-term : Term → SPS $ Err Expr
  sps-kompile-term t = do
    ps ← P.get
    lift-ks $ kompile-term t (PS.ctx ps)

kompile-ty : Type → (pi-ok : Bool) → SPS (Err ⊤)
kompile-ty (Π[ s ∶ arg i x ] y) false = kp "higher-order functions are not supported"
kompile-ty (Π[ s ∶ ty@(arg i x) ] y) true  = do
    v ← ps-fresh "x_"
    P.modify λ k → record k { cur = v }
    (ok t) ← kompile-ty x false
      where e → return e
    P.modify λ k → record k { cur = PS.ret k  -- In case this is a return type
                            ; ctx = PS.ctx k ++ L.[(v , ty)] }
    kompile-ty y true

kompile-ty (con c args) pi-ok =
  kp $ "don't know how to handle `" ++ showName c ++ "` constructor"
kompile-ty (def (quote ℕ) args) _ = return $ ok tt
kompile-ty (def (quote Bool) args) _ = return $ ok tt
kompile-ty (def (quote Fin) (arg _ x ∷ [])) _ = do
  ok p ← sps-kompile-term x where error x → ke x
  v ← PS.cur <$> P.get
  P.modify $ _p+=a (mk v (BinOp Lt (Var v) p))
  return $ ok tt

kompile-ty (def (quote _≡_) (_ ∷ arg _ ty ∷ arg _ x ∷ arg _ y ∷ [])) _ = do
  ok x ← sps-kompile-term x where error x → ke x
  ok y ← sps-kompile-term y where error x → ke x
  v ← PS.cur <$> P.get
  P.modify $ _p+=a (mk v (BinOp Eq x y))
  return $ ok tt

kompile-ty (def (quote Dec) (_ ∷ arg _ p ∷ [])) _ = do
  --_ ← kompile-ty p false
  return $ ok tt

kompile-ty (def n _) _ = kp $ "cannot handle `" ++ showName n ++ "` type"

kompile-ty t _ =
  kp $ "failed with the term `" ++ showTerm t ++ "`"

kompile-pi x = kompile-ty x true

-- The names in the telescopes very oftern are not unique, which
-- would be pretty disasterous if the code generation relies on them.
-- see https://github.com/agda/agda/issues/5048 for more details.
--
-- This function simply ensures that variable names are unique in
-- in the telescope.
tel-rename : Telescope → (db : List (String × ℕ)) → Telescope
tel-rename [] db = []
tel-rename ((v , ty) ∷ tel) db with list-find-el ((_≈? v) ∘ proj₁) db
... | just (_ , n) = (v ++ "_" ++ showNat n , ty)
                     ∷ tel-rename tel (list-update-fst ((_≈? v) ∘ proj₁) db (Σ.map₂ suc))
... | nothing      = (v , ty)
                     ∷ tel-rename tel ((v , 1) ∷ db)

private
  kc : String → SKS $ Err Expr
  kc x = return $ error $ "kompile-cls: " ++ x

  _>>=e_ : ∀ {a}{X : Set a} → Err X → (X → SKS $ Err Expr) → SKS $ Err Expr
  (error s) >>=e _ = return $ error s
  (ok x)    >>=e f = f x

kompile-tel : Telescope → SPS (Err ⊤)
kompile-tel [] = return $ ok tt
kompile-tel ((v , t@(arg i x)) ∷ tel) = do
  (ok τ) ← kompile-ty x false where (error x) → return $ error x
  P.modify λ k → record k{ ctx = PS.ctx k ++ [( v , t )] }
  kompile-tel tel

fold-expr : (Expr → Expr → Expr) → Expr → List Expr → Expr
fold-expr f e [] = e
fold-expr f _ (x ∷ []) = x
fold-expr f e (x ∷ xs) = f x (fold-expr f e xs)

emap : ∀ {a b}{X : Set a}{Y : Set b} → (X → Y) → Err X → Err Y
emap f (error x) = error x
emap f (ok x) = ok $ f x

emap₂ : ∀ {a b c}{X : Set a}{Y : Set b}{Z : Set c}
      → (X → Y → Z) → Err X → Err Y → Err Z
emap₂ f (error x) _ = error x
emap₂ f _ (error x) = error x
emap₂ f (ok x) (ok y) = ok (f x y)

kompile-cls [] ctx ret = kc "zero clauses found"
kompile-cls (clause tel ps t ∷ []) ctx ret =
  -- Make telscope names unique.
  let tel = (tel-rename $! tel) $! [] in
  kompile-clpats tel ps (L.map Var ctx) defaultPatSt >>=e λ pst → do
  let (mk vars assgns _ _) = pst --in
  ok t ← kompile-term t $! tel where (error x) → kc x
  let as = flip (L.foldr (uncurry Let)) assgns
  return $ ok $ as
              $ t
              --Let ret t
              --$ Var ret

kompile-cls (absurd-clause tel ps ∷ []) ctx ret =
  -- Exactly the same as above
  -- We don't really need to make this call, but we keep it
  -- for sanity checks.  I.e. if we'll get an error in the
  -- patterns, it will bubble up to the caller.
  kompile-clpats ((tel-rename $! tel) $! []) ps (L.map Var ctx) defaultPatSt >>=e λ pst → do
  return $ ok $ Assert (Nat 0)

kompile-cls (absurd-clause tel ps ∷ ts@(_ ∷ _)) ctx ret =
  kompile-clpats ((tel-rename $! tel) $! []) ps (L.map Var ctx) defaultPatSt >>=e λ pst → do
  let (mk vars _ conds _) = pst
      cs = fold-expr (BinOp And) (Nat 1) conds
  ok r ← kompile-cls ts ctx ret where (error x) → kc x
  return $ ok $ If cs (Assert (Nat 0)) r

kompile-cls (clause tel ps t ∷ ts@(_ ∷ _)) ctx ret =
  kompile-clpats ((tel-rename $! tel) $! []) ps (L.map Var ctx) defaultPatSt >>=e λ pst → do
  let (mk vars assgns conds _) = pst
      cs = fold-expr (BinOp And) (Nat 1) conds
      as = flip (L.foldr (uncurry Let)) assgns
  --ok t ← kompile-term t tel where (error x) → kc x
  --ok r ← kompile-cls ts ctx ret where (error x) → kc x
  --return $ ok $ If cs (as t) r
  t ← kompile-term t tel
  r ← kompile-cls ts ctx ret
  return $ emap₂ (If cs) (emap as t) r

tel-lookup-name : Telescope → ℕ → Prog
tel-lookup-name tel n with n ℕ.<? L.length (L.reverse tel)
... | yes n<l = ok $ proj₁ $ L.lookup (L.reverse tel) $ fromℕ< n<l
... | no _ = error "Variable lookup in telescope failed"

private
  kcp : String → Err PatSt
  kcp x = error $ "kompile-clpats: " ++ x

  infixl 10 _+=c_ _+=a_ _+=v_ _+=n_
  _+=c_ : PatSt → Expr → PatSt
  p +=c c = record p { conds = PatSt.conds p ++ [ c ] }

  _+=a_ : PatSt → _ → PatSt
  p +=a a = record p { assigns = PatSt.assigns p ++ [ a ] }

  _+=v_ : PatSt → String × ℕ → PatSt
  p +=v v = record p { vars = PatSt.vars p ++ [ v ] }

  _+=n_ : PatSt → ℕ → PatSt
  p +=n n = record p { cnt = PatSt.cnt p + 1 }

  pst-fresh : PatSt → String → Err $ String × PatSt
  pst-fresh pst x =
    return $ x ++ showNat (PatSt.cnt pst) , pst +=n 1

  sz : List $ Arg Pattern → ℕ
  sz [] = 0
  sz (arg i (con c ps) ∷ l) = 1 + sz ps + sz l
  sz (arg i _ ∷ l) = 1 + sz l

  sz++ : ∀ (a b : List $ Arg Pattern) → sz (a L.++ b) ≡ sz a + sz b
  sz++ [] b = refl
  sz++ (arg i (con c ps) ∷ a) b rewrite ℕ.+-assoc (sz ps) (sz a) (sz b)
    = cong suc (cong (sz ps +_) (sz++ a b))
  sz++ (arg i (dot t) ∷ a) b = cong suc $ sz++ a b
  sz++ (arg i (var x₁) ∷ a) b = cong suc $ sz++ a b
  sz++ (arg i (lit l) ∷ a) b = cong suc $ sz++ a b
  sz++ (arg i (proj f) ∷ a) b = cong suc $ sz++ a b
  sz++ (arg i (absurd x₁) ∷ a) b = cong suc $ sz++ a b

  ++-strict : ∀ {X : Set} (a b : List X) → a ++ b ≡ a L.++ b
  ++-strict a b rewrite force′-≡ a L._++_ | force′-≡ b (L._++_ a) = refl

  ps++l<m : ∀ {m} ps l → suc (sz ps + sz l) ℕ.< suc m → sz (ps ++ l) ℕ.< m
  ps++l<m {m} ps l sz<m rewrite ++-strict ps l = subst (ℕ._< m) (sym $ sz++ ps l) (ℕ.≤-pred sz<m)

  a<b⇒a<1+b : ∀ {a b} → a ℕ.< b → a ℕ.< 1 + b
  a<b⇒a<1+b {a} {b} a<b = ℕ.s≤s (ℕ.<⇒≤ a<b)

  a+b<c⇒b<c : ∀ {a b c} → a + b ℕ.< c → b ℕ.< c
  a+b<c⇒b<c {zero} {b} {c} a+b<c = a+b<c
  a+b<c⇒b<c {suc a} {b} {suc c} a+b<c = a<b⇒a<1+b $ a+b<c⇒b<c (ℕ.≤-pred a+b<c)

  sz[l]<m : ∀ {m} ps l → suc (sz ps + sz l) ℕ.< suc m → sz l ℕ.< m
  sz[l]<m {m} ps l sz<m = a+b<c⇒b<c $ ℕ.≤-pred sz<m

--kompile-cls    : Clauses → (vars : Strings) → (ret : String) → SKS $ Err String

kompile-clpats′ : ∀ {m} → Telescope → (pats : List $ Arg Pattern) → .(sz pats ℕ.< m)
               → (exprs : List Expr) → PatSt → Err PatSt

kompile-clpats′ {suc m} tel (arg i (con (quote true) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel l (sz[l]<m ps l sz<m) ctx $ pst +=c v {- != 0 -} --is true
kompile-clpats′ {suc m} tel (arg i (con (quote false) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel l (sz[l]<m ps l sz<m) ctx $ pst +=c BinOp Eq v (Nat 0)

kompile-clpats′ {suc m} tel (arg i (con (quote ℕ.zero) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel l (sz[l]<m ps l sz<m) ctx $ pst +=c BinOp Eq v (Nat 0) --(v == 0)
kompile-clpats′ {suc m} tel (arg i (con (quote ℕ.suc) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel (ps ++ l) (ps++l<m ps l sz<m) (BinOp Minus v (Nat 1) ∷ ctx) $ pst +=c BinOp Gt v (Nat 0) --(v > 0)

kompile-clpats′ {suc m} tel (arg i (con (quote F.zero) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel l (sz[l]<m ps l sz<m) ctx $ pst +=c BinOp Eq v (Nat 0) --(v ++ " == 0")
kompile-clpats′ {suc m} tel (arg i (con (quote F.suc) ps@(_ ∷ _ ∷ [])) ∷ l) sz<m (v ∷ ctx) pst = do
  (ub , pst) ← pst-fresh pst "ub_"
  -- XXX here we are not using `ub` in conds.  For two reasons:
  -- 1) as we have assertions, we should check the upper bound on function entry
  -- 2) typically, the value of this argument would be Pat.dot, which we ignore
  --    right now.  It is possible to capture the value of the dot-patterns, as
  --    they carry the value when reconstructed.
  kompile-clpats′ tel (ps ++ l) (ps++l<m ps l sz<m) (Var ub ∷ (BinOp Minus v (Nat 1)) ∷ ctx) $ pst +=c BinOp Gt v (Nat 0) --(v ++ " > 0")

-- For refl we don't need to generate a predicate, as refl is an element of a singleton type.
kompile-clpats′ {suc m} tel (arg i (con (quote refl) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel l (sz[l]<m ps l sz<m) ctx pst

kompile-clpats′ {suc m} tel (arg i (con (quote _because_) ps) ∷ l) sz<m (v ∷ ctx) pst = do
  pf , pst ← pst-fresh pst $ "pf_"
  kompile-clpats′ tel (ps ++ l) (ps++l<m ps l sz<m) (v ∷ Var pf ∷ ctx) pst
kompile-clpats′ {suc m} tel (arg i (con (quote Reflects.ofʸ) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel (ps ++ l) (ps++l<m ps l sz<m) (Nat 1 ∷ ctx) pst
kompile-clpats′ {suc m} tel (arg i (con (quote Reflects.ofⁿ) ps) ∷ l) sz<m (v ∷ ctx) pst =
  kompile-clpats′ tel (ps ++ l) (ps++l<m ps l sz<m) (Nat 0 ∷ ctx) pst

kompile-clpats′ {suc m} tel (arg (arg-info _ r) (var i) ∷ l) sz<m (v ∷ vars) pst = do
  s ← tel-lookup-name tel i
  let pst = pst +=v (s , i)
  let pst = if does (s ≈? "_")
            then pst
            else pst +=a (s , v)
  kompile-clpats′ tel l (ℕ.≤-pred sz<m) vars pst

kompile-clpats′ {suc m} tel (arg i (dot t) ∷ l) sz<m (v ∷ vars) pst =
  -- For now we just skip dot patterns.
  kompile-clpats′ tel l (ℕ.≤-pred sz<m) vars pst

kompile-clpats′ {suc m} tel (arg i (absurd _) ∷ l) sz<m (v ∷ ctx) pst =
  -- If have met the absurd pattern, we'd still have to
  -- accumulate remaining conditions, as patterns are not
  -- linear :(  For example, see test4-f in examples.
  kompile-clpats′ tel l (ℕ.≤-pred sz<m) ctx pst

kompile-clpats′ _ [] _ [] pst = ok pst

kompile-clpats′ tel ps _ ctx patst = kcp $ "failed on pattern: ["
                                     ++ (", " ++/ L.map (λ where (arg _ x) → showPattern x) ps)
                                     ++ "], ctx: [" ++ (", " ++/ (L.map (expr-to-string 0) ctx)) ++ "]"

kompile-clpats tel pats ctx pst = kompile-clpats′ {m = suc (sz pats)} tel pats ℕ.≤-refl ctx pst

private
  kt : ∀ {X} → String → SKS $ Err X
  kt x = return $ error $ "kompile-term: " ++ x

mk-mask : (n : ℕ) → List $ Fin n
mk-mask zero =    []
mk-mask (suc n) = L.reverse $ go n (suc n) ℕ.≤-refl
  where
    sa<b⇒a<b : ∀ a b → suc a ℕ.< b → a ℕ.< b
    sa<b⇒a<b zero    (suc b) _        = ℕ.s≤s ℕ.z≤n
    sa<b⇒a<b (suc a) (suc n) (ℕ.s≤s pf) = ℕ.s≤s $ sa<b⇒a<b a n pf

    go : (m n : ℕ) → m ℕ.< n → List $ Fin n
    go 0       (suc _) _  = zero ∷ []
    go (suc m) n       pf = F.fromℕ< pf ∷ go m n (sa<b⇒a<b m n pf)

le-to-el : ∀ {a}{X : Set a} → List (Err X) → Err (List X)
le-to-el [] = ok []
le-to-el (x ∷ l) = _∷_ <$> x ⊛ le-to-el l

mk-iota-mask : ℕ → List ℕ
mk-iota-mask n = L.reverse $! go n []
  where
    go : ℕ → List ℕ → List ℕ
    go zero l = l
    go (suc n) l = n ∷ go n l

{-
kompile-arglist : (n : ℕ) → List $ Arg Term → List $ Fin n → Telescope → SKS $ Err (List Expr)
kompile-arglist n args mask varctx with L.length args ℕ.≟ n | V.fromList args
... | yes p | vargs rewrite p = do
                 l ← mapM (λ where (arg _ x) → kompile-term x varctx)
                          $ L.map (V.lookup vargs) mask
                 return $ le-to-el l
              where open TraversableM (StateMonad KS)

... | no ¬p | _ = kt "Incorrect argument mask"
-}

kompile-arglist-idx : List $ Arg Term → (idx : ℕ) → Telescope → SKS $ Err Expr
kompile-arglist-idx [] _ tel = return $ error "incorrect arglist index"
kompile-arglist-idx (arg _ x ∷ args) zero tel = kompile-term x tel
kompile-arglist-idx (x ∷ args) (suc n) tel = kompile-arglist-idx args n tel

kompile-arglist : List $ Arg Term → List ℕ → Telescope → SKS $ Err (List Expr)
kompile-arglist args [] tel = return $ ok []
kompile-arglist args (x ∷ idxs) tel = do
  ok t ← kompile-arglist-idx args x tel where (error x) → return $ error x
  ok ts ← kompile-arglist args idxs tel where (error x) → return $ error x
  return $ ok $ t ∷ ts

kompile-term (var x []) vars =
  return $ Var <$> tel-lookup-name vars x

kompile-term (var x args@(_ ∷ _)) vars = do
  let f = tel-lookup-name vars x
      l = L.length args
  --args ← kompile-arglist l args (mk-mask l) vars
  args ← kompile-arglist args (mk-iota-mask l) vars
  return $ Call <$> f ⊛ args

kompile-term (lit l@(nat x)) vars = return $ ok $ Nat x

kompile-term (con (quote ℕ.zero) _) _ =
  return $ ok $ Nat 0
kompile-term (con (quote ℕ.suc) (arg _ a ∷ [])) vars = do
  a ← kompile-term a vars
  return $ BinOp <$> ok Plus ⊛ ok (Nat 1) ⊛ a

kompile-term (con (quote F.zero) _) _ =
  return $ ok $ Nat 0
kompile-term (con (quote F.suc) (_ ∷ arg _ a ∷ [])) vars = do
  a ← kompile-term a vars
  return $ BinOp <$> ok Plus ⊛ ok (Nat 1) ⊛ a

kompile-term (con (quote refl) _) _ =
  return $ ok $ Nat 1

kompile-term (con c _) vars  = kt $ "don't know constructor " ++ (showName c)

-- From Agda.Builtin.Nat: div-helper k m n j = k + (n + m - j) div (1 + m)
kompile-term (def (quote div-helper) (arg _ k ∷ arg _ m ∷ arg _ n ∷ arg _ j ∷ [])) vars = do
  k ← kompile-term k vars
  m ← kompile-term m vars
  n ← kompile-term n vars
  j ← kompile-term j vars
  let n+m = BinOp <$> ok Plus ⊛ n ⊛ m
      n+m-j = BinOp <$> ok Minus ⊛ n+m ⊛ j
      k+[n+m-j] = BinOp <$> ok Plus ⊛ k ⊛ n+m-j
      1+m = BinOp <$> ok Plus ⊛ ok (Nat 1) ⊛ m
  return $ BinOp <$> ok Divide ⊛ k+[n+m-j] ⊛ 1+m

kompile-term (def (quote ℕ._≟_) (arg _ a ∷ arg _ b ∷ [])) vars = do
  a ← kompile-term a vars
  b ← kompile-term b vars
  return $ BinOp <$> ok Eq ⊛ a ⊛ b

kompile-term (def (quote _+_) args@(arg _ a ∷ arg _ b ∷ [])) vars = do
  a ← kompile-term a vars
  b ← kompile-term b vars
  return $ BinOp <$> ok Plus ⊛ a ⊛ b

kompile-term (def (quote ℕ._*_) args@(arg _ a ∷ arg _ b ∷ [])) vars = do
  a ← kompile-term a vars
  b ← kompile-term b vars
  return $ BinOp <$> ok Times ⊛ a ⊛ b

kompile-term (def (quote F.fromℕ<) args) vars = do
  ok (x ∷ []) ← kompile-arglist args (0 ∷ []) vars
                where _ → kt "kopmile-arglist is broken"
  return $ ok x

-- The last pattern in the list of `def` matches
kompile-term (def n []) _ =
  kt $ "attempting to compile `" ++ showName n ++ "` as function with 0 arguments"

kompile-term (def n args@(_ ∷ _)) vars = do
  R.modify λ k → record k { funs = KS.funs k ++ [ n ] }
  let n = {-nnorm $-} showName n
      l = L.length args
  --args ← kompile-arglist l args (mk-mask l) vars
  args ← kompile-arglist args (mk-iota-mask l) vars
  return $ Call <$> ok n ⊛ args

kompile-term t vctx = kt $ "failed to compile term `" ++ showTerm t ++ "`"


-- Andreas, 2017-02-14 issue #2455 reported by mechvel
-- Test case by Andrea

-- Seem that the fix for issue #44 was not complete.

-- When inserting module parameters for a definition,
-- we need to respect polarities!

-- {-# OPTIONS -v tc.decl:10 -v tc.polarity:70 -v tc.sig.inst:30 #-}

module Issue2455 where

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

data Unit : Set where
  unit : Unit

postulate
  A : Set
  P : A → Set
  p : ∀ {e} → P e

module M (e : A) (f : Unit) where

   aux : Unit → P e
   aux unit = p

   -- se does not depent on f
   -- se gets type (e : A) (f :{UnusedArg} Unit) -> A
   se = e

   -- aux' should not depend on f
   -- For this to work, the module parameters for se must be
   -- respecting UnusedArg.
   aux' : Unit → P se
   aux' unit = p

works : ∀ x y e → M.aux e x ≡ M.aux e y
works _ _ _ = refl

fails : ∀ x y e → M.aux' e x ≡ M.aux' e y
fails _ _ _ = refl


module Numeral.Natural.Oper.Summation.Range.Proofs where

import      Lvl
open import Data.List
open import Data.List.Functions
open        Data.List.Functions.LongOper
open import Data.List.Proofs
open import Data.List.Equiv.Id
open import Data.List.Proofs.Length
open import Functional as Fn using (_$_ ; _∘_ ; const)
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Summation.Range
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals hiding (_≡_)
open import Relator.Equals.Proofs.Equiv
open import Structure.Function
open import Structure.Function.Multi
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

Range-empty : ∀{a} → (a ‥ a ≡ ∅)
Range-empty {𝟎} = [≡]-intro
Range-empty {𝐒 a} rewrite Range-empty {a} = [≡]-intro
{-# REWRITE Range-empty #-}

Range-reversed : ∀{a b} → ⦃ _ : (a ≥ b) ⦄ → (a ‥ b ≡ ∅)
Range-reversed {a}   {𝟎}   ⦃ min ⦄ = [≡]-intro
Range-reversed {𝐒 a} {𝐒 b} ⦃ succ p ⦄
  rewrite Range-reversed {a} {b} ⦃ p ⦄
  = [≡]-intro

Range-succ : ∀{a b} → (map 𝐒(a ‥ b) ≡ 𝐒(a) ‥ 𝐒(b))
Range-succ = [≡]-intro

Range-prepend : ∀{a b} → ⦃ _ : (a < b) ⦄ → (a ‥ b ≡ prepend a (𝐒(a) ‥ b))
Range-prepend {𝟎}   {𝐒 b} = [≡]-intro
Range-prepend {𝐒 a} {𝐒 b} ⦃ succ ab ⦄ rewrite Range-prepend {a} {b} ⦃ ab ⦄ = [≡]-intro

Range-postpend : ∀{a b} → ⦃ _ : (a < 𝐒(b)) ⦄ → (a ‥ 𝐒(b) ≡ postpend b (a ‥ b))
Range-postpend {𝟎}   {𝟎}   ⦃ [≤]-with-[𝐒] ⦄ = [≡]-intro
Range-postpend {𝟎}   {𝐒 b} ⦃ [≤]-with-[𝐒] ⦄  = congruence₁(prepend 𝟎) $
  map 𝐒(𝟎 ‥ 𝐒(b))                 🝖[ _≡_ ]-[ congruence₁(map 𝐒) (Range-postpend {𝟎}{b}) ]
  map 𝐒(postpend b (𝟎 ‥ b))       🝖[ _≡_ ]-[ map-postpend ]
  postpend (𝐒(b)) (map 𝐒(𝟎 ‥ b))  🝖-end
Range-postpend {𝐒 a} {𝐒 b} ⦃ succ 𝐒ab ⦄
  rewrite Range-postpend {a} {b} ⦃ 𝐒ab ⦄
  = map-postpend

Range-length : ∀{a b} → (length(a ‥ b) ≡ b −₀ a)
Range-length {𝟎} {𝟎} = [≡]-intro
Range-length {𝟎} {𝐒 b}
  rewrite length-map{f = 𝐒}{x = 𝟎 ‥ b}
  rewrite Range-length {𝟎} {b}
  = congruence₁(𝐒) [≡]-intro
Range-length {𝐒 a} {𝟎} = [≡]-intro
Range-length {𝐒 a} {𝐒 b}
  rewrite length-map{f = 𝐒}{x = a ‥ b}
  rewrite Range-length {a} {b}
  = [≡]-intro

Range-length-zero : ∀{b} → (length(𝟎 ‥ b) ≡ b)
Range-length-zero {b} = Range-length {𝟎}{b}

Range-singleton : ∀{a} → (a ‥ 𝐒(a) ≡ singleton(a))
Range-singleton {𝟎} = [≡]-intro
Range-singleton {𝐒 a}
  rewrite Range-singleton {a}
  = [≡]-intro
{-# REWRITE Range-singleton #-}

Range-concat : ∀{a b c} → ⦃ ab : (a ≤ b) ⦄ ⦃ bc : (b < c) ⦄ → ((a ‥ b) ++ (b ‥ c) ≡ a ‥ c)
Range-concat {𝟎} {𝟎}   {𝐒 c} ⦃ min ⦄ ⦃ succ bc ⦄ = [≡]-intro
Range-concat {𝟎} {𝐒 b} {𝐒 c} ⦃ min ⦄ ⦃ succ bc ⦄ = congruence₁ (prepend 0) $
  map 𝐒(𝟎 ‥ b) ++ map 𝐒 (b ‥ c) 🝖[ _≡_ ]-[ preserving₂(map 𝐒)(_++_)(_++_) {𝟎 ‥ b}{b ‥ c} ]-sym
  map 𝐒((𝟎 ‥ b) ++ (b ‥ c))     🝖[ _≡_ ]-[ congruence₁(map 𝐒) (Range-concat {𝟎} {b} {c}) ]
  map 𝐒(𝟎 ‥ c)                  🝖-end
  where instance _ = bc
Range-concat {𝐒 a} {𝐒 b} {𝐒 c} ⦃ succ ab ⦄ ⦃ succ bc ⦄ =
  map 𝐒(a ‥ b) ++ map 𝐒 (b ‥ c) 🝖[ _≡_ ]-[ preserving₂(map 𝐒)(_++_)(_++_) {a ‥ b}{b ‥ c} ]-sym
  map 𝐒((a ‥ b) ++ (b ‥ c))     🝖[ _≡_ ]-[ congruence₁(map 𝐒) (Range-concat {a} {b} {c}) ]
  map 𝐒(a ‥ c)                  🝖-end
  where
    instance _ = ab
    instance _ = bc


{-# OPTIONS --no-main #-}

postulate
  easy : (A : Set₁) → A

record R₁ : Set₂ where
  field
    A : Set₁

record R₂ : Set₂ where
  field
    r₁ : R₁
    a  : R₁.A r₁

r₁ : R₁
r₁ .R₁.A = Set

r₂ : R₂
r₂ = λ where
  .R₂.r₁ → r₁
  .R₂.a  → easy _


{-# OPTIONS --safe #-}

module Definition.Typed.Decidable where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Consequences.Syntactic
open import Definition.Conversion
open import Definition.Conversion.Decidable
open import Definition.Conversion.Soundness
open import Definition.Conversion.Stability
open import Definition.Conversion.Consequences.Completeness

open import Tools.Nullary
open import Tools.Product

-- Decidability of conversion of well-formed types
dec : ∀ {A B r Γ} → Γ ⊢ A ^ r → Γ ⊢ B ^ r → Dec (Γ ⊢ A ≡ B ^ r)
dec ⊢A ⊢B =
  let ⊢Γ≡Γ = reflConEq (wf ⊢A)
  in  map soundnessConv↑ completeEq
          (decConv↑ ⊢Γ≡Γ (completeEq (refl ⊢A)) (completeEq (refl ⊢B)))

-- Decidability of conversion of well-formed terms
decTerm : ∀ {t u A r Γ} → Γ ⊢ t ∷ A ^ r → Γ ⊢ u ∷ A ^ r → Dec (Γ ⊢ t ≡ u ∷ A ^ r)
decTerm {r = [ ! , l ]} ⊢t ⊢u =
  let ⊢Γ≡Γ = reflConEq (wfTerm ⊢t)
  in  map soundnessConv↑Term completeEqTerm
          (decConv↑TermConv ⊢Γ≡Γ (refl (syntacticTerm ⊢t)) (completeEqTerm (genRefl ⊢t)) (completeEqTerm (genRefl ⊢u)))
decTerm {r = [ % , l ]} ⊢t ⊢u =
  let ⊢Γ≡Γ = reflConEq (wfTerm ⊢t)
  in  map (λ x → proj₂ (proj₂ (soundness~↑% x))) completeEqTerm
          (decConv↑TermConv ⊢Γ≡Γ (refl (syntacticTerm ⊢t)) (completeEqTerm (genRefl ⊢t)) (completeEqTerm (genRefl ⊢u)))


------------------------------------------------------------------------
-- The Agda standard library
--
-- AVL trees
------------------------------------------------------------------------

-- AVL trees are balanced binary search trees.

-- The search tree invariant is specified using the technique
-- described by Conor McBride in his talk "Pivotal pragmatism".

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

open import Relation.Binary using (StrictTotalOrder)

module Data.AVL
  {a ℓ₁ ℓ₂} (strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂)
  where

open import Data.Bool.Base using (Bool)
import Data.DifferenceList as DiffList
open import Data.List.Base as List using (List)
open import Data.Maybe using (Maybe; nothing; just; is-just)
open import Data.Nat.Base using (suc)
open import Data.Product hiding (map)
open import Function as F
open import Level using (_⊔_)
open import Relation.Unary

open StrictTotalOrder strictTotalOrder renaming (Carrier to Key)
import Data.AVL.Indexed strictTotalOrder as Indexed
open Indexed using (K&_ ; ⊥⁺ ; ⊤⁺; ⊥⁺<⊤⁺; ⊥⁺<[_]<⊤⁺; ⊥⁺<[_]; [_]<⊤⁺)

------------------------------------------------------------------------
-- Re-export some core definitions publically

open Indexed using (Value; MkValue; const) public

------------------------------------------------------------------------
-- Types and functions with hidden indices

data Tree {v} (V : Value v) : Set (a ⊔ v ⊔ ℓ₂) where
  tree : ∀ {h} → Indexed.Tree V ⊥⁺ ⊤⁺ h → Tree V

module _ {v} {V : Value v} where

  private
    Val = Value.family V

  empty : Tree V
  empty = tree $′ Indexed.empty ⊥⁺<⊤⁺

  singleton : (k : Key) → Val k → Tree V
  singleton k v = tree (Indexed.singleton k v ⊥⁺<[ k ]<⊤⁺)

  insert : (k : Key) → Val k → Tree V → Tree V
  insert k v (tree t) = tree $′ proj₂ $ Indexed.insert k v t ⊥⁺<[ k ]<⊤⁺

  insertWith : (k : Key) → (Maybe (Val k) → Val k) →
               Tree V → Tree V
  insertWith k f (tree t) = tree $′ proj₂ $ Indexed.insertWith k f t ⊥⁺<[ k ]<⊤⁺

  delete : Key → Tree V → Tree V
  delete k (tree t) = tree $′ proj₂ $ Indexed.delete k t ⊥⁺<[ k ]<⊤⁺

  lookup : (k : Key) → Tree V → Maybe (Val k)
  lookup k (tree t) = Indexed.lookup k t ⊥⁺<[ k ]<⊤⁺

module _ {v w} {V : Value v} {W : Value w} where

  private
    Val = Value.family V
    Wal = Value.family W

  map : ∀[ Val ⇒ Wal ] → Tree V → Tree W
  map f (tree t) = tree $ Indexed.map f t

module _ {v} {V : Value v} where

  private
    Val = Value.family V

  infix 4 _∈?_

  _∈?_ : Key → Tree V → Bool
  k ∈? t = is-just (lookup k t)

  headTail : Tree V → Maybe ((K& V) × Tree V)
  headTail (tree (Indexed.leaf _)) = nothing
  headTail (tree {h = suc _} t)    with Indexed.headTail t
  ... | (k , _ , _ , t′) = just (k , tree (Indexed.castˡ ⊥⁺<[ _ ] t′))

  initLast : Tree V → Maybe (Tree V × (K& V))
  initLast (tree (Indexed.leaf _)) = nothing
  initLast (tree {h = suc _} t)    with Indexed.initLast t
  ... | (k , _ , _ , t′) = just (tree (Indexed.castʳ t′ [ _ ]<⊤⁺) , k)

  -- The input does not need to be ordered.

  fromList : List (K& V) → Tree V
  fromList = List.foldr (uncurry insert) empty

  -- Returns an ordered list.

  toList : Tree V → List (K& V)
  toList (tree t) = DiffList.toList (Indexed.toDiffList t)

  -- Naive implementations of union.

module _ {v w} {V : Value v} {W : Value w} where
  private
    Val = Value.family V
    Wal = Value.family W

  unionWith : (∀ {k} → Val k → Maybe (Wal k) → Wal k) →
              -- Left → right → result.
              Tree V → Tree W → Tree W
  unionWith f t₁ t₂ =
    List.foldr (uncurry $ λ k v → insertWith k (f v)) t₂ (toList t₁)

  -- Left-biased.

module _ {v} {V : Value v} where

  private Val = Value.family V

  union : Tree V → Tree V → Tree V
  union = unionWith F.const

  unionsWith : (∀ {k} → Val k → Maybe (Val k) → Val k) → List (Tree V) → Tree V
  unionsWith f ts = List.foldr (unionWith f) empty ts

  -- Left-biased.

  unions : List (Tree V) → Tree V
  unions = unionsWith F.const


{-# OPTIONS --without-K #-}
module HoTT.Base where

open import Agda.Primitive public

-- Universe
𝒰 : (i : Level) → Set (lsuc i)
𝒰 i = Set i

𝒰₀ : Set₁
𝒰₀ = Set₀

module variables where
  variable
    i j : Level
    A B : 𝒰 i
    P Q : A → 𝒰 i
open variables

record Lift {i j} (A : 𝒰 j) : 𝒰 (i ⊔ j) where
  constructor lift
  field lower : A
open Lift public

-- Instance search
⟨⟩ : ∀ {i} {A : 𝒰 i} → ⦃ A ⦄ → A
⟨⟩ ⦃ a ⦄ = a

-- Dependent functions (Π-types)
Π : (A : 𝒰 i) (B : A → 𝒰 j) → 𝒰 (i ⊔ j)
Π A B = (x : A) → B x
syntax Π A (λ x → Φ) = Π[ x ∶ A ] Φ
infixr 6 Π

id : {A : 𝒰 i} → A → A
id x = x

const : A → B → A
const x _ = x

swap : {C : A → B → 𝒰 i} → ((x : A) (y : B) → C x y) →
       (y : B) (x : A) → C x y
swap f y x = f x y

_∘_ : {C : {x : A} → P x → 𝒰 i} →
      ({x : A} → Π (P x) C) → (g : Π A P) → (x : A) → C (g x)
f ∘ g = λ x → f (g x)
infixr 30 _∘_

_$_ : Π A P → Π A P
_$_ = id
infixr 0 _$_

-- Identity
data _==_ {A : 𝒰 i} (a : A) : A → 𝒰 i where
  instance refl : a == a
infixr 10 _==_
{-# BUILTIN EQUALITY _==_ #-}

=-ind : (C : (x y : A) → x == y → 𝒰 i) → ((x : A) → C x x refl) →
        {x y : A} → (p : x == y) → C x y p
=-ind C c refl = c _

-- Based path induction
=-ind' : {a : A} → (C : (x : A) → a == x → 𝒰 i) → C a refl →
         {x : A} → (p : a == x) → C x p
=-ind' C c refl = c

-- Lemma 2.1.1
_⁻¹ : {x y : A} → x == y → y == x
_⁻¹ refl = refl
infix 30 _⁻¹

-- Lemma 2.1.2
_∙_ : {x y z : A} → x == y → y == z → x == z
_∙_ refl refl = refl
infixl 20 _∙_

-- Lemma 2.2.1
ap : {x y : A} (f : A → B) → x == y → f x == f y
ap f refl = refl

ap² : {C : 𝒰 i} {x y : A} {z w : B} (f : A → B → C) → x == y → z == w → f x z == f y w
ap² _ refl refl = refl

-- Lemma 2.3.1
transport : {x y : A} (P : A → 𝒰 j) → x == y → P x → P y
transport _ refl = id

-- Lemma 2.3.4
apd : {x y : A} (f : (x : A) → P x) (p : x == y) → transport P p (f x) == f y
apd f refl = refl

-- Empty
data 𝟎 {i} : 𝒰 i where

𝟎-rec : {C : 𝒰 i} → 𝟎 {j} → C
𝟎-rec ()

𝟎-ind : {C : 𝟎 → 𝒰 i} → (z : 𝟎 {j}) → C z
𝟎-ind ()

¬_ : 𝒰 i → 𝒰 i
¬_ {i} A = A → 𝟎 {i}
infix 25 ¬_

_≠_ : A → A → 𝒰 _
_≠_ x y = ¬ (x == y)

-- Unit
record 𝟏 {i} : 𝒰 i where
  no-eta-equality
  instance constructor ★

𝟏-ind : (C : 𝟏 → 𝒰 i) → C ★ → (x : 𝟏 {j}) → C x
𝟏-ind C c ★ = c

𝟏-uniq : (x : 𝟏 {i}) → x == ★
𝟏-uniq ★ = refl

-- Boolean
data 𝟐 : 𝒰₀ where
  0₂ : 𝟐
  1₂ : 𝟐
{-# BUILTIN BOOL 𝟐 #-}
{-# BUILTIN FALSE 0₂ #-}
{-# BUILTIN TRUE 1₂ #-}

𝟐-rec : {C : 𝒰 i} → C → C → 𝟐 → C
𝟐-rec c₀ c₁ 0₂ = c₀
𝟐-rec c₀ c₁ 1₂ = c₁

𝟐-ind : (C : 𝟐 → 𝒰 i) → C 0₂ → C 1₂ → (x : 𝟐) → C x
𝟐-ind C c₀ c₁ 0₂ = c₀
𝟐-ind C c₀ c₁ 1₂ = c₁

-- Dependent pairs (Σ-types)
record Σ (A : 𝒰 i) (B : A → 𝒰 j) : 𝒰 (i ⊔ j) where
  no-eta-equality
  constructor _,_
  field
    pr₁ : A
    pr₂ : B pr₁
infixr 15 _,_
open Σ public
syntax Σ A (λ x → Φ) = Σ[ x ∶ A ] Φ
infixr 6 Σ

Σ-rec : (C : 𝒰 i) → ((x : A) → P x → C) → (Σ A λ x → P x) → C
Σ-rec C g (a , b) = g a b

Σ-ind : (C : Σ A P → 𝒰 i) → ((a : A) → (b : P a) → C (a , b)) →
        (p : Σ A P) → C p
Σ-ind C g (a , b) = g a b

Σ-uniq : (x : Σ A P) → pr₁ x , pr₂ x == x
Σ-uniq (a , b) = refl

-- Product
_×_ : (A : 𝒰 i) (B : 𝒰 j) → 𝒰 (i ⊔ j)
A × B = Σ[ _ ∶ A ] B
infixr 8 _×_

×-rec : (C : 𝒰 i) → (A → B → C) → A × B → C
×-rec _ g (a , b) = g a b

×-ind : (C : A × B → 𝒰 i) → ((x : A) (y : B) → C (x , y)) →
        (x : A × B) → C x
×-ind _ g (a , b) = g a b

×-uniq : (x : A × B) → pr₁ x , pr₂ x == x
×-uniq (a , b) = refl

-- Coproduct
data _+_ (A : 𝒰 i) (B : 𝒰 j) : 𝒰 (i ⊔ j) where
  inl : A → A + B
  inr : B → A + B
infixr 8 _+_

+-rec : {C : 𝒰 i} → (A → C) → (B → C) → A + B → C
+-rec gₗ gᵣ (inl a) = gₗ a
+-rec gₗ gᵣ (inr b) = gᵣ b

+-ind : (C : A + B → 𝒰 i) →
        ((a : A) → C (inl a)) →
        ((b : B) → C (inr b)) → (x : A + B) → C x
+-ind C g₀ g₁ (inl a) = g₀ a
+-ind C g₀ g₁ (inr b) = g₁ b

-- Natural numbers
data ℕ : 𝒰₀ where
  zero : ℕ
  succ : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

ℕ-rec : {C : 𝒰 i} → C → (ℕ → C → C) → ℕ → C
ℕ-rec c₀ cₛ zero = c₀
ℕ-rec c₀ cₛ (succ n) = cₛ n (ℕ-rec c₀ cₛ n)

ℕ-ind : (C : ℕ → 𝒰 i) → C 0 → ((n : ℕ) → C n → C (succ n)) → (n : ℕ) → C n
ℕ-ind C c₀ cₛ 0 = c₀
ℕ-ind C c₀ cₛ (succ n) = cₛ n (ℕ-ind C c₀ cₛ n)

-- Homotopy
_~_ : (f g : Π A P) → 𝒰 _
f ~ g = ∀ x → f x == g x

happly : {f g : Π A P} → f == g → f ~ g
happly refl _ = refl

-- Lemma 2.4.2
reflₕ : {f : Π A P} → f ~ f
reflₕ _ = refl

_∙ₕ_ : {f g h : Π A P} → f ~ g → g ~ h → f ~ h
α ∙ₕ β = λ x → α x ∙ β x
infixl 20 _∙ₕ_

_⁻¹ₕ : {f g : Π A P} → f ~ g → g ~ f
α ⁻¹ₕ = λ x → α x ⁻¹


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Equivalences.PreXModReflGraph where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Structure

open import Cubical.Functions.FunExtEquiv

open import Cubical.Homotopy.Base

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Relation.Binary

open import Cubical.Structures.Subtype
open import Cubical.Algebra.Group
open import Cubical.Structures.LeftAction
open import Cubical.Algebra.Group.Semidirect

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties

open import Cubical.DStructures.Meta.Isomorphism
open import Cubical.DStructures.Structures.Constant
open import Cubical.DStructures.Structures.Type
open import Cubical.DStructures.Structures.Group
open import Cubical.DStructures.Structures.SplitEpi
open import Cubical.DStructures.Structures.ReflGraph
open import Cubical.DStructures.Structures.Action
open import Cubical.DStructures.Structures.XModule
open import Cubical.DStructures.Equivalences.GroupSplitEpiAction

private
  variable
    ℓ ℓ' ℓ'' ℓ₁ ℓ₁' ℓ₁'' ℓ₂ ℓA ℓA' ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓC ℓ≅C ℓ≅ᴰ ℓ≅ᴰ' ℓ≅B' : Level

open Kernel
open GroupHom -- such .fun!
open GroupLemmas
open MorphismLemmas
open ActionLemmas

{-
After associating, we have

  B × isEqui   - B × isSecRet
    |        /      |
    |      /        |
  Action    ≃    SplitMono

Fix any action and its
corresponding split mono
    α             π₂
G₀ --> H   ↦  G₀ ↔ H ⋊⟨ α ⟩ G₀
                  ι₂

Precrossed module
α : G₀ --> H
φ : G₀ ← H
isEquivariant (α , φ)

gives internal reflexive graph
ι₂ : G₀ → H⋊⟨ α ⟩ G₀
     G₀ ← H⋊⟨ α ⟩ G₀ : π₂
     G₀ ← H⋊⟨ α ⟩ G₀ : τ_φ
τ_φ (h , g) := φ h + g
isSecRet (ι₂ , π₂)
isSecRet (ι₂ , τ_φ)

Conversely, a internal reflexive graph

ι₂ : G₀ → H⋊⟨ α ⟩ G₀
     G₀ ← H⋊⟨ α ⟩ G₀ : π₂
     G₀ ← H⋊⟨ α ⟩ G₀ : τ
isSecRet (ι₂ , π₂)
isSecRet (ι₂ , τ)

Then
ι₁ : H ≃ ker σ ↪ H ⋊⟨ α ⟩ G₀
α : G₀ --> H
    G₀ ← H : φ
φ := τ ∘ ι₁ is equivariant

-}

module _ (ℓ ℓ' : Level) where
  private
    ℓℓ' = ℓ-max ℓ ℓ'

    F = Iso.fun (IsoActionSplitEpi ℓ ℓℓ')

  -- reassociate: Display B + isSplitEpi over SplitEpi
  ReflGraph' = Σ[ (((G₀ , G₁) , (ι , σ)) , split-σ) ∈ SplitEpi ℓ ℓℓ' ] Σ[ τ ∈ GroupHom G₁ G₀ ] isGroupSplitEpi ι τ

  𝒮ᴰ-ReflGraph' : URGStrᴰ (𝒮-SplitEpi ℓ ℓℓ')
                          (λ (((G₀ , G₁) , (ι , σ)) , split-σ) → Σ[ τ ∈ GroupHom G₁ G₀ ] isGroupSplitEpi ι τ)
                          ℓℓ'
  𝒮ᴰ-ReflGraph' = splitTotal-𝒮ᴰ (𝒮-SplitEpi ℓ ℓℓ') (𝒮ᴰ-G²FBSplit\B ℓ ℓℓ') (𝒮ᴰ-ReflGraph ℓ ℓℓ')

  -- reassociate: Display B + isEquivar over Action
  PreXModule' = Σ[ (((G₀ , H) , _α_) , isAct) ∈ Action ℓ ℓℓ' ] Σ[ φ ∈ GroupHom H G₀ ] (isEquivariant (((G₀ , H) , _α_) , isAct) φ)

  𝒮ᴰ-PreXModule' : URGStrᴰ (𝒮-Action ℓ ℓℓ')
                           (λ (((G₀ , H) , _α_) , isAct) → Σ[ φ ∈ GroupHom H G₀ ] (isEquivariant (((G₀ , H) , _α_) , isAct) φ))
                           ℓℓ'
  𝒮ᴰ-PreXModule' = splitTotal-𝒮ᴰ (𝒮-Action ℓ ℓℓ') (𝒮ᴰ-Action\PreXModuleStr ℓ ℓℓ') (𝒮ᴰ-PreXModule ℓ ℓℓ')

  -- Establish ♭-relational isomorphism of precrossed modules and reflexive graphs
  -- over the isomorphism of actions and split epis
  𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' : 𝒮ᴰ-♭PIso F 𝒮ᴰ-PreXModule' 𝒮ᴰ-ReflGraph'
  RelIso.fun (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui) .fst = τ
    where
      -- notation
      open GroupNotation₀ G₀
      open GroupNotationᴴ H
      f = GroupHom.fun φ
      A = groupaction _α_ isAct
      H⋊G₀ : Group {ℓ-max ℓ ℓ'}
      H⋊G₀ = H ⋊⟨ A ⟩ G₀

      -- define the morphism τ
      τ : GroupHom H⋊G₀ G₀
      τ .fun (h , g) = f h +₀ g
      τ .isHom (h , g) (h' , g') = q
        where
          abstract
            q = f (h +ᴴ (g α h')) +₀ (g +₀ g')
                  ≡⟨ cong (_+₀ (g +₀ g')) (φ .isHom h (g α h')) ⟩
                (f h +₀ f (g α h')) +₀ (g +₀ g')
                  ≡⟨ cong (λ z → (f h +₀ z) +₀ (g +₀ g')) (isEqui g h') ⟩
                (f h +₀ ((g +₀ (f h')) -₀ g)) +₀ (g +₀ g')
                  ≡⟨ cong (λ z → (f h +₀ z) +₀ (g +₀ g') ) (sym (assoc₀ g (f h') (-₀ g))) ⟩
                (f h +₀ (g +₀ (f h' +₀ (-₀ g)))) +₀ (g +₀ g')
                  ≡⟨ cong (_+₀ (g +₀ g')) (assoc₀ (f h) g (f h' +₀ (-₀ g))) ⟩
                ((f h +₀ g) +₀ (f h' +₀ (-₀ g))) +₀ (g +₀ g')
                  ≡⟨ sym (assoc₀ (f h +₀ g) (f h' +₀ (-₀ g)) (g +₀ g')) ⟩
                (f h +₀ g) +₀ ((f h' +₀ (-₀ g)) +₀ (g +₀ g'))
                  ≡⟨ cong ((f h +₀ g) +₀_)
                          (sym (assoc₀ (f h') (-₀ g) (g +₀ g'))
                          ∙ (cong (f h' +₀_)
                                  (assoc₀ (-₀ g) g g'
                                  ∙∙ cong (_+₀ g') (lCancel₀ g)
                                  ∙∙ lId₀ g')))⟩
                (f h +₀ g) +₀ (f  h' +₀ g') ∎

  RelIso.fun (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui) .snd = q
    where
      -- notation
      open GroupNotation₀ G₀
      open GroupNotationᴴ H
      f = GroupHom.fun φ
      τ = RelIso.fun (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui) .fst
      ι = Iso.fun (IsoActionSplitEpi ℓ ℓℓ') (((G₀ , H) , _α_) , isAct) .fst .snd .fst

      -- prove that τ as constructed above is split
      abstract
        q : isGroupSplitEpi ι τ
        q = GroupMorphismExt λ g → f 0ᴴ +₀ g
                                             ≡⟨ cong (_+₀ g) (mapId φ) ⟩
                                           0₀ +₀ g
                                             ≡⟨ lId₀ g ⟩
                                           g ∎

  -- end of RelIso.fun (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui)

  RelIso.inv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (τ , split-τ) = φ , isEqui
    where
      -- notation
      ℬ = F (((G₀ , H) , _α_) , isAct)
      A = groupaction _α_ isAct

      -- σ = snd (snd (fst ℬ))
      -- φ should be τ| ker σ
      -- but ker σ ≅ H so we "restrict" τ to that
      -- by precomposing with the inclusion H → H⋊G₀
      ι1 = ι₁ A
      𝒾 = ι1 .fun

      t = τ .fun

      H⋊G₀ = H ⋊⟨ A ⟩ G₀
      _+α_ =  GroupStr._+_ (snd H⋊G₀)

      open GroupNotationᴴ H
      open GroupNotation₀ G₀

      -- define φ
      φ : GroupHom H G₀
      φ = compGroupHom ι1 τ
      f = φ .fun

      -- prove equivariance
      abstract
        isEqui : isEquivariant (((G₀ , H) , _α_) , isAct) φ
        isEqui g h = f (g α h)
                       ≡⟨ refl ⟩
                     t (g α h , 0₀)
                       ≡⟨ cong t
                               (g α h , 0₀
                                 ≡⟨ ΣPathP (sym ((cong (_+ᴴ ((g +₀ 0₀) α 0ᴴ)) (lIdᴴ (g α h)))
                                                ∙∙ cong ((g α h) +ᴴ_) (actOnUnit A (g +₀ 0₀))
                                                ∙∙ rIdᴴ (g α h))
                                           , sym (cong (_+₀ (-₀ g)) (rId₀ g) ∙ rCancel₀ g)) ⟩
                               (0ᴴ +ᴴ (g α h)) +ᴴ ((g +₀ 0₀) α 0ᴴ) , (g +₀ 0₀) -₀ g
                                 ≡⟨ refl ⟩
                               ((0ᴴ , g) +α (h , 0₀)) +α (0ᴴ , -₀ g) ∎) ⟩
                     t (((0ᴴ , g) +α (h , 0₀)) +α (0ᴴ , -₀ g))
                       ≡⟨ hom-homl τ (0ᴴ , g) (h , 0₀) (0ᴴ , -₀ g) ⟩
                     ((t (0ᴴ , g)) +₀ t (h , 0₀)) +₀ t (0ᴴ , -₀ g)
                       ≡⟨ cong (((t (0ᴴ , g)) +₀ t (h , 0₀)) +₀_) (funExt⁻ (cong fun split-τ) (-₀ g)) ⟩
                     ((t (0ᴴ , g)) +₀ t (h , 0₀)) -₀ g
                       ≡⟨ cong (λ z → (z +₀ t (h , 0₀)) -₀ g) (funExt⁻ (cong fun split-τ) g) ⟩
                     (g +₀ f h) -₀ g ∎

  -- RelIso.inv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (τ , split-τ)

  RelIso.leftInv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui) .fst = φ-≅
    where
      open GroupNotation₀ G₀

      abstract
        -- φ ≅ inv (fun φ) ≡ τ ∘ ι₁
        φ-≅ : (h : ⟨ H ⟩) → φ .fun h +₀ 0₀ ≡ φ .fun h
        φ-≅ h = rId₀ (φ .fun h)

  RelIso.leftInv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui) .snd = isEqui-≅
    where
      abstract
        isEqui-≅ : Unit
        isEqui-≅ = tt

  -- end of RelIso.leftInv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (φ , isEqui)

  RelIso.rightInv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (τ , split-τ) .fst = τ-≅
    where
      A = groupaction _α_ isAct
      H⋊G₀ = H ⋊⟨ A ⟩ G₀
      t = τ .fun
      open GroupNotation₀ G₀
      open GroupNotationᴴ H

      abstract
        τ-≅ : ((h , g) : ⟨ H⋊G₀ ⟩) → t (h , 0₀) +₀ g ≡ t (h , g)
        τ-≅ (h , g) = t (h , 0₀) +₀ g
                        ≡⟨ cong (t (h , 0₀) +₀_) (sym (funExt⁻ (cong GroupHom.fun split-τ) g)) ⟩
                      t (h , 0₀) +₀ t (0ᴴ , g)
                        ≡⟨ sym (τ .isHom (h , 0₀) (0ᴴ , g)) ⟩
                      t (h +ᴴ (0₀ α 0ᴴ) , 0₀ +₀ g)
                        ≡⟨ cong t (ΣPathP (cong (h +ᴴ_) (actOnUnit A 0₀) ∙ rIdᴴ h , lId₀ g)) ⟩
                      t (h , g) ∎

  RelIso.rightInv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (τ , split-τ) .snd = split-τ-≅
    where
      abstract
        split-τ-≅ : Unit
        split-τ-≅ = tt

  -- end of RelIso.rightInv (𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' (((G₀ , H) , _α_) , isAct)) (τ , split-τ)

  -- end of 𝒮ᴰ-♭PIso-PreXModule'-ReflGraph' : 𝒮ᴰ-♭PIso F 𝒮ᴰ-PreXModule' 𝒮ᴰ-ReflGraph'

  -- turn the ♭-relational isomorphism into a (normal) iso
  Iso-PreXModule-ReflGraph' : Iso PreXModule' ReflGraph'
  Iso-PreXModule-ReflGraph' = 𝒮ᴰ-♭PIso-Over→TotalIso (IsoActionSplitEpi ℓ ℓℓ') 𝒮ᴰ-PreXModule' 𝒮ᴰ-ReflGraph' 𝒮ᴰ-♭PIso-PreXModule'-ReflGraph'

  -- reassociate on both sides
  Iso-PreXModule-ReflGraph : Iso (PreXModule ℓ ℓℓ') (ReflGraph ℓ ℓℓ')
  Iso-PreXModule-ReflGraph = compIso (compIso Σ-assoc-Iso
                                            Iso-PreXModule-ReflGraph')
                                   (invIso Σ-assoc-Iso)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the heterogeneous prefix relation
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Prefix.Heterogeneous.Properties where

open import Data.Empty
open import Data.List.Relation.Unary.All as All using (All; []; _∷_)
import Data.List.Relation.Unary.All.Properties as All
open import Data.List.Base as List hiding (map; uncons)
open import Data.List.Membership.Propositional.Properties using ([]∈inits)
open import Data.List.Relation.Binary.Pointwise using (Pointwise; []; _∷_)
open import Data.List.Relation.Binary.Prefix.Heterogeneous as Prefix hiding (PrefixView; _++_)
open import Data.Nat.Base using (ℕ; zero; suc; _≤_; z≤n; s≤s)
open import Data.Nat.Properties using (suc-injective)
open import Data.Product as Prod using (_×_; _,_; proj₁; proj₂; uncurry)
open import Function

open import Relation.Nullary using (yes; no; ¬_)
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Unary as U using (Pred)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)

------------------------------------------------------------------------
-- First as a decidable partial order (once made homogeneous)

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  fromPointwise : Pointwise R ⇒ Prefix R
  fromPointwise []       = []
  fromPointwise (r ∷ rs) = r ∷ fromPointwise rs

  toPointwise : ∀ {as bs} → length as ≡ length bs →
                Prefix R as bs → Pointwise R as bs
  toPointwise {bs = []} eq [] = []
  toPointwise {bs = _ ∷ _} () []
  toPointwise eq (r ∷ rs) = r ∷ toPointwise (suc-injective eq) rs

module _ {a b c r s t} {A : Set a} {B : Set b} {C : Set c}
         {R : REL A B r} {S : REL B C s} {T : REL A C t} where

  trans : Trans R S T → Trans (Prefix R) (Prefix S) (Prefix T)
  trans rs⇒t []       ss       = []
  trans rs⇒t (r ∷ rs) (s ∷ ss) = rs⇒t r s ∷ trans rs⇒t rs ss

module _ {a b r s e} {A : Set a} {B : Set b}
         {R : REL A B r} {S : REL B A s} {E : REL A B e} where

  antisym : Antisym R S E → Antisym (Prefix R) (Prefix S) (Pointwise E)
  antisym rs⇒e []       []       = []
  antisym rs⇒e (r ∷ rs) (s ∷ ss) = rs⇒e r s ∷ antisym rs⇒e rs ss

------------------------------------------------------------------------
-- length

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  length-mono : ∀ {as bs} → Prefix R as bs → length as ≤ length bs
  length-mono []       = z≤n
  length-mono (r ∷ rs) = s≤s (length-mono rs)

------------------------------------------------------------------------
-- _++_

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  ++⁺ : ∀ {as bs cs ds} → Pointwise R as bs →
        Prefix R cs ds → Prefix R (as ++ cs) (bs ++ ds)
  ++⁺ []       cs⊆ds = cs⊆ds
  ++⁺ (r ∷ rs) cs⊆ds = r ∷ (++⁺ rs cs⊆ds)

  ++⁻ : ∀ {as bs cs ds} → length as ≡ length bs →
        Prefix R (as ++ cs) (bs ++ ds) → Prefix R cs ds
  ++⁻ {[]}    {[]}    eq rs       = rs
  ++⁻ {_ ∷ _} {_ ∷ _} eq (_ ∷ rs) = ++⁻ (suc-injective eq) rs
  ++⁻ {[]} {_ ∷ _} ()
  ++⁻ {_ ∷ _} {[]} ()

------------------------------------------------------------------------
-- map

module _ {a b c d r} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
         {R : REL C D r} where

  map⁺ : ∀ {as bs} (f : A → C) (g : B → D) →
         Prefix (λ a b → R (f a) (g b)) as bs →
         Prefix R (List.map f as) (List.map g bs)
  map⁺ f g []       = []
  map⁺ f g (r ∷ rs) = r ∷ map⁺ f g rs

  map⁻ : ∀ {as bs} (f : A → C) (g : B → D) →
         Prefix R (List.map f as) (List.map g bs) →
         Prefix (λ a b → R (f a) (g b)) as bs
  map⁻ {[]}     {bs}     f g rs       = []
  map⁻ {a ∷ as} {[]}     f g ()
  map⁻ {a ∷ as} {b ∷ bs} f g (r ∷ rs) = r ∷ map⁻ f g rs

------------------------------------------------------------------------
-- filter

module _ {a b r p q} {A : Set a} {B : Set b} {R : REL A B r}
         {P : Pred A p} {Q : Pred B q} (P? : U.Decidable P) (Q? : U.Decidable Q)
         (P⇒Q : ∀ {a b} → R a b → P a → Q b) (Q⇒P : ∀ {a b} → R a b → Q b → P a)
         where

  filter⁺ : ∀ {as bs} → Prefix R as bs → Prefix R (filter P? as) (filter Q? bs)
  filter⁺ [] = []
  filter⁺ {a ∷ as} {b ∷ bs} (r ∷ rs) with P? a | Q? b
  ... | yes pa | yes qb = r ∷ filter⁺ rs
  ... | yes pa | no ¬qb = ⊥-elim (¬qb (P⇒Q r pa))
  ... | no ¬pa | yes qb = ⊥-elim (¬pa (Q⇒P r qb))
  ... | no ¬pa | no ¬qb = filter⁺ rs

------------------------------------------------------------------------
-- take

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  take⁺ : ∀ {as bs} n → Prefix R as bs →
          Prefix R (take n as) (take n bs)
  take⁺ zero    rs       = []
  take⁺ (suc n) []       = []
  take⁺ (suc n) (r ∷ rs) = r ∷ take⁺ n rs

  take⁻ : ∀ {as bs} n →
          Prefix R (take n as) (take n bs) →
          Prefix R (drop n as) (drop n bs) →
          Prefix R as bs
  take⁻                   zero    hds       tls = tls
  take⁻ {[]}              (suc n) hds       tls = []
  take⁻ {a ∷ as} {[]}     (suc n) ()        tls
  take⁻ {a ∷ as} {b ∷ bs} (suc n) (r ∷ hds) tls = r ∷ take⁻ n hds tls

------------------------------------------------------------------------
-- drop

  drop⁺ : ∀ {as bs} n → Prefix R as bs → Prefix R (drop n as) (drop n bs)
  drop⁺ zero    rs       = rs
  drop⁺ (suc n) []       = []
  drop⁺ (suc n) (r ∷ rs) = drop⁺ n rs

  drop⁻ : ∀ {as bs} n → Pointwise R (take n as) (take n bs) →
          Prefix R (drop n as) (drop n bs) → Prefix R as bs
  drop⁻                 zero    hds       tls = tls
  drop⁻ {[]}            (suc n) hds       tls = []
  drop⁻ {_ ∷ _} {[]}    (suc n) ()        tls
  drop⁻ {_ ∷ _} {_ ∷ _} (suc n) (r ∷ hds) tls = r ∷ (drop⁻ n hds tls)

------------------------------------------------------------------------
-- replicate

  replicate⁺ : ∀ {m n a b} → m ≤ n → R a b →
               Prefix R (replicate m a) (replicate n b)
  replicate⁺ z≤n       r = []
  replicate⁺ (s≤s m≤n) r = r ∷ replicate⁺ m≤n r

  replicate⁻ : ∀ {m n a b} → m ≢ 0 →
               Prefix R (replicate m a) (replicate n b) → R a b
  replicate⁻ {zero}  {n}     m≢0 r  = ⊥-elim (m≢0 P.refl)
  replicate⁻ {suc m} {zero}  m≢0 ()
  replicate⁻ {suc m} {suc n} m≢0 rs = Prefix.head rs

------------------------------------------------------------------------
-- inits

module _ {a r} {A : Set a} {R : Rel A r} where

  inits⁺ : ∀ {as} → Pointwise R as as → All (flip (Prefix R) as) (inits as)
  inits⁺ []       = [] ∷ []
  inits⁺ (r ∷ rs) = [] ∷ All.map⁺ (All.map (r ∷_) (inits⁺ rs))

  inits⁻ : ∀ {as} → All (flip (Prefix R) as) (inits as) → Pointwise R as as
  inits⁻ {as = []}     rs       = []
  inits⁻ {as = a ∷ as} (r ∷ rs) =
    let (hd , tls) = All.unzip (All.map uncons (All.map⁻ rs)) in
    All.lookup hd ([]∈inits as) ∷ inits⁻ tls

------------------------------------------------------------------------
-- zip(With)

module _ {a b c} {A : Set a} {B : Set b} {C : Set c}
         {d e f} {D : Set d} {E : Set e} {F : Set f}
         {r s t} {R : REL A D r} {S : REL B E s} {T : REL C F t} where

  zipWith⁺ : ∀ {as bs ds es} {f : A → B → C} {g : D → E → F} →
    (∀ {a b c d} → R a c → S b d → T (f a b) (g c d)) →
    Prefix R as ds → Prefix S bs es →
    Prefix T (zipWith f as bs) (zipWith g ds es)
  zipWith⁺ f []       ss       = []
  zipWith⁺ f (r ∷ rs) []       = []
  zipWith⁺ f (r ∷ rs) (s ∷ ss) = f r s ∷ zipWith⁺ f rs ss

module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
         {r s} {R : REL A C r} {S : REL B D s} where

  private
    R×S : REL (A × B) (C × D) _
    R×S (a , b) (c , d) = R a c × S b d

  zip⁺ : ∀ {as bs cs ds} → Prefix R as cs → Prefix S bs ds →
         Prefix R×S (zip as bs) (zip cs ds)
  zip⁺ = zipWith⁺ _,_

------------------------------------------------------------------------
-- Irrelevance

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  irrelevant : Irrelevant R → Irrelevant (Prefix R)
  irrelevant R-irr []       []         = P.refl
  irrelevant R-irr (r ∷ rs) (r′ ∷ rs′) =
    P.cong₂ _∷_ (R-irr r r′) (irrelevant R-irr rs rs′)

------------------------------------------------------------------------
-- Decidability

  prefix? : Decidable R → Decidable (Prefix R)
  prefix? R? []       bs       = yes []
  prefix? R? (a ∷ as) []       = no (λ ())
  prefix? R? (a ∷ as) (b ∷ bs) = Dec.map′ (uncurry _∷_) uncons
                               $ R? a b ×-dec prefix? R? as bs


-- Andreas, 2016-01-22, issue 1790
-- Projections should be highlighted as such everywhere,
-- even in the parts of a record declaration that
-- make the record constructor type.

record Σ A (B : A → Set) : Set where
  field
    fst : A
    snd : B fst  -- fst should be highlighted as projection here

-- Should also work under 'mutual'.

mutual
  record IOInterface : Set₁ where
    constructor ioInterface
    field  Command   :  Set
           Response  :  (m : Command) → Set


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

open import lib.Basics
open import lib.Equivalence2
open import lib.Function2
open import lib.NType2
open import lib.types.Coproduct
open import lib.types.Fin
open import lib.types.Group
open import lib.types.Int
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Subtype
open import lib.types.Truncation
open import lib.groups.SubgroupProp

module lib.groups.Homomorphism where

{-
Group homomorphisms.
-}

preserves-comp : ∀ {i j} {A : Type i} {B : Type j}
  (A-comp : A → A → A) (B-comp : B → B → B) (f : A → B)
  → Type (lmax i j)
preserves-comp Ac Bc f = ∀ a₁ a₂ → f (Ac a₁ a₂) == Bc (f a₁) (f a₂)

preserves-comp-prop : ∀ {i j} {A : Type i} {B : Type j}
  {{_ : is-set B}} (A-comp : A → A → A) (B-comp : B → B → B)
  → SubtypeProp (A → B) (lmax i j)
preserves-comp-prop Ac Bc =
  preserves-comp Ac Bc , ⟨⟩

abstract
  ∼-preserves-preserves-comp : ∀ {i j} {A : Type i} {B : Type j}
    (A-comp : A → A → A) (B-comp : B → B → B) {f₀ f₁ : A → B} → f₀ ∼ f₁
    → preserves-comp A-comp B-comp f₀
    → preserves-comp A-comp B-comp f₁
  ∼-preserves-preserves-comp Ac Bc {f₀ = f₀} {f₁} f₀∼f₁ f₀-pc a₁ a₂ =
    ! (f₀∼f₁ (Ac a₁ a₂)) ∙ f₀-pc a₁ a₂ ∙ ap2 Bc (f₀∼f₁ a₁) (f₀∼f₁ a₂)

record GroupStructureHom {i j} {GEl : Type i} {HEl : Type j}
  (GS : GroupStructure GEl) (HS : GroupStructure HEl) : Type (lmax i j) where
  constructor group-structure-hom
  private
    module G = GroupStructure GS
    module H = GroupStructure HS
  field
    f : GEl → HEl
    pres-comp : preserves-comp G.comp H.comp f

  abstract
    pres-ident : f G.ident == H.ident
    pres-ident = H.cancel-l (f G.ident) $
      H.comp (f G.ident) (f G.ident)
        =⟨ ! (pres-comp G.ident G.ident) ⟩
      f (G.comp G.ident G.ident)
        =⟨ ap f (G.unit-l G.ident) ⟩
      f G.ident
        =⟨ ! (H.unit-r (f G.ident)) ⟩
      H.comp (f G.ident) H.ident =∎

    pres-inv : ∀ g → f (G.inv g) == H.inv (f g)
    pres-inv g = ! $ H.inv-unique-l _ _ $
      H.comp (f (G.inv g)) (f g)
        =⟨ ! (pres-comp (G.inv g) g) ⟩
      f (G.comp (G.inv g) g)
        =⟨ ap f (G.inv-l g) ⟩
      f G.ident
        =⟨ pres-ident ⟩
      H.ident
        =∎

    pres-exp : ∀ g i → f (G.exp g i) == H.exp (f g) i
    pres-exp g (pos O) = pres-ident
    pres-exp g (pos (S O)) = idp
    pres-exp g (pos (S (S n))) = pres-comp g (G.exp g (pos (S n))) ∙ ap (H.comp (f g)) (pres-exp g (pos (S n)))
    pres-exp g (negsucc O) = pres-inv g
    pres-exp g (negsucc (S n)) = pres-comp (G.inv g) (G.exp g (negsucc n)) ∙ ap2 H.comp (pres-inv g) (pres-exp g (negsucc n))

    pres-conj : ∀ g h → f (G.conj g h) == H.conj (f g) (f h)
    pres-conj g h = pres-comp (G.comp g h) (G.inv g) ∙ ap2 H.comp (pres-comp g h) (pres-inv g)

    pres-diff : ∀ g h → f (G.diff g h) == H.diff (f g) (f h)
    pres-diff g h = pres-comp g (G.inv h) ∙ ap (H.comp (f g)) (pres-inv h)

    pres-sum : ∀ {I : ℕ} (g : Fin I → GEl) → f (G.sum g) == H.sum (f ∘ g)
    pres-sum {I = O} _ = pres-ident
    pres-sum {I = S I} g = pres-comp (G.sum (g ∘ Fin-S)) (g (_ , ltS))
      ∙ ap (λ h → H.comp h (f (g (_ , ltS)))) (pres-sum (g ∘ Fin-S))

    pres-subsum-r : ∀ {k l} {I : ℕ} {A : Type k} {B : Type l}
      → (p : Fin I → Coprod A B) (g : B → GEl)
      → f (G.subsum-r p g) == H.subsum-r p (f ∘ g)
    pres-subsum-r p g = pres-sum (Coprod-rec (λ _ → G.ident) g ∘ p)
      ∙ ap H.sum (λ= λ x →
            Coprod-rec-post∘ f (λ _ → G.ident) g (p x)
          ∙ ap (λ h → Coprod-rec h (f ∘ g) (p x)) (λ= λ _ → pres-ident))

  ⊙f : ⊙[ GEl , G.ident ] ⊙→ ⊙[ HEl , H.ident ]
  ⊙f = f , pres-ident

infix 0 _→ᴳˢ_ -- [ˢ] for structures
_→ᴳˢ_ = GroupStructureHom

record GroupHom {i j} (G : Group i) (H : Group j) : Type (lmax i j) where
  constructor group-hom
  private
    module G = Group G
    module H = Group H
  field
    f : G.El → H.El
    pres-comp : ∀ g₁ g₂ → f (G.comp g₁ g₂) == H.comp (f g₁) (f g₂)
  open GroupStructureHom {GS = G.group-struct} {HS = H.group-struct}
    record {f = f ; pres-comp = pres-comp} hiding (f ; pres-comp) public

infix 0 _→ᴳ_
_→ᴳ_ = GroupHom

→ᴳˢ-to-→ᴳ : ∀ {i j} {G : Group i} {H : Group j}
  → (Group.group-struct G →ᴳˢ Group.group-struct H) → (G →ᴳ H)
→ᴳˢ-to-→ᴳ (group-structure-hom f pres-comp) = group-hom f pres-comp

idhom : ∀ {i} (G : Group i) → (G →ᴳ G)
idhom G = group-hom (idf _) (λ _ _ → idp)

idshom : ∀ {i} {GEl : Type i} (GS : GroupStructure GEl) → (GS →ᴳˢ GS)
idshom GS = group-structure-hom (idf _) (λ _ _ → idp)

{- constant (zero) homomorphism -}
module _ where
  cst-hom : ∀ {i j} {G : Group i} {H : Group j} → (G →ᴳ H)
  cst-hom {H = H} = group-hom (cst (Group.ident H)) (λ _ _ → ! (Group.unit-l H _))

{- negation is a homomorphism in an abelian gruop -}
inv-hom : ∀ {i} (G : AbGroup i) → GroupHom (AbGroup.grp G) (AbGroup.grp G)
inv-hom G = group-hom G.inv inv-pres-comp where
  module G = AbGroup G
  abstract
    inv-pres-comp : (g₁ g₂ : G.El) → G.inv (G.comp g₁ g₂) == G.comp (G.inv g₁) (G.inv g₂)
    inv-pres-comp g₁ g₂ = G.inv-comp g₁ g₂ ∙ G.comm (G.inv g₂) (G.inv g₁)

{- equality of homomorphisms -}
abstract
  group-hom= : ∀ {i j} {G : Group i} {H : Group j} {φ ψ : G →ᴳ H}
    → GroupHom.f φ == GroupHom.f ψ → φ == ψ
  group-hom= {G = G} {H = H} p = ap (uncurry group-hom) $
    Subtype=-out (preserves-comp-prop (Group.comp G) (Group.comp H)) p

  group-hom=-↓ : ∀ {i j k} {A : Type i} {G : A → Group j} {H : A → Group k} {x y : A}
    {p : x == y} {φ : G x →ᴳ H x} {ψ : G y →ᴳ H y}
    → GroupHom.f φ == GroupHom.f ψ
      [ (λ a → Group.El (G a) → Group.El (H a)) ↓ p ]
    → φ == ψ [ (λ a → G a →ᴳ H a) ↓ p ]
  group-hom=-↓ {p = idp} = group-hom=

abstract
  instance
    GroupHom-level : ∀ {i j} {G : Group i} {H : Group j} → is-set (G →ᴳ H)
    GroupHom-level {G = G} {H = H} = equiv-preserves-level
      (equiv (uncurry group-hom) (λ x → GroupHom.f x , GroupHom.pres-comp x)
             (λ _ → idp) (λ _ → idp))
      {{Subtype-level
        (preserves-comp-prop (Group.comp G) (Group.comp H))}}

infixr 80 _∘ᴳˢ_ _∘ᴳ_

abstract
  ∘ᴳˢ-pres-comp : ∀ {i j k} {GEl : Type i} {HEl : Type j} {KEl : Type k}
    {GS : GroupStructure GEl} {HS : GroupStructure HEl} {KS : GroupStructure KEl}
    (ψ : HS →ᴳˢ KS) (φ : GS →ᴳˢ HS)
    → preserves-comp (GroupStructure.comp GS) (GroupStructure.comp KS) (GroupStructureHom.f ψ ∘ GroupStructureHom.f φ)
  ∘ᴳˢ-pres-comp ψ φ g₁ g₂ = ap (GroupStructureHom.f ψ) (GroupStructureHom.pres-comp φ g₁ g₂)
    ∙ GroupStructureHom.pres-comp ψ (GroupStructureHom.f φ g₁) (GroupStructureHom.f φ g₂)

  ∘ᴳ-pres-comp : ∀ {i j k} {G : Group i} {H : Group j} {K : Group k} (ψ : H →ᴳ K) (φ : G →ᴳ H)
    → preserves-comp (Group.comp G) (Group.comp K) (GroupHom.f ψ ∘ GroupHom.f φ)
  ∘ᴳ-pres-comp ψ φ g₁ g₂ = ap (GroupHom.f ψ) (GroupHom.pres-comp φ g₁ g₂)
    ∙ GroupHom.pres-comp ψ (GroupHom.f φ g₁) (GroupHom.f φ g₂)

_∘ᴳˢ_ : ∀  {i j k} {GEl : Type i} {HEl : Type j} {KEl : Type k}
  {GS : GroupStructure GEl} {HS : GroupStructure HEl} {KS : GroupStructure KEl}
  → (HS →ᴳˢ KS) → (GS →ᴳˢ HS) → (GS →ᴳˢ KS)
ψ ∘ᴳˢ φ = group-structure-hom (GroupStructureHom.f ψ ∘ GroupStructureHom.f φ) (∘ᴳˢ-pres-comp ψ φ)

_∘ᴳ_ : ∀ {i j k} {G : Group i} {H : Group j} {K : Group k}
  → (H →ᴳ K) → (G →ᴳ H) → (G →ᴳ K)
ψ ∘ᴳ φ = group-hom (GroupHom.f ψ ∘ GroupHom.f φ) (∘ᴳ-pres-comp ψ φ)

{- algebraic properties -}

∘ᴳ-unit-r : ∀ {i j} {G : Group i} {H : Group j} (φ : G →ᴳ H)
  → φ ∘ᴳ idhom G == φ
∘ᴳ-unit-r φ = group-hom= idp

∘ᴳ-unit-l : ∀ {i j} {G : Group i} {H : Group j} (φ : G →ᴳ H)
  → idhom H ∘ᴳ φ == φ
∘ᴳ-unit-l φ = group-hom= idp

∘ᴳ-assoc : ∀ {i j k l} {G : Group i} {H : Group j} {K : Group k} {L : Group l}
  (χ : K →ᴳ L) (ψ : H →ᴳ K) (φ : G →ᴳ H)
  → (χ ∘ᴳ ψ) ∘ᴳ φ == χ ∘ᴳ ψ ∘ᴳ φ
∘ᴳ-assoc χ ψ φ = group-hom= idp

is-injᴳ : ∀ {i j} {G : Group i} {H : Group j}
  → (G →ᴳ H) → Type (lmax i j)
is-injᴳ hom = is-inj (GroupHom.f hom)

is-surjᴳ : ∀ {i j} {G : Group i} {H : Group j}
  → (G →ᴳ H) → Type (lmax i j)
is-surjᴳ hom = is-surj (GroupHom.f hom)

{- subgroups -}

infix 80 _∘subᴳ_
_∘subᴳ_ : ∀ {i j k} {G : Group i} {H : Group j}
  → SubgroupProp H k → (G →ᴳ H) → SubgroupProp G k
_∘subᴳ_ {k = k} {G = G} P φ = record {M} where
  module G = Group G
  module P = SubgroupProp P
  module φ = GroupHom φ
  module M where
    prop : G.El → Type k
    prop = P.prop ∘ φ.f

    abstract
      ident : prop G.ident
      ident = transport! P.prop φ.pres-ident P.ident

      diff : {g₁ g₂ : G.El} → prop g₁ → prop g₂ → prop (G.diff g₁ g₂)
      diff {g₁} {g₂} pφg₁ pφg₂ = transport! P.prop
        (φ.pres-diff g₁ g₂)
        (P.diff pφg₁ pφg₂)

infix 80 _∘nsubᴳ_
_∘nsubᴳ_ : ∀ {i j k} {G : Group i} {H : Group j}
  → NormalSubgroupProp H k → (G →ᴳ H) → NormalSubgroupProp G k
_∘nsubᴳ_ {G = G} {H} P φ = P.propᴳ ∘subᴳ φ , P-φ-is-normal
  where module P = NormalSubgroupProp P
        module φ = GroupHom φ
        abstract
          P-φ-is-normal : is-normal (P.propᴳ ∘subᴳ φ)
          P-φ-is-normal g₁ {g₂} pφg₂ = transport! P.prop
            (φ.pres-conj g₁ g₂)
            (P.conj (φ.f g₁) pφg₂)

{- kernels and images -}

module _ {i j} {G : Group i} {H : Group j} (φ : G →ᴳ H) where
  private
    module G = Group G
    module H = Group H
    module φ = GroupHom φ

  ker-propᴳ : SubgroupProp G j
  ker-propᴳ = record {M} where
    module M where
      prop : G.El → Type j
      prop g = φ.f g == H.ident
      abstract
        ident : prop G.ident
        ident = φ.pres-ident

        diff : {g₁ g₂ : G.El} → prop g₁ → prop g₂ → prop (G.diff g₁ g₂)
        diff {g₁} {g₂} p₁ p₂ = φ.pres-diff g₁ g₂ ∙ ap2 H.diff p₁ p₂ ∙ H.inv-r H.ident

  -- 'n' for 'normal'
  ker-npropᴳ : NormalSubgroupProp G j
  ker-npropᴳ = ker-propᴳ , ker-is-normal where
    abstract
      ker-is-normal : is-normal ker-propᴳ
      ker-is-normal g₁ {g₂} pg₂ =
          φ.pres-conj g₁ g₂
        ∙ ap (H.conj (φ.f g₁)) pg₂
        ∙ H.conj-ident-r (φ.f g₁)

  im-propᴳ : SubgroupProp H (lmax i j)
  im-propᴳ = record {M} where
    module M where
      prop : H.El → Type (lmax i j)
      prop h = Trunc -1 (hfiber φ.f h)

      level : (h : H.El) → is-prop (prop h)
      level h = Trunc-level

      abstract
        ident : prop H.ident
        ident = [ G.ident , φ.pres-ident ]

        diff : {h₁ h₂ : H.El} → prop h₁ → prop h₂ → prop (H.diff h₁ h₂)
        diff = Trunc-fmap2 λ {(g₁ , p₁) (g₂ , p₂)
          → G.diff g₁ g₂ , φ.pres-diff g₁ g₂ ∙ ap2 H.diff p₁ p₂}

  im-npropᴳ : is-abelian H → NormalSubgroupProp H (lmax i j)
  im-npropᴳ H-is-abelian = sub-abelian-normal H-is-abelian im-propᴳ

  has-trivial-kerᴳ : Type (lmax i j)
  has-trivial-kerᴳ = is-trivial-propᴳ ker-propᴳ

  abstract
    -- any homomorphism with trivial kernel is injective
    has-trivial-ker-is-injᴳ : has-trivial-kerᴳ → is-injᴳ φ
    has-trivial-ker-is-injᴳ tk g₁ g₂ p =
      G.zero-diff-same g₁ g₂ $ tk (G.diff g₁ g₂) $
        φ.pres-diff g₁ g₂ ∙ ap (λ h → H.diff h (φ.f g₂)) p ∙ H.inv-r (φ.f g₂)

ker-cst-hom-is-full : ∀ {i j} (G : Group i) (H : Group j)
  → is-fullᴳ (ker-propᴳ (cst-hom {G = G} {H}))
ker-cst-hom-is-full G H g = idp

{- exactness -}

module _ {i j k} {G : Group i} {H : Group j} {K : Group k}
  (φ : G →ᴳ H) (ψ : H →ᴳ K) where

  private
    module G = Group G
    module H = Group H
    module K = Group K
    module φ = GroupHom φ
    module ψ = GroupHom ψ

  record is-exact : Type (lmax k (lmax j i)) where
    field
      im-sub-ker : im-propᴳ φ ⊆ᴳ ker-propᴳ ψ
      ker-sub-im : ker-propᴳ ψ ⊆ᴳ  im-propᴳ φ

  open is-exact public

  abstract
    {- an equivalent version of is-exact-ktoi  -}
    im-sub-ker-in : is-fullᴳ (ker-propᴳ (ψ ∘ᴳ φ)) → im-propᴳ φ ⊆ᴳ ker-propᴳ ψ
    im-sub-ker-in r h = Trunc-rec (λ {(g , p) → ap ψ.f (! p) ∙ r g})

    im-sub-ker-out : im-propᴳ φ ⊆ᴳ ker-propᴳ ψ → is-fullᴳ (ker-propᴳ (ψ ∘ᴳ φ))
    im-sub-ker-out s g = s (φ.f g) [ g , idp ]

{- homomorphisms into an abelian group can be composed with
 - the group operation and form a group -}
module _ {i j} (G : Group i) (H : AbGroup j)
  where

  private
    module G = Group G
    module H = AbGroup H

  hom-comp : (G →ᴳ H.grp) → (G →ᴳ H.grp) → (G →ᴳ H.grp)
  hom-comp φ ψ = group-hom (λ g → H.comp (φ.f g) (ψ.f g)) hom-comp-pres-comp where
    module φ = GroupHom φ
    module ψ = GroupHom ψ
    abstract
      hom-comp-pres-comp : ∀ g₁ g₂
        →  H.comp (φ.f (G.comp g₁ g₂)) (ψ.f (G.comp g₁ g₂))
        == H.comp (H.comp (φ.f g₁) (ψ.f g₁)) (H.comp (φ.f g₂) (ψ.f g₂))
      hom-comp-pres-comp g₁ g₂ =
        H.comp (φ.f (G.comp g₁ g₂)) (ψ.f (G.comp g₁ g₂))
          =⟨ ap2 H.comp (φ.pres-comp g₁ g₂) (ψ.pres-comp g₁ g₂) ⟩
        H.comp (H.comp (φ.f g₁) (φ.f g₂)) (H.comp (ψ.f g₁) (ψ.f g₂))
          =⟨ H.interchange (φ.f g₁) (φ.f g₂) (ψ.f g₁) (ψ.f g₂) ⟩
        H.comp (H.comp (φ.f g₁) (ψ.f g₁)) (H.comp (φ.f g₂) (ψ.f g₂)) =∎

  hom-group-structure : GroupStructure (G →ᴳ H.grp)
  hom-group-structure = record {M} where
    module M where
      ident : G →ᴳ H.grp
      ident = cst-hom

      comp : (G →ᴳ H.grp) → (G →ᴳ H.grp) → (G →ᴳ H.grp)
      comp = hom-comp

      inv : (G →ᴳ H.grp) → (G →ᴳ H.grp)
      inv φ = inv-hom H ∘ᴳ φ

      abstract
        unit-l : ∀ φ → comp ident φ == φ
        unit-l φ = group-hom= $ λ= λ _ → H.unit-l _

        assoc : ∀ φ ψ ξ → comp (comp φ ψ) ξ == comp φ (comp ψ ξ)
        assoc φ ψ ξ = group-hom= $ λ= λ _ → H.assoc _ _ _

        inv-l : ∀ φ → comp (inv φ) φ == ident
        inv-l φ = group-hom= $ λ= λ _ → H.inv-l _

  hom-group : Group (lmax i j)
  hom-group = group (G →ᴳ H.grp) hom-group-structure

  abstract
    hom-group-is-abelian : is-abelian hom-group
    hom-group-is-abelian φ ψ = group-hom= $ λ= λ g → H.comm _ _

  hom-abgroup : AbGroup (lmax i j)
  hom-abgroup = hom-group , hom-group-is-abelian

module _ {i j} {G : Group i} {H : AbGroup j} where
  app-hom : Group.El G → hom-group G H →ᴳ AbGroup.grp H
  app-hom g = group-hom (λ φ → GroupHom.f φ g) lemma
    where abstract lemma = λ φ ψ → idp

  appᴳ = app-hom

pre∘ᴳ-hom : ∀ {i j k} {G : Group i} {H : Group j} (K : AbGroup k)
  → (G →ᴳ H) → (hom-group H K →ᴳ hom-group G K)
pre∘ᴳ-hom K φ = record { f = _∘ᴳ φ ; pres-comp = lemma}
  where abstract lemma = λ _ _ → group-hom= idp

post∘ᴳ-hom : ∀ {i j k} (G : Group i) (H : AbGroup j) (K : AbGroup k)
  → (AbGroup.grp H →ᴳ AbGroup.grp K) → (hom-group G H →ᴳ hom-group G K)
post∘ᴳ-hom G H K φ = record { f = φ ∘ᴳ_ ; pres-comp = lemma}
  where abstract lemma = λ _ _ → group-hom= $ λ= λ _ → GroupHom.pres-comp φ _ _


-- Lemma for `Constructive.Axiom.Properties.Base`

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

module Constructive.Axiom.Properties.Base.Lemma where

-- agda-stdlib
open import Data.Empty
open import Data.Nat
import Data.Nat.Properties as ℕₚ
open import Data.Product
open import Data.Sum as Sum
open import Data.Sum.Properties
open import Function.Base
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

-- agda-misc
open import Constructive.Combinators
open import Constructive.Common

-- lemma for `ℕ-llpo⇒mp∨`
ℕ≤-any-dec : ∀ {p} {P : ℕ → Set p} → DecU P → DecU (λ n → ∃ λ m → m ≤ n × P m)
ℕ≤-any-dec {P = P} P? zero with P? 0
... | inj₁  P0 = inj₁ (0 , ℕₚ.≤-refl , P0)
... | inj₂ ¬P0 = inj₂ λ {(m , m≤0 , Pm) → ¬P0 (subst P (ℕₚ.n≤0⇒n≡0 m≤0) Pm)}
ℕ≤-any-dec P? (suc n) with P? 0
... | inj₁  P0 = inj₁ (0 , (z≤n , P0))
... | inj₂ ¬P0 with ℕ≤-any-dec (P? ∘ suc) n
ℕ≤-any-dec {P = P} P? (suc n) | inj₂ ¬P0 | inj₁ (m , m≤n , Psm) =
  inj₁ (suc m , s≤s m≤n , Psm)
ℕ≤-any-dec {P = P} P? (suc n) | inj₂ ¬P0 | inj₂ ¬∃m→m≤n×Psm     = inj₂ f
  where
  f : (∃ λ m → m ≤ suc n × P m) → ⊥
  f (zero  , m≤sn  , Pm)  = ¬P0 Pm
  f (suc m , sm≤sn , Psm) = ¬∃m→m≤n×Psm (m , (ℕₚ.≤-pred sm≤sn , Psm))

private
  1+n≰0 : ∀ n → ¬ (suc n ≤ 0)
  1+n≰0 n ()

module _ {p} {P : ℕ → Set p} (P? : DecU P) where
  ℕ<-any-dec : DecU (λ n → ∃ λ m → m < n × P m)
  ℕ<-any-dec zero           = inj₂ λ {(m , m<0 , _) → 1+n≰0 m m<0}
  ℕ<-any-dec (suc n) with ℕ≤-any-dec P? n
  ... | inj₁ (m , m≤n , Pm) = inj₁ (m , s≤s m≤n , Pm)
  ... | inj₂ ¬∃m→m≤n×Pm     = inj₂ (contraposition f ¬∃m→m≤n×Pm)
    where
    f : (∃ λ m → suc m ≤ suc n × P m) → ∃ λ m → m ≤ n × P m
    f (m , sm≤sn , Pm) = m , (ℕₚ.≤-pred sm≤sn , Pm)

  ℕ≤-all-dec : DecU (λ n → ∀ m → m ≤ n → P m)
  ℕ≤-all-dec n with ℕ≤-any-dec (¬-DecU P?) n
  ... | inj₁ (m , m≤n , ¬Pm) = inj₂ λ ∀i→i≤n→Pi → ¬Pm (∀i→i≤n→Pi m m≤n)
  ... | inj₂ ¬∃m→m≤n×¬Pm     =
    inj₁ λ m m≤n → DecU⇒stable P? m λ ¬Pm → ¬∃m→m≤n×¬Pm (m , m≤n , ¬Pm)

module _ {p} {P : ℕ → Set p} (P? : DecU P) where
  ℕ<-all-dec : DecU (λ n → ∀ m → m < n → P m)
  ℕ<-all-dec n with ℕ<-any-dec (¬-DecU P?) n
  ... | inj₁ (m , m<n , ¬Pm) = inj₂ λ ∀i→i<n→Pi → ¬Pm (∀i→i<n→Pi m m<n)
  ... | inj₂ ¬∃m→m<n×¬Pm     =
    inj₁ λ m m<n → DecU⇒stable P? m λ ¬Pm → ¬∃m→m<n×¬Pm (m , m<n , ¬Pm)

-- lemma for llpo-ℕ⇒llpo
lemma₁ : ∀ {p} {P : ℕ → Set p} →
         (∀ m n → m ≢ n → P m ⊎ P n) →
         ∃ (λ n → ¬ P (2 * n)) → ∃ (λ n → ¬ P (suc (2 * n))) → ⊥
lemma₁ ∀mn→m≢n→Pm⊎Pn (m , ¬P2m) (n , ¬P1+2n) with
  ∀mn→m≢n→Pm⊎Pn (2 * m) (suc (2 * n)) (ℕₚ.even≢odd m n)
... | inj₁ P2m   = ¬P2m P2m
... | inj₂ P1+2n = ¬P1+2n P1+2n

parity : ℕ → ℕ ⊎ ℕ
parity zero          = inj₁ zero
parity (suc zero)    = inj₂ zero
parity (suc (suc n)) = Sum.map suc suc (parity n)

parity-even : ∀ n → parity (2 * n) ≡ inj₁ n
parity-even zero    = refl
parity-even (suc n) = begin
  parity (2 * (suc n))             ≡⟨ cong parity (ℕₚ.*-distribˡ-+ 2 1 n) ⟩
  parity (2 + 2 * n)               ≡⟨⟩
  Sum.map suc suc (parity (2 * n)) ≡⟨ cong (Sum.map suc suc) (parity-even n) ⟩
  Sum.map suc suc (inj₁ n)         ≡⟨⟩
  inj₁ (suc n)                     ∎
  where open ≡-Reasoning

parity-odd : ∀ n → parity (suc (2 * n)) ≡ inj₂ n
parity-odd zero    = refl
parity-odd (suc n) = begin
  parity (suc (2 * suc n))             ≡⟨ cong (parity ∘ suc) $ ℕₚ.*-distribˡ-+ 2 1 n ⟩
  parity (1 + (2 * 1 + 2 * n))         ≡⟨⟩
  parity (2 + (1 + 2 * n))             ≡⟨⟩
  Sum.map suc suc (parity (1 + 2 * n)) ≡⟨ cong (Sum.map suc suc) (parity-odd n) ⟩
  Sum.map suc suc (inj₂ n)             ≡⟨⟩
  inj₂ (suc n)                         ∎
  where open ≡-Reasoning

Sum-map-injective : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
                    {f : A → C} {g : B → D} →
                    (∀ {u v} → f u ≡ f v → u ≡ v) →
                    (∀ {u v} → g u ≡ g v → u ≡ v) → ∀ {x y} →
                    Sum.map f g x ≡ Sum.map f g y → x ≡ y
Sum-map-injective f-inj g-inj {inj₁ x} {inj₁ x₁} eq = cong inj₁ (f-inj (inj₁-injective eq))
Sum-map-injective f-ing g-inj {inj₂ y} {inj₂ y₁} eq = cong inj₂ (g-inj (inj₂-injective eq))

parity-injective : ∀ {m n} → parity m ≡ parity n → m ≡ n
parity-injective {zero}        {zero}        pm≡pn = refl
parity-injective {zero}        {suc (suc n)} pm≡pn with parity n
parity-injective {zero}        {suc (suc n)} () | inj₁ _
parity-injective {zero}        {suc (suc n)} () | inj₂ _
parity-injective {suc (suc m)} {zero}        pm≡pn with parity m
parity-injective {suc (suc m)} {zero}        () | inj₁ _
parity-injective {suc (suc m)} {zero}        () | inj₂ _
parity-injective {suc zero}    {suc zero}    pm≡pn = refl
parity-injective {suc zero}    {suc (suc n)} pm≡pn with parity n
parity-injective {suc zero}    {suc (suc n)} () | inj₁ _
parity-injective {suc zero}    {suc (suc n)} () | inj₂ _
parity-injective {suc (suc m)} {suc zero}    pm≡pn with parity m
parity-injective {suc (suc m)} {suc zero}    () | inj₁ _
parity-injective {suc (suc m)} {suc zero}    () | inj₂ _
parity-injective {suc (suc m)} {suc (suc n)} pm≡pn =
  cong (suc ∘ suc)
       (parity-injective
          (Sum-map-injective ℕₚ.suc-injective ℕₚ.suc-injective pm≡pn))

parity-even′ : ∀ {m n} → parity m ≡ inj₁ n → m ≡ 2 * n
parity-even′ {m} {n} eq = parity-injective (begin
    parity m       ≡⟨ eq ⟩
    inj₁ n         ≡⟨ sym $ parity-even n ⟩
    parity (2 * n) ∎)
  where open ≡-Reasoning

parity-odd′ : ∀ {m n} → parity m ≡ inj₂ n → m ≡ 1 + 2 * n
parity-odd′ {m} {n} eq = parity-injective (begin
  parity m           ≡⟨ eq ⟩
  inj₂ n             ≡⟨ sym $ parity-odd n ⟩
  parity (1 + 2 * n) ∎)
  where open ≡-Reasoning

mix : ℕ ⊎ ℕ → ℕ
mix = Sum.[ (λ n → 2 * n) , (λ n → 1 + 2 * n) ]

parity-mix : ∀ s → parity (mix s) ≡ s
parity-mix (inj₁ n) = parity-even n
parity-mix (inj₂ n) = parity-odd n

mix-parity : ∀ n → mix (parity n) ≡ n
mix-parity n = parity-injective (parity-mix (parity n))


------------------------------------------------------------------------
-- Identifiers
------------------------------------------------------------------------

{-# OPTIONS --guardedness #-}

module Examples.Identifier where

open import Codata.Musical.Notation
open import Data.Bool
open import Data.Char
open import Data.List.NonEmpty
open import Data.Product
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary

open import Grammar.Infinite as Grammar
  using (Grammar) hiding (module Grammar)
open import Pretty using (Doc; Pretty-printer)
open import Renderer
open import Utilities

-- Lower-case (ASCII) characters.

is-lower : Char → Bool
is-lower t = ('a' ≤?C t) ∧ (t ≤?C 'z')

-- A problematic attempt to define a grammar and a corresponding
-- pretty-printer for identifiers.

module Problematic where

  -- The grammar can be defined.

  identifier : Grammar (List⁺ Char)
  identifier = (proj₁ <$> sat is-lower) +
    where open Grammar

  -- However, it is impossible to define a corresponding
  -- pretty-printer.

  no-printer : ¬ Pretty-printer identifier
  no-printer identifier-printer = no-doc (identifier-printer [ 'A' ])
    where
    open Grammar

    lemma : ∀ {p : Char → Bool} {t s s′} →
            t ∷ s ∈ (proj₁ <$> sat p) + · s′ → T (p t)
    lemma (⊛-sem (<$>-sem (<$>-sem {x = _ , ok} _)) _) = ok

    no-doc : ¬ Doc identifier [ 'A' ]
    no-doc d = lemma (proj₂ (Renderer.string-exists d))

-- Identifiers.

Identifier : Set
Identifier = List⁺ (∃ λ t → T (is-lower t))

identifier : Grammar Identifier
identifier = sat is-lower +
  where open Grammar

identifier-printer : Pretty-printer identifier
identifier-printer = map+ (sat is-lower)
  where open Pretty

-- Identifiers possibly followed by whitespace.

identifier-w : Grammar Identifier
identifier-w = identifier <⊛ whitespace ⋆
  where open Grammar

identifier-w-printer : Pretty-printer identifier-w
identifier-w-printer n = identifier-printer n <⊛ nil-⋆
  where open Pretty

test : render 80 (identifier-w-printer (str⁺ "aaa")) ≡ "aaa"
test = refl


{-# OPTIONS --cubical --allow-unsolved-metas #-}
module TranspPiOnMeta where

open import Agda.Primitive.Cubical
open import Agda.Builtin.Cubical.Path

-- Transporting along a function type with unknown sort of
-- domain/codomain shouldn't result into an impossible being thrown.

-- We equate to Set to trigger reduction.

test1 : (primTransp (\ i → (x : {!!}) → {!!}) i0 {!!} {!!}) ≡ Set
test1 i = Set

test2 : (primTransp (\ i → (x : Set) → {!!}) i0 {!!} {!!}) ≡ Set
test2 i = Set

Foo : Set₂
Foo = {!!}

test3 : (primTransp (\ i → (x : {!!}) → Foo) i0 {!!} {!!}) ≡ Set
test3 i = Set


module Imports.Unsolved where

X : Set
X = ?


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Library.Relation.Binary.Equality.Decidable where

open import Light.Library.Relation using (Base)
open import Light.Library.Relation.Binary.Equality using (Equality)
open import Light.Level using (Setω)
import Light.Library.Relation.Decidable as Decidable
open import Light.Package using (Package)
open import Light.Variable.Levels

record DecidableEquality (𝕒 : Set aℓ) (𝕓 : Set aℓ) : Setω where
      constructor wrap
      field ⦃ decidable‐package ⦄ : Package record { Decidable }
      field ⦃ equals ⦄ : Equality 𝕒 𝕓

DecidableSelfEquality : ∀ (𝕒 : Set aℓ) → Setω
DecidableSelfEquality 𝕒 = DecidableEquality 𝕒 𝕒

open DecidableEquality ⦃ ... ⦄ public


-- {-# OPTIONS -v tc.proj.like:10 #-} {-# OPTIONS -v tc.conv:10 #-}
import Common.Level

module ProjectionLikeAndModules1 (A : Set) (a : A) where

record ⊤ : Set where
  constructor tt

data Wrap (W : Set) : Set where
  wrap : W → Wrap W

data Bool : Set where
  true false : Bool

-- `or' should be projection like in the module parameters
if : Bool → {B : Set} → B → B → B
if true  a b = a
if false a b = b

postulate
  u v : ⊤
  P : Wrap ⊤ -> Set

test : (y : Bool)
  -> P (if y (wrap u) (wrap tt))
  -> P (if y (wrap tt) (wrap v))
test y h = h

-- Error:
-- u != tt of type Set
-- when checking that the expression h has type
-- P (if y (wrap tt) (wrap v))