{-# OPTIONS --cubical --safe #-}

module Data.Bag where

open import Prelude
open import Algebra
open import Path.Reasoning

infixr 5 _∷_
data ⟅_⟆ (A : Type a) : Type a where
  []     : ⟅ A ⟆
  _∷_    : A → ⟅ A ⟆ → ⟅ A ⟆
  com    : ∀ x y xs → x ∷ y ∷ xs ≡ y ∷ x ∷ xs
  trunc  : isSet ⟅ A ⟆

record Elim {a ℓ}
             (A : Type a)
             (P : ⟅ A ⟆ → Type ℓ)
             : Type (a ℓ⊔ ℓ) where
  constructor elim
  field
    ⟅_⟆-set : ∀ {xs} → isSet (P xs)
    ⟅_⟆[] : P []
    ⟅_⟆_∷_⟨_⟩ : ∀ x xs → P xs → P (x ∷ xs)
  private z = ⟅_⟆[]; f = ⟅_⟆_∷_⟨_⟩
  field
    ⟅_⟆-com : (∀ x y xs pxs →
      PathP  (λ i → P (com x y xs i))
             (f x (y ∷ xs) (f y xs pxs))
             (f y (x ∷ xs) (f x xs pxs)))
  ⟅_⟆⇓ : (xs : ⟅ A ⟆) → P xs
  ⟅ [] ⟆⇓ = z
  ⟅ x ∷ xs ⟆⇓ = f x xs ⟅ xs ⟆⇓
  ⟅ com x y xs i ⟆⇓ = ⟅_⟆-com x y xs ⟅ xs ⟆⇓ i
  ⟅ trunc xs ys x y i j ⟆⇓ =
    isOfHLevel→isOfHLevelDep 2
      (λ xs → ⟅_⟆-set {xs})
      ⟅ xs ⟆⇓ ⟅ ys ⟆⇓
      (cong ⟅_⟆⇓ x) (cong ⟅_⟆⇓ y)
      (trunc xs ys x y)
      i j

open Elim

infixr 0 elim-syntax
elim-syntax  : ∀ {a ℓ}
             → (A : Type a)
             → (⟅ A ⟆ → Type ℓ)
             → Type (a ℓ⊔ ℓ)
elim-syntax = Elim

syntax elim-syntax A (λ xs → Pxs) = xs ⦂⟅ A ⟆→ Pxs

record ElimProp {a ℓ} (A : Type a) (P : ⟅ A ⟆ → Type ℓ) : Type (a ℓ⊔ ℓ) where
  constructor elim-prop
  field
    ⟦_⟧-prop : ∀ {xs} → isProp (P xs)
    ⟦_⟧[] : P []
    ⟦_⟧_∷_⟨_⟩ : ∀ x xs → P xs → P (x ∷ xs)
  private z = ⟦_⟧[]; f = ⟦_⟧_∷_⟨_⟩
  ⟦_⟧⇑ = elim
          (isProp→isSet ⟦_⟧-prop)
          z f
          (λ x y xs pxs → toPathP (⟦_⟧-prop (transp (λ i → P (com x y xs i)) i0
            (f x (y ∷ xs) (f y xs pxs))) (f y (x ∷ xs) (f x xs pxs))))
  ⟦_⟧⇓ = ⟅ ⟦_⟧⇑ ⟆⇓

open ElimProp

infixr 0 elim-prop-syntax
elim-prop-syntax : ∀ {a ℓ} → (A : Type a) → (⟅ A ⟆ → Type ℓ) → Type (a ℓ⊔ ℓ)
elim-prop-syntax = ElimProp

syntax elim-prop-syntax A (λ xs → Pxs) = xs ⦂⟅ A ⟆→∥ Pxs ∥

record [⟅_⟆→_] {a b} (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  constructor rec
  field
    [_]-set  : isSet B
    [_]_∷_ : A → B → B
    [_][]    : B
  private f = [_]_∷_; z = [_][]
  field
    [_]-com : ∀ x y xs → f x (f y xs) ≡ f y (f x xs)
  [_]⇑ = elim [_]-set z (λ x _ → f x) (λ x y _ → [_]-com x y)
  [_]↓ = ⟅ [_]⇑ ⟆⇓
open [⟅_⟆→_]

infixr 5 _∪_
_∪_ : ⟅ A ⟆ → ⟅ A ⟆ → ⟅ A ⟆
_∪_ = λ xs ys → [ ys ∪′ ]↓ xs
  where
  _∪′ : ⟅ A ⟆ → [⟅ A ⟆→ ⟅ A ⟆ ]
  [ ys ∪′ ]-set = trunc
  [ ys ∪′ ] x ∷ xs = x ∷ xs
  [ ys ∪′ ][] = ys
  [ ys ∪′ ]-com = com

∪-assoc : (xs ys zs : ⟅ A ⟆) →
  (xs ∪ ys) ∪ zs ≡ xs ∪ (ys ∪ zs)
∪-assoc = λ xs ys zs → ⟦ ∪-assoc′ ys zs ⟧⇓ xs
  where
  ∪-assoc′ : ∀ ys zs →
    xs ⦂⟅ A ⟆→∥ (xs ∪ ys) ∪ zs ≡ xs ∪ (ys ∪ zs) ∥
  ⟦ ∪-assoc′ ys zs ⟧-prop = trunc _ _
  ⟦ ∪-assoc′ ys zs ⟧[] = refl
  ⟦ ∪-assoc′ ys zs ⟧ x ∷ xs ⟨ P ⟩ = cong (x ∷_) P

∪-cons  : ∀ (x : A) xs ys
        → (x ∷ xs) ∪ ys ≡ xs ∪ (x ∷ ys)
∪-cons = λ x xs ys → ⟦ ∪-cons′ x ys ⟧⇓ xs
  where
  ∪-cons′ : ∀ x ys →
    xs ⦂⟅ A ⟆→∥ (x ∷ xs) ∪ ys ≡ xs ∪ (x ∷ ys) ∥
  ⟦ ∪-cons′ x ys ⟧-prop = trunc _ _
  ⟦ ∪-cons′ x ys ⟧[] = refl
  ⟦ ∪-cons′ x ys ⟧ y ∷ xs ⟨ P ⟩ = cong (_∪ ys) (com x y xs) ; cong (y ∷_) P

∪-idʳ : (xs : ⟅ A ⟆) → xs ∪ [] ≡ xs
∪-idʳ = ⟦ ∪-idʳ′ ⟧⇓
  where
  ∪-idʳ′ : xs ⦂⟅ A ⟆→∥ xs ∪ [] ≡ xs ∥
  ⟦ ∪-idʳ′ ⟧-prop = trunc _ _
  ⟦ ∪-idʳ′ ⟧[] = refl
  ⟦ ∪-idʳ′ ⟧ x ∷ xs ⟨ P ⟩ = cong (x ∷_) P

∪-comm : (xs ys : ⟅ A ⟆) → xs ∪ ys ≡ ys ∪ xs
∪-comm {A = A} = λ xs ys → ⟦ ∪-comm′ ys ⟧⇓ xs
  where
  ∪-comm′ : (ys : ⟅ A ⟆) →
    xs ⦂⟅ A ⟆→∥ xs ∪ ys ≡ ys ∪ xs ∥
  ⟦ ∪-comm′ ys ⟧-prop = trunc _ _
  ⟦ ∪-comm′ ys ⟧[] = sym (∪-idʳ ys)
  ⟦ ∪-comm′ ys ⟧ x ∷ xs ⟨ P ⟩ =
    (x ∷ xs) ∪ ys ≡⟨ cong (x ∷_) P ⟩
    (x ∷ ys) ∪ xs ≡⟨ ∪-cons x ys xs ⟩
    ys ∪ x ∷ xs ∎

⟅⟆-commutative-monoid : ∀ {a} (A : Type a) → CommutativeMonoid _
Monoid.𝑆 (CommutativeMonoid.monoid (⟅⟆-commutative-monoid A)) = ⟅ A ⟆
Monoid._∙_ (CommutativeMonoid.monoid (⟅⟆-commutative-monoid A)) = _∪_
Monoid.ε (CommutativeMonoid.monoid (⟅⟆-commutative-monoid A)) = []
Monoid.assoc (CommutativeMonoid.monoid (⟅⟆-commutative-monoid A)) = ∪-assoc
Monoid.ε∙ (CommutativeMonoid.monoid (⟅⟆-commutative-monoid A)) _ = refl
Monoid.∙ε (CommutativeMonoid.monoid (⟅⟆-commutative-monoid A)) = ∪-idʳ
CommutativeMonoid.comm (⟅⟆-commutative-monoid A) = ∪-comm

module _ {ℓ} (mon : CommutativeMonoid ℓ) (sIsSet : isSet (CommutativeMonoid.𝑆 mon)) where
  open CommutativeMonoid mon
  ⟦_⟧ : (A → 𝑆) → ⟅ A ⟆ → 𝑆
  ⟦_⟧ = λ h → [ ⟦ h ⟧′ ]↓
    where
    ⟦_⟧′ : (A → 𝑆) → [⟅ A ⟆→ 𝑆 ]
    [ ⟦ h ⟧′ ] x ∷ xs = h x ∙ xs
    [ ⟦ h ⟧′ ][] = ε
    [ ⟦ h ⟧′ ]-com x y xs =
      h x ∙ (h y ∙ xs)
        ≡˘⟨ assoc _ _ _ ⟩
      (h x ∙ h y) ∙ xs
        ≡⟨ cong (_∙ xs) (comm _ _) ⟩
      (h y ∙ h x) ∙ xs
        ≡⟨ assoc _ _ _ ⟩
      h y ∙ (h x ∙ xs) ∎
    [ ⟦ h ⟧′ ]-set = sIsSet

record ⟦_≡_⟧ {a b} {A : Type a} {B : Type b}
            (h : ⟅ A ⟆ → B)
            (xf : [⟅ A ⟆→ B ])
            : Type (a ℓ⊔ b) where
  constructor elim-univ
  field
    ⟦_≡⟧_∷_ : ∀ x xs → h (x ∷ xs) ≡ [ xf ] x ∷ h xs
    ⟦_≡⟧[] : h [] ≡ [ xf ][]
  ⟦_≡⟧⇓ : ∀ xs → h xs ≡ [ xf ]↓ xs
  ⟦_≡⟧⇓ = ⟦ ≡⇓′ ⟧⇓
    where
    ≡⇓′ : xs ⦂⟅ A ⟆→∥ h xs ≡ [ xf ]↓ xs ∥
    ⟦ ≡⇓′ ⟧-prop = [ xf ]-set _ _
    ⟦ ≡⇓′ ⟧[] = ⟦_≡⟧[]
    ⟦ ≡⇓′ ⟧ x ∷ xs ⟨ P ⟩ = ⟦_≡⟧_∷_ x _ ; cong ([ xf ] x ∷_) P
open ⟦_≡_⟧

record ⟦_⊚_≡_⟧ {a b c} {A : Type a} {B : Type b} {C : Type c}
               (h : B → C)
               (xf : [⟅ A ⟆→ B ])
               (yf : [⟅ A ⟆→ C ])
               : Type (a ℓ⊔ b ℓ⊔ c)
    where
  constructor elim-fuse
  field
    ⟦_∘≡⟧_∷_ : ∀ x xs → h ([ xf ] x ∷ xs) ≡ [ yf ] x ∷ h xs
    ⟦_∘≡⟧[] : h [ xf ][] ≡ [ yf ][]
  ⟦_∘≡⟧⇓ : ∀ xs → h ([ xf ]↓ xs) ≡ [ yf ]↓ xs
  ⟦_∘≡⟧⇓ = ⟦ ≡⇓′ ⟧⇓
    where
    ≡⇓′ : xs ⦂⟅ A ⟆→∥ h ([ xf ]↓ xs) ≡ [ yf ]↓ xs ∥
    ⟦ ≡⇓′ ⟧-prop = [ yf ]-set _ _
    ⟦ ≡⇓′ ⟧[] = ⟦_∘≡⟧[]
    ⟦ ≡⇓′ ⟧ x ∷ xs ⟨ P ⟩ = ⟦_∘≡⟧_∷_ x _ ; cong ([ yf ] x ∷_) P
open ⟦_⊚_≡_⟧

map-alg : (A → B) → [⟅ A ⟆→ ⟅ B ⟆ ]
[ map-alg f ]-set = trunc
[ map-alg f ][] = []
[ map-alg f ] x ∷ xs = f x ∷ xs
[ map-alg f ]-com x y = com (f x) (f y)

map : (A → B) → ⟅ A ⟆ → ⟅ B ⟆
map f = [ map-alg f ]↓

[_]∘_ : [⟅ B ⟆→ C ] → (A → B) → [⟅ A ⟆→ C ]
[ [ g ]∘ f ]-set      = [ g ]-set
[ [ g ]∘ f ][]        = [ g ][]
[ [ g ]∘ f ] x ∷ xs   = [ g ] f x ∷ xs
[ [ g ]∘ f ]-com x y  = [ g ]-com (f x) (f y)

map-fuse  : ∀ (g : [⟅ B ⟆→ C ]) (f : A → B)
          → [ g ]↓ ∘ map f ≡ [ [ g ]∘ f ]↓
map-fuse g f = funExt ⟦ map-fuse′ g f ∘≡⟧⇓
  where
  map-fuse′  : (g : [⟅ B ⟆→ C ]) (f : A → B)
             → ⟦ [ g ]↓ ⊚ map-alg f ≡ [ g ]∘ f ⟧
  ⟦ map-fuse′ g f ∘≡⟧ x ∷ xs = refl
  ⟦ map-fuse′ g f ∘≡⟧[] = refl

bind : ⟅ A ⟆ → (A → ⟅ B ⟆) → ⟅ B ⟆
bind xs f = ⟦ ⟅⟆-commutative-monoid _ ⟧ trunc f xs


{-# OPTIONS --cubical #-}

open import Agda.Builtin.Cubical.Path

data D : Set where
  c : (@0 x y : D) → x ≡ y


-- Andreas, 2012-04-18 make sure with functions of irrelevant functions
-- are also irrelevant
module IrrelevantWith where

import Common.Level
open import Common.Irrelevance

.unsq : ∀ {a}{A : Set a} → Squash A → A
unsq sq with Set
... | _ = unsquash sq


{-# OPTIONS --copatterns #-}
module CoinductiveUnitRecord where

import Common.Level
open import Common.Equality

record Unit : Set where
  coinductive
  constructor delay
  field force : Unit
open Unit

good : Unit
force good = good

bad : Unit
bad = delay bad
-- should not termination check ...

bad' : Unit
bad' = delay bad'

-- ... because this loops:
-- loop : bad ≡ bad'
-- loop = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Propertiers of any for containers
------------------------------------------------------------------------

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

module Data.Container.Relation.Unary.Any.Properties where

open import Level
open import Algebra
open import Data.Product as Prod using (∃; _×_; ∃₂; _,_; proj₂)
open import Data.Product.Function.NonDependent.Propositional using (_×-cong_)
import Data.Product.Function.Dependent.Propositional as Σ
open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_])
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (equivalence)
open import Function.HalfAdjointEquivalence using (_≃_; ↔→≃)
open import Function.Inverse as Inv using (_↔_; inverse; module Inverse)
open import Function.Related as Related using (Related; SK-sym)
open import Function.Related.TypeIsomorphisms
open import Relation.Unary using (Pred ; _∪_ ; _∩_)
open import Relation.Binary using (REL)
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≗_; refl)

open Related.EquationalReasoning hiding (_≡⟨_⟩_)
private
  module ×⊎ {k ℓ} = CommutativeSemiring (×-⊎-commutativeSemiring k ℓ)

open import Data.Container.Core
import Data.Container.Combinator as C
open import Data.Container.Combinator.Properties
open import Data.Container.Related
open import Data.Container.Relation.Unary.Any as Any using (◇; any)
open import Data.Container.Membership

module _ {s p} (C : Container s p) {x} {X : Set x} {ℓ} {P : Pred X ℓ} where

-- ◇ can be unwrapped to reveal the Σ type

  ↔Σ : ∀ {xs : ⟦ C ⟧ X} → ◇ C P xs ↔ ∃ λ p → P (proj₂ xs p)
  ↔Σ {xs} = inverse ◇.proof any (λ _ → P.refl) (λ _ → P.refl)

-- ◇ can be expressed using _∈_.

  ↔∈ : ∀ {xs : ⟦ C ⟧ X} → ◇ C P xs ↔ (∃ λ x → x ∈ xs × P x)
  ↔∈ {xs} = inverse to from (λ _ → P.refl) (to∘from) where

    to : ◇ C P xs → ∃ λ x → x ∈ xs × P x
    to (any (p , Px)) = (proj₂ xs p , (any (p , P.refl)) , Px)

    from : (∃ λ x → x ∈ xs × P x) → ◇ C P xs
    from (.(proj₂ xs p) , (any (p , refl)) , Px) = any (p , Px)

    to∘from : to ∘ from ≗ id
    to∘from (.(proj₂ xs p) , any (p , refl) , Px) = P.refl

module _ {s p} {C : Container s p} {x} {X : Set x}
         {ℓ₁ ℓ₂} {P₁ : Pred X ℓ₁} {P₂ : Pred X ℓ₂} where
-- ◇ is a congruence for bag and set equality and related preorders.

  cong : ∀ {k} {xs₁ xs₂ : ⟦ C ⟧ X} →
         (∀ x → Related k (P₁ x) (P₂ x)) → xs₁ ∼[ k ] xs₂ →
         Related k (◇ C P₁ xs₁) (◇ C P₂ xs₂)
  cong {k} {xs₁} {xs₂} P₁↔P₂ xs₁≈xs₂ =
    ◇ C P₁ xs₁               ↔⟨ ↔∈ C ⟩
    (∃ λ x → x ∈ xs₁ × P₁ x) ∼⟨ Σ.cong Inv.id (xs₁≈xs₂ ×-cong P₁↔P₂ _) ⟩
    (∃ λ x → x ∈ xs₂ × P₂ x) ↔⟨ SK-sym (↔∈ C) ⟩
    ◇ C P₂ xs₂               ∎

-- Nested occurrences of ◇ can sometimes be swapped.

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂}
         {x y} {X : Set x} {Y : Set y} {r} {P : REL X Y r} where

  swap : {xs : ⟦ C₁ ⟧ X} {ys : ⟦ C₂ ⟧ Y} →
         let ◈ : ∀ {s p} {C : Container s p} {x} {X : Set x} {ℓ} → ⟦ C ⟧ X → Pred X ℓ → Set (p ⊔ ℓ)
             ◈ = λ {_} {_} → flip (◇ _) in
         ◈ xs (◈ ys ∘ P) ↔ ◈ ys (◈ xs ∘ flip P)
  swap {xs} {ys} =
    ◇ _ (λ x → ◇ _ (P x) ys) xs                ↔⟨ ↔∈ C₁ ⟩
    (∃ λ x → x ∈ xs × ◇ _ (P x) ys)            ↔⟨ Σ.cong Inv.id $ Σ.cong Inv.id $ ↔∈ C₂ ⟩
    (∃ λ x → x ∈ xs × ∃ λ y → y ∈ ys × P x y)  ↔⟨ Σ.cong Inv.id (λ {x} → ∃∃↔∃∃ (λ _ y → y ∈ ys × P x y)) ⟩
    (∃₂ λ x y → x ∈ xs × y ∈ ys × P x y)       ↔⟨ ∃∃↔∃∃ (λ x y → x ∈ xs × y ∈ ys × P x y) ⟩
    (∃₂ λ y x → x ∈ xs × y ∈ ys × P x y)       ↔⟨ Σ.cong Inv.id (λ {y} → Σ.cong Inv.id (λ {x} →
      (x ∈ xs × y ∈ ys × P x y)                     ↔⟨ SK-sym Σ-assoc ⟩
      ((x ∈ xs × y ∈ ys) × P x y)                   ↔⟨ Σ.cong (×-comm _ _) Inv.id ⟩
      ((y ∈ ys × x ∈ xs) × P x y)                   ↔⟨ Σ-assoc ⟩
      (y ∈ ys × x ∈ xs × P x y)                     ∎)) ⟩
    (∃₂ λ y x → y ∈ ys × x ∈ xs × P x y)       ↔⟨ Σ.cong Inv.id (λ {y} → ∃∃↔∃∃ {B = y ∈ ys} (λ x _ → x ∈ xs × P x y)) ⟩
    (∃ λ y → y ∈ ys × ∃ λ x → x ∈ xs × P x y)  ↔⟨ Σ.cong Inv.id (Σ.cong Inv.id (SK-sym (↔∈ C₁))) ⟩
    (∃ λ y → y ∈ ys × ◇ _ (flip P y) xs)       ↔⟨ SK-sym (↔∈ C₂) ⟩
    ◇ _ (λ y → ◇ _ (flip P y) xs) ys           ∎

