------------------------------------------------------------------------------
-- Problem with a simplified version of the combinators for preorder
-- reasoning
------------------------------------------------------------------------------

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

module FOT.Common.FOL.Relation.Binary.PreorderReasoning.ImplicitArgumentsProblem
  where

-- Nils suggested a possible problem with the relation

-- R : {A : Set} → A → A → Set
-- R _ _ = ⊤

-- and a version of the combinators for preorder reasoning without use
-- the wrapper data type. This example shows that Nils was right.

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

record ⊤ : Set where
  constructor tt

R : {A : Set} → A → A → Set
R _ _ = ⊤

R-refl : {A : Set}{x : A} → R x x
R-refl = tt

R-trans : {A : Set}{x y z : A} → R x y → R y z → R x z
R-trans _ _ = tt

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

module Thesis where
  -- From Ulf's thesis (p. 112).

  infix  7 _≃_
  infix  6 chain>_
  infixl 5 _===_by_
  infix  4 _qed

  data _≃_ {A : Set}(x y : A) : Set where
    prf : R x y → x ≃ y

  chain>_ : {A : Set}(x : A) → x ≃ x
  chain> x = prf (R-refl {x = x})

  _===_by_ : {A : Set}{x y : A} → x ≃ y → (z : A) → R y z → x ≃ z
  _===_by_ {x = x} {y} (prf p) z q = prf (R-trans {x = x} {y} {z} p q)

  _qed : {A : Set}{x y : A} → x ≃ y → R x y
  prf p qed = p

  -- Example (no problem with implicit arguments).
  test : (x y : ℕ) → R x y
  test x y =
    chain> x
      === y by tt
    qed

module SL where
  -- Adapted from the Agda standard library 0.8.1 (see
  -- Relation/Binary/PreorderReasoning.agda).

  infix  7 _≃_
  infix  4 begin_
  infixr 5 _≡⟨_⟩_
  infix  6 _∎

  data _≃_ {A : Set}(x y : A) : Set where
    prf : R x y → x ≃ y

  begin_ : {A : Set}{x y : A} → x ≃ y → R x y
  begin_ {x = x} (prf Rxy) = R-refl {x = x}

  _≡⟨_⟩_ : {A : Set}(x : A){y z : A} → R x y → y ≃ z → x ≃ z
  _≡⟨_⟩_ x {y} {z} Rxy (prf Ryz) = prf (R-trans {x = x} {y} {z} Rxy Ryz)

  _∎ : {A : Set}(x : A) → x ≃ x
  _∎ x = prf (R-refl {x = x})

  -- Example (no problem with implicit arguments).
  test : (x y : ℕ) → R x y
  test x y =
    begin
      x ≡⟨ tt ⟩
      y
    ∎

module NonWrapper where
  -- A set of combinators without request a wrapper data type (Mu,
  -- S.-C., Ko, H.-S. and Jansson, P. (2009)).

  infixr 5 _≡⟨_⟩_
  infix  6 _∎

  _≡⟨_⟩_ : {A : Set}(x : A){y z : A} → R x y → R y z → R x z
  _≡⟨_⟩_ x {y} {z} x≡y y≡z = R-trans {x = x} {y} {z} x≡y y≡z

  _∎ : {A : Set}(x : A) → R x x
  _∎ x = R-refl {x = x}

  -- Example.
  test : (x y : ℕ) → R x y
  test x y = x ≡⟨ tt ⟩
             y ∎

------------------------------------------------------------------------------
-- References
--
-- Mu, S.-C., Ko, H.-S. and Jansson, P. (2009). Algebra of programming
-- in Agda: Dependent types for relational program derivation. Journal
-- of Functional Programming 19.5, pp. 545–579.


open import Prelude
open import core

module lemmas-matching where
  -- matching produces unique answers for arrows, sums, and products
  ▸arr-unicity : ∀{ t t2 t3 } →
                 t ▸arr t2 →
                 t ▸arr t3 →
                 t2 == t3
  ▸arr-unicity MAHole MAHole = refl
  ▸arr-unicity MAArr MAArr = refl

  -- if an arrow matches, then it's consistent with the least restrictive
  -- function type
  matchconsisthole : ∀{t t'} →
                 t ▸arr t' →
                 t ~ (⦇-⦈ ==> ⦇-⦈)
  matchconsisthole MAHole = TCHole2
  matchconsisthole MAArr = TCArr TCHole1 TCHole1

  match-consist : ∀{τ1 τ2} → τ1 ▸arr τ2 → (τ2 ~ τ1)
  match-consist MAHole = TCHole1
  match-consist MAArr = TCRefl

  match-unicity : ∀{ τ τ1 τ2} → τ ▸arr τ1 → τ ▸arr τ2 → τ1 == τ2
  match-unicity MAHole MAHole = refl
  match-unicity MAArr MAArr = refl


open import Relation.Binary.Core

module PLRTree.Push.Heap {A : Set}
                     (_≤_ : A → A → Set)
                     (tot≤ : Total _≤_)
                     (trans≤ : Transitive _≤_) where

open import Data.Sum
open import Induction.WellFounded
open import Order.Total _≤_ tot≤
open import PLRTree {A}
open import PLRTree.Drop _≤_ tot≤
open import PLRTree.Heap _≤_
open import PLRTree.Heap.Properties _≤_ trans≤
open import PLRTree.Order {A}
open import PLRTree.Order.Properties {A}

lemma-push-≤* : {x y : A}{l r : PLRTree}(t : Tag) → x ≤ y → x ≤* l → x ≤* r → (acc : Acc _≺_ (node t y l r)) → x ≤* (push (node t y l r) acc)
lemma-push-≤* {x} t x≤y (lf≤* .x) x≤*r (acc rs) = nd≤* x≤y (lf≤* x) (lf≤* x)
lemma-push-≤* {x} {y} t x≤y (nd≤* {t'} .{x} {x'} x≤x' x≤*l' x≤*r') (lf≤* .x) (acc rs)
    with tot≤ y x'
... | inj₁ y≤x' = nd≤* x≤y (nd≤* x≤x' (lf≤* x) (lf≤* x)) (lf≤* x)
... | inj₂ x'≤y = nd≤* x≤x' (nd≤* x≤y (lf≤* x) (lf≤* x)) (lf≤* x)
lemma-push-≤* {x} {y} t x≤y (nd≤* {t'} .{x} {x'} {l'} {r'} x≤x' x≤*l' x≤*r') (nd≤* {t''} .{x} {x''} {l''} {r''} x≤x'' x≤*l'' x≤*r'') (acc rs)
    with tot≤ y x' | tot≤ y x'' | tot≤ x' x''
... | inj₁ y≤x' | inj₁ y≤x'' | _ = nd≤* x≤y (nd≤* x≤x' x≤*l' x≤*r') (nd≤* x≤x'' x≤*l'' x≤*r'')
... | inj₁ y≤x' | inj₂ x''≤y | _ rewrite lemma-≡-height t'' y x'' l'' r'' =
           let acc-t''yl''r'' = rs (node t'' y l'' r'') (lemma-≺-right t y (node t' x' l' r') (node t'' x'' l'' r''))
           in nd≤* x≤x'' (nd≤* x≤x' x≤*l' x≤*r') (lemma-push-≤* t'' x≤y x≤*l'' x≤*r'' acc-t''yl''r'')
... | inj₂ x'≤y | inj₁ y≤x'' | _ rewrite lemma-≡-height t' y x' l' r' =
           let acc-t'yl'r' = rs (node t' y l' r') (lemma-≺-left t y (node t' x' l' r') (node t'' x'' l'' r''))
           in nd≤* x≤x' (lemma-push-≤* t' x≤y x≤*l' x≤*r' acc-t'yl'r') (nd≤* x≤x'' x≤*l'' x≤*r'')
... | inj₂ x'≤y | inj₂ x''≤y | inj₁ x'≤x'' rewrite lemma-≡-height t' y x' l' r' =
           let acc-t'yl'r' = rs (node t' y l' r') (lemma-≺-left t y (node t' x' l' r') (node t'' x'' l'' r''))
           in nd≤* x≤x' (lemma-push-≤* t' x≤y x≤*l' x≤*r' acc-t'yl'r') (nd≤* x≤x'' x≤*l'' x≤*r'')
... | inj₂ x'≤y | inj₂ x''≤y | inj₂ x''≤x' rewrite lemma-≡-height t'' y x'' l'' r'' =
           let acc-t''yl''r'' = rs (node t'' y l'' r'') (lemma-≺-right t y (node t' x' l' r') (node t'' x'' l'' r''))
           in nd≤* x≤x'' (nd≤* x≤x' x≤*l' x≤*r') (lemma-push-≤* t'' x≤y x≤*l'' x≤*r'' acc-t''yl''r'')

lemma-push-heap : {l r : PLRTree}(t : Tag)(x : A) → Heap l → Heap r → (acc : Acc _≺_ (node t x l r)) → Heap (push (node t x l r) acc)
lemma-push-heap t x leaf _ _ = node (lf≤* x) (lf≤* x) leaf leaf
lemma-push-heap t x (node {t'} {x'} x'≤*l' x'≤*r' hl' hr') leaf (acc rs)
    with tot≤ x x'
... | inj₁ x≤x' = node (nd≤* x≤x' (lf≤* x) (lf≤* x)) (lf≤* x) (node (lf≤* x') (lf≤* x') leaf leaf) leaf
... | inj₂ x'≤x = node (nd≤* x'≤x (lf≤* x') (lf≤* x')) (lf≤* x') (node (lf≤* x) (lf≤* x) leaf leaf) leaf
lemma-push-heap t x (node {t'} {x'} {l'} {r'} x'≤*l' x'≤*r' hl' hr') (node {t''} {x''} {l''} {r''} x''≤*l'' x''≤*r'' hl'' hr'') (acc rs)
    with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
... | inj₁ x≤x' | inj₁ x≤x'' | _ =
           let x≤*t'x'l'r' = nd≤* x≤x' (lemma-≤-≤* x≤x' x'≤*l') (lemma-≤-≤* x≤x' x'≤*r') ;
                x≤*t''x''l''r'' = nd≤* x≤x'' (lemma-≤-≤* x≤x'' x''≤*l'') (lemma-≤-≤* x≤x'' x''≤*r'')
           in node x≤*t'x'l'r' x≤*t''x''l''r'' (node x'≤*l' x'≤*r' hl' hr') (node x''≤*l'' x''≤*r'' hl'' hr'')
... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height t'' x x'' l'' r'' =
           let acc-t''xl''r'' = rs (node t'' x l'' r'') (lemma-≺-right t x (node t' x' l' r') (node t'' x'' l'' r'')) ;
                x''≤*t'x'l'r' = lemma-≤-≤* x''≤x (nd≤* x≤x' (lemma-≤-≤* x≤x' x'≤*l') (lemma-≤-≤* x≤x' x'≤*r')) ;
                x''≤*push-t''xl''r'' = lemma-push-≤* t'' x''≤x x''≤*l'' x''≤*r'' acc-t''xl''r''
           in node x''≤*t'x'l'r' x''≤*push-t''xl''r'' (node x'≤*l' x'≤*r' hl' hr') (lemma-push-heap t'' x hl'' hr'' acc-t''xl''r'')
... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height t' x x' l' r' =
           let acc-t'xl'r' = rs (node t' x l' r') (lemma-≺-left t x (node t' x' l' r') (node t'' x'' l'' r'')) ;
                x'≤*t''x''l''r'' = lemma-≤-≤* x'≤x (nd≤* x≤x'' (lemma-≤-≤* x≤x'' x''≤*l'') (lemma-≤-≤* x≤x'' x''≤*r'')) ;
                x'≤*push-t'xl'r' = lemma-push-≤* t' x'≤x x'≤*l' x'≤*r' acc-t'xl'r'
           in node x'≤*push-t'xl'r' x'≤*t''x''l''r'' (lemma-push-heap t' x hl' hr' acc-t'xl'r') (node x''≤*l'' x''≤*r'' hl'' hr'')
... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height t' x x' l' r' =
           let acc-t'xl'r' = rs (node t' x l' r') (lemma-≺-left t x (node t' x' l' r') (node t'' x'' l'' r'')) ;
                x'≤*t''x''l''r'' = lemma-≤-≤* x'≤x'' (nd≤* refl≤ x''≤*l'' x''≤*r'') ;
                x'≤*push-t'xl'r' = lemma-push-≤* t' x'≤x x'≤*l' x'≤*r' acc-t'xl'r'
           in node x'≤*push-t'xl'r' x'≤*t''x''l''r'' (lemma-push-heap t' x hl' hr' acc-t'xl'r') (node x''≤*l'' x''≤*r'' hl'' hr'')
... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height t'' x x'' l'' r'' =
           let acc-t''xl''r'' = rs (node t'' x l'' r'') (lemma-≺-right t x (node t' x' l' r') (node t'' x'' l'' r'')) ;
                x''≤*t'x'l'r' = lemma-≤-≤* x''≤x' (nd≤* refl≤ x'≤*l' x'≤*r') ;
                x''≤*push-t''xl''r'' = lemma-push-≤* t'' x''≤x x''≤*l'' x''≤*r'' acc-t''xl''r''
           in node x''≤*t'x'l'r' x''≤*push-t''xl''r'' (node x'≤*l' x'≤*r' hl' hr') (lemma-push-heap t'' x hl'' hr'' acc-t''xl''r'')


module DaraisPhoas where

open import Agda.Primitive using (_⊔_)