-- Nested occurrences of ◇ can sometimes be flattened.

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂}
         {x} {X : Set x} {ℓ} (P : Pred X ℓ) where

  flatten : ∀ (xss : ⟦ C₁ ⟧ (⟦ C₂ ⟧ X)) →
            ◇ C₁ (◇ C₂ P) xss ↔
            ◇ (C₁ C.∘ C₂) P (Inverse.from (Composition.correct C₁ C₂) ⟨$⟩ xss)
  flatten xss = inverse t f (λ _ → P.refl) (λ _ → P.refl) where

    ◇₁ = ◇ C₁; ◇₂ = ◇ C₂; ◇₁₂ = ◇ (C₁ C.∘ C₂)
    open Inverse

    t : ◇₁ (◇₂ P) xss → ◇₁₂ P (from (Composition.correct C₁ C₂) ⟨$⟩ xss)
    t (any (p₁ , (any (p₂ , p)))) = any (any (p₁ , p₂) , p)

    f : ◇₁₂ P (from (Composition.correct C₁ C₂) ⟨$⟩ xss) → ◇₁ (◇₂ P) xss
    f (any (any (p₁ , p₂) , p)) = any (p₁ , any (p₂ , p))

-- Sums commute with ◇ (for a fixed instance of a given container).

module _ {s p} {C : Container s p} {x} {X : Set x}
         {ℓ ℓ′} {P : Pred X ℓ} {Q : Pred X ℓ′} where

  ◇⊎↔⊎◇ : ∀ {xs : ⟦ C ⟧ X} → ◇ C (P ∪ Q) xs ↔ (◇ C P xs ⊎ ◇ C Q xs)
  ◇⊎↔⊎◇ {xs} = inverse to from from∘to to∘from
    where
    to : ◇ C (λ x → P x ⊎ Q x) xs → ◇ C P xs ⊎ ◇ C Q xs
    to (any (pos , inj₁ p)) = inj₁ (any (pos , p))
    to (any (pos , inj₂ q)) = inj₂ (any (pos , q))

    from : ◇ C P xs ⊎ ◇ C Q xs → ◇ C (λ x → P x ⊎ Q x) xs
    from = [ Any.map₂ inj₁ , Any.map₂ inj₂ ]

    from∘to : from ∘ to ≗ id
    from∘to (any (pos , inj₁ p)) = P.refl
    from∘to (any (pos , inj₂ q)) = P.refl

    to∘from : to ∘ from ≗ id
    to∘from = [ (λ _ → P.refl) , (λ _ → P.refl) ]

-- Products "commute" with ◇.

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂}
         {x y} {X : Set x} {Y : Set y} {ℓ ℓ′} {P : Pred X ℓ} {Q : Pred Y ℓ′} where

  ×◇↔◇◇× : ∀ {xs : ⟦ C₁ ⟧ X} {ys : ⟦ C₂ ⟧ Y} →
           ◇ C₁ (λ x → ◇ C₂ (λ y → P x × Q y) ys) xs ↔ (◇ C₁ P xs × ◇ C₂ Q ys)
  ×◇↔◇◇× {xs} {ys} = inverse to from (λ _ → P.refl) (λ _ → P.refl)
    where
    ◇₁ = ◇ C₁; ◇₂ = ◇ C₂

    to : ◇₁ (λ x → ◇₂ (λ y → P x × Q y) ys) xs → ◇₁ P xs × ◇₂ Q ys
    to (any (p₁ , any (p₂ , p , q))) = (any (p₁ , p) , any (p₂ , q))

    from : ◇₁ P xs × ◇₂ Q ys → ◇₁ (λ x → ◇₂ (λ y → P x × Q y) ys) xs
    from (any (p₁ , p) , any (p₂ , q)) = any (p₁ , any (p₂ , p , q))

-- map can be absorbed by the predicate.

module _ {s p} (C : Container s p) {x y} {X : Set x} {Y : Set y}
         {ℓ} (P : Pred Y ℓ) where

  map↔∘ : ∀ {xs : ⟦ C ⟧ X} (f : X → Y) → ◇ C P (map f xs) ↔ ◇ C (P ∘′ f) xs
  map↔∘ {xs} f =
   ◇ C P (map f xs)          ↔⟨ ↔Σ C ⟩
   ∃ (P ∘′ proj₂ (map f xs)) ↔⟨⟩
   ∃ (P ∘′ f ∘′ proj₂ xs)    ↔⟨ SK-sym (↔Σ C) ⟩
   ◇ C (P ∘′ f) xs           ∎

-- Membership in a mapped container can be expressed without reference
-- to map.

module _ {s p} (C : Container s p) {x y} {X : Set x} {Y : Set y}
         {ℓ} (P : Pred Y ℓ) where

  ∈map↔∈×≡ : ∀ {f : X → Y} {xs : ⟦ C ⟧ X} {y} →
             y ∈ map f xs ↔ (∃ λ x → x ∈ xs × y ≡ f x)
  ∈map↔∈×≡ {f = f} {xs} {y} =
    y ∈ map f xs               ↔⟨ map↔∘ C (y ≡_) f ⟩
    ◇ C (λ x → y ≡ f x) xs     ↔⟨ ↔∈ C ⟩
    ∃ (λ x → x ∈ xs × y ≡ f x) ∎

-- map is a congruence for bag and set equality and related preorders.

module _ {s p} (C : Container s p) {x y} {X : Set x} {Y : Set y}
         {ℓ} (P : Pred Y ℓ) where

  map-cong : ∀ {k} {f₁ f₂ : X → Y} {xs₁ xs₂ : ⟦ C ⟧ X} →
             f₁ ≗ f₂ → xs₁ ∼[ k ] xs₂ →
             map f₁ xs₁ ∼[ k ] map f₂ xs₂
  map-cong {f₁ = f₁} {f₂} {xs₁} {xs₂} f₁≗f₂ xs₁≈xs₂ {x} =
    x ∈ map f₁ xs₁           ↔⟨ map↔∘ C (_≡_ x) f₁ ⟩
    ◇ C (λ y → x ≡ f₁ y) xs₁ ∼⟨ cong (Related.↔⇒ ∘ helper) xs₁≈xs₂ ⟩
    ◇ C (λ y → x ≡ f₂ y) xs₂ ↔⟨ SK-sym (map↔∘ C (_≡_ x) f₂) ⟩
    x ∈ map f₂ xs₂           ∎
    where
    helper : ∀ y → (x ≡ f₁ y) ↔ (x ≡ f₂ y)
    helper y rewrite f₁≗f₂ y = Inv.id

-- Uses of linear morphisms can be removed.

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂}
         {x} {X : Set x} {ℓ} (P : Pred X ℓ) where

  remove-linear : ∀ {xs : ⟦ C₁ ⟧ X} (m : C₁ ⊸ C₂) → ◇ C₂ P (⟪ m ⟫⊸ xs) ↔ ◇ C₁ P xs
  remove-linear {xs} m = Inv.inverse t f f∘t t∘f
    where
    open _≃_
    open P.≡-Reasoning renaming (_∎ to _∎′)

    position⊸m : ∀ {s} → Position C₂ (shape⊸ m s) ≃ Position C₁ s
    position⊸m = ↔→≃ (position⊸ m)

    ◇₁ = ◇ C₁; ◇₂ = ◇ C₂

    t : ◇₂ P (⟪ m ⟫⊸ xs) → ◇₁ P xs
    t = Any.map₁ (_⊸_.morphism m)

    f : ◇₁ P xs → ◇₂ P (⟪ m ⟫⊸ xs)
    f (any (x , p)) =
      any $ from position⊸m x
          , P.subst (P ∘′ proj₂ xs) (P.sym (right-inverse-of position⊸m _)) p

    f∘t : f ∘ t ≗ id
    f∘t (any (p₂ , p)) = P.cong any $ Inverse.to Σ-≡,≡↔≡ ⟨$⟩
      ( left-inverse-of position⊸m p₂
      , (P.subst (P ∘ proj₂ xs ∘ to position⊸m)
           (left-inverse-of position⊸m p₂)
           (P.subst (P ∘ proj₂ xs)
              (P.sym (right-inverse-of position⊸m
                        (to position⊸m p₂)))
              p)                                                ≡⟨ P.subst-∘ (left-inverse-of position⊸m _) ⟩

         P.subst (P ∘ proj₂ xs)
           (P.cong (to position⊸m)
              (left-inverse-of position⊸m p₂))
           (P.subst (P ∘ proj₂ xs)
              (P.sym (right-inverse-of position⊸m
                        (to position⊸m p₂)))
              p)                                                ≡⟨ P.cong (λ eq → P.subst (P ∘ proj₂ xs) eq
                                                                                (P.subst (P ∘ proj₂ xs)
                                                                                (P.sym (right-inverse-of position⊸m _)) _))
                                                                     (_≃_.left-right position⊸m _) ⟩
         P.subst (P ∘ proj₂ xs)
           (right-inverse-of position⊸m
              (to position⊸m p₂))
           (P.subst (P ∘ proj₂ xs)
              (P.sym (right-inverse-of position⊸m
                        (to position⊸m p₂)))
              p)                                                ≡⟨ P.subst-subst (P.sym (right-inverse-of position⊸m _)) ⟩

         P.subst (P ∘ proj₂ xs)
           (P.trans
              (P.sym (right-inverse-of position⊸m
                        (to position⊸m p₂)))
              (right-inverse-of position⊸m
                 (to position⊸m p₂)))
           p                                                    ≡⟨ P.cong (λ eq → P.subst (P ∘ proj₂ xs) eq p)
                                                                     (P.trans-symˡ (right-inverse-of position⊸m _)) ⟩

         P.subst (P ∘ proj₂ xs) P.refl p                        ≡⟨⟩

        p                                                       ∎′)
      )

    t∘f : t ∘ f ≗ id
    t∘f (any (p₁ , p)) = P.cong any $ Inverse.to Σ-≡,≡↔≡ ⟨$⟩
      ( right-inverse-of position⊸m p₁
      , (P.subst (P ∘ proj₂ xs)
           (right-inverse-of position⊸m p₁)
           (P.subst (P ∘ proj₂ xs)
              (P.sym (right-inverse-of position⊸m p₁))
              p)                                                ≡⟨ P.subst-subst (P.sym (right-inverse-of position⊸m _)) ⟩

         P.subst (P ∘ proj₂ xs)
           (P.trans
              (P.sym (right-inverse-of position⊸m p₁))
              (right-inverse-of position⊸m p₁))
           p                                                    ≡⟨ P.cong (λ eq → P.subst (P ∘ proj₂ xs) eq p)
                                                                     (P.trans-symˡ (right-inverse-of position⊸m _)) ⟩
         P.subst (P ∘ proj₂ xs) P.refl p                        ≡⟨⟩

        p                                                       ∎′)
      )

-- Linear endomorphisms are identity functions if bag equality is used.

module _ {s p} {C : Container s p} {x} {X : Set x} where

  linear-identity : ∀ {xs : ⟦ C ⟧ X} (m : C ⊸ C) → ⟪ m ⟫⊸ xs ∼[ bag ] xs
  linear-identity {xs} m {x} =
    x ∈ ⟪ m ⟫⊸ xs  ↔⟨ remove-linear (_≡_ x) m ⟩
    x ∈        xs  ∎

-- If join can be expressed using a linear morphism (in a certain
-- way), then it can be absorbed by the predicate.

module _ {s₁ s₂ s₃ p₁ p₂ p₃}
         {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂} {C₃ : Container s₃ p₃}
         {x} {X : Set x} {ℓ} (P : Pred X ℓ) where

  join↔◇ : (join′ : (C₁ C.∘ C₂) ⊸ C₃) (xss : ⟦ C₁ ⟧ (⟦ C₂ ⟧ X)) →
           let join : ∀ {X} → ⟦ C₁ ⟧ (⟦ C₂ ⟧ X) → ⟦ C₃ ⟧ X
               join = λ {_} → ⟪ join′ ⟫⊸ ∘
                      _⟨$⟩_ (Inverse.from (Composition.correct C₁ C₂)) in
           ◇ C₃ P (join xss) ↔ ◇ C₁ (◇ C₂ P) xss
  join↔◇ join xss =
    ◇ C₃ P (⟪ join ⟫⊸ xss′) ↔⟨ remove-linear P join ⟩
    ◇ (C₁ C.∘ C₂) P xss′    ↔⟨ SK-sym $ flatten P xss ⟩
    ◇ C₁ (◇ C₂ P) xss       ∎
    where xss′ = Inverse.from (Composition.correct C₁ C₂) ⟨$⟩ xss


module Builtin where

open import Agda.Primitive

data Bool : Set where
  false : Bool
  true  : Bool

not : Bool -> Bool
not true = false
not false = true

_||_ : Bool -> Bool -> Bool
true  || _ = true
false || x = x

_&&_ : Bool -> Bool -> Bool
true  && x = x
false && _ = false

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

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