module Prelude where

  infixr 3 ∃𝑠𝑡
  infixl 5 _∨_
  infixr 20 _∷_

  data 𝔹 : Set where
    T : 𝔹
    F : 𝔹

  data _∨_ {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
    Inl : A → A ∨ B
    Inr : B → A ∨ B

  syntax ∃𝑠𝑡 A (λ x → B) = ∃ x ⦂ A 𝑠𝑡 B
  data ∃𝑠𝑡 {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : A → Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
    ⟨∃_,_⟩ : ∀ (x : A) → B x → ∃ x ⦂ A 𝑠𝑡 B x

  data ⟬_⟭ {ℓ} (A : Set ℓ) : Set ℓ where
    [] : ⟬ A ⟭
    _∷_ : A → ⟬ A ⟭ → ⟬ A ⟭

open Prelude

infixr 15 _⟨→⟩_
data type : Set where
  ⟨ℕ⟩   : type
  _⟨→⟩_ : type → type → type

infixl 15 _⟨∙⟩_
data exp-phoas (var : type → ⟬ type ⟭ → Set) : ∀ (Γ : ⟬ type ⟭) (τ : type) → Set where
  Var : ∀ {Γ τ}
    (x : var τ Γ)
    → exp-phoas var Γ τ
  ⟨λ⟩ : ∀ {Γ τ₁ τ₂}
    (e : var τ₁ (τ₁ ∷ Γ) → exp-phoas var (τ₁ ∷ Γ) τ₂)
    → exp-phoas var Γ (τ₁ ⟨→⟩ τ₂)
  _⟨∙⟩_ : ∀ {Γ τ₁ τ₂}
    (e₁ : exp-phoas var Γ (τ₁ ⟨→⟩ τ₂))
    (e₂ : exp-phoas var Γ τ₁)
    → exp-phoas var Γ τ₂

infix 10 _∈_
data _∈_ {ℓ} {A : Set ℓ} (x : A) : ∀ (xs : ⟬ A ⟭) → Set ℓ where
  Z : ∀ {xs} → x ∈ x ∷ xs
  S : ∀ {x′ xs} → x ∈ xs → x ∈ x′ ∷ xs

infix 10 _⊢_
data _⊢_ : ∀ (Γ : ⟬ type ⟭) (τ : type) → Set where
  Var : ∀ {Γ τ}
    (x : τ ∈ Γ)
    → Γ ⊢ τ
  ⟨λ⟩ : ∀ {Γ τ₁ τ₂}
    (e : τ₁ ∷ Γ ⊢ τ₂)
    → Γ ⊢ τ₁ ⟨→⟩ τ₂
  _⟨∙⟩_ : ∀ {Γ τ₁ τ₂}
    (e₁ : Γ ⊢ τ₁ ⟨→⟩ τ₂)
    (e₂ : Γ ⊢ τ₁)
    → Γ ⊢ τ₂

⟦_⟧₁ : ∀ {Γ τ} (e : exp-phoas _∈_ Γ τ) → Γ ⊢ τ
⟦ Var x ⟧₁ = Var x
⟦ ⟨λ⟩ e ⟧₁ = ⟨λ⟩ ⟦ e Z ⟧₁
⟦ e₁ ⟨∙⟩ e₂ ⟧₁ = ⟦ e₁ ⟧₁ ⟨∙⟩ ⟦ e₂ ⟧₁

⟦_⟧₂ : ∀ {Γ τ} (e : Γ ⊢ τ) → exp-phoas _∈_ Γ τ
⟦ Var x ⟧₂ = Var x
⟦ ⟨λ⟩ e ⟧₂ = ⟨λ⟩ (λ _ → ⟦ e ⟧₂)
⟦ e₁ ⟨∙⟩ e₂ ⟧₂ = ⟦ e₁ ⟧₂ ⟨∙⟩ ⟦ e₂ ⟧₂

Ch : type
Ch =  (⟨ℕ⟩ ⟨→⟩ ⟨ℕ⟩) ⟨→⟩ ⟨ℕ⟩ ⟨→⟩ ⟨ℕ⟩

twoDB : [] ⊢ Ch
twoDB = ⟨λ⟩ (⟨λ⟩ (Var (S Z) ⟨∙⟩ (Var (S Z) ⟨∙⟩ Var Z)))

twoPH : exp-phoas _∈_ [] Ch
twoPH = ⟨λ⟩ (λ f → ⟨λ⟩ (λ x → Var f ⟨∙⟩ (Var f ⟨∙⟩ Var x)))

{-
/Users/wadler/sf/src/extra/DaraisPhoas.agda:82,9-60
⟨ℕ⟩ ⟨→⟩ ⟨ℕ⟩ != ⟨ℕ⟩ of type type
when checking that the expression
⟨λ⟩ (λ f → ⟨λ⟩ (λ x → Var f ⟨∙⟩ (Var f ⟨∙⟩ Var x))) has type
exp-phoas _∈_ [] Ch
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Maybe-related properties
------------------------------------------------------------------------

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

module Data.Maybe.Properties where

open import Algebra
import Algebra.Structures as Structures
import Algebra.FunctionProperties as FunctionProperties
open import Data.Maybe.Base
open import Data.Maybe.Relation.Unary.All using (All; just; nothing)
open import Data.Product using (_,_)
open import Function
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- Equality

module _ {a} {A : Set a} where

  just-injective : ∀ {x y} → (Maybe A ∋ just x) ≡ just y → x ≡ y
  just-injective refl = refl

  ≡-dec : Decidable _≡_ → Decidable {A = Maybe A} _≡_
  ≡-dec _≟_ nothing  nothing  = yes refl
  ≡-dec _≟_ (just x) nothing  = no λ()
  ≡-dec _≟_ nothing  (just y) = no λ()
  ≡-dec _≟_ (just x) (just y) with x ≟ y
  ... | yes refl = yes refl
  ... | no  x≢y  = no (x≢y ∘ just-injective)

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

  map-id : map id ≗ id {A = Maybe A}
  map-id (just x) = refl
  map-id nothing  = refl

  map-id₂ : ∀ {f : A → A} {mx} → All (λ x → f x ≡ x) mx → map f mx ≡ mx
  map-id₂ (just eq) = cong just eq
  map-id₂ nothing   = refl

module _ {a b} {A : Set a} {B : Set b} where

  map-<∣>-commute : ∀ (f : A → B) mx my →
    map f (mx <∣> my) ≡ map f mx <∣> map f my
  map-<∣>-commute f (just x) my = refl
  map-<∣>-commute f nothing  my = refl

  map-cong : {f g : A → B} → f ≗ g → map f ≗ map g
  map-cong f≗g (just x) = cong just (f≗g x)
  map-cong f≗g nothing  = refl

  map-cong₂ : ∀ {f g : A → B} {mx} →
    All (λ x → f x ≡ g x) mx → map f mx ≡ map g mx
  map-cong₂ (just eq) = cong just eq
  map-cong₂ nothing   = refl

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} where

  map-compose : {g : B → C} {f : A → B} → map (g ∘ f) ≗ map g ∘ map f
  map-compose (just x) = refl
  map-compose nothing  = refl

------------------------------------------------------------------------
-- maybe

module _ {a b} {A : Set a} {B : Set b} where

  maybe-map : ∀ {c} {C : Maybe B → Set c}
              (j : (x : B) → C (just x)) (n : C nothing) (f : A → B) ma →
              maybe {B = C} j n (map f ma) ≡ maybe {B = C ∘ map f} (j ∘ f) n ma
  maybe-map j n f (just x) = refl
  maybe-map j n f nothing  = refl

  maybe′-map : ∀ {c} {C : Set c} j (n : C) (f : A → B) ma →
               maybe′ j n (map f ma) ≡ maybe′ (j ∘′ f) n ma
  maybe′-map = maybe-map

------------------------------------------------------------------------
-- _<∣>_

module _ {a} {A : Set a} where

  open FunctionProperties {A = Maybe A} _≡_

  <∣>-assoc : Associative _<∣>_
  <∣>-assoc (just x) y z = refl
  <∣>-assoc nothing  y z = refl

  <∣>-identityˡ : LeftIdentity nothing _<∣>_
  <∣>-identityˡ (just x) = refl
  <∣>-identityˡ nothing  = refl

  <∣>-identityʳ : RightIdentity nothing _<∣>_
  <∣>-identityʳ (just x) = refl
  <∣>-identityʳ nothing  = refl

  <∣>-identity : Identity nothing _<∣>_
  <∣>-identity = <∣>-identityˡ , <∣>-identityʳ

module _ {a} (A : Set a) where

  open Structures {A = Maybe A} _≡_

  <∣>-isMagma : IsMagma _<∣>_
  <∣>-isMagma = record
    { isEquivalence = isEquivalence
    ; ∙-cong        = cong₂ _<∣>_
    }

  <∣>-isSemigroup : IsSemigroup _<∣>_
  <∣>-isSemigroup = record
    { isMagma = <∣>-isMagma
    ; assoc   = <∣>-assoc
    }

  <∣>-isMonoid : IsMonoid _<∣>_ nothing
  <∣>-isMonoid = record
    { isSemigroup = <∣>-isSemigroup
    ; identity    = <∣>-identity
    }

  <∣>-semigroup : Semigroup a a
  <∣>-semigroup = record
    { isSemigroup = <∣>-isSemigroup
    }

  <∣>-monoid : Monoid a a
  <∣>-monoid = record
    { isMonoid = <∣>-isMonoid
    }


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

open import Setoids.Setoids
open import Groups.Definition
open import Groups.Lemmas
open import Groups.Homomorphisms.Definition
open import Groups.QuotientGroup.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Actions.Definition
open import Sets.EquivalenceRelations

module Groups.SymmetricGroups.Lemmas where

trivialAction : {m n o p : _} {A : Set m} {S : Setoid {m} {o} A} {_·_ : A → A → A} {B : Set n} (G : Group S _·_) (X : Setoid {n} {p} B) → GroupAction G X
trivialAction G X = record { action = λ _ x → x ; actionWellDefined1 = λ _ → reflexive ; actionWellDefined2 = λ wd1 → wd1 ; identityAction = reflexive ; associativeAction = reflexive }
  where
    open Setoid X renaming (eq to setoidEq)
    open Equivalence (Setoid.eq X)

leftRegularAction : {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_·_ : A → A → A} (G : Group S _·_) → GroupAction G S
GroupAction.action (leftRegularAction {_·_ = _·_} G) g h = g · h
  where
    open Group G
GroupAction.actionWellDefined1 (leftRegularAction {S = S} G) eq1 = +WellDefined eq1 reflexive
  where
    open Group G
    open Setoid S renaming (eq to setoidEq)
    open Equivalence setoidEq
GroupAction.actionWellDefined2 (leftRegularAction {S = S} G) {g} {x} {y} eq1 = +WellDefined reflexive eq1
  where
    open Group G
    open Setoid S
    open Equivalence eq
GroupAction.identityAction (leftRegularAction G) = identLeft
  where
    open Group G
GroupAction.associativeAction (leftRegularAction {S = S} G) = symmetric +Associative
  where
    open Group G
    open Setoid S
    open Equivalence eq

conjugationAction : {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_·_ : A → A → A} → (G : Group S _·_) → GroupAction G S
conjugationAction {S = S} {_·_ = _·_} G = record { action = λ g h → (g · h) · (inverse g) ; actionWellDefined1 = λ gh → +WellDefined (+WellDefined gh reflexive) (inverseWellDefined G gh) ; actionWellDefined2 = λ x~y → +WellDefined (+WellDefined reflexive x~y) reflexive ; identityAction = transitive (+WellDefined reflexive (invIdent G)) (transitive identRight identLeft)  ; associativeAction = λ {x} {g} {h} → transitive (+WellDefined reflexive (invContravariant G)) (transitive +Associative (+WellDefined (transitive (symmetric +Associative) (transitive (symmetric (+Associative)) (+WellDefined reflexive +Associative))) reflexive)) }
  where
    open Group G
    open Setoid S
    open Equivalence eq

conjugationNormalSubgroupAction : {m n o p : _} {A : Set m} {B : Set o} {S : Setoid {m} {n} A} {T : Setoid {o} {p} B} {_·A_ : A → A → A} {_·B_ : B → B → B} → (G : Group S _·A_) → (H : Group T _·B_) → {underF : A → B} (f : GroupHom G H underF) → GroupAction G (quotientGroupSetoid G f)
GroupAction.action (conjugationNormalSubgroupAction {_·A_ = _·A_} G H {f} fHom) a b = a ·A (b ·A (Group.inverse G a))
GroupAction.actionWellDefined1 (conjugationNormalSubgroupAction {S = S} {T = T} {_·A_ = _·A_} G H {f} fHom) {g} {h} {x} g~h = ans
  where
    open Group G
    open Setoid T
    open Equivalence eq
    ans : f ((g ·A (x ·A (inverse g))) ·A inverse (h ·A (x ·A inverse h))) ∼ Group.0G H
    ans = transitive (GroupHom.wellDefined fHom (transferToRight'' G (Group.+WellDefined G g~h (Group.+WellDefined G (Equivalence.reflexive (Setoid.eq S)) (inverseWellDefined G g~h))))) (imageOfIdentityIsIdentity fHom)
GroupAction.actionWellDefined2 (conjugationNormalSubgroupAction {S = S} {T = T} {_·A_ = _·A_} {_·B_ = _·B_} G H {f} fHom) {g} {x} {y} x~y = ans
  where
    open Group G
    open Setoid T
    open Equivalence (Setoid.eq S)
    open Equivalence (Setoid.eq T) renaming (transitive to transitiveH ; symmetric to symmetricH ; reflexive to reflexiveH)
    input : f (x ·A inverse y) ∼ Group.0G H
    input = x~y
    p1 : Setoid._∼_ S ((g ·A (x ·A inverse g)) ·A inverse (g ·A (y ·A inverse g))) ((g ·A (x ·A inverse g)) ·A (inverse (y ·A (inverse g)) ·A inverse g))
    p1 = Group.+WellDefined G reflexive (invContravariant G)
    p2 : Setoid._∼_ S ((g ·A (x ·A inverse g)) ·A (inverse (y ·A (inverse g)) ·A inverse g)) ((g ·A (x ·A inverse g)) ·A ((inverse (inverse g) ·A inverse y) ·A inverse g))
    p2 = Group.+WellDefined G reflexive (Group.+WellDefined G (invContravariant G) reflexive)
    p3 : Setoid._∼_ S ((g ·A (x ·A inverse g)) ·A ((inverse (inverse g) ·A inverse y) ·A inverse g)) (g ·A (((x ·A inverse g) ·A (inverse (inverse g) ·A inverse y)) ·A inverse g))
    p3 = symmetric (transitive (+WellDefined reflexive (symmetric +Associative)) +Associative)
    p4 : Setoid._∼_ S (g ·A (((x ·A inverse g) ·A (inverse (inverse g) ·A inverse y)) ·A inverse g)) (g ·A ((x ·A ((inverse g ·A inverse (inverse g)) ·A inverse y)) ·A inverse g))
    p4 = Group.+WellDefined G reflexive (Group.+WellDefined G (symmetric (transitive (+WellDefined reflexive (symmetric +Associative)) +Associative)) reflexive)
    p5 : Setoid._∼_ S (g ·A ((x ·A ((inverse g ·A inverse (inverse g)) ·A inverse y)) ·A inverse g)) (g ·A ((x ·A (0G ·A inverse y)) ·A inverse g))
    p5 = Group.+WellDefined G reflexive (Group.+WellDefined G (Group.+WellDefined G reflexive (Group.+WellDefined G invRight reflexive)) reflexive)
    p6 : Setoid._∼_ S  (g ·A ((x ·A (0G ·A inverse y)) ·A inverse g)) (g ·A ((x ·A inverse y) ·A inverse g))
    p6 = Group.+WellDefined G reflexive (Group.+WellDefined G (Group.+WellDefined G reflexive identLeft) reflexive)
    intermediate : Setoid._∼_ S ((g ·A (x ·A inverse g)) ·A inverse (g ·A (y ·A inverse g))) (g ·A ((x ·A inverse y) ·A inverse g))
    intermediate = transitive p1 (transitive p2 (transitive p3 (transitive p4 (transitive p5 p6))))
    p7 : f ((g ·A (x ·A inverse g)) ·A inverse (g ·A (y ·A inverse g))) ∼ f (g ·A ((x ·A inverse y) ·A inverse g))
    p7 = GroupHom.wellDefined fHom intermediate
    p8 : f (g ·A ((x ·A inverse y) ·A inverse g)) ∼ (f g) ·B (f ((x ·A inverse y) ·A inverse g))
    p8 = GroupHom.groupHom fHom
    p9 : (f g) ·B (f ((x ·A inverse y) ·A inverse g)) ∼ (f g) ·B (f (x ·A inverse y) ·B f (inverse g))
    p9 = Group.+WellDefined H reflexiveH (GroupHom.groupHom fHom)
    p10 : (f g) ·B (f (x ·A inverse y) ·B f (inverse g)) ∼ (f g) ·B (Group.0G H ·B f (inverse g))
    p10 = Group.+WellDefined H reflexiveH (Group.+WellDefined H input reflexiveH)
    p11 : (f g) ·B (Group.0G H ·B f (inverse g)) ∼ (f g) ·B (f (inverse g))
    p11 = Group.+WellDefined H reflexiveH (Group.identLeft H)
    p12 : (f g) ·B (f (inverse g)) ∼ f (g ·A (inverse g))
    p12 = symmetricH (GroupHom.groupHom fHom)
    intermediate2 : f ((g ·A (x ·A inverse g)) ·A inverse (g ·A (y ·A inverse g))) ∼ (f (g ·A (inverse g)))
    intermediate2 = transitiveH p7 (transitiveH p8 (transitiveH p9 (transitiveH p10 (transitiveH p11 p12))))
    ans : f ((g ·A (x ·A inverse g)) ·A inverse (g ·A (y ·A inverse g))) ∼ Group.0G H
    ans = transitiveH intermediate2 (transitiveH (GroupHom.wellDefined fHom invRight) (imageOfIdentityIsIdentity fHom))
GroupAction.identityAction (conjugationNormalSubgroupAction {S = S} {T = T} {_·A_ = _·A_} G H {f} fHom) {x} = ans
  where
    open Group G
    open Setoid S
    open Setoid T renaming (_∼_ to _∼T_)
    open Equivalence (Setoid.eq T)
    i : Setoid._∼_ S (x ·A inverse 0G) x
    i = Equivalence.transitive (Setoid.eq S) (+WellDefined (Equivalence.reflexive (Setoid.eq S)) (invIdent G)) identRight
    h : 0G ·A (x ·A inverse 0G) ∼ x
    h = Equivalence.transitive (Setoid.eq S) identLeft i
    g : ((0G ·A (x ·A inverse 0G)) ·A inverse x) ∼ 0G
    g = transferToRight'' G h
    ans : f ((0G ·A (x ·A inverse 0G)) ·A Group.inverse G x) ∼T Group.0G H
    ans = transitive (GroupHom.wellDefined fHom g) (imageOfIdentityIsIdentity fHom)
GroupAction.associativeAction (conjugationNormalSubgroupAction {S = S} {T = T} {_·A_ = _·A_} G H {f} fHom) {x} {g} {h} = ans
  where
    open Group G
    open Setoid T renaming (_∼_ to _∼T_)
    open Setoid S renaming (_∼_ to _∼S_)
    open Equivalence (Setoid.eq T) renaming (transitive to transitiveH)
    open Equivalence (Setoid.eq S) renaming (transitive to transitiveG ; symmetric to symmetricG ; reflexive to reflexiveG)
    ans : f (((g ·A h) ·A (x ·A inverse (g ·A h))) ·A inverse ((g ·A ((h ·A (x ·A inverse h)) ·A inverse g)))) ∼T Group.0G H
    ans = transitiveH (GroupHom.wellDefined fHom (transferToRight'' G (transitiveG (symmetricG +Associative) (Group.+WellDefined G reflexiveG (transitiveG (+WellDefined reflexiveG (transitiveG (+WellDefined reflexiveG (invContravariant G)) +Associative)) +Associative))))) (imageOfIdentityIsIdentity fHom)


import      Lvl
open import Type

module Structure.Logic.Constructive.Functions {ℓₒ} (Domain : Type{ℓₒ}) where

private
  module Meta where
    open import Numeral.Finite           public
    open import Numeral.Natural                public

-- The type of a function. Functions on the domain in the meta-logic.
Function : Type{_}
Function = (Domain → Domain)

BinaryOperator : Type{_}
BinaryOperator = (Domain → Domain → Domain)

Tuple : Meta.ℕ → Type{_}
Tuple(n) = Meta.𝕟(n) → Domain

Sequence : Type{_}
Sequence = Meta.ℕ → Domain


{-# OPTIONS --universe-polymorphism #-}
module tests.Coind where

open import Prelude.IO
open import Prelude.Level
open import Prelude.Nat
open import Prelude.Unit

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

data Stream (A : Set) : Set where
  _::_ : (x : A) (xs : ∞ (Stream A)) → Stream A

ones : Stream Nat
ones = 1 :: (♯ ones)

twos : Stream Nat
twos = 2 :: (♯ twos)

incr : Nat -> Stream Nat
incr n = n :: (♯ (incr (n + 1)))

printStream : Nat -> Stream Nat -> IO Unit
printStream Z _ = putStrLn ""
printStream (S steps) (n :: ns) =
    printNat n ,,
    printStream steps (♭ ns)

main : IO Unit
main =
    printStream 10 twos ,,
    printStream 10 ones ,,
    printStream 10 (incr Z)


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

open import LogicalFormulae
open import Lists.Lists
open import Numbers.BinaryNaturals.Definition
open import Maybe

module Numbers.BinaryNaturals.SubtractionGo where

go : Bit → BinNat → BinNat → Maybe BinNat
go zero [] [] = yes []
go one [] [] = no
go zero [] (zero :: b) = go zero [] b
go zero [] (one :: b) = no
go one [] (x :: b) = no
go zero (zero :: a) [] = yes (zero :: a)
go one (zero :: a) [] = mapMaybe (one ::_) (go one a [])
go zero (zero :: a) (zero :: b) = mapMaybe (zero ::_) (go zero a b)
go one (zero :: a) (zero :: b) = mapMaybe (one ::_) (go one a b)
go zero (zero :: a) (one :: b) = mapMaybe (one ::_) (go one a b)
go one (zero :: a) (one :: b) = mapMaybe (zero ::_) (go one a b)
go zero (one :: a) [] = yes (one :: a)
go zero (one :: a) (zero :: b) = mapMaybe (one ::_) (go zero a b)
go zero (one :: a) (one :: b) = mapMaybe (zero ::_) (go zero a b)
go one (one :: a) [] = yes (zero :: a)
go one (one :: a) (zero :: b) = mapMaybe (zero ::_) (go zero a b)
go one (one :: a) (one :: b) = mapMaybe (one ::_) (go one a b)

_-B_ : BinNat → BinNat → Maybe BinNat
a -B b = go zero a b

goEmpty : (a : BinNat) → go zero a [] ≡ yes a
goEmpty [] = refl
goEmpty (zero :: a) = refl
goEmpty (one :: a) = refl

goOneSelf : (a : BinNat) → go one a a ≡ no
goOneSelf [] = refl
goOneSelf (zero :: a) rewrite goOneSelf a = refl
goOneSelf (one :: a) rewrite goOneSelf a = refl

goOneEmpty : (b : BinNat) {t : BinNat} → go one [] b ≡ yes t → False
goOneEmpty [] {t} ()
goOneEmpty (x :: b) {t} ()

goOneEmpty' : (b : BinNat) → go one [] b ≡ no
goOneEmpty' b with inspect (go one [] b)
goOneEmpty' b | no with≡ x = x
goOneEmpty' b | yes x₁ with≡ x = exFalso (goOneEmpty b x)

goZeroEmpty : (b : BinNat) {t : BinNat} → go zero [] b ≡ yes t → canonical b ≡ []
goZeroEmpty [] {t} = λ _ → refl
goZeroEmpty (zero :: b) {t} pr with inspect (canonical b)
goZeroEmpty (zero :: b) {t} pr | [] with≡ pr2 rewrite pr2 = refl
goZeroEmpty (zero :: b) {t} pr | (x :: r) with≡ pr2 with goZeroEmpty b pr
... | u = exFalso (nonEmptyNotEmpty (transitivity (equalityCommutative pr2) u))

goZeroEmpty' : (b : BinNat) {t : BinNat} → go zero [] b ≡ yes t → canonical t ≡ []
goZeroEmpty' [] {[]} pr = refl
goZeroEmpty' (x :: b) {[]} pr = refl
goZeroEmpty' (zero :: b) {x₁ :: t} pr = goZeroEmpty' b pr

goZeroIncr : (b : BinNat) → go zero [] (incr b) ≡ no
goZeroIncr [] = refl
goZeroIncr (zero :: b) = refl
goZeroIncr (one :: b) = goZeroIncr b

goPreservesCanonicalRightEmpty : (b : BinNat) → go zero [] (canonical b) ≡ go zero [] b
goPreservesCanonicalRightEmpty [] = refl
goPreservesCanonicalRightEmpty (zero :: b) with inspect (canonical b)
goPreservesCanonicalRightEmpty (zero :: b) | [] with≡ x with goPreservesCanonicalRightEmpty b
... | pr2 rewrite x = pr2
goPreservesCanonicalRightEmpty (zero :: b) | (x₁ :: y) with≡ x with goPreservesCanonicalRightEmpty b
... | pr2 rewrite x = pr2
goPreservesCanonicalRightEmpty (one :: b) = refl

goZero : (b : BinNat) {t : BinNat} → mapMaybe canonical (go zero [] b) ≡ yes t → t ≡ []
goZero b {[]} pr = refl
goZero b {x :: t} pr with inspect (go zero [] b)
goZero b {x :: t} pr | no with≡ pr2 rewrite pr2 = exFalso (noNotYes pr)
goZero b {x :: t} pr | yes x₁ with≡ pr2 with goZeroEmpty b pr2
... | u with applyEquality (mapMaybe canonical) (goPreservesCanonicalRightEmpty b)
... | bl rewrite u | pr = exFalso (nonEmptyNotEmpty (equalityCommutative (yesInjective bl)))


open import FRP.JS.String using ( _≟_ )
open import FRP.JS.Bool using ( Bool ; true ; false ; if_then_else_ ; _∧_ ; _∨_ ; not ; _xor_ )
open import FRP.JS.QUnit using ( TestSuite ; ok ; test ; _,_ )

module FRP.JS.Test.Bool where

tests : TestSuite
tests =
  ( test "true"
    ( ok "true" true )
  , test "false"
    ( ok "false" (not false) )
  , test "if"
    ( ok "if true" (if true then "a" else "b" ≟ "a")
    , ok "if false" (if false then "a" else "b" ≟ "b") )
  , test "∧"
    ( ok "true ∧ true" (true ∧ true)
    , ok "true ∧ false" (not (true ∧ false))
    , ok "false ∧ true" (not (false ∧ true))
    , ok "false ∧ false" (not (false ∧ false)) )
  , test "∨"
    ( ok "true ∨ true" (true ∨ true)
    , ok "true ∨ false" (true ∨ false)
    , ok "false ∨ true" (false ∨ true)
    , ok "false ∨ false" (not (false ∨ false)) )
  , test "xor"
    ( ok "true xor true" (not (true xor true))
    , ok "true xor false" (true xor false)
    , ok "false xor true" (false xor true)
    , ok "false xor false" (not (false xor false)) )
  )


------------------------------------------------------------------------------
-- Bisimilarity relation on unbounded lists
------------------------------------------------------------------------------

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

module FOTC.Relation.Binary.Bisimilarity.Type where

open import FOTC.Base
open import FOTC.Base.List

infix 4 _≈_ _≉_

------------------------------------------------------------------------------
-- The bisimilarity relation _≈_ on unbounded lists is the greatest
-- fixed-point (by ≈-out and ≈-coind) of the bisimulation functional
-- (FOTC.Relation.Binary.Bisimulation).

-- The bisimilarity relation on unbounded lists.
postulate _≈_ : D → D → Set

-- The bisimilarity relation _≈_ on unbounded lists is a post-fixed
-- point of the bisimulation functional (FOTC.Relation.Binary.Bisimulation).
postulate
  ≈-out : ∀ {xs ys} → xs ≈ ys →
          ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ xs' ≈ ys'
{-# ATP axiom ≈-out #-}

-- The bisimilarity relation _≈_ on unbounded lists is the greatest
-- post-fixed point of the bisimulation functional (see
-- FOTC.Relation.Binary.Bisimulation).
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-coind :
    (B : D → D → Set) →
    -- B is a post-fixed point of the bisimulation functional.
    (∀ {xs ys} → B xs ys →
      ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ B xs' ys') →
    -- _≈_ is greater than B.
    ∀ {xs ys} → B xs ys → xs ≈ ys

------------------------------------------------------------------------------
-- Auxiliary definition.
_≉_ : D → D → Set
x ≉ y = ¬ x ≈ y
{-# ATP definition _≉_ #-}


-- Andreas, 2011-09-21, reported by Nisse
-- {-# OPTIONS -v tc.lhs.unify:25 #-}
module Issue292-23 where

data ⊤ : Set where
  tt : ⊤

data D : (A : Set) → A → Set₁ where
  d : (A : Set) (x : A) → D A x

data P : (x : ⊤) → D ⊤ x → Set₁ where
  p : (x : ⊤) → P x (d ⊤ x)

Foo : P tt (d ⊤ tt) → Set₁
Foo (p .tt) = Set
-- should work
-- bug was caused by a use of ureduce instead of reduce


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

open import library.Basics hiding (Type ; Σ)
open import library.types.Sigma
open import library.NType2

open import Sec2preliminaries
open import Sec3hedberg

module Sec4hasConstToSplit where

-- Auxiliary Lemma 4.2
transport-is-comp : {X Y : Type} → {x₁ x₂ : X}
  → (h k : X → Y) → (t : x₁ == x₂) → (p : h x₁ == k x₁)
  → (transport _ t p) == ! (ap h t) ∙ p ∙ ap k t
transport-is-comp h k idp p = ! (∙-unit-r _)

-- Auxiliary Lemma 4.3, part 1
wconstant-implies-path-wconstant : {X Y : Type} → (f : X → Y) → (const f)
  → (x₁ x₂ : X) → const (ap f {x = x₁} {y = x₂})
wconstant-implies-path-wconstant {X} f c x₁ x₂ p₁ p₂ = claim-cor where
  claim : {x₃ x₄ : X} → {p : x₃ == x₄} → (ap f p) == ! (c x₃ x₃) ∙ (c x₃ x₄)
  claim {x₃} {p = idp} = ! (!-inv-l (c x₃ x₃))
  claim-cor : ap f p₁ == ap f p₂
  claim-cor =
    ap f p₁                 =⟨ claim ⟩
    ! (c x₁ x₁) ∙ (c x₁ x₂) =⟨ ! claim ⟩
    ap f p₂                 ∎

-- Auxiliary Lemma 4.3, part 2
wconstant-refl : {X Y : Type} → (f : X → Y) → (const f)
  → (x : X) → (p : x == x) → ap f p == idp
wconstant-refl f c x p = wconstant-implies-path-wconstant f c x x p idp

-- We also need the following very simple lemma:
ap-id-trivial : {X : Type} → {x₁ x₂ : X} → (p : x₁ == x₂) → ap (idf X) p == p
ap-id-trivial idp = idp

-- Lemma 4.1 needs a bit of preparation.
fix : {X : Type} → (f : X → X) → Type
fix {X} f = Σ X λ x → x == f x

-- let us give a name to the map X → fix f:
to-fix : {X : Type} → (f : X → X) → (const f) → X → fix f
to-fix f c x₀ = f x₀ , c _ _

-- the other direction is just projection:
from-fix : {X : Type} → (f : X → X) → fix f → X
from-fix f (x₀ , p₀) = x₀

-- let us structure the proof of the fixed point lemma a bit:
module fixedpoint {X : Type} (f : X → X) (c : const f) where

  -- let us show that (x , p) == (x , q) first
  module _ (x : X) (p q : x == f x) where
    t : x == x
    t = p ∙ ! q

    r : f x == f x
    r = ap f t

    r-is-triv : r == idp
    r-is-triv = wconstant-refl f c x t

    t' : x == x
    t' = ap (idf X) t

    t'-is-t : t' == t
    t'-is-t = ap-id-trivial t

    trans-t-p-is-q : transport (λ y → y == f y) t p == q
    trans-t-p-is-q =
      transport (λ y → y == f y) t p   =⟨  transport-is-comp (idf X) f t p  ⟩
      ! t' ∙ p ∙ r                     =⟨ ap (λ s → ! s ∙ p ∙ r) t'-is-t ⟩
      ! t ∙ p ∙ r                      =⟨ ! (∙-assoc (! t) _ _) ⟩
      (! t ∙ p) ∙ r                    =⟨ ap (λ s → (! t ∙ p) ∙ s) r-is-triv ⟩
      (! t ∙ p) ∙ idp                  =⟨ ∙-unit-r _ ⟩
      ! t ∙ p                          =⟨ ap (λ s → s ∙ p) (!-∙ p (! q)) ⟩
      (! (! q) ∙ ! p) ∙ p              =⟨ ∙-assoc (! (! q)) _ _ ⟩
      ! (! q) ∙ ! p ∙ p                =⟨ ap (λ s → ! (! q) ∙ s) (!-inv-l p) ⟩
      ! (! q) ∙ idp                    =⟨ ∙-unit-r _ ⟩
      ! (! q)                          =⟨ !-! _ ⟩
      q                                ∎

    single-x-claim : (x , p) == (x , q)
    single-x-claim = pair= t (from-transp _ _ trans-t-p-is-q)

  -- Now, we can prove that (x₁ , p₁) and (x₂ , p₂) are always equal:
  fix-paths : has-all-paths (fix f)
  fix-paths (x₁ , p₁) (x₂ , p₂) =
    (x₁ , p₁) =⟨ pair= (p₁ ∙ c x₁ x₂ ∙ ! p₂) (from-transp _ (p₁ ∙ c x₁ x₂ ∙ ! p₂) idp) ⟩
    (x₂ , _)  =⟨ single-x-claim x₂ _ _ ⟩
    (x₂ , p₂) ∎

-- finally, the proof of the fixed point lemma
fixed-point : {X : Type} → (f : X → X) → (const f) → is-prop (fix f)
fixed-point {X} f c = all-paths-is-prop (fixedpoint.fix-paths f c)

-- Sattler's argument
fixed-point-alt : {X : Type} → (f : X → X) → (const f) → is-prop (fix f)
fixed-point-alt {X} f c = inhab-to-contr-is-prop inh→contr where
  inh→contr : fix f → is-contr (fix f)
  inh→contr (x₀ , p₀) = equiv-preserves-level {A = Σ X λ x → x == f x₀} {B = fix f} claim-Σ (pathto-is-contr _) where
    claim : (x : X) → (x == f x₀) ≃ (x == f x)
    claim x = (λ p → p ∙ c x₀ x) , post∙-is-equiv _
    claim-Σ : (Σ X λ x → x == f x₀) ≃ fix f
    claim-Σ = equiv-Σ-snd claim

-- Corollary 4.4
-- let us define the following map:
trunc-to-fix : {X : Type} → (fc : hasConst X) → Trunc X → fix (fst fc)
trunc-to-fix (f , c) z = rec (fixed-point f c) (to-fix f c) z

hasConst→splitSup : {X : Type} → hasConst X → splitSup X
hasConst→splitSup (f , c) = (from-fix f) ∘ trunc-to-fix (f , c)

-- Theorem 4.5
hasConst↔splitSup : {X : Type} → hasConst X ↔ splitSup X
hasConst↔splitSup {X} = hasConst→splitSup , splitSup→hasConst where
  splitSup→hasConst : splitSup X → hasConst X
  splitSup→hasConst hst = f , c where
    f = hst ∘ ∣_∣
    c : const f
    c x₁ x₂ =
      f x₁      =⟨ idp ⟩
      hst ∣ x₁ ∣ =⟨ ap hst (prop-has-all-paths (h-tr _) _ _) ⟩
      hst ∣ x₂ ∣ =⟨ idp ⟩
      f x₂      ∎

-- preparation for Theorem 4.6 - we need to prove that
-- f : X → X with an inhabitant of Trunc (wconst f) is enough
-- to show that fix f is propositional.
fixed-point-strong : {X : Type} → (f : X → X) → (Trunc (const f)) → is-prop (fix f)
fixed-point-strong {X} f = rec {X = const f} {P = is-prop(fix f)} is-prop-is-prop (fixed-point f)

-- Theorem 4.6 (we exclude the part which is already included in 4.5)
-- to get an easy proof of the addendum, we structure it in the following way:
module thm46 {X : Type} where
  module _ (fhc : Σ (X → X) (Trunc ∘ const))  where
    f = fst fhc
    hc = snd fhc
    trunc-wconst-fix : Trunc X → Trunc(const f) → fix f
    trunc-wconst-fix z = rec {X = const f} {P = fix f} (fixed-point-strong f hc) (λ c → trunc-to-fix (f , c) z)
    trunc-fix : Trunc X → fix f
    trunc-fix z = trunc-wconst-fix z hc
    g : X → X
    g = fst ∘ trunc-fix ∘ ∣_∣
    g-wconst : const g
    g-wconst x₁ x₂ = ap (fst ∘ trunc-fix) (prop-has-all-paths (h-tr _) _ _)

hasConst↔hideProof : {X : Type} → hasConst X ↔ Σ (X → X) (Trunc ∘ const)
hasConst↔hideProof {X} = one , two where
  one : hasConst X → Σ (X → X) (Trunc ∘ const)
  one (f , c) = f , ∣ c ∣
  two : (Σ (X → X) (Trunc ∘ const)) → hasConst X
  two fhc = thm46.g fhc , thm46.g-wconst fhc

-- Theorem 4.6 addendum
merely-equal : {X : Type} → (fhc : Σ (X → X) (Trunc ∘ const)) → Trunc ((x : X) → fst fhc x == thm46.g fhc x)
merely-equal {X} (f , hc) = rec (h-tr _) (∣_∣ ∘ wconst-equal) hc where
  open thm46 hiding (f ; hc)
  wconst-equal : const f → (x : X) → f x == thm46.g (f , hc) x
  wconst-equal c x =
    f x                                     =⟨ idp ⟩
    fst (to-fix f c x)                      =⟨ ap fst (! (trunc-β _ _ x)) ⟩
    fst (trunc-to-fix (f , c) ∣ x ∣)          =⟨ ap fst (! (trunc-β _ _ c)) ⟩
    fst (trunc-wconst-fix (f , hc) ∣ x ∣ ∣ c ∣) =⟨ ap (λ hc' → fst (trunc-wconst-fix (f , hc) ∣ x ∣ hc')) (prop-has-all-paths (h-tr _) _ _) ⟩
    fst (trunc-wconst-fix (f , hc) ∣ x ∣ hc)   =⟨ idp ⟩
    fst (trunc-fix (f , hc) ∣ x ∣)            =⟨ idp ⟩
    g (f , hc) x                             ∎


module _ where

-- Ulf's example of why removing abstract may
-- cause a proof that used to work to now fail

-- Agda mailing list, 16 May 2018

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

module WithAbstract where

  abstract
    f : Nat → Nat
    f zero    = zero
    f (suc n) = suc (f n)

    lem : ∀ n → f n ≡ n
    lem zero    = refl
    lem (suc n) rewrite lem n = refl

  thm : ∀ m n → f (suc m) + n ≡ suc (m + n)
  thm m n rewrite lem (suc m) = refl
  -- Works.

  thm′ : ∀ m n → f (suc m) + n ≡ suc (m + n)
  thm′ m n = {!!}

{- Hole 0
Goal: f (suc m) + n ≡ suc (m + n)
————————————————————————————————————————————————————————————
n : Nat
m : Nat
-}

module WithoutAbstract where

  f : Nat → Nat
  f zero    = zero
  f (suc n) = suc (f n)

  lem : ∀ n → f n ≡ n
  lem zero    = refl
  lem (suc n) rewrite lem n = refl

  thm : ∀ m n → f (suc m) + n ≡ suc (m + n)
  thm m n rewrite lem (suc m) = {! refl!}
  -- Fails since rewrite doesn't trigger:
  --   lem (suc m)  : suc (f m)     ≡ suc m
  --   goal         : suc (f m + n) ≡ suc (m + n)

  -- NB: The problem is with the expansion of `f`,
  -- not with the expansion of the lemma

  thm′ : ∀ m n → f (suc m) + n ≡ suc (m + n)
  thm′ m n = {!!}

{- Holes 1 and 2
Goal: suc (f m + n) ≡ suc (m + n)
————————————————————————————————————————————————————————————
n : Nat
m : Nat
-}


module Prelude.Fractional where

open import Agda.Primitive

record Fractional {a} (A : Set a) : Set (lsuc a) where
  infixl 7 _/_
  field
    Constraint : A → A → Set a
    _/_ : (x y : A) {{_ : Constraint x y}} → A

  NoConstraint : Set a
  NoConstraint = ∀ {x y} → Constraint x y

open Fractional {{...}} using (_/_) public
{-# DISPLAY Fractional._/_ _ x y = x / y #-}


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

module mwe where

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_) public

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

data ℕ : Set lzero where
  zero-ℕ : ℕ
  succ-ℕ : ℕ → ℕ

add-ℕ : ℕ → ℕ → ℕ
add-ℕ x zero-ℕ = x
add-ℕ x (succ-ℕ y) = succ-ℕ (add-ℕ x y)

{- The following function returns the triangular numbers. In other words,
   test-with n = (1/2) * n * (n+1) -}

test-with-1 : ℕ → ℕ
test-with-1 x with x
test-with-1 zero-ℕ | y = y
test-with-1 (succ-ℕ x) | y = add-ℕ y (test-with-1 x)

{- Now we construct a function with manual with-abstraction, of which the
   definition *looks* the same. But actually we will have
   test-with-2 n = n * (n+1). -}

cases-test-with-2 : ℕ → ℕ → ℕ
cases-test-with-2 zero-ℕ y = y
cases-test-with-2 (succ-ℕ x) y = add-ℕ y (cases-test-with-2 x y)

test-with-2 : ℕ → ℕ
test-with-2 x = cases-test-with-2 x x

{- The following function test-with-3 is again the same as test-with-1. -}

cases-test-with-3 : ℕ → ℕ → ℕ
cases-test-with-3 zero-ℕ y = y
cases-test-with-3 (succ-ℕ x) zero-ℕ = zero-ℕ
cases-test-with-3 (succ-ℕ x) (succ-ℕ y) =
  add-ℕ (succ-ℕ y) (cases-test-with-3 x y)

test-with-3 : ℕ → ℕ
test-with-3 x = cases-test-with-3 x x

-- test-with-1 (succ-ℕ (succ-ℕ (succ-ℕ (succ-ℕ zero-ℕ))))
-- test-with-2 (succ-ℕ (succ-ℕ (succ-ℕ (succ-ℕ zero-ℕ))))
-- test-with-3 (succ-ℕ (succ-ℕ (succ-ℕ (succ-ℕ zero-ℕ))))

-- We do some basic setup, introducing only what we need. All else is removed.

id : {i : Level} {A : Set i} → A → A
id a = a

data empty : Set lzero where

ex-falso : {i : Level} {A : Set i} → empty → A
ex-falso ()

¬ : {i : Level} → Set i → Set i
¬ A = A → empty

data unit : Set lzero where
  star : unit

data coprod {i j : Level} (A : Set i) (B : Set j) : Set (i ⊔ j)  where
  inl : A → coprod A B
  inr : B → coprod A B

is-decidable : {l : Level} (A : Set l) → Set l
is-decidable A = coprod A (¬ A)

data Id {i : Level} {A : Set i} (x : A) : A → Set i where
  refl : Id x x

_∙_ :
  {i : Level} {A : Set i} {x y z : A} → Id x y → Id y z → Id x z
refl ∙ q = q

inv :
  {i : Level} {A : Set i} {x y : A} → Id x y → Id y x
inv refl = refl

ap :
  {i j : Level} {A : Set i} {B : Set j} (f : A → B) {x y : A} (p : Id x y) →
  Id (f x) (f y)
ap f refl = refl

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

-- We introduce the finite types

Fin : ℕ → Set lzero
Fin zero-ℕ = empty
Fin (succ-ℕ k) = coprod (Fin k) unit

Eq-Fin : (k : ℕ) → Fin k → Fin k → Set lzero
Eq-Fin (succ-ℕ k) (inl x) (inl y) = Eq-Fin k x y
Eq-Fin (succ-ℕ k) (inl x) (inr y) = empty
Eq-Fin (succ-ℕ k) (inr x) (inl y) = empty
Eq-Fin (succ-ℕ k) (inr x) (inr y) = unit

eq-Eq-Fin :
  {k : ℕ} {x y : Fin k} → Eq-Fin k x y → Id x y
eq-Eq-Fin {succ-ℕ k} {inl x} {inl y} e = ap inl (eq-Eq-Fin e)
eq-Eq-Fin {succ-ℕ k} {inr star} {inr star} star = refl

is-decidable-Eq-Fin :
  (k : ℕ) (x y : Fin k) → is-decidable (Eq-Fin k x y)
is-decidable-Eq-Fin (succ-ℕ k) (inl x) (inl y) = is-decidable-Eq-Fin k x y
is-decidable-Eq-Fin (succ-ℕ k) (inl x) (inr y) = inr id
is-decidable-Eq-Fin (succ-ℕ k) (inr x) (inl y) = inr id
is-decidable-Eq-Fin (succ-ℕ k) (inr x) (inr y) = inl star

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

-- We now study the successor and predecessor functions on Fin k

zero-Fin : {k : ℕ} → Fin (succ-ℕ k)
zero-Fin {zero-ℕ} = inr star
zero-Fin {succ-ℕ k} = inl zero-Fin

neg-one-Fin : {k : ℕ} → Fin (succ-ℕ k)
neg-one-Fin {k} = inr star

succ-Fin : {k : ℕ} → Fin k → Fin k
succ-Fin {succ-ℕ zero-ℕ} x = x
succ-Fin {succ-ℕ (succ-ℕ k)} (inl (inl x)) = inl (succ-Fin (inl x))
succ-Fin {succ-ℕ (succ-ℕ k)} (inl (inr x)) = neg-one-Fin
succ-Fin {succ-ℕ (succ-ℕ k)} (inr x) = zero-Fin

succ-neg-one-Fin : {k : ℕ} → Id (succ-Fin (neg-one-Fin {k})) zero-Fin
succ-neg-one-Fin {zero-ℕ} = refl
succ-neg-one-Fin {succ-ℕ k} = refl

pred-Fin' : {k : ℕ} → Fin k → Fin k
pred-Fin' {succ-ℕ k} x with (is-decidable-Eq-Fin (succ-ℕ k) x zero-Fin)
pred-Fin' {succ-ℕ zero-ℕ} (inr star) | d = zero-Fin
pred-Fin' {succ-ℕ (succ-ℕ k)} (inl x) | inl e = neg-one-Fin
pred-Fin' {succ-ℕ (succ-ℕ k)} (inl x) | inr f = inl (pred-Fin' {succ-ℕ k} x)
pred-Fin' {succ-ℕ (succ-ℕ k)} (inr x) | inr f = inl neg-one-Fin

succ-pred-Fin' :
  {k : ℕ} (x : Fin k) → Id (succ-Fin (pred-Fin' x)) x
succ-pred-Fin' {succ-ℕ k} x with is-decidable-Eq-Fin (succ-ℕ k) x zero-Fin
succ-pred-Fin' {succ-ℕ zero-ℕ} (inr star) | d = refl
succ-pred-Fin' {succ-ℕ (succ-ℕ k)} (inl x) | inl e =
  succ-neg-one-Fin ∙ inv (eq-Eq-Fin e)
succ-pred-Fin' {succ-ℕ (succ-ℕ zero-ℕ)} (inl (inr star)) | inr f =
  ex-falso (f star)
succ-pred-Fin' {succ-ℕ (succ-ℕ (succ-ℕ k))} (inl (inl x)) | inr f =
  {!!} ∙ ap inl (succ-pred-Fin' {succ-ℕ (succ-ℕ k)} (inl x))
succ-pred-Fin' {succ-ℕ (succ-ℕ (succ-ℕ k))} (inl (inr star)) | inr f = refl
succ-pred-Fin' {succ-ℕ (succ-ℕ k)} (inr star) | inr f = refl


------------------------------------------------------------------------
-- A small definition of a dependently typed language, using the
-- technique from McBride's "Outrageous but Meaningful Coincidences"
------------------------------------------------------------------------

-- The code contains an example, a partial definition of categories,
-- which triggers the use of an enormous amount of memory (with the
-- development version of Agda which is current at the time of
-- writing). I'm not entirely sure if the code is correct: 2.5G heap
-- doesn't seem to suffice to typecheck this code. /NAD

module Language where

------------------------------------------------------------------------
-- Prelude

record ⊤ : Set₁ where

record Σ (A : Set₁) (B : A → Set₁) : Set₁ where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ

uncurry : ∀ {A : Set₁} {B : A → Set₁} {C : Σ A B → Set₁} →
          ((x : A) (y : B x) → C (x , y)) →
          ((p : Σ A B) → C p)
uncurry f (x , y) = f x y

record ↑ (A : Set) : Set₁ where
  constructor lift
  field
    lower : A

------------------------------------------------------------------------
-- Contexts

-- The definition of contexts is parametrised by a universe.

module Context (U : Set₁) (El : U → Set₁) where

  mutual

    -- Contexts.

    data Ctxt : Set₁ where
      ε   : Ctxt
      _▻_ : (Γ : Ctxt) → Ty Γ → Ctxt

    -- Types.

    Ty : Ctxt → Set₁
    Ty Γ = Env Γ → U

    -- Environments.

    Env : Ctxt → Set₁
    Env ε       = ⊤
    Env (Γ ▻ σ) = Σ (Env Γ) λ γ → El (σ γ)

  -- Variables (de Bruijn indices).

  infix 4 _∋_

  data _∋_ : (Γ : Ctxt) → Ty Γ → Set₁ where
    zero : ∀ {Γ σ}               → Γ ▻ σ ∋ λ γ → σ (proj₁ γ)
    suc  : ∀ {Γ σ τ} (x : Γ ∋ τ) → Γ ▻ σ ∋ λ γ → τ (proj₁ γ)

  -- A lookup function.

  lookup : ∀ {Γ σ} → Γ ∋ σ → (γ : Env Γ) → El (σ γ)
  lookup zero    (γ , v) = v
  lookup (suc x) (γ , v) = lookup x γ

------------------------------------------------------------------------
-- A universe

mutual

  data U : Set₁ where
    set : U
    el  : Set → U
    σ π : (a : U) → (El a → U) → U

  El : U → Set₁
  El set     = Set
  El (el A)  = ↑ A
  El (σ a b) = Σ (El a) λ x → El (b x)
  El (π a b) = (x : El a) → El (b x)

open Context U El

-- Abbreviations.

infixr 20 _⊗_
infixr 10 _⇾_

_⇾_ : U → U → U
a ⇾ b = π a λ _ → b

_⊗_ : U → U → U
a ⊗ b = σ a λ _ → b

-- Example.

raw-categoryU : U
raw-categoryU =
  σ set λ obj →
  σ (el obj ⇾ el obj ⇾ set) λ hom →
  (π (el obj) λ x → el (hom x x))
    ⊗
  (π (el obj) λ x → π (el obj) λ y → π (el obj) λ z →
     el (hom x y) ⇾ el (hom y z) ⇾ el (hom x z))

------------------------------------------------------------------------
-- A language

mutual

  infixl 30 _·_
  infix   4 _⊢_

  -- Syntax for types.

  data Type : (Γ : Ctxt) → Ty Γ → Set₁ where
    set : ∀ {Γ} → Type Γ (λ _ → set)
    el  : ∀ {Γ} (x : Γ ⊢ λ _ → set) → Type Γ (λ γ → el (⟦ x ⟧ γ))
    σ   : ∀ {Γ a b} → Type Γ a → Type (Γ ▻ a) b →
          Type Γ (λ γ → σ (a γ) (λ v → b (γ , v)))
    π   : ∀ {Γ a b} → Type Γ a → Type (Γ ▻ a) b →
          Type Γ (λ γ → π (a γ) (λ v → b (γ , v)))

  -- Terms.

  data _⊢_ : (Γ : Ctxt) → Ty Γ → Set₁ where
    var : ∀ {Γ a} → Γ ∋ a → Γ ⊢ a
    ƛ   : ∀ {Γ a b} → Γ ▻ a ⊢ uncurry b →
          Γ ⊢ (λ γ → π (a γ) (λ v → b γ v))
    _·_ : ∀ {Γ a} {b : (γ : Env Γ) → El (a γ) → U} →
          Γ ⊢ (λ γ → π (a γ) (λ v → b γ v)) →
          (t₂ : Γ ⊢ a) → Γ ⊢ (λ γ → b γ (⟦ t₂ ⟧ γ))

  -- The semantics of a term.

  ⟦_⟧ : ∀ {Γ a} → Γ ⊢ a → (γ : Env Γ) → El (a γ)
  ⟦ var x   ⟧ γ = lookup x γ
  ⟦ ƛ t     ⟧ γ = λ v → ⟦ t ⟧ (γ , v)
  ⟦ t₁ · t₂ ⟧ γ = (⟦ t₁ ⟧ γ) (⟦ t₂ ⟧ γ)

-- Example.

raw-category : Type ε (λ _ → raw-categoryU)
raw-category =
     -- Objects.
   σ set
     -- Morphisms.
  (σ (π (el (var zero)) (π (el (var (suc zero))) set))
     -- Identity.
  (σ (π (el (var (suc zero)))
        (el (var (suc zero) · var zero · var zero)))
     -- Composition.
     (π (el (var (suc (suc zero))))                          -- X.
     (π (el (var (suc (suc (suc zero)))))                    -- Y.
     (π (el (var (suc (suc (suc (suc zero))))))              -- Z.
     (π (el (var (suc (suc (suc (suc zero)))) ·
             var (suc (suc zero)) ·
             var (suc zero)))                                -- Hom X Y.
     (π (el (var (suc (suc (suc (suc (suc zero))))) ·
             var (suc (suc zero)) ·
             var (suc zero)))                                -- Hom Y Z.
        (el (var (suc (suc (suc (suc (suc (suc zero)))))) ·
             var (suc (suc (suc (suc zero)))) ·
             var (suc (suc zero)))))                         -- Hom X Z.
  ))))))


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

open import Level

module Categories.Categories.Products (o ℓ e : Level) where

open import Categories.Category
open import Categories.Categories

import Categories.Object.Products
open Categories.Object.Products (Categories o ℓ e)

open import Categories.Product
import Categories.Product.Projections
import Categories.Product.Properties

open import Categories.Terminal

private
    import Categories.Object.Product
    open Categories.Object.Product (Categories o ℓ e)
        renaming (Product to ProductObject)

    product :
        {A B : Category o ℓ e}
        → ProductObject A B

    product {A}{B} = record
        { A×B       = Product A B
        ; π₁        = ∏₁
        ; π₂        = ∏₂
        ; ⟨_,_⟩     = _※_
        ; commute₁  = λ {C}{f}{g}    → ※-commute₁  {A = C}{f}{g}
        ; commute₂  = λ {C}{f}{g}    → ※-commute₂  {A = C}{f}{g}
        ; universal = λ {C}{f}{g}{i} → ※-universal {A = C}{f}{g}{i}
        } where
            open Categories.Product.Projections A B
            open Categories.Product.Properties  A B

products : Products
products = record
    { terminal = One {o}{ℓ}{e}
    ; binary = record
        { product = λ {A}{B} → product {A}{B}
        }
    }


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Categories.Limits.Terminal where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Sigma
-- open import Cubical.Categories.Limits.Base
open import Cubical.Categories.Category
open import Cubical.Categories.Functor

private
  variable
    ℓ ℓ' : Level

module _ (C : Precategory ℓ ℓ') where
  open Precategory C

  isInitial : (x : ob) → Type (ℓ-max ℓ ℓ')
  isInitial x = ∀ (y : ob) → isContr (C [ x , y ])

  isFinal : (x : ob) → Type (ℓ-max ℓ ℓ')
  isFinal x = ∀ (y : ob) → isContr (C [ y , x ])

  hasFinalOb : Type (ℓ-max ℓ ℓ')
  hasFinalOb = Σ[ x ∈ ob ] isFinal x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Automatic solvers for equations over naturals
------------------------------------------------------------------------

-- See README.Nat for examples of how to use this solver

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

module Data.Nat.Tactic.RingSolver where

open import Agda.Builtin.Reflection

open import Data.Maybe.Base using (just; nothing)
open import Data.Nat.Base using (zero; suc)
open import Data.Nat.Properties
open import Level using (0ℓ)
open import Data.Unit using (⊤)
open import Relation.Binary.PropositionalEquality

import Tactic.RingSolver as Solver
import Tactic.RingSolver.Core.AlmostCommutativeRing as ACR

------------------------------------------------------------------------
-- A module for automatically solving propositional equivalences
-- containing _+_ and _*_

ring : ACR.AlmostCommutativeRing 0ℓ 0ℓ
ring = ACR.fromCommutativeSemiring *-+-commutativeSemiring
  λ { zero → just refl; _ → nothing }

macro
  solve-∀ : Term → TC ⊤
  solve-∀ = Solver.solve-∀-macro (quote ring)

macro
  solve : Term → Term → TC ⊤
  solve n = Solver.solve-macro n (quote ring)


-- Jesper, 2018-10-29 (comment on #3332): Besides for rewrite, builtin
-- equality is also used for primErase and primForceLemma. But I don't
-- see how it would hurt to have these use a Prop instead of a Set for
-- equality.

{-# OPTIONS --prop #-}

data _≡_ {A : Set} (a : A) : A → Prop where
  refl : a ≡ a
{-# BUILTIN EQUALITY _≡_ #-}


module Plain.Terms where

open import Data.Nat
open import Data.Fin

record Signature (n : ℕ) : Set where
  field
    -- symbols are encoded as numbers in Fin n
    -- arity
    ar : Fin n → ℕ

open Signature public

-- | Countable set of Variables
Var : Set
Var = ℕ

open import Data.Vec as V
open import Size
-- | Term in with a signature Σ with variables var
data Term {i : Size} {j : Size< i} {n : ℕ}
  (Σ : Signature n) (var : Set) : Set where
   FNode : {k : Size< j}
     → (f : Fin n) → Vec (Term {j} {k} {n} Σ var) (ar Σ f)
     → Term {i} {j} {n} Σ var
   VNode :  (v : var) → Term {i} {j} {n} Σ var

open import Data.Empty

-- | Ground Terms
GTerm : {n : ℕ} → (Σ : Signature n) → Set
GTerm Σ =  Term Σ ⊥

open import Data.List as L

-- | Horn clause
--
data Clause {n : ℕ} (Σ : Signature n) : Set where
  _:-_ : (Term Σ Var) → List (Term Σ Var)  → Clause Σ

cHead : {n : ℕ} → {Σ : Signature n} → Clause Σ → Term Σ Var
cHead (a :- _) = a

cBody : {n : ℕ} → {Σ : Signature n} → Clause Σ → List (Term Σ Var)
cBody (_ :- bs) = bs

record Program {n : ℕ} (Σ : Signature n) : Set where
  field
    prg : List (Clause Σ) -- → Program Σ

--unPrg : {n : ℕ} → {Σ : Signature n} → Program Σ → List (Clause Σ)
--unPrg (prg cls) = cls

record GSubst {n : ℕ} (Σ : Signature n) : Set₁ where
  field
    subst : (Var → GTerm Σ)

open GSubst

-- | substitution application
app : {i : Size} → {j : Size< i} →
  {n : ℕ} → {Σ : Signature n}
  → GSubst Σ → Term {i} {j} Σ Var → GTerm Σ
app σ (FNode f fs) = FNode f (V.map (app σ) fs)
app σ (VNode v) = subst σ v


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

open import HoTT

module homotopy.ConstantToSetExtendsToProp {i j}
  {A : Type i} {B : Type j} (B-is-set : is-set B)
  (f : A → B) (f-is-const : ∀ a₁ a₂ → f a₁ == f a₂) where

  private
    Skel = SetQuot {A = A} (λ _ _ → Unit)

    abstract
      Skel-has-all-paths : has-all-paths Skel
      Skel-has-all-paths =
        SetQuot-elim (λ _ → Π-is-set λ _ → =-preserves-set SetQuot-is-set)
          (λ a₁ →
            SetQuot-elim {P = λ s₂ → q[ a₁ ] == s₂}
              (λ _ → =-preserves-set SetQuot-is-set)
              (λ _ → quot-rel _)
              (λ _ → prop-has-all-paths-↓ (SetQuot-is-set _ _)))
          (λ {a₁ a₂} _ → ↓-Π-cst-app-in λ s₂ →
              prop-has-all-paths-↓ (SetQuot-is-set _ _))

    Skel-is-prop : is-prop Skel
    Skel-is-prop = all-paths-is-prop Skel-has-all-paths

    Skel-lift : Skel → B
    Skel-lift = SetQuot-rec B-is-set f (λ {a₁ a₂} _ → f-is-const a₁ a₂)

  ext : Trunc -1 A → B
  ext = Skel-lift ∘ Trunc-rec Skel-is-prop q[_]

  abstract
    ext-is-const : ∀ a₁ a₂ → ext a₁ == ext a₂
    ext-is-const = Trunc-elim
      (λ a₁ → Π-is-prop λ a₂ → B-is-set _ _)
      (λ a₁ → Trunc-elim (λ a₂ → B-is-set _ _)
        (λ a₂ → f-is-const a₁ a₂))

  private
    abstract
      -- The beta rule.
      -- This is definitionally true, so you don't need it.
      β : ext ∘ [_] == f
      β = idp


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Categories.Category.Base where

open import Cubical.Core.Glue
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv

private
  variable
    ℓ ℓ' : Level

-- Precategories

record Precategory ℓ ℓ' : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  -- no-eta-equality ; NOTE: need eta equality for `opop`
  field
    ob : Type ℓ
    Hom[_,_] : ob → ob → Type ℓ'
    id : ∀ x → Hom[ x , x ]
    _⋆_ : ∀ {x y z} (f : Hom[ x , y ]) (g : Hom[ y , z ]) → Hom[ x , z ]
    -- TODO: change these to implicit argument
    ⋆IdL : ∀ {x y : ob} (f : Hom[ x , y ]) → (id x) ⋆ f ≡ f
    ⋆IdR : ∀ {x y} (f : Hom[ x , y ]) → f ⋆ (id y) ≡ f
    ⋆Assoc : ∀ {u v w x} (f : Hom[ u , v ]) (g : Hom[ v , w ]) (h : Hom[ w , x ]) → (f ⋆ g) ⋆ h ≡ f ⋆ (g ⋆ h)

  -- composition: alternative to diagramatic order
  _∘_ : ∀ {x y z} (g : Hom[ y , z ]) (f : Hom[ x , y ]) → Hom[ x , z ]
  g ∘ f = f ⋆ g

open Precategory

-- Helpful syntax/notation

_[_,_] : (C : Precategory ℓ ℓ') → (x y : C .ob) → Type ℓ'
_[_,_] = Hom[_,_]

-- needed to define this in order to be able to make the subsequence syntax declaration
seq' : ∀ (C : Precategory ℓ ℓ') {x y z} (f : C [ x , y ]) (g : C [ y , z ]) → C [ x , z ]
seq' = _⋆_

infixl 15 seq'
syntax seq' C f g = f ⋆⟨ C ⟩ g

-- composition
comp' : ∀ (C : Precategory ℓ ℓ') {x y z} (g : C [ y , z ]) (f : C [ x , y ]) → C [ x , z ]
comp' = _∘_

infixr 16 comp'
syntax comp' C g f = g ∘⟨ C ⟩ f

-- Categories

record isCategory (C : Precategory ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
  field
    isSetHom : ∀ {x y} → isSet (C [ x , y ])

-- Isomorphisms and paths in precategories

record CatIso {C : Precategory ℓ ℓ'} (x y : C .Precategory.ob) : Type ℓ' where
  constructor catiso
  field
    mor : C [ x , y ]
    inv : C [ y , x ]
    sec : inv ⋆⟨ C ⟩ mor ≡ C .id y
    ret : mor ⋆⟨ C ⟩ inv ≡ C .id x

pathToIso : {C : Precategory ℓ ℓ'} (x y : C .ob) (p : x ≡ y) → CatIso {C = C} x y
pathToIso {C = C} x y p = J (λ z _ → CatIso x z) (catiso (C .id x) idx (C .⋆IdL idx) (C .⋆IdL idx)) p
  where
    idx = C .id x

-- Univalent Categories

record isUnivalent (C : Precategory ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
  field
    univ : (x y : C .ob) → isEquiv (pathToIso {C = C} x y)

  -- package up the univalence equivalence
  univEquiv : ∀ (x y : C .ob) → (x ≡ y) ≃ (CatIso x y)
  univEquiv x y = (pathToIso {C = C} x y) , (univ x y)

open isUnivalent public

-- Opposite Categories

_^op : Precategory ℓ ℓ' → Precategory ℓ ℓ'
(C ^op) .ob = C .ob
(C ^op) .Hom[_,_] x y = C .Hom[_,_] y x
(C ^op) .id = C .id
(C ^op) ._⋆_ f g = C ._⋆_ g f
(C ^op) .⋆IdL = C .⋆IdR
(C ^op) .⋆IdR = C .⋆IdL
(C ^op) .⋆Assoc f g h = sym (C .⋆Assoc _ _ _)

open isCategory public


module Vector where

open import OscarPrelude
open import Arity

record Vector (A : Set) (𝑎 : Arity) : Set
 where
  constructor ⟨_⟩
  field
    vector : Vec A (arity 𝑎)

open Vector public

instance EqVector : {A : Set} ⦃ _ : Eq A ⦄ {𝑎 : Arity} → Eq (Vector A 𝑎)
Eq._==_ EqVector _ = decEq₁ (cong vector) ∘ (_≟_ on vector $ _)


module Oscar.Class.Equivalence where

open import Oscar.Class.Reflexivity
open import Oscar.Class.Symmetry
open import Oscar.Class.Transitivity
open import Oscar.Function
open import Oscar.Level

record Equivalence {a} {A : Set a} {ℓ} (_≋_ : A → A → Set ℓ) : Set (a ⊔ ℓ) where
  field
    ⦃ ′reflexivity ⦄ : Reflexivity _≋_
    ⦃ ′symmetry ⦄ : Symmetry _≋_
    ⦃ ′transitivity ⦄ : Transitivity _≋_

open Equivalence ⦃ … ⦄ public hiding (′reflexivity; ′symmetry; ′transitivity)

instance

  Equivalence⋆ : ∀
    {a} {A : Set a} {ℓ} {_≋_ : A → A → Set ℓ}
    ⦃ _ : Reflexivity _≋_ ⦄
    ⦃ _ : Symmetry _≋_ ⦄
    ⦃ _ : Transitivity _≋_ ⦄
    → Equivalence _≋_
  Equivalence.′reflexivity Equivalence⋆ = it
  Equivalence.′symmetry Equivalence⋆ = it
  Equivalence.′transitivity Equivalence⋆ = it


module Structure.Operator.Ring.Proofs where

import      Data.Tuple as Tuple
open import Functional
open import Logic.IntroInstances
open import Logic.Propositional
import      Lvl
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Operator.Properties
open import Structure.Operator.Ring
open import Structure.Operator
open import Structure.Operator.Proofs
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Implication
open import Syntax.Transitivity
open import Type.Properties.MereProposition
open import Type.Properties.Singleton
open import Type.Properties.Singleton.Proofs
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable T : Type{ℓ}
private variable _+_ _⋅_ : T → T → T

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ rng : Rng{T = T}(_+_)(_⋅_) ⦄ where
  open Rng(rng)

  instance
    [+]-cancellationₗ : Cancellationₗ(_+_)
    [+]-cancellationₗ = One.cancellationₗ-by-associativity-inverse

  instance
    [+]-cancellationᵣ : Cancellationᵣ(_+_)
    [+]-cancellationᵣ = One.cancellationᵣ-by-associativity-inverse

  instance
    [⋅]-absorberₗ : Absorberₗ(_⋅_)(𝟎)
    Absorberₗ.proof [⋅]-absorberₗ {x} = One.zero-when-redundant-addition $
      𝟎 ⋅ x             🝖-[ congruence₂ₗ(_⋅_)(x) (identityₗ(_+_)(𝟎)) ]-sym
      (𝟎 + 𝟎) ⋅ x       🝖-[ distributivityᵣ(_⋅_)(_+_) ]
      (𝟎 ⋅ x) + (𝟎 ⋅ x) 🝖-end

  instance
    [⋅]-absorberᵣ : Absorberᵣ(_⋅_)(𝟎)
    Absorberᵣ.proof [⋅]-absorberᵣ {x} = One.zero-when-redundant-addition $
      x ⋅ 𝟎             🝖-[ congruence₂ᵣ(_⋅_)(x) (identityₗ(_+_)(𝟎)) ]-sym
      x ⋅ (𝟎 + 𝟎)       🝖-[ distributivityₗ(_⋅_)(_+_) ]
      (x ⋅ 𝟎) + (x ⋅ 𝟎) 🝖-end

  -- TODO: Stuff provable in groups
  [−]-binaryOperator : BinaryOperator(_−_)
  BinaryOperator.congruence [−]-binaryOperator {x₁}{y₁}{x₂}{y₂} xy1 xy2 =
    (x₁ − x₂)     🝖[ _≡_ ]-[]
    (x₁ + (− x₂)) 🝖[ _≡_ ]-[ congruence₂(_+_) xy1 (congruence₁(−_) xy2) ]
    (y₁ + (− y₂)) 🝖[ _≡_ ]-[]
    (y₁ − y₂)     🝖-end

  postulate [⋅][−]-distributivityₗ : Distributivityₗ(_⋅_)(_−_)
  postulate [⋅][−]-distributivityᵣ : Distributivityᵣ(_⋅_)(_−_)

  instance
    [−]-involution : Involution(−_)
    [−]-involution = intro One.double-inverse

  [+]-negation-distribution : ∀{x y} → (−(x + y) ≡ (− x) + (− y))
  [+]-negation-distribution = One.inverse-distribution 🝖 commutativity(_+_)

  [−]-negation-distribution : ∀{x y} → (−(x − y) ≡ y − x)
  [−]-negation-distribution = One.inverse-distribution 🝖 congruence₂ₗ(_−_) ⦃ [−]-binaryOperator ⦄ (_) (involution(−_))

  -- TODO: See abs-of-negation for a similiar proof
  postulate zero-when-equal-negation : ∀{x} → (− x ≡ x) → (x ≡ 𝟎)

  instance
    [+]-inversePropₗ : InversePropertyₗ(_+_)(−_)
    [+]-inversePropₗ = One.inverse-propertyₗ-by-groupₗ

  instance
    [+]-inversePropᵣ : InversePropertyᵣ(_+_)(−_)
    [+]-inversePropᵣ = One.inverse-propertyᵣ-by-groupᵣ

  [+][−]-inverseOperᵣ : InverseOperatorᵣ(_+_)(_−_)
  [+][−]-inverseOperᵣ = One.standard-inverse-inverse-operatorᵣ-by-inverse-propᵣ ⦃ inverPropᵣ = [+]-inversePropᵣ ⦄

  [−][+]-inverseOperᵣ : InverseOperatorᵣ(_−_)(_+_)
  [−][+]-inverseOperᵣ = One.standard-inverse-operatorᵣ-by-involuting-inverse-propᵣ ⦃ inverPropᵣ = [+]-inversePropᵣ ⦄

  -- TODO: Defined set subset of natural numbers and integers by using summation ∑. That is: (x ∈ ℕ) = ∃{Obj = ℕ}(n ↦ ∑(0 ‥ n) (const 𝟏))

  [−]-of-𝟎 : ((− 𝟎) ≡ 𝟎)
  [−]-of-𝟎 =
    − 𝟎       🝖-[ symmetry(_≡_) (identityₗ(_+_)(𝟎)) ]
    𝟎 + (− 𝟎) 🝖-[ inverseFunctionᵣ(_+_)(−_) ]
    𝟎         🝖-end

  [−]-is-𝟎 : ∀{x} → ((− x) ≡ 𝟎) ↔ (x ≡ 𝟎)
  [−]-is-𝟎 = [↔]-intro (p ↦ congruence₁(−_) p 🝖 [−]-of-𝟎) (p ↦ symmetry(_≡_) (involution(−_)) 🝖 congruence₁(−_) p 🝖 [−]-of-𝟎)

  [−]-difference-is-𝟎 : ∀{x y} → ((x − y) ≡ 𝟎) ↔ (x ≡ y)
  [−]-difference-is-𝟎 {x}{y} = [↔]-intro l r where
    l =
      (x     ≡ y    ) ⇒-[ congruence₂ᵣ(_−_) ⦃ [−]-binaryOperator ⦄ (x) ]
      (x − x ≡ x − y) ⇒-[ symmetry(_≡_) ]
      (x − y ≡ x − x) ⇒-[ _🝖 inverseFunctionᵣ(_+_)(−_) ]
      (x − y ≡ 𝟎    ) ⇒-end

    r =
      (x − y           ≡ 𝟎    ) ⇒-[]
      (x + (− y)       ≡ 𝟎    ) ⇒-[ congruence₂ₗ(_+_)(y) ]
      ((x + (− y)) + y ≡ 𝟎 + y) ⇒-[ symmetry(_≡_) (associativity(_+_)) 🝖_ ]
      (x + ((− y) + y) ≡ 𝟎 + y) ⇒-[ congruence₂ᵣ(_+_)(x) (symmetry(_≡_) (inverseFunctionₗ(_+_)(−_))) 🝖_ ]
      (x + 𝟎           ≡ 𝟎 + y) ⇒-[ (\p → symmetry(_≡_) (identityᵣ(_+_)(𝟎)) 🝖 p 🝖 identityₗ(_+_)(𝟎)) ]
      (x               ≡ y    ) ⇒-end

  module _ ⦃ unity : Unity(_+_)(_⋅_) ⦄ where
    open import Type.Properties.MereProposition
    open import Type.Properties.Singleton
    open import Type.Properties.Singleton.Proofs

    open Unity(unity)

    singleton-when-identities-equal : (𝟎 ≡ 𝟏) ↔ IsUnit(T)
    singleton-when-identities-equal = [↔]-intro l r where
      l : (𝟎 ≡ 𝟏) ← IsUnit(T)
      l p = uniqueness(_) ⦃ inst = unit-is-prop ⦃ proof = p ⦄ ⦄

      r : (𝟎 ≡ 𝟏) → IsUnit(T)
      IsUnit.unit       (r oi)     = 𝟎
      IsUnit.uniqueness (r oi) {x} =
        x     🝖[ _≡_ ]-[ identityᵣ(_⋅_)(𝟏) ]-sym
        x ⋅ 𝟏 🝖[ _≡_ ]-[ congruence₂ᵣ(_⋅_)(x) oi ]-sym
        x ⋅ 𝟎 🝖[ _≡_ ]-[ absorberᵣ(_⋅_)(𝟎) ]
        𝟎     🝖-end

    [⋅]ₗ-of-[−1] : ∀{x} → ((− 𝟏) ⋅ x ≡ − x)
    [⋅]ₗ-of-[−1] {x} = One.unique-inverseᵣ-by-id $
      x + ((− 𝟏) ⋅ x)       🝖-[ congruence₂ₗ(_+_)(_) (identityₗ(_⋅_)(𝟏)) ]-sym
      (𝟏 ⋅ x) + ((− 𝟏) ⋅ x) 🝖-[ distributivityᵣ(_⋅_)(_+_) ]-sym
      (𝟏 + (− 𝟏)) ⋅ x       🝖-[ congruence₂ₗ(_⋅_)(x) (inverseFunctionᵣ(_+_)(−_)) ]
      𝟎 ⋅ x                 🝖-[ absorberₗ(_⋅_)(𝟎) ]
      𝟎                     🝖-end

    [⋅]ᵣ-of-[−1] : ∀{x} → (x ⋅ (− 𝟏) ≡ − x)
    [⋅]ᵣ-of-[−1] {x} = One.unique-inverseₗ-by-id $
      (x ⋅ (− 𝟏)) + x       🝖-[ congruence₂ᵣ(_+_)(_) (identityᵣ(_⋅_)(𝟏)) ]-sym
      (x ⋅ (− 𝟏)) + (x ⋅ 𝟏) 🝖-[ distributivityₗ(_⋅_)(_+_) ]-sym
      x ⋅ ((− 𝟏) + 𝟏)       🝖-[ congruence₂ᵣ(_⋅_)(x) (inverseFunctionₗ(_+_)(−_)) ]
      x ⋅ 𝟎                 🝖-[ absorberᵣ(_⋅_)(𝟎) ]
      𝟎                     🝖-end

    [⋅]ₗ-of-[−] : ∀{x y} → ((− x) ⋅ y ≡ −(x ⋅ y))
    [⋅]ₗ-of-[−] {x}{y} =
      ((− x) ⋅ y)       🝖-[ congruence₂ₗ(_⋅_)(y) [⋅]ₗ-of-[−1] ]-sym
      (((− 𝟏) ⋅ x) ⋅ y) 🝖-[ associativity(_⋅_) ]
      ((− 𝟏) ⋅ (x ⋅ y)) 🝖-[ [⋅]ₗ-of-[−1] ]
      (−(x ⋅ y))        🝖-end

    [⋅]ᵣ-of-[−] : ∀{x y} → (x ⋅ (− y) ≡ −(x ⋅ y))
    [⋅]ᵣ-of-[−] {x}{y} =
      (x ⋅ (− y))       🝖-[ congruence₂ᵣ(_⋅_)(x) [⋅]ᵣ-of-[−1] ]-sym
      (x ⋅ (y ⋅ (− 𝟏))) 🝖-[ associativity(_⋅_) ]-sym
      ((x ⋅ y) ⋅ (− 𝟏)) 🝖-[ [⋅]ᵣ-of-[−1] ]
      (−(x ⋅ y))        🝖-end

    [⋅]-of-[−] : ∀{x y} → ((− x) ⋅ (− y) ≡ x ⋅ y)
    [⋅]-of-[−] {x}{y} =
      ((− x) ⋅ (− y)) 🝖[ _≡_ ]-[ [⋅]ᵣ-of-[−] ]
      −((− x) ⋅ y)    🝖[ _≡_ ]-[ congruence₁(−_) [⋅]ₗ-of-[−] ]
      −(−(x ⋅ y))     🝖[ _≡_ ]-[ involution(−_) ]
      (x ⋅ y)         🝖-end


-- this is so this can be imported even though it has unresolved holes
{-# OPTIONS --allow-unsolved-metas #-}

module v01-01-basics where

import Relation.Binary.PropositionalEquality as Eq
open Eq             using (_≡_; refl)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)

data day : Set where
 mon : day
 tue : day
 wed : day
 thu : day
 fri : day
 sat : day
 sun : day

next-weekday : day → day
next-weekday mon = tue
next-weekday tue = wed
next-weekday wed = thu
next-weekday thu = fri
next-weekday fri = mon
next-weekday sat = mon
next-weekday sun = mon

_ : next-weekday fri ≡ mon
_ = refl

_ : next-weekday (next-weekday sat) ≡ tue
_ = refl

data bool : Set where
  true  : bool
  false : bool

negb : bool → bool
negb true  = false
negb false = true

andb : bool → bool → bool
andb  true b2 = b2
andb false  _ = false

orb : bool → bool → bool
orb  true  _ = true
orb false b2 = b2

_ : orb false false ≡ false
_ = refl
_ : orb false  true ≡ true
_ = refl
_ : orb  true false ≡ true
_ = refl
_ : orb  true  true ≡ true
_ = refl

nandb : bool → bool → bool
nandb true true = false
nandb    _    _ = true

_ : nandb false false ≡ true
_ = refl
_ : nandb false  true ≡ true
_ = refl
_ : nandb  true false ≡ true
_ = refl
_ : nandb  true  true ≡ false
_ = refl

andb3 : bool → bool → bool → bool
andb3 true true true = true
andb3    _    _    _ = false

_ : andb3  true  true  true ≡ true
_ = refl
_ : andb3 false  true  true ≡ false
_ = refl
_ : andb3  true false  true ≡ false
_ = refl
_ : andb3  true  true false ≡ false
_ = refl

data rgb : Set where
  red   : rgb
  green : rgb
  blue  : rgb

data color : Set where
  black   : color
  white   : color
  primary : rgb → color

monochrome : color → bool
monochrome black = true
monochrome white = true
monochrome (primary _) = false

isred : color → bool
isred (primary red) = true
isred            _  = false

data bit : Set where
  B0 : bit
  B1 : bit

data nybble : Set where
  bits : (b0 b1 b2 b3 : bit) → nybble

all-zero : nybble → bool
all-zero (bits B0 B0 B0 B0) = true
all-zero                 _  = false

_ : all-zero (bits B1 B0 B1 B0) ≡ false
_ = refl
_ : all-zero (bits B0 B0 B0 B0) ≡ true
_ = refl

data nat : Set where
  O : nat
  S : nat → nat

pred : nat → nat
pred    O  = O
pred (S n) = n

{-# BUILTIN NATURAL nat #-}

_ : S (S (S (S O))) ≡ 4
_ = refl

minustwo : nat → nat
minustwo       O   = O
minustwo    (S O)  = O
minustwo (S (S n)) = n

_ : minustwo 4 ≡ 2
_ = refl

evenb : nat → bool
evenb       O   = true
evenb    (S O)  = false
evenb (S (S n)) = evenb n

oddb : nat → bool
oddb n = negb (evenb n)

_ : oddb 1 ≡ true
_ = refl
_ : oddb 4 ≡ false
_ = refl

plus : nat → nat → nat
plus    O  m = m
plus (S n) m = S (plus n m)

_ : plus 3 2 ≡ 5
_ = refl

mult : nat → nat → nat
mult    O  m = 0
mult (S n) m = plus m (mult n m)

_ : mult 3 3 ≡ 9
_ = refl

minus : nat → nat → nat
minus    O     _  = O
minus    x     O  = x
minus (S n) (S m) = minus n m

exp : (base power : nat) → nat
exp _    O  = S O
exp b (S p) = mult b (exp b p)

_ : exp 2 0 ≡ 1
_ = refl
_ : exp 2 1 ≡ 2
_ = refl
_ : exp 2 2 ≡ 4
_ = refl
_ : exp 2 3 ≡ 8
_ = refl

factorial : nat → nat
factorial    O  = 1
factorial (S n) = mult (S n) (factorial n)

_ : factorial 3 ≡ 6
_ = refl
_ : factorial 5 ≡ mult 10 12
_ = refl

_+_ : nat → nat → nat
_+_ = plus

_-_ : nat → nat → nat
_-_ = minus

_*_ : nat → nat → nat
_*_ = mult

infixl 6  _+_  _-_
infixl 7  _*_
{-# BUILTIN NATPLUS  _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}
{-# BUILTIN NATMINUS _-_ #-}

eqb : (n m : nat) → bool
eqb    O     O  = true
eqb    O  (S _) = false
eqb (S _)    O  = false
eqb (S l) (S r) = eqb l r

leb : (n m : nat) → bool
leb    O     _  = true
leb (S n)    O  = false
leb (S n) (S m) = leb n m

_ : leb 2 2 ≡ true
_ = refl
_ : leb 2 4 ≡ true
_ = refl
_ : leb 4 2 ≡ false
_ = refl

_=?_ : (n m : nat) → bool
_=?_ = eqb

_<=?_ : (n m : nat) → bool
_<=?_ = leb

infix 4 _=?_
infix 4 _<=?_

_ : (4 <=? 2) ≡ false
_ = refl

ltb : (n m : nat) → bool
ltb    O     O  = false
ltb    O  (S m) = true
ltb (S n)    O  = false
ltb (S n) (S m) = ltb n m

_<?_ : (n m : nat) → bool
_<?_ = ltb
infix 4 _<?_

_ : ltb 2 2 ≡ false
_ = refl
_ : ltb 2 4 ≡ true
_ = refl
_ : ltb 4 2 ≡ false
_ = refl

-- proof by simplification

plus-O-n : ∀ {n : nat} → 0 + n ≡ n
plus-O-n = refl

plus-1-l : ∀ {n : nat} → 1 + n ≡ S n
plus-1-l = refl

mult-O-l : ∀ {n : nat} → 0 * n ≡ 0
mult-O-l = refl

-- proof by rewriting

plus-id-example : ∀ {n m : nat}
  →     n ≡ m
  → n + n ≡ m + m
plus-id-example n≡m rewrite n≡m = refl

plus_id_exercise : ∀ {n m o : nat}
  → n     ≡ m
  →     m ≡     o
  → n + m ≡ m + o
plus_id_exercise n≡m m≡o rewrite n≡m | m≡o = refl

*0 : ∀ (m : nat) → m * 0 ≡ 0
*0    0  = refl
*0 (S m) = *0 m

mult-n-O : ∀ (n : nat) → 0 ≡ n * 0
mult-n-O n rewrite *0 n = refl

*1 : ∀ (n : nat) → n * 1 ≡ n
*1    0 = refl
*1 (S n) rewrite *1 n = refl

1* : ∀ (n : nat) → 1 * n ≡ n
1*    0 = refl
1* (S n) rewrite 1* n = refl

mult-n-Sm : ∀ (n m : nat) → n * m + n ≡ n * S m
mult-n-Sm    O     m  = refl
mult-n-Sm    n     O  rewrite *0 n | plus-O-n {n} | *1 n = refl
mult-n-Sm (S n) (S m) = {!!} -- TODO

mult-n-0-m-0 : ∀ (p q : nat)
  → (p * 0) + (q * 0) ≡ 0
mult-n-0-m-0 p q rewrite *0 p | *0 q = refl

mult-n-1 : ∀ (p : nat) → p * 1 ≡ p
mult-n-1 = *1

-- proof by case analysis

plus-1-neq-0 : ∀ (n : nat) → ((n + 1) =? 0) ≡ false
plus-1-neq-0    O  = refl
plus-1-neq-0 (S n) rewrite plus-1-neq-0 n = refl

negb-involutive : ∀ (b : bool) → negb (negb b) ≡ b
negb-involutive true  = refl
negb-involutive false = refl

andb-commutative : ∀ (b c : bool) → andb b c ≡ andb c b
andb-commutative false false = refl
andb-commutative false  true = refl
andb-commutative  true false = refl
andb-commutative  true  true = refl

andb3-exchange : ∀ (b c d : bool) → andb (andb b c) d ≡ andb (andb b d) c
andb3-exchange  true  true  true = refl
andb3-exchange  true  true false = refl
andb3-exchange  true false  true = refl
andb3-exchange  true false false = refl
andb3-exchange false  true  true = refl
andb3-exchange false  true false = refl
andb3-exchange false false  true = refl
andb3-exchange false false false = refl

andb-true-elim2 : ∀ (b c : bool)
  → andb b c ≡ true
  →        c ≡ true
andb-true-elim2 false      _ ()
andb-true-elim2  true  false ()
andb-true-elim2  true   true _ = refl

zero-nbeq-plus-1 : ∀ (n : nat) → (0 =? (n + 1)) ≡ false
zero-nbeq-plus-1    O  = refl
zero-nbeq-plus-1 (S n) rewrite  zero-nbeq-plus-1 n = refl

identity-fn-applied-twice : ∀ {f : bool → bool} (b : bool)
  →    f b  ≡ b
  → f (f b) ≡ b
identity-fn-applied-twice b p rewrite p | p = refl

negation-fn-applied-twice : ∀ {f : bool → bool} {b : bool} -- TODO
  →    f b  ≡ negb b
  → f (f b) ≡ b
negation-fn-applied-twice {f} {false} p = {!!} -- TODO
negation-fn-applied-twice {f}  {true} p = {!!} -- TODO

andb-eq-orb : ∀ (b c : bool)
  → andb b c ≡ orb b c
  →      b   ≡       c
andb-eq-orb  true c p rewrite p = refl
andb-eq-orb false c p rewrite p = refl

-- NOTE: lowest order bit is on LEFT
data bin : Set where
  Z  : bin
  B₀ : bin → bin
  B₁ : bin → bin

incr : bin → bin
incr     Z  = B₁ Z
incr (B₀ x) = B₁ x
incr (B₁ x) = B₀ (incr x)

bin-to-nat : bin → nat
bin-to-nat     Z  = 0
bin-to-nat (B₀ x) =     2 * (bin-to-nat x)
bin-to-nat (B₁ x) = 1 + 2 * (bin-to-nat x)

_ :     (incr (B₁ Z))  ≡     B₀ (B₁ Z)
_ = refl
_ : (incr (B₀ (B₁ Z))) ≡     B₁ (B₁ Z)
_ = refl
_ : (incr (B₁ (B₁ Z))) ≡ B₀ (B₀ (B₁ Z))
_ = refl

_ : bin-to-nat         (B₀ (B₁ Z))  ≡ 2
_ = refl
_ : bin-to-nat       (incr (B₁ Z))  ≡ 1 + bin-to-nat (B₁ Z)
_ = refl
_ : bin-to-nat (incr (incr (B₁ Z))) ≡ 2 + bin-to-nat (B₁ Z)
_ = refl


module Category.Strong where
open import Data.Product using (_×_)
open import Agda.Primitive using (Level; _⊔_; lsuc)
open import Category.Profunctor

record StrongImp {a b : Level} (p : Set a → Set a → Set b) : Set (lsuc (a ⊔ b)) where
  field
    isProfunctor : ProfunctorImp p
    first' : ∀ {x y z : Set a} → p x y → p (x × z) (y × z)
    second' : ∀ {x y z : Set a} → p x y → p (z × x) (z × y)

module Strong {a b : Level} {p : Set a → Set a → Set b} (isStrong : StrongImp p) where
  first : ∀ {x y z : Set a} → p x y → p (x × z) (y × z)
  first = StrongImp.first' isStrong
  second : ∀ {x y z : Set a} → p x y → p (z × x) (z × y)
  second = StrongImp.second' isStrong
  open Profunctor (StrongImp.isProfunctor isStrong)


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

module Categories.Diagram.Coend.Properties where

open import Categories.Category.Core using (Category)
open import Categories.Category.Product
import Categories.Category.Construction.Cowedges as Cowedges
open import Categories.Category.Construction.Functors
open import Categories.Category.Equivalence
open import Categories.Category.Equivalence.Preserves
open import Categories.Diagram.Coend
open import Categories.Diagram.Colimit
open import Categories.Diagram.Cowedge
open import Categories.Diagram.Cowedge.Properties
open import Categories.Functor using (Functor)
open import Categories.Functor.Bifunctor using (Bifunctor)
open import Categories.Functor.Instance.Twisted
import Categories.Morphism as M
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Dinatural
open import Categories.Object.Initial as Initial

import Categories.Morphism.Reasoning as MR

open import Level
open import Data.Product using (Σ; _,_)
open import Function using (_$_)

module _ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where
  open Cowedges F

  -- Being a Coend is the same as being an Initial object in the category of Cowedges
  Coend⇒Initial : Coend F → Initial Cowedges
  Coend⇒Initial c = record
    { ⊥ = cowedge
    ; ⊥-is-initial = record
      { ! = λ {A} → record { u = factor A ; commute = universal }
      ; !-unique = λ {A} f → unique {A} (Cowedge-Morphism.commute f)
      }
    }
    where
    open Coend c

  Initial⇒Coend : Initial Cowedges → Coend F
  Initial⇒Coend i = record
    { cowedge = ⊥
    ; factor = λ W → u {W₂ = W} !
    ; universal = commute !
    ; unique = λ {_} {g} x → !-unique (record { u = g ; commute = x })
    }
    where
    open Initial.Initial i
    open Cowedge-Morphism

private
  variable
    o ℓ e : Level
    C D E : Category o ℓ e

module _ (F : Functor E (Functors (Product (Category.op C) C) D)) where
  private
    module C = Category C
    module D = Category D
    module E = Category E
    module NT = NaturalTransformation
  open D
  open HomReasoning

  open MR D
  open Functor F
  open Coend hiding (E)
  open NT using (η)

  CoendF : (∀ X → Coend (F₀ X)) → Functor E D
  CoendF coend = record
    { F₀           = λ X → Coend.E (coend X)
    ; F₁           = F₁′
    ; identity     = λ {A} → unique (coend A) (id-comm-sym ○ ∘-resp-≈ʳ (⟺ identity))
    ; homomorphism = λ {A B C} {f g} → unique (coend A) $ λ {Z} → begin
      (F₁′ g ∘ F₁′ f) ∘ dinatural.α (coend A) Z                         ≈⟨  pullʳ (universal (coend A)) ⟩
      (F₁′ g ∘ (dinatural.α (coend B) Z ∘ η (F₁ f) (Z , Z) )  )         ≈⟨ pullˡ (universal (coend B))  ⟩
      ((dinatural.α (coend C) Z ∘ η (F₁ g) (Z , Z)) ∘ η (F₁ f) (Z , Z)) ≈˘⟨ pushʳ homomorphism ⟩
      dinatural.α (coend C) Z ∘ η (F₁ (g E.∘ f)) (Z , Z)                ∎
    ; F-resp-≈     = λ {A B f g} eq → unique (coend A) $ λ {Z} → begin
      F₁′ g ∘ dinatural.α (coend A) Z                               ≈⟨ universal (coend A) ⟩
      dinatural.α (coend B) Z ∘ η (F₁ g) (Z , Z)                   ≈˘⟨ refl⟩∘⟨ F-resp-≈ eq ⟩
      dinatural.α (coend B) Z ∘ η (F₁ f) (Z , Z)                   ∎
    }
    where F₁′ : ∀ {X Y} → X E.⇒ Y → Coend.E (coend X) ⇒ Coend.E (coend Y)
          F₁′ {X} {Y} f = factor (coend X) $ record
            { E         = Coend.E (coend Y)
            ; dinatural = dinatural (coend Y) ∘> F₁ f
            }

-- A Natural Transformation between two functors induces an arrow between the
-- (object part of) the respective coends.
module _ {P Q : Functor (Product (Category.op C) C) D} (P⇒Q : NaturalTransformation P Q) where
  open Coend renaming (E to coend)
  open Category D

  coend-η : {cp : Coend P} {cq : Coend Q} → coend cp ⇒ coend cq
  coend-η {cp} {cq} = factor cp ((record
    { E = Coend.E cq
    ; dinatural = dtHelper record
      { α = λ c →  dinatural.α cq c ∘ η (c , c)
      ; commute = λ {C} {C′} f → begin
        id ∘ (αq C ∘ η (C , C)) ∘ P.₁ (f , C.id)    ≈⟨ pushʳ assoc ⟩
        (id ∘ αq C) ∘ (η (C , C) ∘ P.₁ (f , C.id))  ≈⟨ refl⟩∘⟨ nt.commute (f , C.id) ⟩
        (id ∘ αq C) ∘ (Q.₁ (f , C.id) ∘ η (C′ , C)) ≈⟨ pullˡ assoc ⟩
        (id ∘ αq C ∘ Q.₁ (f , C.id)) ∘ η (C′ , C)   ≈⟨ αq-comm f ⟩∘⟨refl ⟩
        (id ∘ αq C′ ∘ Q.₁ (C.id , f)) ∘ η (C′ , C)  ≈⟨ pushˡ sym-assoc ⟩
        (id ∘ αq C′) ∘ Q.₁ (C.id , f) ∘ η (C′ , C)  ≈⟨ refl⟩∘⟨ nt.sym-commute (C.id , f) ⟩
        (id ∘ αq C′) ∘ η (C′ , C′) ∘ P.₁ (C.id , f) ≈⟨ pullʳ sym-assoc ⟩
        id ∘ (αq C′ ∘ η (C′ , C′)) ∘ P.₁ (C.id , f) ∎
      }
    }))
    where
    module nt = NaturalTransformation P⇒Q
    open nt using (η)
    open HomReasoning
    module C = Category C
    module P = Functor P
    module Q = Functor Q
    open DinaturalTransformation (dinatural cp) renaming (α to αp; commute to αp-comm)
    open DinaturalTransformation (dinatural cq) renaming (α to αq; commute to αq-comm)
    open Cowedge
    open MR D

module _ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where
  private
    Eq = CoconesTwist≅Cowedges F
    module O = M D
  open M (Cowedges.Cowedges F)
  open Functor

  open StrongEquivalence Eq renaming (F to F⇒)

  -- Coends and Colimits are equivalent, in the category Cowedge F
  Coend-as-Colimit : (coend : Coend F) → (cl : Colimit (Twist′ C D F)) → Coend.cowedge coend ≅ F₀ F⇒ (Colimit.initial.⊥ cl)
  Coend-as-Colimit coend cl = Initial.up-to-iso (Cowedges.Cowedges F) (Coend⇒Initial F coend) (pres-Initial Eq initial)
    where
    open Colimit cl

  -- Which then induces that the objects, in D, are also equivalent.
  Coend-as-Colimit-on-Obj : (coend : Coend F) → (cl : Colimit (Twist′ C D F)) → Coend.E coend O.≅ Colimit.coapex cl
  Coend-as-Colimit-on-Obj coend cl = record
    { from = Cowedge-Morphism.u (M._≅_.from X≅Y)
    ; to = Cowedge-Morphism.u (M._≅_.to X≅Y)
    ; iso = record
      { isoˡ = M._≅_.isoˡ X≅Y
      ; isoʳ = M._≅_.isoʳ X≅Y
      }
    }
    where
      X≅Y = Coend-as-Colimit coend cl
      open Category D


module examplesPaperJFP.ConsoleInterface where

open import examplesPaperJFP.NativeIOSafe
open import examplesPaperJFP.BasicIO hiding (main)

module _ where
  data ConsoleCommand : Set where
    getLine   :  ConsoleCommand
    putStrLn  :  String → ConsoleCommand

  ConsoleResponse : ConsoleCommand → Set
  ConsoleResponse  getLine      =  Maybe String
  ConsoleResponse (putStrLn s)  =  Unit

  ConsoleInterface : IOInterface
  Command   ConsoleInterface  =  ConsoleCommand
  Response  ConsoleInterface  =  ConsoleResponse


open import FRP.JS.Nat using ( ℕ ; float ) renaming
  ( _+_ to _+n_ ; _∸_ to _∸n_ ; _*_ to _*n_ ; _≟_ to _≟n_ ; _≠_ to _≠n_
  ; _/_ to _/n_ ; _/?_ to _/?n_ ; _≤_ to _≤n_ ; _<_ to _<n_ )
open import FRP.JS.Float using ( ℝ )
open import FRP.JS.Bool using ( Bool )
open import FRP.JS.True using ( True )
open import FRP.JS.Maybe using ( Maybe )

module FRP.JS.Delay where

record Delay : Set where
  constructor _ms
  field toℕ : ℕ

{-# COMPILED_JS Delay function(x,v) { return v["_ms"](x); } #-}
{-# COMPILED_JS _ms function(d) { return d; } #-}

_≟_ : Delay → Delay → Bool
(d ms) ≟ (e ms) = d ≟n e

{-# COMPILED_JS _≟_ function(d) { return function(e) { return d === e; }; } #-}

_≠_ : Delay → Delay → Bool
(d ms) ≠ (e ms) = d ≠n e

{-# COMPILED_JS _≠_ function(d) { return function(e) { return d !== e; }; } #-}

_≤_ : Delay → Delay → Bool
(d ms) ≤ (e ms) = d ≤n e

{-# COMPILED_JS _≤_ function(d) { return function(e) { return d <= e; }; } #-}

_<_ : Delay → Delay → Bool
(d ms) < (e ms) = d <n e

{-# COMPILED_JS _<_ function(d) { return function(e) { return d < e; }; } #-}

_+_ : Delay → Delay → Delay
(d ms) + (e ms) = (d +n e) ms

{-# COMPILED_JS _+_ function(d) { return function(e) { return d + e; }; } #-}

_∸_ : Delay → Delay → Delay
(d ms) ∸ (e ms) = (d ∸n e) ms

{-# COMPILED_JS _∸_ function(d) { return function(e) { return Math.min(0, d - e); }; } #-}

_*_ : ℕ → Delay → Delay
n * (d ms) = (n *n d) ms

{-# COMPILED_JS _*_ function(n) { return function(d) { return n * d; }; } #-}

_/_ : ∀ (d e : Delay) → {e≠0 : True (e ≠ 0 ms)} → ℝ
_/_ (d ms) (e ms) {e≠0} = _/n_ d e {e≠0}

{-# COMPILED_JS _/_ function(d) { return function(e) { return function() { return d / e; }; }; } #-}

_/?_ : Delay → Delay → Maybe ℝ
(d ms) /? (e ms) = d /?n e

{-# COMPILED_JS _/?_ function(d) { return function(e) { if (e === 0) { return null; } else { return d / e; } }; } #-}

_sec : ℕ → Delay
n sec = n * (1000 ms)

{-# COMPILED_JS _sec function(t) { return t * 1000; } #-}

_min : ℕ → Delay
n min = n * (60000 ms)

{-# COMPILED_JS _min function(t) { return t * 60000; } #-}


{-# OPTIONS --cubical --safe #-}
module Cubical.Structures.Monoid where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Data.Prod.Base hiding (_×_) renaming (_×Σ_ to _×_)

open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)

open import Cubical.Structures.Pointed
open import Cubical.Structures.InftyMagma

private
  variable
    ℓ : Level

-- Now we're getting serious: Monoids
raw-monoid-structure : Type ℓ → Type ℓ
raw-monoid-structure X = X × (X → X → X)

raw-monoid-iso : StrIso raw-monoid-structure ℓ
raw-monoid-iso (M , e , _·_) (N , d , _∗_) f =
    (equivFun f e ≡ d)
  × ((x y : M) → equivFun f (x · y) ≡ (equivFun f x) ∗ (equivFun f y))

-- If we ignore the axioms we get something like a "raw" monoid, which
-- essentially is the join of a pointed type and an ∞-magma
raw-monoid-is-SNS : SNS {ℓ} raw-monoid-structure raw-monoid-iso
raw-monoid-is-SNS = join-SNS pointed-structure pointed-iso pointed-is-SNS
                             ∞-magma-structure ∞-magma-iso ∞-magma-is-SNS

-- Now define monoids
monoid-axioms : (X : Type ℓ) → raw-monoid-structure X → Type ℓ
monoid-axioms X (e , _·_ ) = isSet X
                           × ((x y z : X) → (x · (y · z)) ≡ ((x · y) · z))
                           × ((x : X) → (x · e) ≡ x)
                           × ((x : X) → (e · x) ≡ x)

monoid-structure : Type ℓ → Type ℓ
monoid-structure = add-to-structure (raw-monoid-structure) monoid-axioms

Monoids : Type (ℓ-suc ℓ)
Monoids {ℓ} = TypeWithStr ℓ monoid-structure

monoid-iso : StrIso monoid-structure ℓ
monoid-iso = add-to-iso raw-monoid-structure raw-monoid-iso monoid-axioms

-- We have to show that the monoid axioms are indeed propositions
monoid-axioms-are-Props : (X : Type ℓ) (s : raw-monoid-structure X) → isProp (monoid-axioms X s)
monoid-axioms-are-Props X (e , _·_) s = β s
   where
   α = s .fst
   -- TODO: it would be nice to have versions of this lemmas for higher arities
   β =     isPropΣ isPropIsSet
     λ _ → isPropΣ (isPropPi (λ x → isPropPi (λ y → isPropPi (λ z → α (x · (y · z)) ((x · y) · z)))))
     λ _ → isPropΣ (isPropPi (λ x → α (x · e) x))
     λ _ →          isPropPi (λ x → α (e · x) x)

monoid-is-SNS : SNS {ℓ} monoid-structure monoid-iso
monoid-is-SNS = add-axioms-SNS raw-monoid-structure raw-monoid-iso
                               monoid-axioms monoid-axioms-are-Props raw-monoid-is-SNS

MonoidPath : (M N : Monoids {ℓ}) → (M ≃[ monoid-iso ] N) ≃ (M ≡ N)
MonoidPath M N = SIP monoid-structure monoid-iso monoid-is-SNS M N

-- Added for groups
-- If there exists a inverse of an element it is unique

inv-lemma : (X : Type ℓ) (e : X) (_·_ : X → X → X)
          → monoid-axioms X (e , _·_)
          → (x y z : X)
          → y · x ≡ e
          → x · z ≡ e
          → y ≡ z
inv-lemma X e _·_ (is-set-X , assoc , runit , lunit) x y z left-inverse right-inverse =
  y           ≡⟨ sym (runit y) ⟩
  y · e       ≡⟨ cong (y ·_) (sym right-inverse) ⟩
  y · (x · z) ≡⟨ assoc y x z ⟩
  (y · x) · z ≡⟨ cong (_· z) left-inverse ⟩
  e · z       ≡⟨ lunit z ⟩
  z ∎


module Issue358 where

postulate Sigma : Set -> (Set -> Set) -> Set
syntax Sigma A (\x -> B)  = x colon A operator B

postulate T : Set
test = x colon T operator {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Convenient syntax for "equational reasoning" using a preorder
------------------------------------------------------------------------

-- Example uses:
--
--    u∼y : u ∼ y
--    u∼y = begin
--      u  ≈⟨ u≈v ⟩
--      v  ≡⟨ v≡w ⟩
--      w  ∼⟨ w∼y ⟩
--      y  ≈⟨ z≈y ⟩
--      z  ∎
--
--    u≈w : u ≈ w
--    u≈w = begin-equality
--      u  ≈⟨ u≈v ⟩
--      v  ≡⟨ v≡w ⟩
--      w  ≡˘⟨ x≡w ⟩
--      x  ∎

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

open import Relation.Binary

module Relation.Binary.Reasoning.Preorder
  {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where

open Preorder P

------------------------------------------------------------------------
-- Publicly re-export the contents of the base module

open import Relation.Binary.Reasoning.Base.Double isPreorder public

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.0

infixr 2 _≈⟨⟩_

_≈⟨⟩_ = _≡⟨⟩_
{-# WARNING_ON_USAGE _≈⟨⟩_
"Warning: _≈⟨⟩_ was deprecated in v1.0.
Please use _≡⟨⟩_ instead."
#-}


------------------------------------------------------------------------------
-- The unary numbers are FOTC total natural numbers
------------------------------------------------------------------------------

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

module FOTC.Data.Nat.UnaryNumbers.TotalityI where

open import FOTC.Base
open import FOTC.Data.Nat.Type
open import FOTC.Data.Nat.UnaryNumbers

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

0-N : N 0'
0-N = nzero

1-N : N 1'
1-N = nsucc 0-N

2-N : N 2'
2-N = nsucc 1-N


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

module Control.Category where

open import Level using (suc; _⊔_)
open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality

-- Module HomSet provides notation A ⇒ B for the Set of morphisms
-- from between objects A and B and names _≈_ and ≈-refl/sym/trans
-- for the equality of morphisms.

module HomSet {o h e} {Obj : Set o} (Hom : Obj → Obj → Setoid h e) where

  _⇒_ : (A B : Obj) → Set h
  A ⇒ B = Setoid.Carrier (Hom A B)

  module _ {A B : Obj} where
    open Setoid (Hom A B) public
      using (_≈_)
      renaming ( isEquivalence to ≈-equiv
               ; refl          to ≈-refl
               ; sym           to ≈-sym
               ; trans         to ≈-trans
               )
{-
  _≈_ : {A B : Obj} → Rel (A ⇒ B) e
  _≈_ {A = A}{B = B} = Setoid._≈_ (Hom A B)

  ≈-equiv : {A B : Obj}  → IsEquivalence (Setoid._≈_ (Hom A B))
  ≈-equiv {A = A}{B = B} = Setoid.isEquivalence (Hom A B)

  ≈-refl  : {A B : Obj}  → Reflexive _≈_
  ≈-refl  {A = A}{B = B} = Setoid.refl (Hom A B)

  ≈-sym   : {A B : Obj}  → Symmetric _≈_
  ≈-sym   {A = A}{B = B} = Setoid.sym (Hom A B)

  ≈-trans : {A B : Obj}  → Transitive _≈_
  ≈-trans {A = A}{B = B} = Setoid.trans (Hom A B)
-}

-- Category operations: identity and composition.

-- Module T-CategoryOps Hom provides the types of
-- identity and composition (forward and backward).

module T-CategoryOps {o h e} {Obj : Set o} (Hom : Obj → Obj → Setoid h e) where

  open HomSet Hom

  T-id = ∀ {A}                            → A ⇒ A
  T-⟫  = ∀ {A B C} (f : A ⇒ B) (g : B ⇒ C) → A ⇒ C
  T-∘  = ∀ {A B C} (g : B ⇒ C) (f : A ⇒ B) → A ⇒ C

-- Record CategoryOps Hom can be instantiated to implement
-- identity and composition for category Hom.

record CategoryOps {o h e} {Obj : Set o} (Hom : Obj → Obj → Setoid h e)
    : Set (o ⊔ h ⊔ e)
  where
  open T-CategoryOps Hom

  infixl 9 _⟫_
  infixr 9 _∘_

  field
    id : T-id
    _⟫_ : T-⟫

  _∘_ : T-∘
  g ∘ f = f ⟫ g

-- Category laws: left and right identity and composition.

-- Module T-CategoryLaws ops provides the types of the laws
-- for the category operations ops.

module T-CategoryLaws {o h e} {Obj : Set o} {Hom : Obj → Obj → Setoid h e}
    (ops : CategoryOps Hom)
  where
  open HomSet Hom public
  open T-CategoryOps Hom public
  open CategoryOps ops public

  T-id-first = ∀ {A B} {g : A ⇒ B} →

    (id ⟫ g) ≈ g

  T-id-last  = ∀ {A B} {f : A ⇒ B} →

    (f ⟫ id) ≈ f

  T-∘-assoc  = ∀ {A B C D} (f : A ⇒ B) {g : B ⇒ C} {h : C ⇒ D} →

    ((f ⟫ g) ⟫ h) ≈ (f ⟫ (g ⟫ h))

  T-∘-cong = ∀ {A B C} {f f′ : A ⇒ B} {g g′ : B ⇒ C} →
    f ≈ f′ → g ≈ g′ → (f ⟫ g) ≈ (f′ ⟫ g′)

-- Record CategoryLaws ops can be instantiated to prove the laws of the
-- category operations (identity and compositions).

record CategoryLaws {o h e} {Obj : Set o} {Hom : Obj → Obj → Setoid h e}
    (ops : CategoryOps Hom) : Set (o ⊔ h ⊔ e)
  where
  open T-CategoryLaws ops

  field
    id-first : T-id-first
    id-last  : T-id-last
    ∘-assoc  : T-∘-assoc
    ∘-cong   : T-∘-cong

-- Record IsCategory Hom contains the data (operations and laws) to make
-- Hom a category.

record IsCategory {o h e} {Obj : Set o} (Hom : Obj → Obj → Setoid h e) : Set (o ⊔ h ⊔ e) where

  field
    ops  : CategoryOps Hom
    laws : CategoryLaws ops

  open HomSet        Hom public
  open CategoryOps   ops public
  open CategoryLaws laws public

-- The category: packaging objects, morphisms, and laws.

record Category o h e : Set (suc (o ⊔ h ⊔ e)) where
   field
     {Obj}      : Set o
     Hom        : Obj → Obj → Setoid h e
     isCategory : IsCategory Hom

   open IsCategory isCategory public

-- Initial object

record IsInitial {o h e} {Obj : Set o} (Hom : Obj → Obj → Setoid h e) (Initial : Obj) : Set (h ⊔ o ⊔ e) where
  open HomSet Hom
  open T-CategoryOps Hom
  field
    initial           : ∀ {A}                   → Initial ⇒ A
    initial-universal : ∀ {A} {f : Initial ⇒ A} → f ≈ initial

-- Terminal object

record IsFinal {o h e} {Obj : Set o} (Hom : Obj → Obj → Setoid h e) (Final : Obj) : Set (h ⊔ o ⊔ e) where
  open HomSet Hom
  open T-CategoryOps Hom
  field
    final           : ∀ {A}                 → A ⇒ Final
    final-universal : ∀ {A} {f : A ⇒ Final} → f ≈ final


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

open import lib.Basics
open import lib.types.Cofiber
open import lib.types.Sigma
open import lib.types.Wedge

module lib.types.Smash {i j} (X : Ptd i) (Y : Ptd j) where

module ∨In× = WedgeRec {X = X} {Y = Y}
  (λ x → (x , pt Y)) (λ y → (pt X , y)) idp

∨-in-× = ∨In×.f

∨-⊙in-× : X ⊙∨ Y ⊙→ X ⊙× Y
∨-⊙in-× = (∨In×.f , idp)

⊙Smash : Ptd (lmax i j)
⊙Smash = ⊙Cofiber ∨-⊙in-×

Smash = de⊙ ⊙Smash

_∧_ = Smash
_⊙∧_ = ⊙Smash


module Data.Var where

open import Data.List using (List; []; _∷_; map)
open import Data.List.Relation.Unary.All using (All; []; _∷_)

open import Function using (const; _∘_)

open import Level using (Level; 0ℓ)

open import Relation.Unary using (IUniversal; _⇒_; _⊢_)

-- ------------------------------------------------------------------------
-- Vars and Contexts

private
  variable
    a b : Level

_-Scoped[_] : Set a → (b : Level) → Set _
I -Scoped[ b ] = I → List I → Set b

private
  variable
    I J : Set a
    i j : I
    Γ : List I

data Var : I -Scoped[ 0ℓ ] where
  zero : ∀[ (i ∷_) ⊢ Var i ]
  suc : ∀[ Var i ⇒ (j ∷_) ⊢ Var i ]

get : {P : I → Set b} → ∀[ Var i ⇒ All P ⇒ const (P i) ]
get zero (p  ∷ _) = p
get (suc v) (_  ∷ ps) = get v ps

_<$>_ : (f : I → J) → ∀[ Var i ⇒ map f ⊢ Var (f i) ]
f <$> zero = zero
f <$> suc v = suc (f <$> v)

tabulate : {P : I → Set b} → (∀ {i} → Var i Γ → P i) → All P Γ
tabulate {Γ = []} f = []
tabulate {Γ = i ∷ Γ} f = f zero ∷ tabulate (f ∘ suc)


------------------------------------------------------------------------
-- The Agda standard library
--
-- A type for expressions over a raw ring.
------------------------------------------------------------------------

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

module Tactic.RingSolver.Core.Expression where

open import Data.Nat.Base using (ℕ)
open import Data.Fin.Base using (Fin)
open import Data.Vec.Base as Vec using (Vec)

open import Algebra

infixl 6 _⊕_
infixl 7 _⊗_
infixr 8 _⊛_

data Expr {a} (A : Set a) (n : ℕ) : Set a where
  Κ   : A → Expr A n                   -- Constant
  Ι   : Fin n → Expr A n               -- Variable
  _⊕_ : Expr A n → Expr A n → Expr A n -- Addition
  _⊗_ : Expr A n → Expr A n → Expr A n -- Multiplication
  _⊛_ : Expr A n → ℕ → Expr A n        -- Exponentiation
  ⊝_  : Expr A n → Expr A n            -- Negation

module Eval
  {ℓ₁ ℓ₂} (rawRing : RawRing ℓ₁ ℓ₂)
  (let open RawRing rawRing)
  {a} {A : Set a} (⟦_⟧ᵣ : A → Carrier) where

  open import Algebra.Operations.Ring rawRing

  ⟦_⟧ : ∀ {n} → Expr A n → Vec Carrier n → Carrier
  ⟦ Κ x   ⟧ ρ = ⟦ x ⟧ᵣ
  ⟦ Ι x   ⟧ ρ = Vec.lookup ρ x
  ⟦ x ⊕ y ⟧ ρ = ⟦ x ⟧ ρ + ⟦ y ⟧ ρ
  ⟦ x ⊗ y ⟧ ρ = ⟦ x ⟧ ρ * ⟦ y ⟧ ρ
  ⟦   ⊝ x ⟧ ρ = - ⟦ x ⟧ ρ
  ⟦ x ⊛ i ⟧ ρ = ⟦ x ⟧ ρ ^ i


module DefinitionalEquality where

postulate
  _≡_      : {A B : Set} -> A -> B -> Set
  refl-≡   : {A : Set}{x : A} -> x ≡ x
  subst-≡  : {A : Set}{x y : A}(C : A -> Set) -> x ≡ y -> C y -> C x
  subst-≡¹ : {A : Set}{x y : A}(C : A -> Set1) -> x ≡ y -> C y -> C x

  subst-≡' : {A B : Set}{x : A}{y : B}(C : {X : Set} -> X -> Set) -> x ≡ y -> C y -> C x

  app-≡₀ : {A₁ A₂ : Set}{B₁ : A₁ -> Set}{B₂ : A₂ -> Set}
           {f : (x : A₁) -> B₁ x}{g : (x : A₂) -> B₂ x}{a₁ : A₁}{a₂ : A₂} ->
            f ≡ g -> a₁ ≡ a₂ -> f a₁ ≡ g a₂

  η-≡ : {A₁ A₂ : Set}{B₁ : A₁ -> Set}{B₂ : A₂ -> Set}
        {f₁ : (x : A₁) -> B₁ x}{f₂ : (x : A₂) -> B₂ x} ->
        ((x : A₁)(y : A₂) -> x ≡ y -> f₁ x ≡ f₂ y) -> f₁ ≡ f₂

  -- Substitution is a no-op
  subst-≡-identity : {A : Set}{x y : A}(C : A -> Set)(p : x ≡ y)(cy : C y) ->
                     subst-≡ C p cy ≡ cy

cong-≡ : {A B : Set}{x y : A}(f : A -> B)(p : x ≡ y) -> f x ≡ f y
cong-≡ {_}{_}{_}{y} f p = subst-≡ (\z -> f z ≡ f y) p refl-≡

cong-≡' : {A : Set}{B : A -> Set}{x y : A}(f : (z : A) -> B z)(p : x ≡ y) -> f x ≡ f y
cong-≡' {_}{_}{_}{y} f p = subst-≡ (\z -> f z ≡ f y) p refl-≡

cong₂-≡' : {A : Set}{B : A -> Set}{C : (x : A) -> B x -> Set}
	   {x y : A}{z : B x}{w : B y}(f : (x : A)(z : B x) -> C x z) ->
	   x ≡ y -> z ≡ w -> f x z ≡ f y w
cong₂-≡' f xy zw = app-≡₀ (cong-≡' f xy) zw

trans-≡ : {A B C : Set}(x : A)(y : B)(z : C) -> x ≡ y -> y ≡ z -> x ≡ z
trans-≡ x y z xy yz = subst-≡' (\w -> w ≡ z) xy yz

postulate
  _≡₁_     : {A B : Set1} -> A -> B -> Set1
  refl-≡₁  : {A : Set1}{x : A} -> x ≡₁ x
  subst-≡₁ : {A : Set1}{x y : A}(C : A -> Set1) -> x ≡₁ y -> C y -> C x
  subst-≡₁' : {A B : Set1}{x : A}{y : B}(C : {X : Set1} -> X -> Set1) -> x ≡₁ y -> C y -> C x

  -- Substitution is a no-op
  subst-≡₁-identity : {A : Set1}{x y : A}(C : A -> Set1)(p : x ≡₁ y)(cy : C y) ->
                      subst-≡₁ C p cy ≡₁ cy

  app-≡₁ : {A₁ A₂ : Set1}{B₁ : A₁ -> Set1}{B₂ : A₂ -> Set1}
           {f : (x : A₁) -> B₁ x}{g : (x : A₂) -> B₂ x}{a₁ : A₁}{a₂ : A₂} ->
           f ≡₁ g -> a₁ ≡₁ a₂ -> f a₁ ≡₁ g a₂

  app-≡₁⁰ : {A₁ A₂ : Set}{B₁ : A₁ -> Set1}{B₂ : A₂ -> Set1}
            {f : (x : A₁) -> B₁ x}{g : (x : A₂) -> B₂ x}{a₁ : A₁}{a₂ : A₂} ->
            f ≡₁ g -> a₁ ≡ a₂ -> f a₁ ≡₁ g a₂

  η-≡₁ : {A₁ A₂ : Set1}{B₁ : A₁ -> Set1}{B₂ : A₂ -> Set1}
         {f₁ : (x : A₁) -> B₁ x}{f₂ : (x : A₂) -> B₂ x} ->
         ((x : A₁)(y : A₂) -> x ≡₁ y -> f₁ x ≡₁ f₂ y) -> f₁ ≡₁ f₂

  η-≡₁⁰ : {A₁ A₂ : Set}{B₁ : A₁ -> Set1}{B₂ : A₂ -> Set1}
          {f₁ : (x : A₁) -> B₁ x}{f₂ : (x : A₂) -> B₂ x} ->
          ((x : A₁)(y : A₂) -> x ≡ y -> f₁ x ≡₁ f₂ y) -> f₁ ≡₁ f₂

cong-≡₁ : {A B : Set1}{x y : A}(f : A -> B)(p : x ≡₁ y) -> f x ≡₁ f y
cong-≡₁ {_}{_}{_}{y} f p = subst-≡₁ (\z -> f z ≡₁ f y) p refl-≡₁

cong-≡₁⁰ : {A : Set}{B : A -> Set1}{x y : A}(f : (x : A) -> B x)(p : x ≡ y) -> f x ≡₁ f y
cong-≡₁⁰ {_}{_}{_}{y} f p = subst-≡¹ (\z -> f z ≡₁ f y) p refl-≡₁

trans-≡₁ : {A B C : Set1}(x : A)(y : B)(z : C) -> x ≡₁ y -> y ≡₁ z -> x ≡₁ z
trans-≡₁ x y z xy yz = subst-≡₁' (\w -> w ≡₁ z) xy yz