{-# BUILTIN NATURAL Nat  #-}

zero' : Nat
zero' = 0

one : Nat
one = 1

data Int : Set where
  pos : Nat → Int
  negsuc : Nat → Int

postulate
  String : Set
  Float  : Set
  Char   : Set

{-# BUILTIN INTEGER Int    #-}
{-# BUILTIN INTEGERPOS pos #-}
{-# BUILTIN INTEGERNEGSUC negsuc #-}
{-# BUILTIN STRING  String #-}
{-# BUILTIN FLOAT   Float  #-}
{-# BUILTIN CHAR    Char   #-}

data Maybe (A : Set) : Set where
  just : A → Maybe A
  nothing : Maybe A

{-# BUILTIN MAYBE Maybe #-}

record Sigma {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    fst : A
    snd : B fst

open Sigma public

infixr 4 _,_

{-# BUILTIN SIGMA Sigma #-}

infixr 10 _::_
data List (A : Set) : Set where
  nil  : List A
  _::_ : A -> List A -> List A

{-# BUILTIN LIST List   #-}

postulate Word64 : Set
{-# BUILTIN WORD64 Word64 #-}

primitive

  -- Integer functions
  primShowInteger     : Int -> String

  -- Floating point function
  primFloatInequality        : Float → Float → Bool
  primFloatEquality          : Float → Float → Bool
  primFloatLess              : Float → Float → Bool
  primFloatIsInfinite        : Float → Bool
  primFloatIsNaN             : Float → Bool
  primFloatIsNegativeZero    : Float → Bool
  primFloatToWord64          : Float → Word64
  primNatToFloat             : Nat → Float
  primIntToFloat             : Int → Float
  primFloatRound             : Float → Maybe Int
  primFloatFloor             : Float → Maybe Int
  primFloatCeiling           : Float → Maybe Int
  primFloatToRatio           : Float → (Sigma Int λ _ → Int)
  primRatioToFloat           : Int → Int → Float
  primFloatDecode            : Float → Maybe (Sigma Int λ _ → Int)
  primFloatEncode            : Int → Int → Maybe Float
  primShowFloat              : Float → String
  primFloatPlus              : Float → Float → Float
  primFloatMinus             : Float → Float → Float
  primFloatTimes             : Float → Float → Float
  primFloatDiv               : Float → Float → Float
  primFloatNegate            : Float → Float
  primFloatSqrt              : Float → Float
  primFloatExp               : Float → Float
  primFloatLog               : Float → Float
  primFloatSin               : Float → Float
  primFloatCos               : Float → Float
  primFloatTan               : Float → Float
  primFloatASin              : Float → Float
  primFloatACos              : Float → Float
  primFloatATan              : Float → Float
  primFloatATan2             : Float → Float → Float
  primFloatSinh              : Float → Float
  primFloatCosh              : Float → Float
  primFloatTanh              : Float → Float
  primFloatASinh             : Float → Float
  primFloatACosh             : Float → Float
  primFloatATanh             : Float → Float
  primFloatPow               : Float → Float → Float

   -- Character functions
  primCharEquality   : Char -> Char -> Bool
  primIsLower        : Char -> Bool
  primIsDigit        : Char -> Bool
  primIsAlpha        : Char -> Bool
  primIsSpace        : Char -> Bool
  primIsAscii        : Char -> Bool
  primIsLatin1       : Char -> Bool
  primIsPrint        : Char -> Bool
  primIsHexDigit     : Char -> Bool
  primToUpper        : Char -> Char
  primToLower        : Char -> Char
  primCharToNat      : Char -> Nat
  primNatToChar      : Nat  -> Char -- partial
  primShowChar       : Char -> String

    -- String functions
  primStringToList   : String -> List Char
  primStringFromList : List Char -> String
  primStringAppend   : String -> String -> String
  primStringEquality : String -> String -> Bool
  primShowString     : String -> String

isLower : Char -> Bool
isLower = primIsLower

isAlpha : Char -> Bool
isAlpha = primIsAlpha

isUpper : Char -> Bool
isUpper c = isAlpha c && not (isLower c)

infixl 14 _/_

nat0 = primCharToNat '\0'
int0 = pos nat0

_/_  = primFloatDiv

pi : Float
pi = 3.141592653589793

sin : Float -> Float
sin = primFloatSin

cos : Float -> Float
cos = primFloatCos

tan : Float -> Float
tan = primFloatTan

reverse : {A : Set} -> List A -> List A
reverse xs = rev xs nil
  where
    rev : {A : Set} -> List A -> List A -> List A
    rev nil       ys = ys
    rev (x :: xs) ys = rev xs (x :: ys)

infixr 20 _∘_
_∘_ : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C
f ∘ g = \x -> f (g x)

map : {A B : Set} -> (A -> B) -> List A -> List B
map f  nil      = nil
map f (x :: xs) = f x :: map f xs

stringAsList : (List Char -> List Char) -> String -> String
stringAsList f = primStringFromList ∘ f ∘ primStringToList

revStr : String -> String
revStr = stringAsList reverse

mapStr : (Char -> Char) -> String -> String
mapStr f = stringAsList (map f)

-- Testing unicode literals
uString = "åäö⊢ξ∀"
uChar   = '∀'

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

thm-show-pos : primShowInteger (pos 42) ≡ "42"
thm-show-pos = refl

thm-show-neg : primShowInteger (negsuc 41) ≡ "-42"
thm-show-neg = refl

thm-floor : primFloatFloor 4.2 ≡ just (pos 4)
thm-floor = refl

thm-ceiling : primFloatCeiling -5.1 ≡ just (negsuc 4)
thm-ceiling = refl


open import Agda.Builtin.Nat
open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit

macro
  five : Term → TC ⊤
  five hole = unify hole (lit (nat 5))

-- Here you get hole = _X (λ {n} → y {_n})
-- and fail to solve _n.
yellow : ({n : Nat} → Set) → Nat
yellow y = five

-- Here you get hole = _X ⦃ n ⦄ (λ ⦃ n' ⦄ → y ⦃ _n ⦄)
-- and fail to solve _n due to the multiple candidates n and n'.
more-yellow : ⦃ n : Nat ⦄ → (⦃ n : Nat ⦄ → Set) → Nat
more-yellow y = five


module regular-concat where

open import Level renaming ( suc to Suc ; zero to Zero )
open import Data.List
open import Data.Nat hiding ( _≟_ )
open import Data.Fin hiding ( _+_ )
open import Data.Empty
open import Data.Unit
open import Data.Product
-- open import Data.Maybe
open import  Relation.Nullary
open import  Relation.Binary.PropositionalEquality hiding ( [_] )
open import logic
open import nat
open import automaton
open import regular-language

open import nfa
open import sbconst2
open import finiteSet
open import finiteSetUtil

open Automaton
open FiniteSet

open RegularLanguage

Concat-NFA :  {Σ : Set} → (A B : RegularLanguage Σ ) → NAutomaton (states A ∨ states B) Σ
Concat-NFA {Σ} A B = record { Nδ = δnfa ; Nend = nend }
   module Concat-NFA where
       δnfa : states A ∨ states B → Σ → states A ∨ states B → Bool
       δnfa (case1 q) i (case1 q₁) = equal? (afin A) (δ (automaton A) q i) q₁
       δnfa (case1 qa) i (case2 qb) = (aend (automaton A) qa ) /\
           (equal? (afin B) qb (δ (automaton B) (astart B) i) )
       δnfa (case2 q) i (case2 q₁) = equal? (afin B) (δ (automaton B) q i) q₁
       δnfa _ i _ = false
       nend : states A ∨ states B → Bool
       nend (case2 q) = aend (automaton B) q
       nend (case1 q) = aend (automaton A) q /\ aend (automaton B) (astart B) -- empty B case

Concat-NFA-start :  {Σ : Set} → (A B : RegularLanguage Σ ) → states A ∨ states B → Bool
Concat-NFA-start A B q = equal? (fin-∨ (afin A) (afin B)) (case1 (astart A)) q

CNFA-exist : {Σ : Set} → (A B : RegularLanguage Σ ) → (states A ∨ states B → Bool) → Bool
CNFA-exist A B qs = exists (fin-∨ (afin A) (afin B)) qs

M-Concat : {Σ : Set} → (A B : RegularLanguage Σ ) → RegularLanguage Σ
M-Concat {Σ} A B = record {
       states = states A ∨ states B → Bool
     ; astart = Concat-NFA-start A B
     ; afin = finf
     ; automaton = subset-construction (CNFA-exist A B) (Concat-NFA A B)
   } where
       fin : FiniteSet (states A ∨ states B )
       fin = fin-∨ (afin A) (afin B)
       finf : FiniteSet (states A ∨ states B → Bool )
       finf = fin→ fin

-- closed-in-concat' :  {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Concat (contain A) (contain B)) x ( M-Concat A B )
-- closed-in-concat' {Σ} A B x = ≡-Bool-func closed-in-concat→ closed-in-concat← where
--     closed-in-concat→ : Concat (contain A) (contain B) x ≡ true → contain (M-Concat A B) x ≡ true
--     closed-in-concat→ = {!!}
--     closed-in-concat← : contain (M-Concat A B) x ≡ true → Concat (contain A) (contain B) x ≡ true
--     closed-in-concat← = {!!}

record Split {Σ : Set} (A : List Σ → Bool ) ( B : List Σ → Bool ) (x :  List Σ ) : Set where
    field
        sp0 : List Σ
        sp1 : List Σ
        sp-concat : sp0 ++ sp1 ≡ x
        prop0 : A sp0 ≡ true
        prop1 : B sp1 ≡ true

open Split

list-empty++ : {Σ : Set} → (x y : List Σ) → x ++ y ≡ [] → (x ≡ [] ) ∧ (y ≡ [] )
list-empty++ [] [] refl = record { proj1 = refl ; proj2 = refl }
list-empty++ [] (x ∷ y) ()
list-empty++ (x ∷ x₁) y ()

open _∧_

open import Relation.Binary.PropositionalEquality hiding ( [_] )

c-split-lemma : {Σ : Set} → (A B : List Σ → Bool ) → (h : Σ) → ( t : List Σ ) → split A B (h ∷ t ) ≡ true
   → ( ¬ (A [] ≡ true )) ∨ ( ¬ (B ( h ∷ t ) ≡ true) )
   → split (λ t1 → A (h ∷ t1)) B t ≡ true
c-split-lemma {Σ} A B h t eq p = sym ( begin
      true
  ≡⟨  sym eq  ⟩
      split A B (h ∷ t )
  ≡⟨⟩
      A [] /\ B (h ∷ t) \/ split (λ t1 → A (h ∷ t1)) B t
  ≡⟨  cong ( λ k → k \/ split (λ t1 → A (h ∷ t1)) B t ) (lemma-p p ) ⟩
      false \/ split (λ t1 → A (h ∷ t1)) B t
  ≡⟨ bool-or-1 refl ⟩
      split (λ t1 → A (h ∷ t1)) B t
  ∎ ) where
     open ≡-Reasoning
     lemma-p : ( ¬ (A [] ≡ true )) ∨ ( ¬ (B ( h ∷ t ) ≡ true) ) → A [] /\ B (h ∷ t) ≡ false
     lemma-p (case1 ¬A ) = bool-and-1 ( ¬-bool-t ¬A )
     lemma-p (case2 ¬B ) = bool-and-2 ( ¬-bool-t ¬B )

split→AB :  {Σ : Set} → (A B : List Σ → Bool ) → ( x : List Σ ) → split A B x ≡ true → Split A B x
split→AB {Σ} A B [] eq with bool-≡-? (A []) true | bool-≡-? (B []) true
split→AB {Σ} A B [] eq | yes eqa | yes eqb =
    record { sp0 = [] ; sp1 = [] ; sp-concat = refl ; prop0 = eqa ; prop1 = eqb }
split→AB {Σ} A B [] eq | yes p | no ¬p = ⊥-elim (lemma-∧-1 eq (¬-bool-t ¬p ))
split→AB {Σ} A B [] eq | no ¬p | t = ⊥-elim (lemma-∧-0 eq (¬-bool-t ¬p ))
split→AB {Σ} A B (h ∷ t ) eq with bool-≡-? (A []) true | bool-≡-? (B (h ∷ t )) true
... | yes px | yes py = record { sp0 = [] ; sp1 = h ∷ t ; sp-concat = refl ; prop0 = px ; prop1 = py }
... | no px | _ with split→AB (λ t1 → A ( h ∷ t1 )) B t (c-split-lemma A B h t eq (case1 px) )
... | S = record { sp0 = h ∷ sp0 S  ; sp1 = sp1 S ; sp-concat = cong ( λ k → h ∷ k) (sp-concat S) ; prop0 = prop0 S ; prop1 = prop1 S }
split→AB {Σ} A B (h ∷ t ) eq  | _ | no px with split→AB (λ t1 → A ( h ∷ t1 )) B t (c-split-lemma A B h t eq (case2 px) )
... | S = record { sp0 = h ∷ sp0 S  ; sp1 = sp1 S ; sp-concat = cong ( λ k → h ∷ k) (sp-concat S) ; prop0 = prop0 S ; prop1 = prop1 S }

AB→split :  {Σ : Set} → (A B : List Σ → Bool ) → ( x y : List Σ ) → A x ≡ true → B y ≡ true → split A B (x ++ y ) ≡ true
AB→split {Σ} A B [] [] eqa eqb = begin
       split A B []
     ≡⟨⟩
       A [] /\ B []
     ≡⟨ cong₂ (λ j k → j /\ k ) eqa eqb ⟩
      true
     ∎  where open ≡-Reasoning
AB→split {Σ} A B [] (h ∷ y ) eqa eqb = begin
      split A B (h ∷ y )
     ≡⟨⟩
      A [] /\ B (h ∷ y) \/ split (λ t1 → A (h ∷ t1)) B y
     ≡⟨ cong₂ (λ j k → j /\ k \/ split (λ t1 → A (h ∷ t1)) B y ) eqa eqb ⟩
      true /\ true \/ split (λ t1 → A (h ∷ t1)) B y
     ≡⟨⟩
      true \/ split (λ t1 → A (h ∷ t1)) B y
     ≡⟨⟩
      true
     ∎  where open ≡-Reasoning
AB→split {Σ} A B (h ∷ t) y eqa eqb = begin
       split A B ((h ∷ t) ++ y)
     ≡⟨⟩
       A [] /\ B (h ∷ t ++ y) \/ split (λ t1 → A (h ∷ t1)) B (t ++ y)
     ≡⟨ cong ( λ k →  A [] /\ B (h ∷ t ++ y) \/ k ) (AB→split {Σ} (λ t1 → A (h ∷ t1)) B t y eqa eqb ) ⟩
       A [] /\ B (h ∷ t ++ y) \/ true
     ≡⟨ bool-or-3 ⟩
      true
     ∎  where open ≡-Reasoning

open NAutomaton
open import Data.List.Properties

closed-in-concat :  {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Concat (contain A) (contain B)) x ( M-Concat A B )
closed-in-concat {Σ} A B x = ≡-Bool-func closed-in-concat→ closed-in-concat← where
    finab = (fin-∨ (afin A) (afin B))
    NFA = (Concat-NFA A B)
    abmove : (q : states A ∨ states B) → (h : Σ ) → states A ∨ states B
    abmove (case1 q) h = case1 (δ (automaton A) q h)
    abmove (case2 q) h = case2 (δ (automaton B) q h)
    lemma-nmove-ab : (q : states A ∨ states B) → (h : Σ ) → Nδ NFA q h (abmove q h) ≡ true
    lemma-nmove-ab (case1 q) h = equal?-refl (afin A)
    lemma-nmove-ab (case2 q) h = equal?-refl (afin B)
    nmove : (q : states A ∨ states B) (nq : states A ∨ states B → Bool ) → (nq q ≡ true) → ( h : Σ ) →
       exists finab (λ qn → nq qn /\ Nδ NFA qn h (abmove q h)) ≡ true
    nmove (case1 q) nq nqt h = found finab (case1 q) ( bool-and-tt nqt (lemma-nmove-ab (case1 q)  h) )
    nmove (case2 q) nq nqt h = found finab (case2 q) ( bool-and-tt nqt (lemma-nmove-ab (case2 q) h) )
    acceptB : (z : List Σ) → (q : states B) → (nq : states A ∨ states B → Bool ) → (nq (case2 q) ≡ true) → ( accept (automaton B) q z ≡ true )
        → Naccept NFA (CNFA-exist A B) nq z  ≡ true
    acceptB [] q nq nqt fb = lemma8 where
        lemma8 : exists finab ( λ q → nq q /\ Nend NFA q ) ≡ true
        lemma8 = found finab (case2 q) ( bool-and-tt nqt fb )
    acceptB (h ∷ t ) q nq nq=q fb = acceptB t (δ (automaton B) q h) (Nmoves NFA (CNFA-exist A B) nq h) (nmove (case2 q) nq nq=q h) fb

    acceptA : (y z : List Σ) → (q : states A) → (nq : states A ∨ states B → Bool ) → (nq (case1 q) ≡ true)
        → ( accept (automaton A) q y ≡ true ) → ( accept (automaton B) (astart B) z ≡ true )
        → Naccept NFA (CNFA-exist A B) nq (y ++ z)  ≡ true
    acceptA [] [] q nq nqt fa fb = found finab (case1 q) (bool-and-tt nqt (bool-and-tt fa fb ))
    acceptA [] (h ∷ z)  q nq nq=q fa fb = acceptB z nextb (Nmoves NFA (CNFA-exist A B) nq h) lemma70 fb where
         nextb : states B
         nextb = δ (automaton B) (astart B) h
         lemma70 : exists finab (λ qn → nq qn /\ Nδ NFA qn h (case2 nextb)) ≡ true
         lemma70 = found finab (case1 q) ( bool-and-tt nq=q (bool-and-tt fa (lemma-nmove-ab (case2 (astart B)) h) ))
    acceptA (h ∷ t) z q nq nq=q fa fb = acceptA t z (δ (automaton A) q h) (Nmoves NFA (CNFA-exist A B) nq h) (nmove (case1 q) nq nq=q h)  fa fb

    acceptAB : Split (contain A) (contain B) x
        → Naccept NFA (CNFA-exist A B) (equal? finab (case1 (astart A))) x  ≡ true
    acceptAB S = subst ( λ k → Naccept NFA (CNFA-exist A B) (equal? finab (case1 (astart A))) k  ≡ true  ) ( sp-concat S )
        (acceptA (sp0 S) (sp1 S)  (astart A) (equal? finab (case1 (astart A))) (equal?-refl finab) (prop0 S) (prop1 S) )

    closed-in-concat→ : Concat (contain A) (contain B) x ≡ true → contain (M-Concat A B) x ≡ true
    closed-in-concat→ concat with split→AB (contain A) (contain B) x concat
    ... | S = begin
          accept  (subset-construction (CNFA-exist A B) (Concat-NFA A B) ) (Concat-NFA-start A B ) x
       ≡⟨ ≡-Bool-func (subset-construction-lemma←  (CNFA-exist A B)  NFA (equal? finab (case1 (astart A))) x )
          (subset-construction-lemma→  (CNFA-exist A B)  NFA (equal? finab (case1 (astart A))) x ) ⟩
          Naccept NFA (CNFA-exist A B) (equal? finab (case1 (astart A))) x
       ≡⟨ acceptAB S ⟩
         true
       ∎  where open ≡-Reasoning

    open Found

    ab-case : (q : states A ∨ states B ) → (qa : states A ) → (x : List Σ ) → Set
    ab-case (case1 qa') qa x = qa'  ≡ qa
    ab-case (case2 qb) qa x = ¬ ( accept (automaton B) qb x  ≡ true )

    contain-A : (x : List Σ) → (nq : states A ∨ states B → Bool ) → (fn : Naccept NFA (CNFA-exist A B) nq x ≡ true )
          → (qa : states A )  → (  (q : states A ∨ states B) → nq q ≡ true → ab-case q qa x )
          → split (accept (automaton A) qa ) (contain B) x ≡ true
    contain-A [] nq fn qa cond with found← finab fn  -- at this stage, A and B must be satisfied with [] (ab-case cond forces it)
    ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S))
    ... | case1 qa' | record { eq = refl } | refl = bool-∧→tt-1 (found-p S)
    ... | case2 qb | record { eq = refl } | ab = ⊥-elim ( ab (bool-∧→tt-1 (found-p S)))
    contain-A (h ∷ t) nq fn qa cond with bool-≡-? ((aend (automaton A) qa) /\  accept (automaton B) (δ (automaton B) (astart B) h) t ) true
    ... | yes eq = bool-or-41 eq  -- found A ++ B all end
    ... | no ne = bool-or-31 (contain-A t (Nmoves NFA (CNFA-exist A B) nq h) fn (δ (automaton A) qa h) lemma11 ) where -- B failed continue with ab-base condtion
       --- prove ab-case condition (we haven't checked but case2 b may happen)
       lemma11 :  (q : states A ∨ states B) → exists finab (λ qn → nq qn /\ Nδ NFA qn h q) ≡ true → ab-case q (δ (automaton A) qa h) t
       lemma11 (case1 qa')  ex with found← finab ex
       ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S))
       ... | case1 qa | record { eq = refl } | refl = sym ( equal→refl (afin A)  ( bool-∧→tt-1 (found-p S) ))  -- continued A case
       ... | case2 qb | record { eq = refl } | nb with  bool-∧→tt-1 (found-p S) -- δnfa (case2 q) i (case1 q₁) is false
       ... | ()
       lemma11 (case2 qb)  ex with found← finab ex
       ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S))
       lemma11 (case2 qb)  ex | S | case2 qb' | record { eq = refl } | nb = contra-position lemma13 nb where -- continued B case should fail
           lemma13 :  accept (automaton B) qb t ≡ true → accept (automaton B) qb' (h ∷ t) ≡ true
           lemma13 fb = subst (λ k → accept (automaton B) k t ≡ true ) (sym (equal→refl (afin B) (bool-∧→tt-1 (found-p S)))) fb
       lemma11 (case2 qb)  ex | S | case1 qa | record { eq = refl } | refl with bool-∧→tt-1 (found-p S)
       ... | eee = contra-position lemma12 ne where -- starting B case should fail
           lemma12 : accept (automaton B) qb t ≡ true → aend (automaton A) qa /\ accept (automaton B) (δ (automaton B) (astart B) h) t ≡ true
           lemma12 fb = bool-and-tt (bool-∧→tt-0 eee) (subst ( λ k → accept (automaton B) k t ≡ true ) (equal→refl (afin B) (bool-∧→tt-1 eee) ) fb )

    lemma10 : Naccept NFA (CNFA-exist A B) (equal? finab (case1 (astart A))) x  ≡ true → split (contain A) (contain B) x ≡ true
    lemma10 CC = contain-A x (Concat-NFA-start A B ) CC (astart A) lemma15 where
       lemma15 : (q : states A ∨ states B) → Concat-NFA-start A B q ≡ true → ab-case q (astart A) x
       lemma15 q nq=t with equal→refl finab nq=t
       ... | refl = refl

    closed-in-concat← : contain (M-Concat A B) x ≡ true → Concat (contain A) (contain B) x ≡ true
    closed-in-concat← C with subset-construction-lemma← (CNFA-exist A B) NFA (equal? finab (case1 (astart A))) x C
    ... | CC = lemma10 CC


postulate
  U V : Set
  T   : V → Set
  H   : ∀ v → T v → Set
  f   : U → V

data D : Set where d : D

foo : (u : U) (t : T (f u)) (h : H (f u) t) → H (f u) t
foo u t h with f u | d
... | fu | x = h


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

open import Base

module Homotopy.Cover.Def {i} (A : Set i) where

record covering : Set (suc i) where
  constructor cov[_,_]
  field
    fiber : A → Set i
    fiber-is-set : ∀ a → is-set (fiber a)

open import Homotopy.Truncation
open import Homotopy.Connected
open import Homotopy.PathTruncation

-- In terms of connectedness
is-universal : covering → Set i
is-universal cov[ fiber , _ ] = is-connected ⟨1⟩ $ Σ A fiber

-- In terms of connectedness
universal-covering : Set (suc i)
universal-covering = Σ covering is-universal

tracing : ∀ cov → let open covering cov in
  ∀ {a₁ a₂} → fiber a₁ → a₁ ≡₀ a₂ → fiber a₂
tracing cov[ fiber , fiber-is-set ] y =
  π₀-extend-nondep
    ⦃ fiber-is-set _ ⦄
    (λ p → transport fiber p y)

compose-tracing : ∀ cov → let open covering cov in
  ∀ {a₁ a₂ a₃} y (p₁ : a₁ ≡₀ a₂) (p₂ : a₂ ≡₀ a₃)
  → tracing cov (tracing cov y p₁) p₂ ≡ tracing cov y (p₁ ∘₀ p₂)
compose-tracing cov y = let open covering cov in
  π₀-extend
    ⦃ λ _ → Π-is-set λ _ → ≡-is-set $ fiber-is-set _ ⦄
    (λ p₁ → π₀-extend
      ⦃ λ _ → ≡-is-set $ fiber-is-set _ ⦄
      (λ p₂ → compose-trans fiber p₂ p₁ y))

covering-eq : ∀ {co₁ co₂ : covering}
  → covering.fiber co₁ ≡ covering.fiber co₂
  → co₁ ≡ co₂
covering-eq {cov[ _ , set₁ ]} {cov[ ._ , set₂ ]} refl =
  ap (λ set → cov[ _ , set ])
    (prop-has-all-paths (Π-is-prop λ _ → is-set-is-prop) _ _)


------------------------------------------------------------------------
-- An equality postulate which evaluates
------------------------------------------------------------------------

module Relation.Binary.PropositionalEquality.TrustMe where

open import Relation.Binary.PropositionalEquality

private
 primitive
   primTrustMe : {A : Set}{a b : A} → a ≡ b

-- trustMe {a = x} {b = y} evaluates to refl if x and y are
-- definitionally equal.
--
-- For an example of the use of trustMe, see Data.String._≟_.

trustMe : {A : Set}{a b : A} → a ≡ b
trustMe = primTrustMe


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

syntax FOL

type
  * : 0-ary
  N : 0-ary

term
  false : * | ⊥
  or    : *  *  ->  * | _∨_ l20
  true  : * | ⊤
  and   : *  *  ->  * | _∧_ l20
  not   : *  ->  * | ¬_ r50
  eq    : N  N  ->  * | _≟_ l20
  all   : N.*  ->  * | ∀′
  ex    : N.*  ->  * | ∃′

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))
  (DM∀) p : N.* |> not (all (x. p[x])) = ex  (x. not(p[x]))
  (DM∃) p : N.* |> not (ex  (x. p[x])) = all (x. not(p[x]))
  (∀D∧) p q : N.* |> all (x. and(p[x], q[x])) = and (all(x.p[x]), all(x.q[x]))
  (∃D∨) p q : N.* |> ex (x. or(p[x], q[x])) = or (ex(x.p[x]), ex(x.q[x]))
  (∧P∀ᴸ) p : *  q : N.* |> and (p, all(x.q[x])) = all (x. and(p, q[x]))
  (∧P∃ᴸ) p : *  q : N.* |> and (p, ex (x.q[x])) = ex  (x. and(p, q[x]))
  (∨P∀ᴸ) p : *  q : N.* |> or  (p, all(x.q[x])) = all (x. or (p, q[x]))
  (∨P∃ᴸ) p : *  q : N.* |> or  (p, ex (x.q[x])) = ex  (x. or (p, q[x]))
  (∧P∀ᴿ) p : N.*  q : * |> and (all(x.p[x]), q) = all (x. and(p[x], q))
  (∧P∃ᴿ) p : N.*  q : * |> and (ex (x.p[x]), q) = ex  (x. and(p[x], q))
  (∨P∀ᴿ) p : N.*  q : * |> or  (all(x.p[x]), q) = all (x. or (p[x], q))
  (∨P∃ᴿ) p : N.*  q : * |> or  (ex (x.p[x]), q) = ex  (x. or (p[x], q))
  (∀Eᴸ) p : N.*  n : N |> all (x.p[x]) = and (p[n], all(x.p[x]))
  (∃Eᴸ) p : N.*  n : N |> ex  (x.p[x]) = or  (p[n], ex (x.p[x]))
  (∀Eᴿ) p : N.*  n : N |> all (x.p[x]) = and (all(x.p[x]), p[n])
  (∃Eᴿ) p : N.*  n : N |> ex  (x.p[x]) = or  (ex (x.p[x]), p[n])
  (∃⟹) p : N.*  q : * |> imp (ex (x.p[x]), q) = all (x. imp(p[x], q))
  (∀⟹) p : N.*  q : * |> imp (all(x.p[x]), q) = ex  (x. imp(p[x], q))
-}

module FOL.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import FOL.Signature
open import FOL.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution FOL:Syn
open import SOAS.Metatheory.SecondOrder.Equality FOL:Syn

private
  variable
    α β γ τ : FOLT
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ FOL) α Γ → (𝔐 ▷ FOL) α Γ → Set where
  ⊥U∨ᴸ : ⁅ * ⁆̣               ▹ ∅ ⊢                  ⊥ ∨ 𝔞 ≋ₐ 𝔞
  ∨A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣   ▹ ∅ ⊢            (𝔞 ∨ 𝔟) ∨ 𝔠 ≋ₐ 𝔞 ∨ (𝔟 ∨ 𝔠)
  ∨C   : ⁅ * ⁆ ⁅ * ⁆̣         ▹ ∅ ⊢                  𝔞 ∨ 𝔟 ≋ₐ 𝔟 ∨ 𝔞
  ⊤U∧ᴸ : ⁅ * ⁆̣               ▹ ∅ ⊢                  ⊤ ∧ 𝔞 ≋ₐ 𝔞
  ∧A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣   ▹ ∅ ⊢            (𝔞 ∧ 𝔟) ∧ 𝔠 ≋ₐ 𝔞 ∧ (𝔟 ∧ 𝔠)
  ∧D∨ᴸ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣   ▹ ∅ ⊢            𝔞 ∧ (𝔟 ∨ 𝔠) ≋ₐ (𝔞 ∧ 𝔟) ∨ (𝔞 ∧ 𝔠)
  ⊥X∧ᴸ : ⁅ * ⁆̣               ▹ ∅ ⊢                  ⊥ ∧ 𝔞 ≋ₐ ⊥
  ¬N∨ᴸ : ⁅ * ⁆̣               ▹ ∅ ⊢              (¬ 𝔞) ∨ 𝔞 ≋ₐ ⊥
  ∧C   : ⁅ * ⁆ ⁅ * ⁆̣         ▹ ∅ ⊢                  𝔞 ∧ 𝔟 ≋ₐ 𝔟 ∧ 𝔞
  ∨I   : ⁅ * ⁆̣               ▹ ∅ ⊢                  𝔞 ∨ 𝔞 ≋ₐ 𝔞
  ∧I   : ⁅ * ⁆̣               ▹ ∅ ⊢                  𝔞 ∧ 𝔞 ≋ₐ 𝔞
  ¬²   : ⁅ * ⁆̣               ▹ ∅ ⊢                ¬ (¬ 𝔞) ≋ₐ 𝔞
  ∨D∧ᴸ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣   ▹ ∅ ⊢            𝔞 ∨ (𝔟 ∧ 𝔠) ≋ₐ (𝔞 ∨ 𝔟) ∧ (𝔞 ∨ 𝔠)
  ∨B∧ᴸ : ⁅ * ⁆ ⁅ * ⁆̣         ▹ ∅ ⊢            (𝔞 ∧ 𝔟) ∨ 𝔞 ≋ₐ 𝔞
  ∧B∨ᴸ : ⁅ * ⁆ ⁅ * ⁆̣         ▹ ∅ ⊢            (𝔞 ∨ 𝔟) ∧ 𝔞 ≋ₐ 𝔞
  ⊤X∨ᴸ : ⁅ * ⁆̣               ▹ ∅ ⊢                  ⊤ ∨ 𝔞 ≋ₐ ⊤
  ¬N∧ᴸ : ⁅ * ⁆̣               ▹ ∅ ⊢              (¬ 𝔞) ∧ 𝔞 ≋ₐ ⊥
  DM∧  : ⁅ * ⁆ ⁅ * ⁆̣         ▹ ∅ ⊢              ¬ (𝔞 ∧ 𝔟) ≋ₐ (¬ 𝔞) ∨ (¬ 𝔟)
  DM∨  : ⁅ * ⁆ ⁅ * ⁆̣         ▹ ∅ ⊢              ¬ (𝔞 ∨ 𝔟) ≋ₐ (¬ 𝔞) ∧ (¬ 𝔟)
  DM∀  : ⁅ N ⊩ * ⁆̣           ▹ ∅ ⊢       ¬ (∀′ (𝔞⟨ x₀ ⟩)) ≋ₐ ∃′ (¬ 𝔞⟨ x₀ ⟩)
  DM∃  : ⁅ N ⊩ * ⁆̣           ▹ ∅ ⊢       ¬ (∃′ (𝔞⟨ x₀ ⟩)) ≋ₐ ∀′ (¬ 𝔞⟨ x₀ ⟩)
  ∀D∧  : ⁅ N ⊩ * ⁆ ⁅ N ⊩ * ⁆̣ ▹ ∅ ⊢ ∀′ (𝔞⟨ x₀ ⟩ ∧ 𝔟⟨ x₀ ⟩) ≋ₐ (∀′ (𝔞⟨ x₀ ⟩)) ∧ (∀′ (𝔟⟨ x₀ ⟩))
  ∃D∨  : ⁅ N ⊩ * ⁆ ⁅ N ⊩ * ⁆̣ ▹ ∅ ⊢ ∃′ (𝔞⟨ x₀ ⟩ ∨ 𝔟⟨ x₀ ⟩) ≋ₐ (∃′ (𝔞⟨ x₀ ⟩)) ∨ (∃′ (𝔟⟨ x₀ ⟩))
  ∧P∀ᴸ : ⁅ * ⁆ ⁅ N ⊩ * ⁆̣     ▹ ∅ ⊢     𝔞 ∧ (∀′ (𝔟⟨ x₀ ⟩)) ≋ₐ ∀′ (𝔞 ∧ 𝔟⟨ x₀ ⟩)
  ∧P∃ᴸ : ⁅ * ⁆ ⁅ N ⊩ * ⁆̣     ▹ ∅ ⊢     𝔞 ∧ (∃′ (𝔟⟨ x₀ ⟩)) ≋ₐ ∃′ (𝔞 ∧ 𝔟⟨ x₀ ⟩)
  ∨P∀ᴸ : ⁅ * ⁆ ⁅ N ⊩ * ⁆̣     ▹ ∅ ⊢     𝔞 ∨ (∀′ (𝔟⟨ x₀ ⟩)) ≋ₐ ∀′ (𝔞 ∨ 𝔟⟨ x₀ ⟩)
  ∨P∃ᴸ : ⁅ * ⁆ ⁅ N ⊩ * ⁆̣     ▹ ∅ ⊢     𝔞 ∨ (∃′ (𝔟⟨ x₀ ⟩)) ≋ₐ ∃′ (𝔞 ∨ 𝔟⟨ x₀ ⟩)
  ∀Eᴸ  : ⁅ N ⊩ * ⁆ ⁅ N ⁆̣     ▹ ∅ ⊢           ∀′ (𝔞⟨ x₀ ⟩) ≋ₐ 𝔞⟨ 𝔟 ⟩ ∧ (∀′ (𝔞⟨ x₀ ⟩))
  ∃Eᴸ  : ⁅ N ⊩ * ⁆ ⁅ N ⁆̣     ▹ ∅ ⊢           ∃′ (𝔞⟨ x₀ ⟩) ≋ₐ 𝔞⟨ 𝔟 ⟩ ∨ (∃′ (𝔞⟨ x₀ ⟩))

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning

-- Derived equations
⊥U∨ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ ⊥ ≋ 𝔞
⊥U∨ᴿ = tr (ax ∨C with《 𝔞 ◃ ⊥ 》) (ax ⊥U∨ᴸ with《 𝔞 》)
⊤U∧ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ ⊤ ≋ 𝔞
⊤U∧ᴿ = tr (ax ∧C with《 𝔞 ◃ ⊤ 》) (ax ⊤U∧ᴸ with《 𝔞 》)
∧D∨ᴿ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ∨ 𝔟) ∧ 𝔠 ≋ (𝔞 ∧ 𝔠) ∨ (𝔟 ∧ 𝔠)
∧D∨ᴿ = begin
  (𝔞 ∨ 𝔟) ∧ 𝔠       ≋⟨ ax ∧C with《 𝔞 ∨ 𝔟 ◃ 𝔠 》 ⟩
  𝔠 ∧ (𝔞 ∨ 𝔟)       ≋⟨ ax ∧D∨ᴸ with《 𝔠 ◃ 𝔞 ◃ 𝔟 》 ⟩
  (𝔠 ∧ 𝔞) ∨ (𝔠 ∧ 𝔟)  ≋⟨ cong₂[ ax ∧C with《 𝔠 ◃ 𝔞 》 ][ ax ∧C with《 𝔠 ◃ 𝔟 》 ]inside ◌ᵈ ∨ ◌ᵉ ⟩
  (𝔞 ∧ 𝔠) ∨ (𝔟 ∧ 𝔠)  ∎
⊥X∧ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ ⊥ ≋ ⊥
⊥X∧ᴿ = tr (ax ∧C with《 𝔞 ◃ ⊥ 》) (ax ⊥X∧ᴸ with《 𝔞 》)
¬N∨ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ (¬ 𝔞) ≋ ⊥
¬N∨ᴿ = tr (ax ∨C with《 𝔞 ◃ (¬ 𝔞) 》) (ax ¬N∨ᴸ with《 𝔞 》)
∨D∧ᴿ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ∧ 𝔟) ∨ 𝔠 ≋ (𝔞 ∨ 𝔠) ∧ (𝔟 ∨ 𝔠)
∨D∧ᴿ = begin
  (𝔞 ∧ 𝔟) ∨ 𝔠       ≋⟨ ax ∨C with《 𝔞 ∧ 𝔟 ◃ 𝔠 》 ⟩
  𝔠 ∨ (𝔞 ∧ 𝔟)       ≋⟨ ax ∨D∧ᴸ with《 𝔠 ◃ 𝔞 ◃ 𝔟 》 ⟩
  (𝔠 ∨ 𝔞) ∧ (𝔠 ∨ 𝔟)  ≋⟨ cong₂[ ax ∨C with《 𝔠 ◃ 𝔞 》 ][ ax ∨C with《 𝔠 ◃ 𝔟 》 ]inside ◌ᵈ ∧ ◌ᵉ ⟩
  (𝔞 ∨ 𝔠) ∧ (𝔟 ∨ 𝔠)  ∎
⊤X∨ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ ⊤ ≋ ⊤
⊤X∨ᴿ = tr (ax ∨C with《 𝔞 ◃ ⊤ 》) (ax ⊤X∨ᴸ with《 𝔞 》)
¬N∧ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ (¬ 𝔞) ≋ ⊥
¬N∧ᴿ = tr (ax ∧C with《 𝔞 ◃ (¬ 𝔞) 》) (ax ¬N∧ᴸ with《 𝔞 》)
∧P∀ᴿ : ⁅ N ⊩ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (∀′ (𝔞⟨ x₀ ⟩)) ∧ 𝔟 ≋ ∀′ (𝔞⟨ x₀ ⟩ ∧ 𝔟)
∧P∀ᴿ = begin
  (∀′ (𝔞⟨ x₀ ⟩)) ∧ 𝔟   ≋⟨ ax ∧C with《 ∀′ (𝔞⟨ x₀ ⟩) ◃ 𝔟 》 ⟩
  𝔟 ∧ (∀′ (𝔞⟨ x₀ ⟩))   ≋⟨ ax ∧P∀ᴸ with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ⟩
  ∀′ (𝔟 ∧ 𝔞⟨ x₀ ⟩)     ≋⟨ cong[ ax ∧C with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ]inside ∀′ (◌ᶜ⟨ x₀ ⟩) ⟩
  ∀′ (𝔞⟨ x₀ ⟩ ∧ 𝔟)     ∎
∧P∃ᴿ : ⁅ N ⊩ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (∃′ (𝔞⟨ x₀ ⟩)) ∧ 𝔟 ≋ ∃′ (𝔞⟨ x₀ ⟩ ∧ 𝔟)
∧P∃ᴿ = begin
  (∃′ (𝔞⟨ x₀ ⟩)) ∧ 𝔟   ≋⟨ ax ∧C with《 ∃′ (𝔞⟨ x₀ ⟩) ◃ 𝔟 》 ⟩
  𝔟 ∧ (∃′ (𝔞⟨ x₀ ⟩))   ≋⟨ ax ∧P∃ᴸ with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ⟩
  ∃′ (𝔟 ∧ 𝔞⟨ x₀ ⟩)     ≋⟨ cong[ ax ∧C with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ]inside ∃′ (◌ᶜ⟨ x₀ ⟩) ⟩
  ∃′ (𝔞⟨ x₀ ⟩ ∧ 𝔟)     ∎
∨P∀ᴿ : ⁅ N ⊩ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (∀′ (𝔞⟨ x₀ ⟩)) ∨ 𝔟 ≋ ∀′ (𝔞⟨ x₀ ⟩ ∨ 𝔟)
∨P∀ᴿ = begin
  (∀′ (𝔞⟨ x₀ ⟩)) ∨ 𝔟   ≋⟨ ax ∨C with《 ∀′ (𝔞⟨ x₀ ⟩) ◃ 𝔟 》 ⟩
  𝔟 ∨ (∀′ (𝔞⟨ x₀ ⟩))   ≋⟨ ax ∨P∀ᴸ with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ⟩
  ∀′ (𝔟 ∨ 𝔞⟨ x₀ ⟩)     ≋⟨ cong[ ax ∨C with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ]inside ∀′ (◌ᶜ⟨ x₀ ⟩) ⟩
  ∀′ (𝔞⟨ x₀ ⟩ ∨ 𝔟)     ∎
∨P∃ᴿ : ⁅ N ⊩ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (∃′ (𝔞⟨ x₀ ⟩)) ∨ 𝔟 ≋ ∃′ (𝔞⟨ x₀ ⟩ ∨ 𝔟)
∨P∃ᴿ = begin
  (∃′ (𝔞⟨ x₀ ⟩)) ∨ 𝔟   ≋⟨ ax ∨C with《 ∃′ (𝔞⟨ x₀ ⟩) ◃ 𝔟 》 ⟩
  𝔟 ∨ (∃′ (𝔞⟨ x₀ ⟩))   ≋⟨ ax ∨P∃ᴸ with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ⟩
  ∃′ (𝔟 ∨ 𝔞⟨ x₀ ⟩)     ≋⟨ cong[ ax ∨C with《 𝔟 ◃ 𝔞⟨ x₀ ⟩ 》 ]inside ∃′ (◌ᶜ⟨ x₀ ⟩) ⟩
  ∃′ (𝔞⟨ x₀ ⟩ ∨ 𝔟)     ∎
∀Eᴿ : ⁅ N ⊩ * ⁆ ⁅ N ⁆̣ ▹ ∅ ⊢ ∀′ (𝔞⟨ x₀ ⟩) ≋ (∀′ (𝔞⟨ x₀ ⟩)) ∧ 𝔞⟨ 𝔟 ⟩
∀Eᴿ = tr (ax ∀Eᴸ with《 𝔞⟨ x₀ ⟩ ◃ 𝔟 》) (ax ∧C with《  𝔞⟨ 𝔟 ⟩ ◃ ∀′ (𝔞⟨ x₀ ⟩) 》)
∃Eᴿ : ⁅ N ⊩ * ⁆ ⁅ N ⁆̣ ▹ ∅ ⊢ ∃′ (𝔞⟨ x₀ ⟩) ≋ (∃′ (𝔞⟨ x₀ ⟩)) ∨ 𝔞⟨ 𝔟 ⟩
∃Eᴿ = tr (ax ∃Eᴸ with《 𝔞⟨ x₀ ⟩ ◃ 𝔟 》) (ax ∨C with《  𝔞⟨ 𝔟 ⟩ ◃ ∃′ (𝔞⟨ x₀ ⟩) 》)
∃⟹ : ⁅ N ⊩ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (∃′ (𝔞⟨ x₀ ⟩)) ⟹ 𝔟 ≋ ∀′ (𝔞⟨ x₀ ⟩ ⟹ 𝔟)
∃⟹ = begin
  (∃′ (𝔞⟨ x₀ ⟩)) ⟹ 𝔟    ≡⟨⟩
  (¬ (∃′ (𝔞⟨ x₀ ⟩))) ∨ 𝔟 ≋⟨ cong[ ax DM∃ with《 𝔞⟨ x₀ ⟩ 》 ]inside (◌ᶜ ∨ 𝔟) ⟩
  (∀′ (¬ (𝔞⟨ x₀ ⟩))) ∨ 𝔟 ≋⟨ thm ∨P∀ᴿ with《 ¬ 𝔞⟨ x₀ ⟩ ◃ 𝔟 》 ⟩
  ∀′ (¬ (𝔞⟨ x₀ ⟩) ∨ 𝔟)   ≡⟨⟩
  ∀′ (𝔞⟨ x₀ ⟩ ⟹ 𝔟)      ∎
∀⟹ : ⁅ N ⊩ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (∀′ (𝔞⟨ x₀ ⟩)) ⟹ 𝔟 ≋ ∃′ (𝔞⟨ x₀ ⟩ ⟹ 𝔟)
∀⟹ = begin
  (∀′ (𝔞⟨ x₀ ⟩)) ⟹ 𝔟    ≡⟨⟩
  (¬ (∀′ (𝔞⟨ x₀ ⟩))) ∨ 𝔟 ≋⟨ cong[ ax DM∀ with《 𝔞⟨ x₀ ⟩ 》 ]inside (◌ᶜ ∨ 𝔟) ⟩
  (∃′ (¬ (𝔞⟨ x₀ ⟩))) ∨ 𝔟 ≋⟨ thm ∨P∃ᴿ with《 ¬ 𝔞⟨ x₀ ⟩ ◃ 𝔟 》 ⟩
  ∃′ (¬ (𝔞⟨ x₀ ⟩) ∨ 𝔟)   ≡⟨⟩
  ∃′ (𝔞⟨ x₀ ⟩ ⟹ 𝔟)      ∎


import Relation.Binary.PropositionalEquality
module Data.Bin.Multiplication where
  private module PropEq = Relation.Binary.PropositionalEquality

  module ℕ-lemmas where
    open import Data.Nat
    open import Data.Nat.Properties
    open import Relation.Binary.PropositionalEquality
    open SemiringSolver

    *-2-3-comm : ∀ x y z → x * y * z ≡ x * z * y
    *-2-3-comm x y z = solve 3 (λ x y z → x :* y :* z := x :* z :* y) refl x y z

    n+x≡0→n≡0 : ∀ {n x} → n + x ≡ 0 → n ≡ 0
    n+x≡0→n≡0 {zero} = λ _ → refl
    n+x≡0→n≡0 {suc _} = λ ()

    distribʳ : ∀ a b c → (a + b) * c ≡ a * c + b * c
    distribʳ a b c = solve 3 (λ a b c → (a :+ b) :* c := a :* c :+ b :* c) refl a b c

  open PropEq using (_≡_; cong; cong₂; trans; sym; [_]; inspect)
  open import Data.Bin using (_*2; toℕ; 0#; _1#; Bin; pred; _*_; _+_)
  open import Data.Nat using (ℕ; zero; suc)
                     renaming (_*_ to _ℕ*_; _+_ to _ℕ+_)
  open import Data.Nat.Properties using (isCommutativeSemiring)
  open import Algebra.Structures
     using (module IsCommutativeSemiring;
            module IsCommutativeMonoid)
  open IsCommutativeSemiring isCommutativeSemiring
     using (+-isCommutativeMonoid; *-isCommutativeMonoid)

  open import Data.Product

  open import Relation.Nullary
  open import Data.Fin using (zero; suc) renaming (toℕ to bitToℕ)
  open import Data.Digit using (Bit)
  open import Data.List using (List; _∷_; [])
  open import Data.Bin.Utils

  open import Data.Bin.Bijection using (fromℕ-bijection; toℕ-inj)
  import Relation.Binary.PropositionalEquality
  open Relation.Binary.PropositionalEquality.≡-Reasoning

  import Data.Bin.Addition
  open Data.Bin.Addition using (+-is-addition)
  module B+ICM = IsCommutativeMonoid Data.Bin.Addition.is-commutativeMonoid
  open B+ICM using () renaming (identity to +-identity; ∙-cong to +-cong)

  *2-is-*2 : ∀ x → toℕ (x *2) ≡ toℕ x ℕ* 2
  *2-is-*2 0# = PropEq.refl
  *2-is-*2 (bs 1#) = PropEq.refl

  bitToX-≡ : ∀ x → bitToℕ x ≡ toℕ (bitToBin x)
  bitToX-≡ zero = PropEq.refl
  bitToX-≡ (suc zero) = PropEq.refl
  bitToX-≡ (suc (suc ()))

  ∷1#-interpretation : ∀ (b : Bit) (bs : List Bit) → ((b ∷ bs) 1#) ≡ bitToBin b + (bs 1#) *2
  ∷1#-interpretation b bs = toℕ-inj (
   begin
    toℕ ((b ∷ bs) 1#)
     ≡⟨ PropEq.refl ⟩
    bitToℕ b ℕ+ toℕ (bs 1#) ℕ* 2
     ≡⟨ cong₂ _ℕ+_ (bitToX-≡ b) (sym (*2-is-*2 (bs 1#))) ⟩
    toℕ (bitToBin b) ℕ+ toℕ ((bs 1#) *2)
     ≡⟨ sym (+-is-addition (bitToBin b) ((bs 1#) *2)) ⟩
    toℕ (bitToBin b + (bs 1#) *2)
   ∎)

  open import Function using (_⟨_⟩_)

  multBit : Bit → Bin → Bin
  multBit zero _ = 0#
  multBit (suc zero) n = n
  multBit (suc (suc ())) _

  n+x≡0→n≡0 : ∀ {n x} → n + x ≡ 0# → n ≡ 0#
  n+x≡0→n≡0 {n} {x} n+x≡0 = toℕ-inj (ℕ-lemmas.n+x≡0→n≡0 ((sym (+-is-addition n x)) ⟨ trans ⟩ cong toℕ n+x≡0))

  1+*n≡0→n≡0 : ∀ {l} n → l 1# * n ≡ 0# → n ≡ 0#
  1+*n≡0→n≡0 {[]} n eq = eq
  1+*n≡0→n≡0 {h ∷ t} n eq with t 1# * n | PropEq.inspect (λ n → (t 1# * n)) n
  1+*n≡0→n≡0 {h ∷ t} n _ | 0# | [ eq ] = 1+*n≡0→n≡0 {t} n eq
  1+*n≡0→n≡0 {zero ∷ t} n eq | (l 1#) | [ eq2 ] rewrite eq2 with eq
  ... | ()
  1+*n≡0→n≡0 {suc zero ∷ t} n eq | (l 1#) | [ eq2 ] rewrite eq2 = n+x≡0→n≡0 {n} {(zero ∷ l) 1#} eq
  1+*n≡0→n≡0 {suc (suc ()) ∷ t} n eq | _ | _

  simplify-mult : ∀ x xs n → (x ∷ xs) 1# * n ≡ multBit x n + (xs 1# * n) *2
  simplify-mult x xs n with (xs 1# * n) | inspect (λ n → (xs 1# * n)) n
  simplify-mult zero xs n | 0# | [ ≡ ] rewrite ≡ = PropEq.refl
  simplify-mult (suc zero) xs n | 0# | [ ≡ ] rewrite ≡ | 1+*n≡0→n≡0 {xs} n ≡ = PropEq.refl
  simplify-mult zero xs n | (xs' 1#)  | [ ≡ ] rewrite ≡ =
    begin
      (zero ∷ xs') 1#
        ≡⟨ PropEq.refl ⟩
      (xs' 1#) *2
        ≡⟨ B+ICM.sym ( B+ICM.identityˡ ((xs' 1#) *2)) ⟩
      0# + (xs' 1#) *2
        ≡⟨ PropEq.refl ⟩
      multBit zero n + (xs' 1#) *2
    ∎
  simplify-mult (suc zero) xs n | (xs' 1#)  | [ ≡ ] rewrite ≡ =
    begin
      n + (zero ∷ xs') 1#
        ≡⟨ PropEq.refl ⟩
      multBit (suc zero) n + (xs' 1#) *2
    ∎
  simplify-mult (suc (suc ())) xs n | _ | _

  _*-def'_ : ℕ → Bin → Bin
  zero *-def' y = 0#
  (suc x) *-def' y = y + (x *-def' y)

  _*-def_ : Bin → Bin → Bin
  x *-def y = (toℕ x) *-def' y
  infixl 7 _*-def_

  *-def'-is-* : ∀ m n → toℕ (m *-def' n) ≡ m ℕ* toℕ n
  *-def'-is-* zero n = PropEq.refl
  *-def'-is-* (suc m) n = +-is-addition  n ( m *-def' n) ⟨ trans ⟩ cong (_ℕ+_ (toℕ n)) (*-def'-is-* m n)

  *-def-is-* : ∀ m n → toℕ (m *-def n) ≡ toℕ m ℕ* toℕ n
  *-def-is-* m = *-def'-is-* (toℕ m)

  *-def-*2-comm : ∀ x y → (x *-def y) *2 ≡ x *2 *-def y
  *-def-*2-comm x y = toℕ-inj (
    begin
     toℕ ((x *-def y) *2)
      ≡⟨ *2-is-*2 (x *-def y) ⟩
     toℕ (x *-def y) ℕ* 2
      ≡⟨ cong (λ x → x ℕ* 2) (*-def-is-* x y) ⟩
     toℕ x ℕ* toℕ y ℕ* 2
      ≡⟨ ℕ-lemmas.*-2-3-comm (toℕ x) (toℕ y) 2 ⟩
     toℕ x ℕ* 2 ℕ* toℕ y
      ≡⟨ cong (λ x → x ℕ* toℕ y) (sym (*2-is-*2 x)) ⟩
     toℕ (x *2) ℕ* toℕ y
      ≡⟨ sym (*-def-is-* (x *2) y) ⟩
     toℕ (x *2 *-def y)
    ∎)

  multbit-is-*-def : ∀ c x → multBit c x ≡ bitToBin c *-def x
  multbit-is-*-def zero x = PropEq.refl
  multbit-is-*-def (suc zero) x = sym (proj₂ +-identity x)
  multbit-is-*-def (suc (suc ())) x

  *-def-distribʳ : ∀ a b c → (a + b) *-def c ≡ a *-def c + b *-def c
  *-def-distribʳ a b c = toℕ-inj (
    begin
     toℕ ((a + b) *-def c)
      ≡⟨ *-def-is-* (a + b) c ⟩
     toℕ (a + b) ℕ* toℕ c
      ≡⟨ cong (λ x → x ℕ* toℕ c) (+-is-addition a b) ⟩
     (toℕ a ℕ+ toℕ b) ℕ* toℕ c
      ≡⟨ ℕ-lemmas.distribʳ (toℕ a) (toℕ b) (toℕ c) ⟩
     toℕ a ℕ* toℕ c ℕ+ toℕ b ℕ* toℕ c
      ≡⟨ cong₂ _ℕ+_ (kojo a) (kojo b) ⟩
     toℕ (a *-def c) ℕ+ toℕ (b *-def c)
      ≡⟨ sym (+-is-addition (a *-def c) (b *-def c)) ⟩
     toℕ (a *-def c + b *-def c)
    ∎
    ) where
     kojo : ∀ x → toℕ x ℕ* toℕ c ≡ toℕ (x *-def c)
     kojo x = sym (*-def-is-* x c)

  mutual
    *-is-*-def : ∀ m n → m * n ≡ m *-def n
    *-is-*-def 0# n = PropEq.refl
    *-is-*-def (l 1#) n = *-is-*-def-1# l n

    *-is-*-def-1# : ∀ l n → l 1# * n ≡ l 1# *-def n
    *-is-*-def-1# [] n = sym (proj₂ +-identity n)
    *-is-*-def-1# (x ∷ xs) n = *-is-*-def-∷ x xs n

    *-is-*-def-∷ : ∀ h t n → (h ∷ t) 1# * n ≡ ((h ∷ t) 1#) *-def n
    *-is-*-def-∷ h t n =
     begin
      (h ∷ t) 1# * n
       ≡⟨ simplify-mult h t n  ⟩
      multBit h n + (t 1# * n) *2
       ≡⟨ +-cong (multbit-is-*-def h n) (cong (λ x → x *2) (*-is-*-def-1# t n) ⟨ trans ⟩ *-def-*2-comm (t 1#) n) ⟩
      bitToBin h *-def n + t 1# *2 *-def n
       ≡⟨ sym (*-def-distribʳ (bitToBin h) (t 1# *2) n) ⟩
      (bitToBin h + t 1# *2) *-def n
       ≡⟨ cong (λ x → x *-def n) (sym (∷1#-interpretation h t)) ⟩
      ((h ∷ t) 1#) *-def n
     ∎

  *-*2-comm : ∀ x y → (x * y) *2 ≡ x *2 * y
  *-*2-comm x y = cong _*2 (*-is-*-def x y) ⟨ trans ⟩ *-def-*2-comm x y ⟨ trans ⟩ sym (*-is-*-def (x *2) y)

  *-distribʳ : ∀ a b c → (a + b) * c ≡ a * c + b * c
  *-distribʳ a b c =
                     *-is-*-def (a + b) c
           ⟨ trans ⟩ *-def-distribʳ a b c
           ⟨ trans ⟩ sym (cong₂ _+_ (*-is-*-def a c) (*-is-*-def b c))

  *-is-multiplication : ∀ a b → toℕ (a * b) ≡ toℕ a ℕ* toℕ b
  *-is-multiplication a b = cong toℕ (*-is-*-def a b) ⟨ trans ⟩ *-def-is-* a b


open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺ using (ℕ⁺; suc; _+_)
open import Data.List as L using (List; []; _∷_; _++_)
open import Data.List.Any as LA using (Any; here; there)
open import Data.Product using (_,_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open import Data.Environment
open import nodcap.Base

module nodcap.Typing where

-- Typing Rules.

infix 1 ⊢_

data ⊢_ : Environment → Set where

  ax   : {A : Type} →

       --------------
       ⊢ A ∷ A ^ ∷ []

  cut  : {Γ Δ : Environment} {A : Type} →

       ⊢ A ∷ Γ → ⊢ A ^ ∷ Δ →
       ---------------------
       ⊢ Γ ++ Δ

  send : {Γ Δ : Environment} {A B : Type} →

       ⊢ A ∷ Γ → ⊢ B ∷ Δ →
       -------------------
       ⊢ A ⊗ B ∷ Γ ++ Δ

  recv : {Γ : Environment} {A B : Type} →

       ⊢ A ∷ B ∷ Γ →
       -------------
       ⊢ A ⅋ B ∷ Γ

  sel₁ : {Γ : Environment} {A B : Type} →

       ⊢ A ∷ Γ →
       -----------
       ⊢ A ⊕ B ∷ Γ

  sel₂ : {Γ : Environment} {A B : Type} →

       ⊢ B ∷ Γ →
       -----------
       ⊢ A ⊕ B ∷ Γ

  case : {Γ : Environment} {A B : Type} →

       ⊢ A ∷ Γ → ⊢ B ∷ Γ →
       -------------------
       ⊢ A & B ∷ Γ

  halt :

       --------
       ⊢ 𝟏 ∷ []

  wait : {Γ : Environment} →

       ⊢ Γ →
       -------
       ⊢ ⊥ ∷ Γ

  loop : {Γ : Environment} →

       -------
       ⊢ ⊤ ∷ Γ

  mk?₁ : {Γ : Environment} {A : Type} →

       ⊢ A ∷ Γ →
       --------------
       ⊢ ?[ 1 ] A ∷ Γ

  mk!₁ : {Γ : Environment} {A : Type} →

       ⊢ A ∷ Γ →
       --------------
       ⊢ ![ 1 ] A ∷ Γ

  cont : {Γ : Environment} {A : Type} {m n : ℕ⁺} →

       ⊢ ?[ m ] A ∷ ?[ n ] A ∷ Γ →
       ------------------------------
       ⊢ ?[ m + n ] A ∷ Γ

  pool : {Γ Δ : Environment} {A : Type} {m n : ℕ⁺} →

       ⊢ ![ m ] A ∷ Γ → ⊢ ![ n ] A ∷ Δ →
       -------------------------------------
       ⊢ ![ m + n ] A ∷ Γ ++ Δ

  exch : {Γ Δ : Environment} →

       Γ ∼[ bag ] Δ → ⊢ Γ →
       --------------------
       ⊢ Δ

cutIn : {Γ Δ : Environment} {A : Type} (i : A ∈ Γ) (j : A ^ ∈ Δ) →

  ⊢ Γ → ⊢ Δ →
  ----------------
  ⊢ Γ - i ++ Δ - j

cutIn {Γ} {Δ} {A} i j P Q with ∈→++ i | ∈→++ j
... | (Γ₁ , Γ₂ , P.refl , p) | (Δ₁ , Δ₂ , P.refl , q) rewrite p | q
    = cut (exch (fwd [] Γ₁) P) (exch (fwd [] Δ₁) Q)

-- -}
-- -}
-- -}
-- -}
-- -}


module Soundness where

{-
open import Relation.Binary.PropositionalEquality
open import Data.Nat hiding (_>_)
-}

open import StdLibStuff

open import Syntax
open import STT
open import FSC
open import DerivedProps
open import HelpDefs

mutual
 sound : {n : ℕ} {Γ-t : Ctx n} (Γ : FSC-Ctx n Γ-t) (F : Form Γ-t $o) →
         Γ ⊢ F →
         ⊢ (hypos Γ F)
 sound Γ .(F || G) (||-I-l {F} {G} p) = inf-V (traverse-hypos F (F || G) Γ ax-2-s) (sound Γ F p)
 sound Γ .(F || G) (||-I-r {F} {G} p) = inf-V (traverse-hypos G (F || G) Γ (inf-V (inf-V ax-4-s ax-3-s) ax-2-s)) (sound Γ G p)
 sound Γ .(F & G) (&-I {F} {G} pF pG) = inf-V (inf-V (traverse-hypos-pair-I F G Γ) (sound Γ F pF)) (sound Γ G pG)
 sound Γ .(F => G) (=>-I {F} {G} p) = sound (F ∷h Γ) G p
 sound Γ .(~ F) (~-I {F} p) = inf-V (traverse-hypos (F => $false) (~ F) Γ (lem10 F)) (sound (F ∷h Γ) $false p)
 sound Γ .(![ t ] F) (!-I {t} {F} p) = traverse-=>-I-dep t F Γ (inf-VI-s (sound (t ∷ Γ) F p))
 sound Γ .(!'[ t ] F) (!'-I {t} {F} p) = traverse-=>-I-dep' t F Γ (sound (t ∷ Γ) (weak F · $ this {refl}) p)
 sound Γ F (elim x p) = inf-V (traverse-hypos-elim F Γ x) (sound-elim Γ (lookup-hyp Γ x) F p)
 sound Γ F (ac {t} p) = inf-V (traverse-hypos ((![ t > $o ] ((?[ t ] (var (next this) refl · var this refl)) => (var this refl · (ι t (var (next this) refl · var this refl))))) => F) F Γ (inf-V (lemb3 (![ t > $o ] ((?[ t ] (var (next this) refl · var this refl)) => (var this refl · ι t (var (next this) refl · var this refl)))) F) (inf-VI-s (ax-11-s {_} {(t > $o) ∷ _} {t} {var (next this) refl · var this refl})))) (sound-elim Γ (![ t > $o ] ((?[ t ] (var (next this) refl · var this refl)) => (var this refl · (ι t (var (next this) refl · var this refl))))) F p)
 sound Γ F (ac' {t} p) = inf-V (traverse-hypos ((![ t > $o ] ((?[ t ] ($ (next this) {refl} · $ this {refl})) => ($ this {refl} · ι' t ($ this {refl})))) => F) F Γ (inf-V (lemb3 (![ t > $o ] ((?[ t ] ($ (next this) {refl} · $ this {refl})) => ($ this {refl} · ι' t ($ this {refl})))) F) (inf-VI-s (ax-11-s2 ($ this {refl}))))) (sound-elim Γ (![ t > $o ] ((?[ t ] ($ (next this) {refl} · $ this {refl})) => ($ this {refl} · ι' t ($ this {refl})))) F p)
 sound Γ .(?[ t ] F) (?-I {t} {F} G p) = inf-V (traverse-hypos (sub G F) (?[ t ] F) Γ (inf-V ax-3-s (ax-5-s (~ F) G))) (sound Γ (sub G F) p)
 sound Γ .(?'[ t ] F) (?'-I {t} {F} G p) = inf-V (traverse-hypos (app F G) (?'[ t ] F) Γ (inf-V ax-3-s (ax-5-s2 F G))) (sound Γ (app F G) p)
 sound Γ .$true $true-I = traverse-hypos-use $true Γ (inf-VI-s (inf-V (inf-V ax-4-s ax-1-s) ax-2-s))
 sound Γ .(F == G) (==-I {t} {F} {G} p) = sound-== Γ t F G p
 sound Γ .(F ((^[ t ] G) · H)) (reduce {t} {u} {F} {G} {H} p) = inf-V (traverse-hypos (F (sub H G)) (F ((^[ t ] G) · H)) Γ (inf-III-samectx (λ x → (F x)) G H)) (sound Γ (F (sub H G)) p)
 sound Γ F (raa p) = inf-V (traverse-hypos (~ (~ F)) F Γ (lemb2 F)) (sound _ _ p)

 sound-elim : ∀ {n Γ-t} → (Γ : FSC-Ctx n Γ-t) (F G : Form Γ-t $o) →
  Γ , F ⊢ G →
  ⊢ (hypos Γ (F => G))
 sound-elim Γ F G (use p) = inf-V (traverse-hypos (G == F) (F => G) Γ (lem13 F G)) (sound-↔ Γ $o G F p)
 sound-elim Γ .(F & G) H (&-E-l {F} {G} p) = inf-V (traverse-hypos (F => H) ((F & G) => H) Γ (lem6 F G H)) (sound-elim Γ F H p)
 sound-elim Γ .(F & G) H (&-E-r {F} {G} p) = inf-V (traverse-hypos (G => H) ((F & G) => H) Γ (lem6b F G H)) (sound-elim Γ G H p)
 sound-elim Γ .(F => G) H (=>-E {F} {G} p₁ p₂) = inf-V (inf-V (traverse-hypos2 F (G => H) ((F => G) => H) Γ (lem7 F G H)) (sound Γ F p₁)) (sound-elim Γ G H p₂)
 sound-elim Γ .(~ F) H (~-E {F} p) = inf-V (traverse-hypos F (~ F => H) Γ (lemb4 F H)) (sound Γ F p)
 sound-elim Γ .(![ t ] F) H (!-E {t} {F} G p) = inf-V (traverse-hypos (sub G F => H) (![ t ] F => H) Γ (inf-V (lem9 (![ t ] F) (sub G F) H) (ax-5-s F G))) (sound-elim Γ (sub G F) H p)
 sound-elim Γ .(!'[ t ] F) H (!'-E {t} {F} G p) = inf-V (traverse-hypos ((F · G) => H) (!'[ t ] F => H) Γ (inf-V (lem9 (!'[ t ] F) (F · G) H) (ax-5-s3 F G))) (sound-elim Γ (F · G) H p)
 sound-elim Γ .$false H $false-E = traverse-hypos-use ($false => H) Γ (lem11 H)
 sound-elim Γ .(F || G) H (||-E {F} {G} p₁ p₂) = inf-V (inf-V (traverse-hypos2 (F => H) (G => H) ((F || G) => H) Γ (lemb5 F G H)) (sound _ _ p₁)) (sound _ _ p₂)
 sound-elim Γ .(?[ t ] F) H (?-E {t} {F} p) = inf-V (traverse-hypos (sub (ι t F) F => H) (?[ t ] F => H) Γ (inf-V (lem9 (?[ t ] F) (sub (ι t F) F) H) (ax-11-s {_} {_} {_} {F}))) (sound-elim Γ (sub (ι t F) F) H p)
 sound-elim Γ .(?'[ t ] F) H (?'-E {t} {F} p) = inf-V (traverse-hypos ((F · ι' _ F) => H) (?'[ t ] F => H) Γ (inf-V (lem9 (?'[ t ] F) (F · ι' t F) H) (ax-11-s2 F))) (sound-elim Γ (F · ι' _ F) H p)
 sound-elim Γ .(F ((^[ t ] G) · H)) I (reduce {t} {u} {F} {G} {H} p) = inf-V (traverse-hypos (F (sub H G) => I) (F ((^[ t ] G) · H) => I) Γ (inf-V (lem9 (F ((^[ t ] G) · H)) (F (sub H G)) I) (inf-II-samectx (λ x → (F x)) G H))) (sound-elim Γ (F (sub H G)) I p)
 sound-elim Γ .(F == G) H (r-bool-ext {F} {G} p) = inf-V (traverse-hypos (((F => G) & (G => F)) => H) ((F == G) => H) Γ (inf-V (lem9 (F == G) ((F => G) & (G => F)) H) (inf-V (lem2 (F == G) (F => G) (G => F)) (inf-V (inf-V (lemb1 ((F == G) => (F => G)) ((F == G) => (G => F))) (inf-V ax-3-s (inf-V (inf-V ax-4-s (inf-V (lem5 (F == G) (G == F)) (lem15 F G))) (inf-V ax-3-s (lem13 F G))))) (lem13 G F))))) (sound-elim Γ ((F => G) & (G => F)) H p)
 sound-elim Γ .(F == G) H (r-fun-ext {t} {u} {F} {G} I p) = inf-V (traverse-hypos (((F · I) == (G · I)) => H) ((F == G) => H) Γ (inf-V (lem9 (F == G) ((F · I) == (G · I)) H) (inf-V (inf-V (lem4 (F == G) (I == I) ((F · I) == (G · I))) (lem16 F G I I)) (lem12 I)))) (sound-elim Γ ((F · I) == (G · I)) H p)

 sound-== : ∀ {n Γ-t} → (Γ : FSC-Ctx n Γ-t) (t : Type n) (F G : Form Γ-t t) →
  Γ ⊢ t ∋ F == G →
  ⊢ (hypos Γ (F == G))
 sound-== Γ t F G (simp p) = sound-↔ Γ t F G p
 sound-== Γ t F G (step F' G' x p₁ p₂ p₃) = inf-V (inf-V (inf-V (traverse-hypos3 (F == F') (F' == G') (G' == G) (F == G) Γ (lem14 F F' G' G)) (sound-↔ Γ t F F' p₂)) (inf-V (traverse-hypos-elim (F' == G') Γ x) (sound-==-elim Γ (lookup-hyp Γ x) t F' G' p₁))) (sound-== Γ t G' G p₃)
 sound-== Γ .$o F G (bool-ext p) = inf-V (traverse-hypos ((F => G) & (G => F)) (F == G) Γ ax-10-a-s) (sound _ _ p)
 sound-== Γ .(t > u) F G (fun-ext {t} {u} p) = inf-V (traverse-hypos (![ t ] (((weak F) · $ this {refl}) == ((weak G) · $ this {refl}))) (F == G) Γ ax-10-b-s2) (traverse-=>-I-dep t ((weak F · $ this {refl}) == (weak G · $ this {refl})) Γ (inf-VI-s (sound-== (t ∷ Γ) u (weak F · $ this {refl}) (weak G · $ this {refl}) p)))

 sound-↔ : ∀ {n Γ-t} → (Γ : FSC-Ctx n Γ-t) (t : Type n) (F G : Form Γ-t t) →
  Γ ⊢ t ∋ F ↔ G →
  ⊢ (hypos Γ (F == G))
 sound-↔ Γ t .(var x p) .(var x p) (head-var ._ x p) = traverse-hypos-use (var x p == var x p) Γ (lem12 (var x p))
 sound-↔ Γ .t .c .c (head-const t c) = traverse-hypos-use (c == c) Γ (lem12 c)
 sound-↔ Γ .t₂ .(F₁ · G₁) .(F₂ · G₂) (head-app t₁ t₂ F₁ F₂ G₁ G₂ p₁ p₂) = inf-V (inf-V (traverse-hypos2 (F₁ == F₂) (G₁ == G₂) ((F₁ · G₁) == (F₂ · G₂)) Γ (lem16 F₁ F₂ G₁ G₂)) (sound-== Γ _ F₁ F₂ p₁)) (sound-== Γ _ G₁ G₂ p₂)
 sound-↔ Γ .(t₁ > t₂) .(lam t₁ F₁) .(lam t₁ F₂) (head-lam t₁ t₂ F₁ F₂ p) = traverse-hypos-eq-=>-I F₁ F₂ Γ (sound-== (t₁ ∷ Γ) t₂ F₁ F₂ p)
 sound-↔ Γ .(t₁ > t₂) .F₁ .(lam t₁ F₂) (head-lam-eta-left t₁ t₂ F₁ F₂ p) = inf-V (traverse-hypos (![ t₁ ] ((weak F₁ · $ this {refl}) == F₂)) (F₁ == lam t₁ F₂) Γ (inf-V (inf-V ax-4-s ax-10-b-s2) (subst (λ z → ⊢ ((![ t₁ ] ((weak F₁ · $ this {refl}) == z)) => (![ t₁ ] ((weak F₁ · $ this {refl}) == (weak (^[ t₁ ] F₂) · $ this {refl}))))) (sub-sub-weak-weak-p-3 F₂) (inf-III _ (t₁ ∷ ε) (λ z → ![ t₁ ] ((weak F₁ · $ this {refl}) == z)) (weak-i (t₁ ∷ ε) _ F₂) ($ this {refl}))))) (tst3' {_} {_} {ε} ((weak F₁ · $ this {refl}) == F₂) Γ refl (sound-== (t₁ ∷ Γ) t₂ (weak F₁ · $ this {refl}) F₂ p))
 sound-↔ Γ .(t₁ > t₂) .(lam t₁ F₂) .F₁ (head-lam-eta-right t₁ t₂ F₁ F₂ p) = inf-V (traverse-hypos (![ t₁ ] (F₂ == (weak F₁ · $ this {refl}))) (lam t₁ F₂ == F₁) Γ (inf-V (inf-V ax-4-s ax-10-b-s2) (subst (λ z → ⊢ ((![ t₁ ] (z == (weak F₁ · $ this {refl}))) => (![ t₁ ] ((weak (^[ t₁ ] F₂) · $ this {refl}) == (weak F₁ · $ this {refl}))))) (sub-sub-weak-weak-p-3 F₂) (inf-III _ (t₁ ∷ ε) (λ z → ![ t₁ ] (z == (weak F₁ · $ this {refl}))) (weak-i (t₁ ∷ ε) _ F₂) ($ this {refl}))))) (tst3' {_} {_} {ε} (F₂ == (weak F₁ · $ this {refl})) Γ refl (sound-== (t₁ ∷ Γ) t₂ F₂ (weak F₁ · $ this {refl}) p))
 sound-↔ Γ t .(F₁ ((^[ u ] G') · H)) G (reduce-l {.t} {u} {v} {F₁} {G'} {H} p) = inf-V (traverse-hypos (F₁ (sub H G') == G) (F₁ ((^[ u ] G') · H) == G) Γ (inf-III-samectx (λ x → (F₁ x == G)) G' H)) (sound-↔ Γ t (F₁ (sub H G')) G p)
 sound-↔ Γ t F .(F₂ ((^[ u ] G) · H)) (reduce-r {.t} {u} {v} {F₂} {G} {H} p) = inf-V (traverse-hypos (F == F₂ (sub H G)) (F == F₂ ((^[ u ] G) · H)) Γ (inf-III-samectx (λ x → (F == F₂ x)) G H)) (sound-↔ Γ t F (F₂ (sub H G)) p)

 sound-==-elim : ∀ {n Γ-t} → (Γ : FSC-Ctx n Γ-t) (F : Form Γ-t $o) (t : Type n) (G H : Form Γ-t t) →
  Γ , F ⊢ G == H →
  ⊢ (hypos Γ (F => (G == H)))
 sound-==-elim Γ .(G == H) t G H use = traverse-hypos-use ((G == H) => (G == H)) Γ (inf-V (inf-V ax-4-s ax-1-s) ax-2-s)
 sound-==-elim Γ F t G H (use' p) = traverse-hypos-use (F => (G == H)) Γ (hn-form (λ z → z => (G == H)) _ 2 (subst (λ z → ⊢ (z => (G == H))) p (hn-form (λ z → headNorm 2 (G == H) => z) _ 2 (inf-V (inf-V ax-4-s ax-1-s) ax-2-s))))
 sound-==-elim Γ .(H == G) t G H use-sym = traverse-hypos-use ((H == G) => (G == H)) Γ (lem15 H G)
 sound-==-elim Γ .(F & G') t G H (&-E-l {F} {G'} p) = inf-V (traverse-hypos (F => (G == H)) ((F & G') => (G == H)) Γ (lem6 F G' (G == H))) (sound-==-elim Γ F t G H p)
 sound-==-elim Γ .(F & G') t G H (&-E-r {F} {G'} p) = inf-V (traverse-hypos (G' => (G == H)) ((F & G') => (G == H)) Γ (lem6b F G' (G == H))) (sound-==-elim Γ G' t G H p)
 sound-==-elim Γ .(F => G') t G H (=>-E {F} {G'} p₁ p₂) = inf-V (inf-V (traverse-hypos2 F (G' => (G == H)) ((F => G') => (G == H)) Γ (lem7 F G' (G == H))) (sound Γ F p₁)) (sound-==-elim Γ G' t G H p₂)
 sound-==-elim Γ .(![ u ] F) t G H (!-E {u} {F} G' p) = inf-V (traverse-hypos (sub G' F => (G == H)) (![ u ] F => (G == H)) Γ (inf-V (lem9 (![ u ] F) (sub G' F) (G == H)) (ax-5-s F G'))) (sound-==-elim Γ (sub G' F) t G H p)
 sound-==-elim Γ .(!'[ u ] F) t G H (!'-E {u} {F} G' p) = inf-V (traverse-hypos ((F · G') => (G == H)) (!'[ u ] F => (G == H)) Γ (inf-V (lem9 (!'[ u ] F) (F · G') (G == H)) (ax-5-s3 F G'))) (sound-==-elim Γ (F · G') t G H p)
 sound-==-elim Γ .(?[ u ] F) t G H (?-E {u} {F} p) = inf-V (traverse-hypos (sub (ι u F) F => (G == H)) (?[ u ] F => (G == H)) Γ (inf-V (lem9 (?[ u ] F) (sub (ι u F) F) (G == H)) (ax-11-s {_} {_} {_} {F}))) (sound-==-elim Γ (sub (ι u F) F) t G H p)
 sound-==-elim Γ .(?'[ u ] F) t G H (?'-E {u} {F} p) = inf-V (traverse-hypos ((F · ι' u F) => (G == H)) (?'[ u ] F => (G == H)) Γ (inf-V (lem9 (?'[ u ] F) (F · ι' u F) (G == H)) (ax-11-s2 F))) (sound-==-elim Γ (F · ι' u F) t G H p)
 sound-==-elim Γ .(F ((^[ u ] G') · H')) t G H (reduce {u} {v} {F} {G'} {H'} p) = inf-V (traverse-hypos (F (sub H' G') => (G == H)) (F ((^[ u ] G') · H') => (G == H)) Γ (inf-V (lem9 (F ((^[ u ] G') · H')) (F (sub H' G')) (G == H)) (inf-II-samectx (λ x → (F x)) G' H'))) (sound-==-elim Γ (F (sub H' G')) t G H p)
 sound-==-elim Γ .(F == G) t H I (r-bool-ext {F} {G} p) = inf-V (traverse-hypos (((F => G) & (G => F)) => (H == I)) ((F == G) => (H == I)) Γ (inf-V (lem9 (F == G) ((F => G) & (G => F)) (H == I)) (inf-V (lem2 (F == G) (F => G) (G => F)) (inf-V (inf-V (lemb1 ((F == G) => (F => G)) ((F == G) => (G => F))) (inf-V ax-3-s (inf-V (inf-V ax-4-s (inf-V (lem5 (F == G) (G == F)) (lem15 F G))) (inf-V ax-3-s (lem13 F G))))) (lem13 G F))))) (sound-==-elim Γ ((F => G) & (G => F)) t H I p)
 sound-==-elim Γ .(F == G) t H I (r-fun-ext {u} {v} {F} {G} J p) = inf-V (traverse-hypos (((F · J) == (G · J)) => (H == I)) ((F == G) => (H == I)) Γ (inf-V (lem9 (F == G) ((F · J) == (G · J)) (H == I)) (inf-V (inf-V (lem4 (F == G) (J == J) ((F · J) == (G · J))) (lem16 F G J J)) (lem12 J)))) (sound-==-elim Γ ((F · J) == (G · J)) t H I p)

sound-top : {n : ℕ} (F : Form {n} ε $o) →
            ε ⊢ F →
            ⊢ F
sound-top = sound ε


{-# OPTIONS --universe-polymorphism #-}

open import Data.Bool using ( Bool ; true ; false ; _∧_ )
open import Data.Empty using ()
open import Data.List using ( List ; [] ; _∷_ ; _++_ ; map )
open import Data.List.Any using ( here ; there )
open import Data.List.Membership.Propositional using ()
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Data.Product using ( ∃ ; ∄ ; _×_ ; _,_ )
open import Data.Unit using ()
open import Level using ( zero )
open import Relation.Binary using ()
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Relation.Nullary using ( Dec ; yes ; no )
open import Relation.Unary using ( _∈_ ; _⊆_ )

module Web.Semantic.Util where

infixr 9 _∘_

id : ∀ {X : Set} → X → X
id x = x

_∘_ : ∀ {X Y Z : Set} → (Y → Z) → (X → Y) → (X → Z)
(f ∘ g) = λ x → f (g x)

Setoid : Set₁
Setoid = Relation.Binary.Setoid zero zero

Subset : Set → Set₁
Subset X = X → Set

⁅_⁆ : ∀ {X} → X → Subset X
⁅ x ⁆ y = x ≡ y

⊆-refl : ∀ {X} (P : Subset X) → (P ⊆ P)
⊆-refl P x∈P = x∈P

_⁻¹ :  ∀ {X Y : Set} → Subset (X × Y) → Subset (Y × X)
(R ⁻¹) (y , x) = R (x , y)

-- Some proofs are classical, and depend on excluded middle.

ExclMiddle : Set₁
ExclMiddle = ∀ (X : Set) → Dec X

ExclMiddle₁ : Set₂
ExclMiddle₁ = ∀ (X : Set₁) → Dec X

smaller-excl-middle : ExclMiddle₁ → ExclMiddle
smaller-excl-middle excl-middle₁ X = X? where

  data Large : Set₁ where
    large : X → Large

  X? : Dec X
  X? with excl-middle₁ Large
  X? | yes (large x) = yes x
  X? | no ¬x         = no (λ x → ¬x (large x))

-- Some nameclashes between the standard library and semantic web terminology:
-- ⊤ and ⊥ are used for concepts, and T is used to range over T-Boxes.

open Data.Bool public using () renaming ( T to □ )
open Data.Empty public using () renaming ( ⊥ to False ; ⊥-elim to elim )
open Data.Unit public using ( tt ) renaming ( ⊤ to True )

□-proj₁ : ∀ {b c} → □(b ∧ c) → □ b
□-proj₁ {true}  □c = tt
□-proj₁ {false} ()

□-proj₂ : ∀ {b c} → □(b ∧ c) → □ c
□-proj₂ {true}  □c = □c
□-proj₂ {false} ()

-- Convert back and forth from Dec and Bool.

is : ∀ {ℓ} {X : Set ℓ} → Dec X → Bool
is (yes _) = true
is (no _) = false

is✓ : ∀ {ℓ} {X : Set ℓ} {x : Dec X} → □(is x) → X
is✓ {ℓ} {X} {yes x} _ = x
is✓ {ℓ} {X} {no _} ()

is! : ∀ {ℓ} {X : Set ℓ} {x : Dec X} → X → □(is x)
is! {ℓ} {X} {yes _} x = tt
is! {ℓ} {X} {no ¬x} x = ¬x x

-- Finite sets are ones backed by a list

open Data.List.Membership.Propositional  public using () renaming ( _∈_ to _∈ˡ_ )

Finite : Set → Set
Finite X = ∃ λ xs → ∀ (x : X) → (x ∈ˡ xs)

False∈Fin : False ∈ Finite
False∈Fin = ([] , λ ())

⊎-resp-Fin : ∀ {X Y} → (X ∈ Finite) → (Y ∈ Finite) → ((X ⊎ Y) ∈ Finite)
⊎-resp-Fin {X} {Y} (xs , ∀x∙x∈xs) (ys , ∀y∙y∈ys) =
  ((map inj₁ xs ++ map inj₂ ys) , lemma) where

  lemma₁ : ∀ {x : X} {xs : List X} →
    (x ∈ˡ xs) → (inj₁ x ∈ˡ (map inj₁ xs ++ map inj₂ ys))
  lemma₁ (here refl) = here refl
  lemma₁ (there x∈xs) = there (lemma₁ x∈xs)

  lemma₂ : ∀ (xs : List X) {y : Y} {ys : List Y} →
    (y ∈ˡ ys) → (inj₂ y ∈ˡ (map inj₁ xs ++ map inj₂ ys))
  lemma₂ [] (here refl) = here refl
  lemma₂ [] (there y∈ys) = there (lemma₂ [] y∈ys)
  lemma₂ (x ∷ xs) y∈ys = there (lemma₂ xs y∈ys)

  lemma : ∀ x → (x ∈ˡ (map inj₁ xs ++ map inj₂ ys))
  lemma (inj₁ x) = lemma₁ (∀x∙x∈xs x)
  lemma (inj₂ y) = lemma₂ xs (∀y∙y∈ys y)

-- symmetric monoidal structure of sum

_⟨⊎⟩_ : ∀ {W X Y Z : Set} → (W → X) → (Y → Z) → (W ⊎ Y) → (X ⊎ Z)
_⟨⊎⟩_ f g (inj₁ x) = inj₁ (f x)
_⟨⊎⟩_ f g (inj₂ y) = inj₂ (g y)

_≡⊎≡_ : ∀ {X Y Z : Set} {f g : (X ⊎ Y) → Z} →
  (∀ x → (f (inj₁ x) ≡ g (inj₁ x))) → (∀ x → (f (inj₂ x) ≡ g (inj₂ x))) →
    ∀ x → (f x ≡ g x)
(f₁≡g₁ ≡⊎≡ f₂≡g₂) (inj₁ x) = f₁≡g₁ x
(f₁≡g₁ ≡⊎≡ f₂≡g₂) (inj₂ y) = f₂≡g₂ y

⊎-swap : ∀ {X Y : Set} → (X ⊎ Y) → (Y ⊎ X)
⊎-swap (inj₁ x) = inj₂ x
⊎-swap (inj₂ y) = inj₁ y

⊎-assoc : ∀ {X Y Z : Set} → ((X ⊎ Y) ⊎ Z) → (X ⊎ (Y ⊎ Z))
⊎-assoc (inj₁ (inj₁ x)) = inj₁ x
⊎-assoc (inj₁ (inj₂ y)) = inj₂ (inj₁ y)
⊎-assoc (inj₂ z) = inj₂ (inj₂ z)

⊎-assoc⁻¹ : ∀ {X Y Z : Set} → (X ⊎ (Y ⊎ Z)) → ((X ⊎ Y) ⊎ Z)
⊎-assoc⁻¹ (inj₁ x) = inj₁ (inj₁ x)
⊎-assoc⁻¹ (inj₂ (inj₁ y)) = inj₁ (inj₂ y)
⊎-assoc⁻¹ (inj₂ (inj₂ z)) = inj₂ z

⊎-unit₁ : ∀ {X : Set} → (False ⊎ X) → X
⊎-unit₁ (inj₁ ())
⊎-unit₁ (inj₂ x) = x

⊎-unit₂ : ∀ {X : Set} → (X ⊎ False) → X
⊎-unit₂ (inj₁ x) = x
⊎-unit₂ (inj₂ ())

inj⁻¹ : ∀ {X : Set} → (X ⊎ X) → X
inj⁻¹ (inj₁ x) = x
inj⁻¹ (inj₂ x) = x

-- A set divided, like Gaul, into three parts

infix 6 _⊕_⊕_

data _⊕_⊕_ (X V Y : Set) : Set where
  inode : (x : X) → (X ⊕ V ⊕ Y) -- Imported node
  bnode : (v : V) → (X ⊕ V ⊕ Y) -- Blank node
  enode : (y : Y) → (X ⊕ V ⊕ Y) -- Exported node

_⟨⊕⟩_⟨⊕⟩_ : ∀ {U V W X Y Z} → (W → X) → (U → V) → (Y → Z) →
  (W ⊕ U ⊕ Y) → (X ⊕ V ⊕ Z)
(f ⟨⊕⟩ g ⟨⊕⟩ h) (inode w) = inode (f w)
(f ⟨⊕⟩ g ⟨⊕⟩ h) (bnode u) = bnode (g u)
(f ⟨⊕⟩ g ⟨⊕⟩ h) (enode y) = enode (h y)

_[⊕]_[⊕]_ : ∀ {X V Y Z : Set} → (X → Z) → (V → Z) → (Y → Z) →
   (X ⊕ V ⊕ Y) → Z
(f [⊕] g [⊕] h) (inode x) = f x
(f [⊕] g [⊕] h) (bnode v) = g v
(f [⊕] g [⊕] h) (enode y) = h y

left : ∀ {V W X Y Z} → (X ⊕ V ⊕ Y) → (X ⊕ (V ⊕ Y ⊕ W) ⊕ Z)
left (inode x) = inode x
left (bnode v) = bnode (inode v)
left (enode y) = bnode (bnode y)

right : ∀ {V W X Y Z} → (Y ⊕ W ⊕ Z) → (X ⊕ (V ⊕ Y ⊕ W) ⊕ Z)
right (inode y) = bnode (bnode y)
right (bnode w) = bnode (enode w)
right (enode z) = enode z

hmerge : ∀ {V W X Y Z A : Set} →
  ((X ⊕ V ⊕ Y) → A) → ((Y ⊕ W ⊕ Z) → A) →
    (X ⊕ (V ⊕ Y ⊕ W) ⊕ Z) → A
hmerge f g (inode x)         = f (inode x)
hmerge f g (bnode (inode v)) = f (bnode v)
hmerge f g (bnode (bnode y)) = g (inode y)
hmerge f g (bnode (enode w)) = g (bnode w)
hmerge f g (enode z)         = g (enode z)

→-dist-⊕ : ∀ {V X Y Z : Set} → ((X ⊕ V ⊕ Y) → Z) →
  ((X → Z) × (V → Z) × (Y → Z))
→-dist-⊕ i = ((i ∘ inode) , (i ∘ bnode) , (i ∘ enode))

up : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (X₁ ⊕ V₁ ⊕ Y₁) →
  ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))
up (inode x) = inode (inj₁ x)
up (bnode v) = bnode (inj₁ v)
up (enode y) = enode (inj₁ y)

down : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (X₂ ⊕ V₂ ⊕ Y₂) →
  ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))
down (inode x) = inode (inj₂ x)
down (bnode v) = bnode (inj₂ v)
down (enode y) = enode (inj₂ y)

vmerge : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂ A : Set} →
  ((X₁ ⊕ V₁ ⊕ Y₁) → A) → ((X₂ ⊕ V₂ ⊕ Y₂) → A) →
    ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂)) → A
vmerge j k (inode (inj₁ x)) = j (inode x)
vmerge j k (inode (inj₂ x)) = k (inode x)
vmerge j k (bnode (inj₁ v)) = j (bnode v)
vmerge j k (bnode (inj₂ v)) = k (bnode v)
vmerge j k (enode (inj₁ y)) = j (enode y)
vmerge j k (enode (inj₂ y)) = k (enode y)


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

module Dodo.Unary.Intersection where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (refl; _≡_)
open import Level using (Level; _⊔_)
open import Function using (_∘₂_)
open import Data.Product using (_×_; _,_; swap; proj₁; proj₂)
open import Relation.Unary using (Pred)
open import Relation.Binary using (Rel; REL)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Unary.Unique

-- # Definitions

infixr 30 _∩₁_

_∩₁_ : {a ℓ₁ ℓ₂ : Level} {A : Set a}
  → Pred A ℓ₁
  → Pred A ℓ₂
  → Pred A (ℓ₁ ⊔ ℓ₂)
_∩₁_ p q x = p x × q x

-- # Properties

module _ {a ℓ : Level} {A : Set a} {P : Pred A ℓ} where

  ∩₁-idem : (P ∩₁ P) ⇔₁ P
  ∩₁-idem = ⇔: (λ _ → proj₁) ⊇-proof
    where
    ⊇-proof : P ⊆₁' (P ∩₁ P)
    ⊇-proof _ Px = (Px , Px)

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {Q : Pred A ℓ₂} where

  ∩₁-comm : (P ∩₁ Q) ⇔₁ (Q ∩₁ P)
  ∩₁-comm = ⇔: (λ _ → swap) (λ _ → swap)

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
  {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∩₁-assoc : P ∩₁ (Q ∩₁ R) ⇔₁ (P ∩₁ Q) ∩₁ R
  ∩₁-assoc = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : P ∩₁ (Q ∩₁ R) ⊆₁' (P ∩₁ Q) ∩₁ R
    ⊆-proof _ (Px , Qx , Rx) = ((Px , Qx) , Rx)
    ⊇-proof : (P ∩₁ Q) ∩₁ R ⊆₁' P ∩₁ (Q ∩₁ R)
    ⊇-proof _ ((Px , Qx) , Rx) = (Px , Qx , Rx)

-- # Operations

-- ## Operations: General

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {Q : Pred A ℓ₂} where

  ∩₁-unique-pred :
      UniquePred P
    → UniquePred Q
    → UniquePred (P ∩₁ Q)
  ∩₁-unique-pred uniqueP uniqueQ x (Px₁ , Qx₁) (Px₂ , Qx₂)
    with uniqueP x Px₁ Px₂ | uniqueQ x Qx₁ Qx₂
  ... | refl | refl = refl

-- ## Operations: ⊆₁

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∩₁-combine-⊆₁ : P ⊆₁ Q → P ⊆₁ R → P ⊆₁ (Q ∩₁ R)
  ∩₁-combine-⊆₁ (⊆: P⊆Q) (⊆: P⊆R) = ⊆: (λ x Px → (P⊆Q x Px , P⊆R x Px))

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∩₁-introˡ-⊆₁ : (P ∩₁ Q) ⊆₁ P
  ∩₁-introˡ-⊆₁ = ⊆: (λ _ → proj₁)

  ∩₁-introʳ-⊆₁ : (P ∩₁ Q) ⊆₁ Q
  ∩₁-introʳ-⊆₁ = ⊆: (λ _ → proj₂)

  ∩₁-elimˡ-⊆₁ : P ⊆₁ (Q ∩₁ R) → P ⊆₁ R
  ∩₁-elimˡ-⊆₁ (⊆: P⊆[Q∩R]) = ⊆: (λ x Px → proj₂ (P⊆[Q∩R] x Px))

  ∩₁-elimʳ-⊆₁ : P ⊆₁ (Q ∩₁ R) → P ⊆₁ Q
  ∩₁-elimʳ-⊆₁ (⊆: P⊆[Q∩R]) = ⊆: (λ x Px → proj₁ (P⊆[Q∩R] x Px))

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∩₁-substˡ-⊆₁ : P ⊆₁ Q → (P ∩₁ R) ⊆₁ (Q ∩₁ R)
  ∩₁-substˡ-⊆₁ (⊆: P⊆Q) = ⊆: lemma
    where
    lemma : (P ∩₁ R) ⊆₁' (Q ∩₁ R)
    lemma x (Px , Rx) = (P⊆Q x Px , Rx)

  ∩₁-substʳ-⊆₁ : P ⊆₁ Q → (R ∩₁ P) ⊆₁ (R ∩₁ Q)
  ∩₁-substʳ-⊆₁ (⊆: P⊆Q) = ⊆: lemma
    where
    lemma : (R ∩₁ P) ⊆₁' (R ∩₁ Q)
    lemma x (Rx , Px) = (Rx , P⊆Q x Px)

-- ## Operations: ⇔₂

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∩₁-substˡ : P ⇔₁ Q → (P ∩₁ R) ⇔₁ (Q ∩₁ R)
  ∩₁-substˡ = ⇔₁-compose ∩₁-substˡ-⊆₁ ∩₁-substˡ-⊆₁

  ∩₁-substʳ : P ⇔₁ Q → (R ∩₁ P) ⇔₁ (R ∩₁ Q)
  ∩₁-substʳ = ⇔₁-compose ∩₁-substʳ-⊆₁ ∩₁-substʳ-⊆₁


-- Intuitionistic propositional calculus.
-- Hilbert-style formalisation of closed syntax.
-- Nested terms.

module IPC.Syntax.ClosedHilbert where

open import IPC.Syntax.Common public

-- Derivations.

infix 3 ⊢_
data ⊢_ : Ty → Set where
  app   : ∀ {A B}   → ⊢ A ▻ B → ⊢ A → ⊢ B
  ci    : ∀ {A}     → ⊢ A ▻ A
  ck    : ∀ {A B}   → ⊢ A ▻ B ▻ A
  cs    : ∀ {A B C} → ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
  cpair : ∀ {A B}   → ⊢ A ▻ B ▻ A ∧ B
  cfst  : ∀ {A B}   → ⊢ A ∧ B ▻ A
  csnd  : ∀ {A B}   → ⊢ A ∧ B ▻ B
  unit  : ⊢ ⊤
  cboom : ∀ {C}     → ⊢ ⊥ ▻ C
  cinl  : ∀ {A B}   → ⊢ A ▻ A ∨ B
  cinr  : ∀ {A B}   → ⊢ B ▻ A ∨ B
  ccase : ∀ {A B C} → ⊢ A ∨ B ▻ (A ▻ C) ▻ (B ▻ C) ▻ C

infix 3 ⊢⋆_
⊢⋆_ : Cx Ty → Set
⊢⋆ ∅     = 𝟙
⊢⋆ Ξ , A = ⊢⋆ Ξ × ⊢ A

-- Cut and multicut.

cut : ∀ {A B} → ⊢ A → ⊢ A ▻ B → ⊢ B
cut t u = app u t

multicut : ∀ {Ξ A} → ⊢⋆ Ξ → ⊢ Ξ ▻⋯▻ A → ⊢ A
multicut {∅}     ∙        u = u
multicut {Ξ , B} (ts , t) u = app (multicut ts u) t

-- Contraction.

ccont : ∀ {A B} → ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = app (app cs cs) (app ck ci)

cont : ∀ {A B} → ⊢ A ▻ A ▻ B → ⊢ A ▻ B
cont t = app ccont t

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C} → ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = app (app cs (app (app cs (app ck cs))
                         (app (app cs (app ck ck)) cs)))
            (app ck ck)

exch : ∀ {A B C} → ⊢ A ▻ B ▻ C → ⊢ B ▻ A ▻ C
exch t = app cexch t

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C} → ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = app (app cs (app ck cs)) ck

comp : ∀ {A B C} → ⊢ B ▻ C → ⊢ A ▻ B → ⊢ A ▻ C
comp t u = app (app ccomp t) u

-- Useful theorems in functional form.

pair : ∀ {A B} → ⊢ A → ⊢ B → ⊢ A ∧ B
pair t u = app (app cpair t) u

fst : ∀ {A B} → ⊢ A ∧ B → ⊢ A
fst t = app cfst t

snd : ∀ {A B} → ⊢ A ∧ B → ⊢ B
snd t = app csnd t

boom : ∀ {C} → ⊢ ⊥ → ⊢ C
boom t = app cboom t

inl : ∀ {A B} → ⊢ A → ⊢ A ∨ B
inl t = app cinl t

inr : ∀ {A B} → ⊢ B → ⊢ A ∨ B
inr t = app cinr t

case : ∀ {A B C} → ⊢ A ∨ B → ⊢ A ▻ C → ⊢ B ▻ C → ⊢ C
case t u v = app (app (app ccase t) u) v

-- Convertibility.

data _⋙_ : ∀ {A} → ⊢ A → ⊢ A → Set where
  refl⋙     : ∀ {A} → {t : ⊢ A}
                     → t ⋙ t

  trans⋙    : ∀ {A} → {t t′ t″ : ⊢ A}
                     → t ⋙ t′ → t′ ⋙ t″
                     → t ⋙ t″

  sym⋙      : ∀ {A} → {t t′ : ⊢ A}
                     → t ⋙ t′
                     → t′ ⋙ t

  congapp⋙  : ∀ {A B} → {t t′ : ⊢ A ▻ B} → {u u′ : ⊢ A}
                       → t ⋙ t′ → u ⋙ u′
                       → app t u ⋙ app t′ u′

  congi⋙    : ∀ {A} → {t t′ : ⊢ A}
                     → t ⋙ t′
                     → app ci t ⋙ app ci t′

  congk⋙    : ∀ {A B} → {t t′ : ⊢ A} → {u u′ : ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app ck t) u ⋙ app (app ck t′) u′

  congs⋙    : ∀ {A B C} → {t t′ : ⊢ A ▻ B ▻ C} → {u u′ : ⊢ A ▻ B} → {v v′ : ⊢ A}
                         → t ⋙ t′ → u ⋙ u′ → v ⋙ v′
                         → app (app (app cs t) u) v ⋙ app (app (app cs t′) u′) v′

  congpair⋙ : ∀ {A B} → {t t′ : ⊢ A} → {u u′ : ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app cpair t) u ⋙ app (app cpair t′) u′

  congfst⋙  : ∀ {A B} → {t t′ : ⊢ A ∧ B}
                       → t ⋙ t′
                       → app cfst t ⋙ app cfst t′

  congsnd⋙  : ∀ {A B} → {t t′ : ⊢ A ∧ B}
                       → t ⋙ t′
                       → app csnd t ⋙ app csnd t′

  congboom⋙ : ∀ {C} → {t t′ : ⊢ ⊥}
                     → t ⋙ t′
                     → app (cboom {C = C}) t ⋙ app cboom t′

  conginl⋙  : ∀ {A B} → {t t′ : ⊢ A}
                       → t ⋙ t′
                       → app (cinl {A = A} {B}) t ⋙ app cinl t′

  conginr⋙  : ∀ {A B} → {t t′ : ⊢ B}
                       → t ⋙ t′
                       → app (cinr {A = A} {B}) t ⋙ app cinr t′

  congcase⋙ : ∀ {A B C} → {t t′ : ⊢ A ∨ B} → {u u′ : ⊢ A ▻ C} → {v v′ : ⊢ B ▻ C}
                         → t ⋙ t′ → u ⋙ u′ → v ⋙ v′
                         → app (app (app ccase t) u) v ⋙ app (app (app ccase t′) u′) v′

  -- TODO: Verify this.
  beta▻ₖ⋙   : ∀ {A B} → {t : ⊢ A} → {u : ⊢ B}
                       → app (app ck t) u ⋙ t

  -- TODO: Verify this.
  beta▻ₛ⋙   : ∀ {A B C} → {t : ⊢ A ▻ B ▻ C} → {u : ⊢ A ▻ B} → {v : ⊢ A}
                         → app (app (app cs t) u) v ⋙ app (app t v) (app u v)

  -- TODO: What about eta for ▻?

  beta∧₁⋙   : ∀ {A B} → {t : ⊢ A} → {u : ⊢ B}
                       → app cfst (app (app cpair t) u) ⋙ t

  beta∧₂⋙   : ∀ {A B} → {t : ⊢ A} → {u : ⊢ B}
                       → app csnd (app (app cpair t) u) ⋙ u

  eta∧⋙     : ∀ {A B} → {t : ⊢ A ∧ B}
                       → t ⋙ app (app cpair (app cfst t)) (app csnd t)

  eta⊤⋙    : ∀ {t : ⊢ ⊤} → t ⋙ unit

  -- TODO: Verify this.
  beta∨₁⋙   : ∀ {A B C} → {t : ⊢ A} → {u : ⊢ A ▻ C} → {v : ⊢ B ▻ C}
                         → app (app (app ccase (app cinl t)) u) v ⋙ app u t

  -- TODO: Verify this.
  beta∨₂⋙   : ∀ {A B C} → {t : ⊢ B} → {u : ⊢ A ▻ C} → {v : ⊢ B ▻ C}
                         → app (app (app ccase (app cinr t)) u) v ⋙ app v t

  -- TODO: What about eta and commuting conversions for ∨? What about ⊥?


?bug : Set
?bug = ?

-- Andreas, 2014-04-16
-- Issue 1104 reported by Fabien Renaud.
-- Emacs mode got confused by identifiers containing --

-- Problem: {!!} is not turned into hole

bug-- : Set
bug-- = ?

another : Set
another = (-- Senfgurke ?
           {!!})-- Noch eine Senfgurke ?

_:--_ : Set → Set → Set
_:--_ = {!!}

bla = let x = Set ;-- bla ?
                   y = Set in  Set

bug? : Set
bug? = {!!}


open import OutsideIn.Prelude
module OutsideIn.X where
   open import Data.Product public hiding (map)
   open import Relation.Nullary

   record Types : Set₁ where
     field Type : Set → Set
           type-is-monad : Monad Type
           funType : ∀ {n} → Type n → Type n → Type n
           appType : ∀ {n} → Type n → Type n → Type n
     type-is-functor = Monad.is-functor type-is-monad

   record QConstraints ⦃ types : Types ⦄ : Set₁ where
     open Types(types)
     field QConstraint : Set → Set
           qconstraint-is-functor : Functor QConstraint
           _∼_ : ∀ {n} → Type n → Type n → QConstraint n
           _∧_ : ∀ {n} → QConstraint n → QConstraint n → QConstraint n
           ε : ∀ {n} → QConstraint n
           constraint-types : ∀ {a b} → (Type a → Type b) → QConstraint a → QConstraint b
           is-ε : ∀ {n} (x : QConstraint n) → Dec (x ≡ ε)
     open Monad   (type-is-monad)
     open Functor (is-functor)
     qc-substitute : ∀{a b} →  (a → Type b) → (QConstraint a → QConstraint b)
     qc-substitute f =  constraint-types (join ∘ map f)

   record AxiomSchemes ⦃ types : Types ⦄ : Set₁ where
     open Types(types)
     field AxiomScheme : Set → Set
           axiomscheme-is-functor : Functor AxiomScheme
           axiomscheme-types : ∀ {a b} → (Type a → Type b) → AxiomScheme a → AxiomScheme b
     open Monad   (type-is-monad)
     open Functor (is-functor)
     ax-substitute : ∀{a b} →  (a → Type b) → (AxiomScheme a → AxiomScheme b)
     ax-substitute f =  axiomscheme-types (join ∘ map f)

   record Entailment ⦃ types : Types ⦄ ⦃ axiomschemes : AxiomSchemes ⦄ ⦃ qconstraints : QConstraints ⦄ : Set₁ where
     open Types(types)
     open AxiomSchemes(axiomschemes)
     open QConstraints(qconstraints)

     open Monad(type-is-monad)
     open Functor(type-is-functor)

     field _,_⊩_ : ∀ {n} → AxiomScheme n → QConstraint n → QConstraint n → Set
           ent-refl : ∀ {n}{Q : AxiomScheme n}{q q′ : QConstraint n}
                    → Q , (q ∧ q′) ⊩ q′
           ent-trans : ∀ {n}{Q : AxiomScheme n}{q q₁ q₂ q₃ : QConstraint n}
                     → Q , (q ∧ q₁) ⊩ q₂ → Q , (q ∧ q₂) ⊩ q₃ → Q , (q ∧ q₁) ⊩ q₃
           ent-subst : ∀ {a b}{θ : a → Type b}{Q : AxiomScheme a}{q q₁ q₂ : QConstraint a}
                     → Q , (q ∧ q₁) ⊩ q₂ → axiomscheme-types (join ∘ map θ) Q
                                         , constraint-types (join ∘ map θ) (q ∧ q₁)
                                         ⊩ constraint-types (join ∘ map θ) q₂
           ent-typeq-refl : ∀ {n}{Q : AxiomScheme n}{q : QConstraint n}{τ : Type n}
                          → Q , q ⊩ (τ ∼ τ)
           ent-typeq-sym : ∀ {n}{Q : AxiomScheme n}{q : QConstraint n}{τ₁ τ₂ : Type n}
                         → Q , q ⊩ (τ₁ ∼ τ₂) → Q , q ⊩ (τ₂ ∼ τ₁)
           ent-typeq-trans : ∀ {n}{Q : AxiomScheme n}{q : QConstraint n}{τ₁ τ₂ τ₃ : Type n}
                           → Q , q ⊩ (τ₁ ∼ τ₂) → Q , q ⊩ (τ₂ ∼ τ₃) → Q , q ⊩ (τ₁ ∼ τ₃)
           ent-typeq-subst : ∀ {a b}{Q : AxiomScheme a}{q : QConstraint a}{τ₁ τ₂ : Type a}{θ : a → Type b}
                         → Q , q ⊩ (τ₁ ∼ τ₂) → axiomscheme-types (join ∘ map θ) Q
                                             , constraint-types (join ∘ map θ) q  ⊩ ((join ∘ map θ) τ₁ ∼ (join ∘ map θ) τ₂)
           ent-conj : ∀ {n}{Q : AxiomScheme n}{q q₁ q₂ : QConstraint n}
                           → Q , q ⊩ q₁ → Q , q ⊩ q₂ → Q , q ⊩ (q₁ ∧ q₂)

   module SimplificationPrelude ⦃ types : Types ⦄
                                ⦃ axiomschemes : AxiomSchemes ⦄
                                ⦃ qconstraints : QConstraints ⦄
                                ⦃ entailment   : Entailment   ⦄ where
     open Types(types)
     open AxiomSchemes(axiomschemes)
     open QConstraints(qconstraints)
     open Entailment(entailment)

     data SimplifierResult′ (x : Set)( n m : ℕ ) : QConstraint (x ⨁ m) → Set where
       solved : (q : QConstraint (x ⨁ m)) → (x ⨁ n → Type (x ⨁ m)) → SimplifierResult′ x n m q

     SimplifierResult : Set → ℕ → Set
     SimplifierResult x n = ∃ (λ m → ∃ (SimplifierResult′ x n m))

     SimplifierResultNoResidual : Set → ℕ → Set
     SimplifierResultNoResidual x n = ∃ (λ m → SimplifierResult′ x n m ε)

     IsSound′ : ∀ {x : Set}{n m : ℕ}{Qr : QConstraint (x ⨁ m)}
                  (Q : AxiomScheme (x ⨁ m))(Qg : QConstraint (x ⨁ m))
                  (Qw : QConstraint (x ⨁ n))(s : SimplifierResult′ x n m Qr) → Set
     IsSound′ Q Qg Qw (solved Qr θ) = Q , Qg ∧ Qr ⊩ qc-substitute θ Qw

     IsSound : ∀ {x : Set}{n : ℕ}
                 (Q : AxiomScheme x)(Qg : QConstraint x)
                 (Qw : QConstraint (x ⨁ n))(s : SimplifierResult x n) → Set
     IsSound {x}{n} Q Qg Qw (m , .Qr , solved Qr θ) = IsSound′ {n = n}{m = m} (Ax-f.map pm-m.unit Q) (Qc-f.map pm-m.unit Qg) Qw (solved Qr θ)
        where module Ax-f = Functor(axiomscheme-is-functor)
              module Qc-f = Functor(qconstraint-is-functor)
              module pm-m = Monad(PlusN-is-monad {m})

   record Simplification ⦃ types : Types ⦄
                         ⦃ axiomschemes : AxiomSchemes ⦄
                         ⦃ qconstraints : QConstraints ⦄
                         ⦃ entailment   : Entailment   ⦄ : Set₁ where
     open Types(types)
     open AxiomSchemes(axiomschemes)
     open QConstraints(qconstraints)
     open Entailment(entailment)
     open SimplificationPrelude

     field simplifier : ∀ {x : Set} → Eq x → (n : ℕ) → AxiomScheme x
                      → QConstraint x → QConstraint (x ⨁ n) → SimplifierResult x n

     field simplifier-sound : ∀ {x : Set}{n : ℕ}{eq : Eq x}
                 (Q : AxiomScheme x)(Qg : QConstraint x)
                 (Qw : QConstraint (x ⨁ n)) → IsSound Q Qg Qw (simplifier eq n Q Qg Qw)

     simplifier′ : ∀ {x : Set} → Eq x → (n : ℕ) → AxiomScheme x
                 → QConstraint x → QConstraint (x ⨁ n) → Ⓢ (SimplifierResultNoResidual x n)
     simplifier′ eq n ax g e with simplifier eq n ax g e
     simplifier′ eq n ax g e | m , Qr , result with is-ε Qr
     simplifier′ eq n ax g e | m , .ε , result | yes refl = suc (m , result)
     simplifier′ eq n ax g e | m , Qr , result | no  p = zero

   record X : Set₂ where
     field dc : ℕ → Set
     field types : Types
     field axiom-schemes : AxiomSchemes
     field qconstraints : QConstraints
     field entailment : Entailment
     field simplification : Simplification
     open Types(types) public
     open AxiomSchemes(axiom-schemes) public
     open QConstraints(qconstraints) public
     open Entailment(entailment) public
     open Simplification(simplification) public
     open SimplificationPrelude public


module Data.Maybe.Primitive where
{-# IMPORT Data.Maybe #-}

-- In Agda 2.2.10 and below, there's no FFI binding for the stdlib
-- Maybe type, so we have to roll our own. This will change.

data #Maybe (X : Set) : Set where
  just : X → #Maybe X
  nothing : #Maybe X
{-# COMPILED_DATA #Maybe Data.Maybe.Maybe Data.Maybe.Just Data.Maybe.Nothing #-}


{-# OPTIONS --universe-polymorphism #-}
module Literals where

open import Common.Nat
open import Common.Float
open import Common.Char
open import Common.String
open import Common.Unit
open import Common.IO

afloat : Float
afloat = 1.23

astring : String
astring = "abc"

achar : Char
achar = 'd'

anat : Nat
anat = 123

main : IO Unit
main =
  printFloat  afloat  ,,
  putStr      astring ,,
  printChar   achar   ,,
  printNat    anat    ,,
  putStrLn ""


{-

Transferring properties of terms between equivalent structures

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Transfer where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Transport
open import Cubical.Structures.Product

private
  variable
    ℓ ℓ₀ ℓ₁ ℓ₂ ℓ₂' : Level

transfer : {ℓ₂' ℓ₀ : Level} {S : Type ℓ → Type ℓ₁} {H : Type ℓ → Type ℓ₂}
  (P : ∀ X → S X → H X → Type ℓ₀)
  (α : EquivAction H) (τ : TransportStr α)
  (ι : StrEquiv S ℓ₂') (θ : UnivalentStr S ι)
  {X Y : Type ℓ} {s : S X} {t : S Y}
  (e : (X , s) ≃[ ι ] (Y , t))
  → (h : H Y) → P X s (invEq (α (e .fst)) h) → P Y t h
transfer P α τ ι θ {X} {Y} {s} {t} e h =
  subst (λ {(Z , u , h) → P Z u h})
    (sip
      (productUnivalentStr ι θ (EquivAction→StrEquiv α)  (TransportStr→UnivalentStr α τ))
      (X , s , invEq (α (e .fst)) h)
      (Y , t , h)
      (e .fst , e .snd , retEq (α (e .fst)) h))

transfer⁻ : {ℓ₂' ℓ₀ : Level} {S : Type ℓ → Type ℓ₁} {H : Type ℓ → Type ℓ₂}
  (P : ∀ X → S X → H X → Type ℓ₀)
  (α : EquivAction H) (τ : TransportStr α)
  (ι : StrEquiv S ℓ₂') (θ : UnivalentStr S ι)
  {X Y : Type ℓ} {s : S X} {t : S Y}
  (e : (X , s) ≃[ ι ] (Y , t))
  → (h : H X) → P Y t (equivFun (α (e .fst)) h) → P X s h
transfer⁻ P α τ ι θ {X} {Y} {s} {t} e h =
  subst⁻ (λ {(Z , u , h) → P Z u h})
    (sip
      (productUnivalentStr ι θ (EquivAction→StrEquiv α)  (TransportStr→UnivalentStr α τ))
      (X , s , h)
      (Y , t , equivFun (α (e .fst)) h)
      (e .fst , e .snd , refl))