Added doc.

Added doc.

Ignore-this: 300e04a63db5641f8b9616ebd205959c

darcs-hash:20120320125722-3bd4e-6defb55ec3f391d451470ff41f0534191b2908eb.gz

------------------------------------------------------------------------------
-- The first-order theory of combinators (FOTC) base
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

{-
FOTC                                  The logical framework (Agda)

* Logical constants                   * Curry-Howard isomorphism
* Equality                            * Identity type
* Term language and conversion rules  * Postulates
* Inductively defined predicates      * Inductive families
* Co-inductively defined predicates   * Greatest fixed-points
-}

-- References:
--
-- • Peter Aczel. The strength of Martin-Löf's intuitionistic type
--   theory with one universe. In Miettinen and Väänanen,
--   editors. Proc. of the Symposium on Mathematical Logic (Oulu,
--   1974), Report No. 2, Department of Philosopy, University of
--   Helsinki, Helsinki, 1977, pages 1–32.

module FOTC.Base where

-- We add 3 to the fixities of the standard library.
infixl 9 _·_  -- The symbol is '\cdot'.
infixr 8 _∷_
infix  8 if_then_else_

------------------------------------------------------------------------------
-- FOL with equality.
open import Common.FOL.FOL-Eq public

------------------------------------------------------------------------------
-- The term language of FOTC

--   t ::= x   | t · t |
--      | true | false | if
--      | 0    | succ  | pred | iszero
--      | nil  | cons  | null | head   | tail
--      | loop

postulate
  _·_                     : D → D → D  -- FOTC application.
  true false if           : D          -- FOTC partial booleans.
  zero succ pred iszero   : D          -- FOTC partial natural numbers.
  nil cons head tail null : D          -- FOTC lists.
  loop                    : D          -- FOTC looping programs.

------------------------------------------------------------------------------
-- Definitions

-- We define some function symbols for convenience in writing and
-- looking for an optimization for the ATPs.

-- 2012-03-20. The definitions are inside an abstract block because
-- the conversion rules (see below) are based on them, so want to
-- avoid their expansion.

abstract
  if_then_else_ : D → D → D → D
  if b then d₁ else d₂ = if · b · d₁ · d₂
  -- {-# ATP definition if_then_else_ #-}

  succ₁ : D → D
  succ₁ d = succ · d
  -- {-# ATP definition succ₁ #-}

  pred₁ : D → D
  pred₁ d = pred · d
  -- {-# ATP definition pred₁ #-}

  iszero₁ : D → D
  iszero₁ d = iszero · d
  -- {-# ATP definition iszero₁ #-}

  [] : D
  [] = nil
  -- {-# ATP definition [] #-}

  _∷_  : D → D → D
  x ∷ xs = cons · x · xs
  -- {-# ATP definition _∷_ #-}

  head₁ : D → D
  head₁ xs = head · xs
  -- {-# ATP definition head₁ #-}

  tail₁ : D → D
  tail₁ xs = tail · xs
  -- {-# ATP definition tail₁ #-}

  null₁ : D → D
  null₁ xs = null · xs
  -- {-# ATP definition null₁ #-}

------------------------------------------------------------------------------
-- Conversion rules

-- The conversion relation _conv_ satifies (Aczel 1977, p. 8)
--
-- x conv y <=> FOTC ⊢ x ≡ y,
--
-- therefore, we introduce the conversion rules as FOL non-logical
-- axioms.

-- N.B. Looking for an optimization for the ATPs, we write the
-- conversion rules on the defined function symbols instead of on the
-- term constants.

-- Conversion rules for booleans.
postulate
  -- if-true  : ∀ d₁ {d₂} → if · true  · d₁ · d₂ ≡ d₁
  -- if-false : ∀ {d₁} d₂ → if · false · d₁ · d₂ ≡ d₂
  if-true  : ∀ d₁ {d₂} → if true  then d₁ else d₂ ≡ d₁
  if-false : ∀ {d₁} d₂ → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom if-true if-false #-}

-- Conversion rules for pred.
postulate
  -- N.B. We don't need this equation.
  -- pred-0 :       pred · zero     ≡ zero
  -- pred-S : ∀ d → pred · (succ · d) ≡ d
  pred-S : ∀ d → pred₁ (succ₁ d) ≡ d
{-# ATP axiom pred-S #-}

-- Conversion rules for iszero.
postulate
  -- iszero-0 :       iszero · zero       ≡ true
  -- iszero-S : ∀ d → iszero · (succ · d) ≡ false
  iszero-0 :       iszero₁ zero      ≡ true
  iszero-S : ∀ d → iszero₁ (succ₁ d) ≡ false
{-# ATP axiom iszero-0 iszero-S #-}

-- Conversion rules for null.
postulate
  -- null-[] :          null · nil             ≡ true
  -- null-∷  : ∀ x xs → null · (cons · x · xs) ≡ false
  null-[] :          null₁ []       ≡ true
  null-∷  : ∀ x xs → null₁ (x ∷ xs) ≡ false

-- Conversion rule for head.
postulate
--  head-∷ : ∀ x xs → head · (cons · x · xs) ≡ x
  head-∷ : ∀ x xs → head₁ (x ∷ xs) ≡ x
{-# ATP axiom head-∷ #-}

-- Conversion rule for tail.
postulate
--  tail-∷ : ∀ x xs → tail · (cons · x · xs) ≡ xs
  tail-∷ : ∀ x xs → tail₁ (x ∷ xs) ≡ xs
{-# ATP axiom tail-∷ #-}

-- Conversion rule for loop.
-- The equation loop-eq adds anything to the logic (because
-- reflexivity is already an axiom of equality), therefore we won't
-- add this equation as a FOL axiom.
postulate loop-eq : loop ≡ loop

------------------------------------------------------------------------------
-- Discrimination rules

postulate
  true≢false : ¬ (true ≡ false)
--  0≢S        : ∀ {d} → ¬ (zero ≡ succ · d)
  0≢S        : ∀ {d} → ¬ (zero ≡ succ₁ d)
{-# ATP axiom true≢false 0≢S #-}

------------------------------------------------------------------------------
-- The first-order theory of combinators (FOTC) base
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

{-
FOTC                                  The logical framework (Agda)

* Logical constants                   * Curry-Howard isomorphism
* Equality                            * Identity type
* Term language and conversion rules  * Postulates
* Inductively defined predicates      * Inductive families
-}

module FOTC.Base where

-- We add 3 to the fixities of the standard library.
infixl 9 _·_  -- The symbol is '\cdot'.
infixr 8 _∷_
infix  8 if_then_else_

------------------------------------------------------------------------------
-- FOL with equality.
open import Common.FOL.FOL-Eq public

------------------------------------------------------------------------------
-- The term language of FOTC correspond to the PCF terms.

--   t ::= x   | t · t |
--      | true | false | if
--      | 0    | succ  | pred | iszero
--      | nil  | cons  | null | head   | tail
--      | loop

-- NB. We define the PCF terms as constants. After that, we will
-- define some function symbols based on these constants for
-- convenience in writing.

postulate
  _·_                     : D → D → D  -- FOTC application.
  true false if           : D          -- FOTC partial booleans.
  zero succ pred iszero   : D          -- FOTC partial natural numbers.
  nil cons head tail null : D          -- FOTC lists.
  loop                    : D          -- FOTC looping programs.

------------------------------------------------------------------------------
-- Definitions

-- We define some function symbols for convenience in writing.
abstract
  if_then_else_ : D → D → D → D
  if b then d₁ else d₂ = if · b · d₁ · d₂
  -- {-# ATP definition if_then_else_ #-}

  succ₁ : D → D
  succ₁ d = succ · d
  -- {-# ATP definition succ₁ #-}

  pred₁ : D → D
  pred₁ d = pred · d
  -- {-# ATP definition pred₁ #-}

  iszero₁ : D → D
  iszero₁ d = iszero · d
  -- {-# ATP definition iszero₁ #-}

  [] : D
  [] = nil
  -- {-# ATP definition [] #-}

  _∷_  : D → D → D
  x ∷ xs = cons · x · xs
  -- {-# ATP definition _∷_ #-}

  head₁ : D → D
  head₁ xs = head · xs
  -- {-# ATP definition head₁ #-}

  tail₁ : D → D
  tail₁ xs = tail · xs
  -- {-# ATP definition tail₁ #-}

  null₁ : D → D
  null₁ xs = null · xs
  -- {-# ATP definition null₁ #-}

------------------------------------------------------------------------------
-- Conversion rules

-- The conversion relation _conv_ satifies (Aczel 1977. The strength
-- of Martin-Löf's intuitionistic type theory with one universe,
-- p. 8).
--
-- x conv y <=> FOTC ⊢ x ≡ y,
--
-- therefore, we introduce the conversion rules as FOL non-logical
-- axioms.

-- N.B. Looking for an optimization for the ATPs, we write the
-- conversion rules on the defined function symbols instead of on the
-- PCF constants.

-- Conversion rules for booleans.
postulate
  -- if-true  : ∀ d₁ {d₂} → if · true  · d₁ · d₂ ≡ d₁
  -- if-false : ∀ {d₁} d₂ → if · false · d₁ · d₂ ≡ d₂
  if-true  : ∀ d₁ {d₂} → if true  then d₁ else d₂ ≡ d₁
  if-false : ∀ {d₁} d₂ → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom if-true if-false #-}

-- Conversion rules for pred.
postulate
  -- N.B. We don't need this equation.
  -- pred-0 :       pred · zero     ≡ zero
  -- pred-S : ∀ d → pred · (succ · d) ≡ d
  pred-S : ∀ d → pred₁ (succ₁ d) ≡ d
{-# ATP axiom pred-S #-}

-- Conversion rules for iszero.
postulate
  -- iszero-0 :       iszero · zero       ≡ true
  -- iszero-S : ∀ d → iszero · (succ · d) ≡ false
  iszero-0 :       iszero₁ zero      ≡ true
  iszero-S : ∀ d → iszero₁ (succ₁ d) ≡ false
{-# ATP axiom iszero-0 iszero-S #-}

-- Conversion rules for null.
postulate
  -- null-[] :          null · nil             ≡ true
  -- null-∷  : ∀ x xs → null · (cons · x · xs) ≡ false
  null-[] :          null₁ []       ≡ true
  null-∷  : ∀ x xs → null₁ (x ∷ xs) ≡ false

-- Conversion rule for head.
postulate
--  head-∷ : ∀ x xs → head · (cons · x · xs) ≡ x
  head-∷ : ∀ x xs → head₁ (x ∷ xs) ≡ x
{-# ATP axiom head-∷ #-}

-- Conversion rule for tail.
postulate
--  tail-∷ : ∀ x xs → tail · (cons · x · xs) ≡ xs
  tail-∷ : ∀ x xs → tail₁ (x ∷ xs) ≡ xs
{-# ATP axiom tail-∷ #-}

-- Conversion rule for loop.
-- The equation loop-eq adds anything to the logic (because
-- reflexivity is already an axiom of equality), therefore we won't
-- add this equation as a FOL axiom.
postulate loop-eq : loop ≡ loop

------------------------------------------------------------------------------
-- Discrimination rules

postulate
  true≢false : ¬ (true ≡ false)
--  0≢S        : ∀ {d} → ¬ (zero ≡ succ · d)
  0≢S        : ∀ {d} → ¬ (zero ≡ succ₁ d)
{-# ATP axiom true≢false 0≢S #-}


Added TODOs.

Added TODOs.

Ignore-this: c0268f8e06c0cb85594dc394a7c5bcec

darcs-hash:20100719034157-3bd4e-17dade58a748cf108250a61023ee394e0afaf7c5.gz

module Test.Succeed.LogicalConstants where

infix  4 _≡_

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

------------------------------------------------------------------------------
-- The conjuction data type

module Conjunction where

  -- N.B. It is not necessary to define neither the data constructor
  -- _,_, nor the projections -- because the ATPs implement it.
  data _∧_ (A B : Set) : Set where

  -- Testing the data constructor and the projections.
  postulate
    A B     : Set
    _,_     : A → B → A ∧ B
    ∧-proj₁ : A ∧ B → A
    ∧-proj₂ : A ∧ B → B
  {-# ATP prove _,_ #-}
  {-# ATP prove ∧-proj₁ #-}
  {-# ATP prove ∧-proj₂ #-}

------------------------------------------------------------------------------
-- The negation

module Negation where

  infix 3 ¬

  data ⊥ : Set where

  ¬ : Set → Set
  ¬ A = A → ⊥

  postulate
    true false : D

  postulate
    true≠false : ¬ (true ≡ false)
  {-# ATP axiom true≠false #-}

  postulate
    testContradiction : (d : D) → true ≡ false → d ≡ true
  {-# ATP prove testContradiction #-}

------------------------------------------------------------------------------
-- The disjunction data type

module Disjunction where
  infixr 1 _∨_

  -- N.B. It is not necessary to define neither the data constructors
  -- inj₁ and inj₂ nor the disyunction elimination because the ATP
  -- implements them.
  data _∨_ (A B : Set) : Set where

  -- Testing the data constructors and the elimination.
  postulate
    A B C : Set
    inj₁  : A → A ∨ B
    inj₂  : B → A ∨ B
    [_,_] : (A → C) → (B → C) → A ∨ B → C
  {-# ATP prove inj₁ #-}
  {-# ATP prove inj₂ #-}
  {-# ATP prove [_,_] #-}

------------------------------------------------------------------------------
-- The existential type of D

module ExistentialQuantifier where

  data ∃D (P : D → Set) : Set where

  -- TODO: We cannot prove the data constructor _,_ due to the
  -- eta-conversion, i.e.  Agda internally translates '∃D (λ d → P d)' to
  -- '∃D P'.

  -- postulate
  --   P        : D → Set
  --   _,_      : (d : D) → P d → ∃D (λ d → P d)
  -- {-# ATP prove _,_ #-}

  -- TODO: What about the eliminators?

module Test.Succeed.LogicalConstants where

infix  4 _≡_

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

------------------------------------------------------------------------------
-- The conjuction data type

module Conjunction where

  -- N.B. It is not necessary to define neither the data constructor
  -- _,_, nor the projections -- because the ATPs implement it.
  data _∧_ (A B : Set) : Set where

  -- Testing the data constructor and the projections.
  postulate
    A B     : Set
    _,_     : A → B → A ∧ B
    ∧-proj₁ : A ∧ B → A
    ∧-proj₂ : A ∧ B → B
  {-# ATP prove _,_ #-}
  {-# ATP prove ∧-proj₁ #-}
  {-# ATP prove ∧-proj₂ #-}

------------------------------------------------------------------------------
-- The negation

module Negation where

  infix 3 ¬

  data ⊥ : Set where

  ¬ : Set → Set
  ¬ A = A → ⊥

  postulate
    true false : D

  postulate
    true≠false : ¬ (true ≡ false)
  {-# ATP axiom true≠false #-}

  postulate
    testContradiction : (d : D) → true ≡ false → d ≡ true
  {-# ATP prove testContradiction #-}

------------------------------------------------------------------------------
-- The disjunction data type

module Disjunction where
  infixr 1 _∨_

  -- N.B. It is not necessary to define neither the data constructors
  -- inj₁ and inj₂ nor the disyunction elimination because the ATP
  -- implements them.
  data _∨_ (A B : Set) : Set where

  -- Testing the data constructors and the elimination.
  postulate
    A B C : Set
    inj₁  : A → A ∨ B
    inj₂  : B → A ∨ B
    [_,_] : (A → C) → (B → C) → A ∨ B → C
  {-# ATP prove inj₁ #-}
  {-# ATP prove inj₂ #-}
  {-# ATP prove [_,_] #-}

------------------------------------------------------------------------------
-- The existential type of D

module ExistentialQuantifier where

  data ∃D (P : D → Set) : Set where

  postulate
    test : (d : D) → ∃D (λ e → e ≡ d)
  {-# ATP prove test #-}


wokring on a proof that the relation of disjoint hole names is symmetric

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness

open import structural

module disjointness where
  mutual
    expand-new-disjoint-synth : ∀ { e u τ d Δ Γ Γ' τ'} →
                          hole-name-new e u →
                          Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                          Δ ## (■ (u , Γ' , τ'))
    expand-new-disjoint-synth HNConst ESConst = empty-disj (■ (_ , _ , _))
    expand-new-disjoint-synth (HNAsc hn) (ESAsc x) = expand-new-disjoint-ana hn x
    expand-new-disjoint-synth HNVar (ESVar x₁) = empty-disj (■ (_ , _ , _))
    expand-new-disjoint-synth (HNLam1 hn) ()
    expand-new-disjoint-synth (HNLam2 hn) (ESLam x₁ exp) = expand-new-disjoint-synth hn exp
    expand-new-disjoint-synth (HNHole x) ESEHole = disjoint-singles x
    expand-new-disjoint-synth (HNNEHole x hn) (ESNEHole x₁ exp) = disjoint-parts (expand-new-disjoint-synth hn exp) (disjoint-singles x)
    expand-new-disjoint-synth (HNAp hn hn₁) (ESAp x x₁ x₂ x₃ x₄ x₅) =
                                            disjoint-parts (expand-new-disjoint-ana hn x₄)
                                                  (expand-new-disjoint-ana hn₁ x₅)

    expand-new-disjoint-ana : ∀ { e u τ d Δ Γ Γ' τ' τ2} →
                              hole-name-new e u →
                              Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ →
                              Δ ## (■ (u , Γ' , τ'))
    expand-new-disjoint-ana hn (EASubsume x x₁ x₂ x₃) = expand-new-disjoint-synth hn x₂
    expand-new-disjoint-ana (HNLam1 hn) (EALam x₁ x₂ ex) = expand-new-disjoint-ana hn ex
    expand-new-disjoint-ana (HNHole x) EAEHole = disjoint-singles x
    expand-new-disjoint-ana (HNNEHole x hn) (EANEHole x₁ x₂) = disjoint-parts (expand-new-disjoint-synth hn x₂) (disjoint-singles x)

  mutual
    expand-disjoint-new-synth : ∀{ e τ d Δ u Γ Γ' τ'} →
                                Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                                Δ ## (■ (u , Γ' , τ')) →
                                hole-name-new e u
    expand-disjoint-new-synth ESConst disj = HNConst
    expand-disjoint-new-synth (ESVar x₁) disj = HNVar
    expand-disjoint-new-synth (ESLam x₁ ex) disj = HNLam2 (expand-disjoint-new-synth ex disj)
    expand-disjoint-new-synth (ESAp {Δ1 = Δ1} x x₁ x₂ x₃ x₄ x₅) disj
      with expand-disjoint-new-ana x₄ (disjoint-union1 disj) | expand-disjoint-new-ana x₅ (disjoint-union2 {Γ1 = Δ1} disj)
    ... | ih1 | ih2 = HNAp ih1 ih2
    expand-disjoint-new-synth {Γ = Γ} ESEHole disj = HNHole (singles-notequal disj)
    expand-disjoint-new-synth (ESNEHole {Δ = Δ} x ex) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj))
                                                                      (expand-disjoint-new-synth ex (disjoint-union1 disj))
    expand-disjoint-new-synth (ESAsc x) disj = HNAsc (expand-disjoint-new-ana x disj)

    expand-disjoint-new-ana : ∀{ e τ d Δ u Γ Γ' τ2 τ'} →
                                Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ →
                                Δ ## (■ (u , Γ' , τ')) →
                                hole-name-new e u
    expand-disjoint-new-ana (EALam x₁ x₂ ex) disj = HNLam1 (expand-disjoint-new-ana ex disj)
    expand-disjoint-new-ana (EASubsume x x₁ x₂ x₃) disj = expand-disjoint-new-synth x₂ disj
    expand-disjoint-new-ana EAEHole disj = HNHole (singles-notequal disj)
    expand-disjoint-new-ana (EANEHole {Δ = Δ} x x₁) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj))
                                                                    (expand-disjoint-new-synth x₁ (disjoint-union1 disj))

  mutual
    -- this looks good but may not *quite* work because of the
    -- weakening calls in the two lambda cases
    expand-ana-disjoint : ∀{ e1 e2 τ1 τ2 e1' e2' τ1' τ2' Γ Δ1 Δ2 } →
          holes-disjoint e1 e2 →
          Γ ⊢ e1 ⇐ τ1 ~> e1' :: τ1' ⊣ Δ1 →
          Γ ⊢ e2 ⇐ τ2 ~> e2' :: τ2' ⊣ Δ2 →
          Δ1 ## Δ2
    expand-ana-disjoint hd (EASubsume x x₁ x₂ x₃) E2 = expand-synth-disjoint hd x₂ E2
    expand-ana-disjoint (HDLam1 hd) (EALam x₁ x₂ ex1) E2 = expand-ana-disjoint hd ex1 (weaken-ana-expand x₁ E2)
    expand-ana-disjoint (HDHole x) EAEHole E2 = ##-comm (expand-new-disjoint-ana x E2)
    expand-ana-disjoint (HDNEHole x hd) (EANEHole x₁ x₂) E2 = disjoint-parts (expand-synth-disjoint hd x₂ E2) (##-comm (expand-new-disjoint-ana x E2))

    expand-synth-disjoint : ∀{ e1 e2 τ1 τ2 e1' e2' τ2' Γ Δ1 Δ2 } →
          holes-disjoint e1 e2 →
          Γ ⊢ e1 ⇒ τ1 ~> e1' ⊣ Δ1 →
          Γ ⊢ e2 ⇐ τ2 ~> e2' :: τ2' ⊣ Δ2 →
          Δ1 ## Δ2
    expand-synth-disjoint HDConst ESConst ana = empty-disj _
    expand-synth-disjoint (HDAsc hd) (ESAsc x) ana = expand-ana-disjoint hd x ana
    expand-synth-disjoint HDVar (ESVar x₁) ana = empty-disj _
    expand-synth-disjoint (HDLam1 hd) () ana
    expand-synth-disjoint (HDLam2 hd) (ESLam x₁ synth) ana = expand-synth-disjoint hd synth (weaken-ana-expand x₁ ana)
    expand-synth-disjoint (HDHole x) ESEHole ana = ##-comm (expand-new-disjoint-ana x ana)
    expand-synth-disjoint (HDNEHole x hd) (ESNEHole x₁ synth) ana = disjoint-parts (expand-synth-disjoint hd synth ana) (##-comm (expand-new-disjoint-ana x ana))
    expand-synth-disjoint (HDAp hd hd₁) (ESAp x x₁ x₂ x₃ x₄ x₅) ana = disjoint-parts (expand-ana-disjoint hd x₄ ana) (expand-ana-disjoint hd₁ x₅ ana)

  ds-lem-asc : ∀{e1 e2 τ} → holes-disjoint e2 e1 → holes-disjoint e2 (e1 ·: τ)
  ds-lem-asc HDConst = HDConst
  ds-lem-asc (HDAsc hd) = HDAsc (ds-lem-asc hd)
  ds-lem-asc HDVar = HDVar
  ds-lem-asc (HDLam1 hd) = HDLam1 (ds-lem-asc hd)
  ds-lem-asc (HDLam2 hd) = HDLam2 (ds-lem-asc hd)
  ds-lem-asc (HDHole x) = HDHole (HNAsc x)
  ds-lem-asc (HDNEHole x hd) = HDNEHole (HNAsc x) (ds-lem-asc hd)
  ds-lem-asc (HDAp hd hd₁) = HDAp (ds-lem-asc hd) (ds-lem-asc hd₁)

  ds-lem-lam1 : ∀{e1 e2 x} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x e1)
  ds-lem-lam1 HDConst = HDConst
  ds-lem-lam1 (HDAsc hd) = HDAsc (ds-lem-lam1 hd)
  ds-lem-lam1 HDVar = HDVar
  ds-lem-lam1 (HDLam1 hd) = HDLam1 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDLam2 hd) = HDLam2 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDHole x₁) = HDHole (HNLam1 x₁)
  ds-lem-lam1 (HDNEHole x₁ hd) = HDNEHole (HNLam1 x₁) (ds-lem-lam1 hd)
  ds-lem-lam1 (HDAp hd hd₁) = HDAp (ds-lem-lam1 hd) (ds-lem-lam1 hd₁)

  ds-lem-lam2 : ∀{e1 e2 x τ} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x [ τ ] e1)
  ds-lem-lam2 HDConst = HDConst
  ds-lem-lam2 (HDAsc hd) = HDAsc (ds-lem-lam2 hd)
  ds-lem-lam2 HDVar = HDVar
  ds-lem-lam2 (HDLam1 hd) = HDLam1 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDLam2 hd) = HDLam2 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDHole x₁) = HDHole (HNLam2 x₁)
  ds-lem-lam2 (HDNEHole x₁ hd) = HDNEHole (HNLam2 x₁) (ds-lem-lam2 hd)
  ds-lem-lam2 (HDAp hd hd₁) = HDAp (ds-lem-lam2 hd) (ds-lem-lam2 hd₁)

  disjoint-sym : (e1 e2 : hexp) → holes-disjoint e1 e2 → holes-disjoint e2 e1
  disjoint-sym .c c HDConst = HDConst
  disjoint-sym .c (e2 ·: x) HDConst = HDAsc (disjoint-sym _ _ HDConst)
  disjoint-sym .c (X x) HDConst = HDVar
  disjoint-sym .c (·λ x e2) HDConst = HDLam1 (disjoint-sym c e2 HDConst)
  disjoint-sym .c (·λ x [ x₁ ] e2) HDConst = HDLam2 (disjoint-sym c e2 HDConst)
  disjoint-sym .c ⦇⦈[ x ] HDConst = HDHole HNConst
  disjoint-sym .c ⦇ e2 ⦈[ x ] HDConst = HDNEHole HNConst (disjoint-sym c e2 HDConst)
  disjoint-sym .c (e2 ∘ e3) HDConst = HDAp (disjoint-sym c e2 HDConst) (disjoint-sym c e3 HDConst)

  disjoint-sym _ c (HDAsc hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x) (HDAsc hd) | HDAsc ih = HDAsc (ds-lem-asc ih)
  disjoint-sym _ (X x) (HDAsc hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDAsc hd) | HDLam1 ih = HDLam1 (ds-lem-asc ih)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) | HDLam2 ih = HDLam2 (ds-lem-asc ih)
  disjoint-sym _ ⦇⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x ] (HDAsc hd) | HDHole x₁ = HDHole (HNAsc x₁)
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDAsc hd) | HDNEHole x₁ ih = HDNEHole (HNAsc x₁) (ds-lem-asc ih)
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) | HDAp ih ih₁ = HDAp (ds-lem-asc ih) (ds-lem-asc ih₁)

  disjoint-sym _ c HDVar = HDConst
  disjoint-sym _ (e2 ·: x₁) HDVar = HDAsc (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (X x₁) HDVar = HDVar
  disjoint-sym _ (·λ x₁ e2) HDVar = HDLam1 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) HDVar = HDLam2 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ ⦇⦈[ x₁ ] HDVar = HDHole HNVar
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] HDVar = HDNEHole HNVar (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (e2 ∘ e3) HDVar = HDAp (disjoint-sym _ e2 HDVar) (disjoint-sym _ e3 HDVar)

  disjoint-sym _ c (HDLam1 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) | HDAsc ih = HDAsc (ds-lem-lam1 ih)
  disjoint-sym _ (X x₁) (HDLam1 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) | HDLam1 ih = HDLam1 (ds-lem-lam1 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) | HDLam2 ih = HDLam2 (ds-lem-lam1 ih)
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam1 hd) | HDHole x = HDHole (HNLam1 x)
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam1 hd) | HDNEHole x ih = HDNEHole (HNLam1 x) (ds-lem-lam1 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam1 ih) (ds-lem-lam1 ih₁)

  disjoint-sym _ c (HDLam2 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) | HDAsc ih = HDAsc (ds-lem-lam2 ih)
  disjoint-sym _ (X x₁) (HDLam2 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) | HDLam1 ih = HDLam1 (ds-lem-lam2 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) | HDLam2 ih = HDLam2 (ds-lem-lam2 ih)
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam2 hd) | HDHole x = HDHole (HNLam2 x)
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam2 hd) | HDNEHole x ih = HDNEHole (HNLam2 x) (ds-lem-lam2 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam2 ih) (ds-lem-lam2 ih₁)

  disjoint-sym _ c (HDHole x) = HDConst
  disjoint-sym _ (e2 ·: x) (HDHole (HNAsc x₁)) = HDAsc (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (X x) (HDHole x₁) = HDVar
  disjoint-sym _ (·λ x e2) (HDHole (HNLam1 x₁)) = HDLam1 (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDHole (HNLam2 x₂)) = HDLam2 (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₂))
  disjoint-sym _ ⦇⦈[ x ] (HDHole (HNHole x₁)) =  HDHole (HNHole (flip x₁))
  disjoint-sym _ ⦇ e2 ⦈[ u' ] (HDHole (HNNEHole x x₁)) = HDNEHole (HNHole (flip x)) (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (e2 ∘ e3) (HDHole (HNAp x x₁)) = HDAp (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x))
                                                    (disjoint-sym ⦇⦈[ _ ] e3 (HDHole x₁))

  disjoint-sym _ c (HDNEHole x hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDNEHole x₁ hd) = HDAsc {!!}
  disjoint-sym _ (X x) (HDNEHole x₁ hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDNEHole x₁ hd) = {!!}
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole x₂ hd) = {!!}
  disjoint-sym _ ⦇⦈[ x ] (HDNEHole x₁ hd) = {!!}
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDNEHole x₁ hd) = {!!}
  disjoint-sym _ (e2 ∘ e3) (HDNEHole x hd) = {!!}

  disjoint-sym _ c (HDAp hd hd₁) = HDConst
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) = {!!}
  disjoint-sym _ (X x) (HDAp hd hd₁) = HDVar
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) = {!!}
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) = {!!}
  disjoint-sym _ ⦇⦈[ x ] (HDAp hd hd₁) = {!!}
  disjoint-sym _ ⦇ e3 ⦈[ x ] (HDAp hd hd₁) = {!!}
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) = {!!}

  -- note that this is false, so holes-disjoint isn't transitive
  -- disjoint-new : ∀{e1 e2 u} → holes-disjoint e1 e2 → hole-name-new e1 u → hole-name-new e2 u

  -- it's also not reflexive, because ⦇⦈[ u ] isn't hole-disjoint with
  -- itself since u == u; it's not anti-reflexive, because the
  -- expression c *is* hole-disjoint with itself (abeit vacuously)


Disable unused instance

Disable unused instance

Agda will not infer explicit arguments of instance arguments. On the
other hand, trying to make this into a proper instance (with an implicit
argument) makes typechecking too much slower or not terminating (more
precisely, on some modules typechecking took longer than I wanted to
wait and I didn't investigate further).

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily ⟦_⟧Base

module Structure {{change-algebra-base : Structure}} where
  -- change algebras

  open CA public renaming
    -- Constructors for All′
    ( [] to ∅
    ; _∷_ to _•_
    )

  change-algebra : ∀ τ → ChangeAlgebra ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = changeAlgebraFun {{change-algebra τ₁}} {{change-algebra τ₂}}

  -- We provide: change algebra for every type
  instance
    change-algebra-family : ChangeAlgebraFamily ⟦_⟧Type
    change-algebra-family = family change-algebra

  -- function changes

  module _ {τ₁ τ₂ : Type} where
    open FunctionChange {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebraListChanges to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍ Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍_₎ Γ

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily ⟦_⟧Base

module Structure {{change-algebra-base : Structure}} where
  -- change algebras

  open CA public renaming
    -- Constructors for All′
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  instance
    change-algebra : ∀ τ → ChangeAlgebra ⟦ τ ⟧Type
    change-algebra (base ι) = change-algebra₍ ι ₎
    change-algebra (τ₁ ⇒ τ₂) = changeAlgebraFun {{change-algebra τ₁}} {{change-algebra τ₂}}

    change-algebra-family : ChangeAlgebraFamily ⟦_⟧Type
    change-algebra-family = family change-algebra

  -- function changes

  module _ {τ₁ τ₂ : Type} where
    open FunctionChange {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebraListChanges to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍ Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍_₎ Γ


Added thesis's examples.

Added thesis's examples.

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}
{-# OPTIONS --no-coverage-check #-}

module AgdaIntroduction where

-- Dependent function types
id : (A : Set) → A → A
id A x = x

-- λ-notation
id₂ : (A : Set) → A → A
id₂ = λ A → λ x → x

id₃ : (A : Set) → A → A
id₃ = λ A x → x

-- Implicit arguments
id₄ : {A : Set} → A → A
id₄ x = x

id₅ : {A : Set} → A → A
id₅ = λ x → x

-- Inductively defined sets and families
data Bool : Set where
  false true : Bool

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

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

data Vec (A : Set) : ℕ → Set where
  []  : Vec A zero
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (succ n)

data Fin : ℕ → Set where
  fzero : {n : ℕ} → Fin (succ n)
  fsucc : {n : ℕ} → Fin n → Fin (succ n)

-- Structurally recursive functions and pattern matching
_+_ : ℕ → ℕ → ℕ
zero   + n = n
succ m + n = succ (m + n)

map : {A B : Set} → (A → B) → List A → List B
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

-- The absurd pattern
magic : {A : Set} → Fin zero → A
magic ()

-- The with constructor
filter : {A : Set} → (A → Bool) → List A → List A
filter p [] = []
filter p (x ∷ xs) with p x
... | true  = x ∷ filter p xs
... | false = filter p xs

filter' : {A : Set} → (A → Bool) → List A → List A
filter' p [] = []
filter' p (x ∷ xs) with p x
filter' p (x ∷ xs) | true  = x ∷ filter' p xs
filter' p (x ∷ xs) | false = filter' p xs

-- Mutual definitions
even : ℕ → Bool
odd  : ℕ → Bool

even zero     = true
even (succ n) = odd n

odd zero     = false
odd (succ n) = even n

data EvenList : Set
data OddList  : Set

data EvenList where
  []  : EvenList
  _∷_ : ℕ → OddList → EvenList

data OddList where
  _∷_ : ℕ → EvenList → OddList

-- Coverage and termination checkers
head : {A : Set} → List A → A
head (x ∷ xs) = x

ack : ℕ → ℕ → ℕ
ack zero     n        = succ n
ack (succ m) zero     = ack m (succ zero)
ack (succ m) (succ n) = ack m (ack (succ m) n)

{-# NO_TERMINATION_CHECK #-}
f : ℕ → ℕ
f n = f n

{-# NO_TERMINATION_CHECK #-}
nest : ℕ → ℕ
nest zero     = zero
nest (succ n) = nest (nest n)

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module AgdaIntroduction where

id : (A : Set) → A → A
id A x = x

id₂ : (A : Set) → A → A
id₂ = λ A → λ x → x

id₃ : (A : Set) → A → A
id₃ = λ A x → x

id₄ : {A : Set} → A → A
id₄ x = x

id₅ : {A : Set} → A → A
id₅ = λ x → x

data Bool : Set where
  false true : Bool

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

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

data Vec (A : Set) : ℕ → Set where
  []  : Vec A zero
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (succ n)

data Fin : ℕ → Set where
  fzero : {n : ℕ} → Fin (succ n)
  fsucc : {n : ℕ} → Fin n → Fin (succ n)

_+_ : ℕ → ℕ → ℕ
zero   + n = n
succ m + n = succ (m + n)

map : {A B : Set} → (A → B) → List A → List B
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

magic : {A : Set} → Fin zero → A
magic ()

head : {A : Set}{n : ℕ} → Vec A (succ n) → A
head (x ∷ xs) = x

filter : {A : Set} → (A → Bool) → List A → List A
filter p [] = []
filter p (x ∷ xs) with p x
... | true  = x ∷ filter p xs
... | false = filter p xs

filter' : {A : Set} → (A → Bool) → List A → List A
filter' p [] = []
filter' p (x ∷ xs) with p x
filter' p (x ∷ xs) | true  = x ∷ filter' p xs
filter' p (x ∷ xs) | false = filter' p xs

even : ℕ → Bool
odd  : ℕ → Bool

even zero     = true
even (succ n) = odd n

odd zero     = false
odd (succ n) = even n

data EvenList : Set
data OddList  : Set

data EvenList where
  []  : EvenList
  _∷_ : ℕ → OddList → EvenList

data OddList where
  _∷_ : ℕ → EvenList → OddList


Restore a renaming...

Restore a renaming...

{-# OPTIONS --without-K #-}
open import Function.NP using (flip; Π; Πⁱ; Op₁; Op₂; nest)
open import Data.Nat.Base using (ℕ; _≤_; _∸_; z≤n; s≤s)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
import Data.Nat.Properties.Simple as ℕ°
open import Data.Integer.NP
  using    (ℤ; +_; -[1+_]; _⊖_; -_)
  renaming ( _+_ to _+ℤ_; _-_ to _−ℤ_
           ; suc to sucℤ; pred to predℤ
           )
open import Data.Product.NP using (_×_; _,_; fst; snd)
open import Relation.Nullary using (¬_)
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
import Algebra.FunctionProperties.NP
open import Algebra.Raw
open ≡-Reasoning
open import HoTT using (module Equivalences)
open Equivalences

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

module Implicits where
  open Algebra.FunctionProperties.NP Πⁱ {a}{a}{A} _≡_ public

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict

  module From-Magma (magma : Magma A) where

    open Magma magma

    module From-Comm
             (comm  : Commutative _∙_)
             {x y x' y' : A}
             (e : (y ∙ x) ≡ (y' ∙ x'))
           where
      comm= : x ∙ y ≡ x' ∙ y'
      comm= = comm ♦ e ♦ comm

    module From-Assoc
             (assoc : Associative _∙_)
           where

      assocs : Associative _∙_ × Associative (flip _∙_)
      assocs = assoc , ! assoc

      module _ {c x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
        assoc= = ! assoc ♦ ∙= e idp ♦ assoc

        !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
        !assoc= = assoc ♦ ∙= idp e ♦ ! assoc

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
        inner= = assoc= (!assoc= e)

    module From-Assoc-Comm
             (assoc : Associative _∙_)
             (comm  : Commutative _∙_)
           where
      open From-Assoc assoc public
      open From-Comm  comm  public

      module _ {x y z} where
        assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
        assoc-comm = assoc= comm

        !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
        !assoc-comm = !assoc= comm

      interchange : Interchange _∙_ _∙_
      interchange = assoc= (!assoc= comm)

      on-sides : ∀ {x x' y y' z z' t t'}
                 → x ∙ z ≡ x' ∙ z'
                 → y ∙ t ≡ y' ∙ t'
                 → (x ∙ y) ∙ (z ∙ t) ≡ (x' ∙ y') ∙ (z' ∙ t')
      on-sides p q = interchange ♦ ∙= p q ♦ interchange

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
        outer= = ∙= comm comm ♦ assoc= (!assoc= e) ♦ ∙= comm comm

  module From-Op₂ (op : Op₂ A) = From-Magma ⟨ op ⟩

  module From-Monoid-Ops (mon-ops : Monoid-Ops A) where
    open Monoid-Ops mon-ops
    open From-Op₂ _∙_ public

    module From-LeftIdentity (idl : LeftIdentity ε _∙_) where
      module _ {x y} where
        is-ε-left : x ≡ ε → x ∙ y ≡ y
        is-ε-left e = ap (λ z → z ∙ _) e ♦ idl

      ε^⁺ : ∀ n → ε ^⁺ n ≡ ε
      ε^⁺ 0      = idp
      ε^⁺ (1+ n) = idl ♦ ε^⁺ n

    module From-RightIdentity (idr : RightIdentity ε _∙_) where
      module _ {x y} where
        is-ε-right : y ≡ ε → x ∙ y ≡ x
        is-ε-right e = ap (λ z → _ ∙ z) e ♦ idr

      module _ {b} where
        ^⁺-^¹⁺ : ∀ n → b ^⁺ (1+ n) ≡ b ^¹⁺ n
        ^⁺-^¹⁺ 0 = idr
        ^⁺-^¹⁺ (1+ n) = ∙= idp (^⁺-^¹⁺ n)

        ^⁺0-ε : b ^⁺ 0 ≡ ε
        ^⁺0-ε = idp

        ^⁺1-id : b ^⁺ 1 ≡ b
        ^⁺1-id = idr

        ^⁺2-∙ : b ^⁺ 2 ≡ b ∙ b
        ^⁺2-∙ = ^⁺-^¹⁺ 1

        ^⁺3-∙ : b ^⁺ 3 ≡ b ∙ (b ∙ b)
        ^⁺3-∙ = ^⁺-^¹⁺ 2

        ^⁺4-∙ : b ^⁺ 4 ≡ b ∙ (b ∙ (b ∙ b))
        ^⁺4-∙ = ^⁺-^¹⁺ 3

    module From-Identities (identities : Identity ε _∙_) where
      comm-ε : ∀ {x} → x ∙ ε ≡ ε ∙ x
      comm-ε = snd identities ♦ ! fst identities

      open From-LeftIdentity  (fst identities) public
      open From-RightIdentity (snd identities) public

    module From-Assoc-RightIdentity
             (assoc : Associative _∙_)
             (idr   : RightIdentity ε _∙_)
             where
      open From-RightIdentity idr

      module _ {c x y}(e : x ∙ y ≡ ε) where
        elim-assoc= : (c ∙ x) ∙ y ≡ c
        elim-assoc= = assoc ♦ ∙= idp e ♦ idr

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-inner= = ! assoc ♦ ∙= (elim-assoc= e) idp

    module From-Assoc-LeftIdentity
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             where
      open From-LeftIdentity idl

      -- Together with ^⁺0-ε, ^⁺-+ shows that (b ^⁺_) is a
      -- monoid homomorphism from (ℕ,+,0) to (M,∙,ε)
      -- therefore also a group homomorphism
      ^⁺-+ : ∀ m {n b} → b ^⁺ (m +ℕ n) ≡ b ^⁺ m ∙ b ^⁺ n
      ^⁺-+ 0      = ! idl
      ^⁺-+ (1+ m) = ap (_∙_ _) (^⁺-+ m) ♦ ! assoc

      -- Derived from ^⁺-+ in Algebra.Group
      ^⁺-* : ∀ m {n b} → b ^⁺(m *ℕ n) ≡ (b ^⁺ n)^⁺ m
      ^⁺-* 0 = idp
      ^⁺-* (1+ m) {n} {b}
        = b ^⁺ (n +ℕ m *ℕ n)     ≡⟨ ^⁺-+ n ⟩
          b ^⁺ n ∙ b ^⁺(m *ℕ n)  ≡⟨ ap (_∙_ (b ^⁺ n)) (^⁺-* m) ⟩
          b ^⁺ n ∙ (b ^⁺ n)^⁺ m  ∎

      module _ {c x y} (e : x ∙ y ≡ ε) where
        elim-!assoc= : x ∙ (y ∙ c) ≡ c
        elim-!assoc= = ! assoc ♦ ∙= e idp ♦ idl

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-!inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-!inner= = assoc ♦ ap (_∙_ c) (elim-!assoc= e)

  module From-Group-Ops (grp-ops : Group-Ops A) where
    open Group-Ops grp-ops
    open From-Monoid-Ops mon-ops public

    module From-Assoc-LeftIdentity-LeftInverse
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             (inverseˡ : LeftInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-LeftIdentity idl
      open From-Assoc-LeftIdentity assoc idl

      ⁻¹-inverseʳ : RightInverse ε _⁻¹ _∙_
      ⁻¹-inverseʳ {x}
         = x ∙ x ⁻¹                      ≡⟨ ! idl ⟩
           ε ∙ (x ∙ x ⁻¹)                ≡⟨ ∙= (! inverseˡ) idp ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹) ∙ (x ∙ x ⁻¹) ≡⟨ elim-!inner= inverseˡ ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹)              ≡⟨ inverseˡ ⟩
           ε                             ∎

      cancels-∙-left : LeftCancel _∙_
      cancels-∙-left {c} {x} {y} e
        = x              ≡⟨ ! idl ⟩
          ε ∙ x          ≡⟨ ∙= (! inverseˡ) idp ⟩
          c ⁻¹ ∙ c ∙ x   ≡⟨ !assoc= e ⟩
          c ⁻¹ ∙ c ∙ y   ≡⟨ ∙= inverseˡ idp ⟩
          ε ∙ y          ≡⟨ idl ⟩
          y              ∎

      module _ {x y} where
        unique-ε-right : x ∙ y ≡ x → y ≡ ε
        unique-ε-right eq
          = y               ≡⟨ ! is-ε-left inverseˡ ⟩
            x ⁻¹ ∙  x ∙ y   ≡⟨ assoc ⟩
            x ⁻¹ ∙ (x ∙ y)  ≡⟨ ∙= idp eq ⟩
            x ⁻¹ ∙ x        ≡⟨ inverseˡ ⟩
            ε               ∎

      ε^⁻ : ∀ n → ε ^⁻ n ≡ ε
      ε^⁻ n = ⁻¹= (ε^⁺ n) ♦ unique-ε-right ⁻¹-inverseʳ

      ε^ : ∀ i → ε ^ i ≡ ε
      ε^ -[1+ n ] = ε^⁻(1+ n)
      ε^ (+ n)    = ε^⁺ n

      module _ {x y} where
        -- _⁻¹ is a group homomorphism, see Algebra.Group._ᵒᵖ
        ⁻¹-hom′ : (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
        ⁻¹-hom′ = cancels-∙-left {x ∙ y}
           ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ ⁻¹-inverseʳ ⟩
            ε                       ≡⟨ ! ⁻¹-inverseʳ ⟩
            x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! idl) ⟩
            x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! ⁻¹-inverseʳ) idp) ⟩
            x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
            x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
            (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

        ⁻¹-∙-distr′ : (x ∙ y)⁻¹ ≡ y ⁻¹ / x
        ⁻¹-∙-distr′ = ⁻¹-hom′

      ⁻¹-hom′= : ∀ {x y z t} → x ∙ y ≡ z ∙ t → y ⁻¹ ∙ x ⁻¹ ≡ t ⁻¹ ∙ z ⁻¹
      ⁻¹-hom′= e = ! ⁻¹-hom′ ♦ ap _⁻¹ e ♦ ⁻¹-hom′

      elim-∙-left-⁻¹∙ : ∀ {c x y} → (c ∙ x)⁻¹ ∙ (c ∙ y) ≡ x ⁻¹ ∙ y
      elim-∙-left-⁻¹∙ {c} {x} {y}
        = (c ∙ x)⁻¹   ∙ (c ∙ y)  ≡⟨ ∙= ⁻¹-hom′ idp ⟩
          x ⁻¹ ∙ c ⁻¹ ∙ (c ∙ y)  ≡⟨ elim-!inner= inverseˡ ⟩
          x ⁻¹ ∙ y               ∎

      elim-∙-right-/ : ∀ {c x y} → (x ∙ c) / (y ∙ c) ≡ x / y
      elim-∙-right-/ {c} {x} {y}
        = x ∙ c ∙ (y ∙ c)⁻¹  ≡⟨ ap (_∙_ _) ⁻¹-hom′  ⟩
          x ∙ c ∙ (c ⁻¹ / y) ≡⟨ elim-!inner= ⁻¹-inverseʳ ⟩
          x / y              ∎

    module From-Assoc-RightIdentity-RightInverse
             (assoc : Associative _∙_)
             (idr : RightIdentity ε _∙_)
             (inverseʳ : RightInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-Assoc-RightIdentity assoc idr

      cancels-∙-right : RightCancel _∙_
      cancels-∙-right {c} {x} {y} e
        = x              ≡⟨ ! idr ⟩
          x ∙ ε          ≡⟨ ∙= idp (! inverseʳ) ⟩
          x ∙ (c ∙ c ⁻¹) ≡⟨ assoc= e ⟩
          y ∙ (c ∙ c ⁻¹) ≡⟨ ∙= idp inverseʳ ⟩
          y ∙ ε          ≡⟨ idr ⟩
          y              ∎

      inverseˡ : LeftInverse ε _⁻¹ _∙_
      inverseˡ {x}
        = x ⁻¹ ∙ x                      ≡⟨ ! idr ⟩
          (x ⁻¹ ∙ x) ∙ ε                ≡⟨ ∙= idp (! inverseʳ) ⟩
          (x ⁻¹ ∙ x) ∙ (x ⁻¹ ∙ x ⁻¹ ⁻¹) ≡⟨ elim-inner= inverseʳ ⟩
          (x ⁻¹ ∙ x ⁻¹ ⁻¹)              ≡⟨ inverseʳ ⟩
          ε                             ∎

      ⁻¹-involutive : Involutive _⁻¹
      ⁻¹-involutive {x}
        = cancels-∙-right
          (x ⁻¹ ⁻¹ ∙ x ⁻¹ ≡⟨ inverseˡ ⟩
           ε              ≡⟨ ! inverseʳ ⟩
           x ∙ x ⁻¹       ∎)

      module _ {x y} where
        /-∙ : (x / y) ∙ y ≡ x
        /-∙ = elim-assoc= inverseˡ

        ∙-/ : (x ∙ y) / y ≡ x
        ∙-/ = elim-assoc= inverseʳ

      module _ {x y} where
        unique-ε-left : x ∙ y ≡ y → x ≡ ε
        unique-ε-left eq
          = x            ≡⟨ ! ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            y / y        ≡⟨ inverseʳ ⟩
            ε            ∎

        x/y≡ε→x≡y : x / y ≡ ε → x ≡ y
        x/y≡ε→x≡y x/y≡ε = cancels-∙-right (x/y≡ε ♦ ! inverseʳ)

        x/y≢ε : x ≢ y → x / y ≢ ε
        x/y≢ε x≢y x/y≡ε = x≢y (x/y≡ε→x≡y x/y≡ε)

      ε⁻¹≡ε : ε ⁻¹ ≡ ε
      ε⁻¹≡ε = unique-ε-left inverseˡ

    module From-Assoc-Identities-RightInverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv-r : RightInverse ε _⁻¹ _∙_)
             where
      private
        idl = fst identities
        idr = snd identities

      inverseʳ : RightInverse ε _⁻¹ _∙_
      inverseʳ = inv-r

      open From-Assoc assoc
      open From-Identities identities using (comm-ε)
      open From-LeftIdentity        idl
      open From-RightIdentity       idr
      open From-Assoc-LeftIdentity  assoc idl
      open From-Assoc-RightIdentity assoc idr
      open From-Assoc-RightIdentity-RightInverse assoc idr inverseʳ public
      open From-Assoc-LeftIdentity-LeftInverse assoc idl inverseˡ public
        hiding (⁻¹-inverseʳ)

      module _ {x y} where
        ∙-/′ : y ∙ (x /′ y) ≡ x
        ∙-/′ = elim-!assoc= inverseʳ

        /′-∙ : (y ∙ x) /′ y ≡ x
        /′-∙ = elim-!assoc= inverseˡ

        /-/′ : x / (x /′ y) ≡ y
        /-/′ =
          x ∙ (y ⁻¹ ∙ x) ⁻¹    ≡⟨ ∙= idp ⁻¹-hom′ ⟩
          x ∙ (x ⁻¹ ∙ y ⁻¹ ⁻¹) ≡⟨ elim-!assoc= inverseʳ ⟩
          y ⁻¹ ⁻¹              ≡⟨ ⁻¹-involutive ⟩
          y                    ∎

        /′-/ : x /′ (x / y) ≡ y
        /′-/ =
          (x / y)⁻¹ ∙ x        ≡⟨ ∙= ⁻¹-hom′ idp ⟩
          y ⁻¹ ⁻¹ ∙ x ⁻¹ ∙ x   ≡⟨ elim-assoc= inverseˡ ⟩
          y ⁻¹ ⁻¹              ≡⟨ ⁻¹-involutive ⟩
          y                    ∎

      ∙-is-equiv : ∀ {k} → Is-equiv (_∙_ k)
      ∙-is-equiv {k} = is-equiv (_∙_ (k ⁻¹))
                                (λ _ → ! assoc ♦ ∙= inverseʳ idp ♦ idl)
                                (λ _ → ! assoc ♦ ∙= inverseˡ idp ♦ idl)

      flip-∙-is-equiv : ∀ {k} → Is-equiv (flip _∙_ k)
      flip-∙-is-equiv {k} = is-equiv (flip _∙_ (k ⁻¹))
                                     (λ _ → assoc ♦ ∙= idp inverseˡ ♦ idr)
                                     (λ _ → assoc ♦ ∙= idp inverseʳ ♦ idr)

      module _ {x y} where
        unique-⁻¹ : x ∙ y ≡ ε → x ≡ y ⁻¹
        unique-⁻¹ eq
          = x            ≡⟨ ! ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            ε / y        ≡⟨ idl ⟩
            y ⁻¹         ∎

      ⁻¹-inj : ∀ {x y} → x ⁻¹ ≡ y ⁻¹ → x ≡ y
      ⁻¹-inj {x} {y} e
         = ! (y              ≡⟨ ! idr ⟩
              y ∙ ε          ≡⟨ ∙= idp (ε        ≡⟨ ! inverseˡ  ⟩
                                        x ⁻¹ ∙ x ≡⟨ ∙= e idp ⟩
                                        y ⁻¹ ∙ x ∎) ⟩
              y ∙ (y ⁻¹ ∙ x) ≡⟨ ∙-/′ ⟩
              x ∎)

      module _ {b} where
        ^⁺-1+ : ∀ n → b ^⁺(1+ n) ≡ b ^⁺ n ∙ b
        ^⁺-1+ 0 = comm-ε
        ^⁺-1+ (1+ n) = ap (_∙_ b) (^⁺-1+ n) ♦ ! assoc

        ^⁺-∸ : ∀ {m n} → n ≤ m → b ^⁺(m ∸ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁺-∸ z≤n = ! is-ε-right ε⁻¹≡ε
        ^⁺-∸ (s≤s {n} {m} n≤m) =
           b ^⁺(m ∸ n)                     ≡⟨ ^⁺-∸ n≤m ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖ : ∀ m n → b ^(m ⊖ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^-⊖ m      0      = ! is-ε-right ε⁻¹≡ε
        ^-⊖ 0      (1+ n) = ! idl
        ^-⊖ (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖ m n ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖' : ∀ m n → b ^(m ⊖ n) ≡ b ^⁻ n ∙ b ^⁺ m
        ^-⊖' m      0      = ! is-ε-left ε⁻¹≡ε
        ^-⊖' 0      (1+ n) = ! idr
        ^-⊖' (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖' m n ⟩
           (b ^⁻ n ∙ b ^⁺ m)               ≡⟨ ! elim-inner= inverseˡ ⟩
           (b ^⁻ n ∙ b ⁻¹) ∙ (b ∙ b ^⁺ m)  ≡⟨ ∙= (! ⁻¹-hom′) idp ⟩
           (b ∙ b ^⁺ n)⁻¹ ∙ (b ∙ b ^⁺ m)   ∎

        ^⁺-comm : ∀ m n → b ^⁺ m ∙ b ^⁺ n ≡ b ^⁺ n ∙ b ^⁺ m
        ^⁺-comm 0      n = ! comm-ε
        ^⁺-comm (1+ m) n =
          b ∙ bᵐ ∙ bⁿ   ≡⟨ !assoc= (^⁺-comm m n) ⟩
          b ∙ bⁿ ∙ bᵐ   ≡⟨ ∙= (^⁺-1+ n) idp ⟩
          bⁿ ∙ b ∙ bᵐ   ≡⟨ assoc ⟩
          bⁿ ∙ (b ∙ bᵐ) ∎
          where
            bⁿ = b ^⁺ n
            bᵐ = b ^⁺ m

        ^⁺-^⁻-comm : ∀ m n → b ^⁺ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁺ m
        ^⁺-^⁻-comm m n = ! ^-⊖ m n ♦ ^-⊖' m n

        ^⁻-^⁺-comm : ∀ m n → b ^⁻ n ∙ b ^⁺ m ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁻-^⁺-comm m n = ! ^-⊖' m n ♦ ^-⊖ m n

        ^⁻-comm : ∀ m n → b ^⁻ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁻ m
        ^⁻-comm m n = ⁻¹-hom′= (^⁺-comm n m)

        ^⁻-1+ : ∀ n → b ^⁻(1+ n) ≡ b ⁻¹ ∙ b ^⁻ n
        ^⁻-1+ n = ap _⁻¹ (^⁺-1+ n) ♦ ⁻¹-hom′

        ^⁻′-spec : ∀ n → b ^⁻′ n ≡ b ^⁻ n
        ^⁻′-spec 0 = ! ε⁻¹≡ε
        ^⁻′-spec (1+ n) = ap (_∙_ (b ⁻¹)) (^⁻′-spec n)
                        ♦ ! ⁻¹-hom′
                        ♦ ap _⁻¹ (! ^⁺-1+ n)

        ^⁻′1-id : b ^⁻′ 1 ≡ b ⁻¹
        ^⁻′1-id = idr

        ^⁻1-id : b ^⁻ 1 ≡ b ⁻¹
        ^⁻1-id = ! ^⁻′-spec 1 ♦ ^⁻′1-id

        ^⁻′2-∙ : b ^⁻′ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻′2-∙ = ap (_∙_ _) ^⁻′1-id

        ^⁻2-∙ : b ^⁻ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻2-∙ = ! ^⁻′-spec 2 ♦ ^⁻′2-∙

        -- ^-+ is a group homomorphism defined in Algebra.Group
        -- Some properties can be derived from it.
        ^-+ : ∀ i j → b ^(i +ℤ j) ≡ b ^ i ∙ b ^ j
        ^-+ -[1+ m ] -[1+ n ] = ap _⁻¹
                                 (ap (λ z → b ^⁺(1+ z)) (ℕ°.+-comm (1+ m) n)
                              ♦ ^⁺-+ (1+ n) {1+ m}) ♦ ⁻¹-hom′
        ^-+ -[1+ m ]   (+ n)  = ^-⊖' n (1+ m)
        ^-+   (+ m)  -[1+ n ] = ^-⊖ m (1+ n)
        ^-+   (+ m)    (+ n)  = ^⁺-+ m

        -- GroupHomomorphism.f-pres-inv
        ^-- : ∀ i → b ^(- i) ≡ (b ^ i)⁻¹
        ^-- -[1+ n ] = ! ⁻¹-involutive
        ^-- (+ 0)    = ! ε⁻¹≡ε
        ^-- (+ 1+ n) = idp

        -- GroupHomomorphism.f-−-/
        ^-− : ∀ i j → b ^(i −ℤ j) ≡ b ^ i / b ^ j
        ^-− i j = ^-+ i (- j) ♦ ∙= idp (^-- j)

        ^-suc : ∀ i → b ^(sucℤ i) ≡ b ∙ b ^ i
        ^-suc i = ^-+ (+ 1) i ♦ ∙= idr idp

        ^-pred : ∀ i → b ^(predℤ i) ≡ b ⁻¹ ∙ b ^ i
        ^-pred i = ^-+ (- + 1) i ♦ ap (λ z → z ⁻¹ ∙ b ^ i) idr

        ^-comm : ∀ i j → b ^ i ∙ b ^ j ≡ b ^ j ∙ b ^ i
        ^-comm -[1+ m ] -[1+ n ] = ^⁻-comm (1+ m) (1+ n)
        ^-comm -[1+ m ]   (+ n)  = ! ^⁺-^⁻-comm n (1+ m)
        ^-comm   (+ m)  -[1+ n ] = ^⁺-^⁻-comm m (1+ n)
        ^-comm   (+ m)    (+ n)  = ^⁺-comm m n

      {-
      ^-* : ∀ i j → b ^(i *ℤ j) ≡ (b ^ j)^ i
      ^-* i j = {!!}
      -}

    module From-Assoc-Identities-Inverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv : Inverse ε _⁻¹ _∙_)
             where
      open From-Assoc-Identities-RightInverse assoc identities (snd inv) public

  module From-Ring-Ops (rng-ops : Ring-Ops A) where
    open Ring-Ops rng-ops

    module DistributesOverʳ
             (*-comm : Commutative _*_)
             (*-+-distrˡ : _*_ DistributesOverˡ _+_)
             where
      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = *-comm ♦ *-+-distrˡ ♦ += *-comm *-comm

    module DistributesOverˡ
             (*-comm : Commutative _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = *-comm ♦ *-+-distrʳ ♦ += *-comm *-comm

    module From-+Group-1*Identity-DistributesOverʳ
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     ; ε⁻¹≡ε to 0−0≡0
                     ; ⁻¹-hom′ to 0−-hom′
                     )

      -0≡0 : -0# ≡ 0#
      -0≡0 = 0−0≡0

      0*-zero : LeftZero 0# _*_
      0*-zero {x} = cancels-+-left
        (x + 0# * x      ≡⟨ += (! 1*-identity) idp ⟩
         1# * x + 0# * x ≡⟨ ! *-+-distrʳ ⟩
         (1# + 0#) * x   ≡⟨ *= +0-identity idp ⟩
         1# * x          ≡⟨ 1*-identity ⟩
         x               ≡⟨ ! +0-identity ⟩
         x + 0#          ∎)

      2*-spec : ∀ {n} → 2* n ≡ 2# * n
      2*-spec = ! += 1*-identity 1*-identity ♦ ! *-+-distrʳ

      0−-*-distr : ∀ {x y} → 0−(x * y) ≡ (0− x) * y
      0−-*-distr = cancels-+-right (0−-inverseˡ ♦ ! 0*-zero ♦ *= (! 0−-inverseˡ) idp ♦ *-+-distrʳ)

      -1*-neg : ∀ {x} → -1# * x ≡ 0− x
      -1*-neg = ! 0−-*-distr ♦ 0−= 1*-identity

      2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
      2*-*-distr = ! *-+-distrʳ

    module From-+Group-*Identity-DistributesOver
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*1-identity : RightIdentity 1# _*_)
             (*-+-distrs : _*_ DistributesOver _+_)
             where
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = fst *-+-distrs

      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = snd *-+-distrs

      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( ⁻¹-involutive to 0−-involutive
                     ; cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     ; ⁻¹-∙-distr′ to 0−-+-distr′
                     )

      open From-+Group-1*Identity-DistributesOverʳ
             +-assoc 0+-identity +0-identity 0−-inverseʳ
             1*-identity *-+-distrʳ
             public

      *0-zero : RightZero 0# _*_
      *0-zero {x} = cancels-+-right
        (x * 0# + x      ≡⟨ += idp (! *1-identity) ⟩
         x * 0# + x * 1# ≡⟨ ! *-+-distrˡ ⟩
         x * (0# + 1#)   ≡⟨ *= idp 0+-identity ⟩
         x * 1#          ≡⟨ *1-identity ⟩
         x               ≡⟨ ! 0+-identity ⟩
         0# + x          ∎)

      0−-*-distrʳ : ∀ {x y} → 0−(x * y) ≡ x * (0− y)
      0−-*-distrʳ = cancels-+-right (0−-inverseˡ ♦ (! *0-zero ♦ *= idp (! 0−-inverseˡ)) ♦ *-+-distrˡ)

      *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
      *-−-distr = *-+-distrˡ ♦ += idp (! 0−-*-distrʳ)

      ²-0−-distr : ∀ {x} → (0− x)² ≡ x ²
      ²-0−-distr = ! 0−-*-distr ♦ 0−=(! 0−-*-distrʳ) ♦ 0−-involutive

      +-comm : Commutative _+_
      +-comm {a} {b} =
          cancels-+-right
            (cancels-+-left
              (a + (a + b + b)   ≡⟨ += idp +-assoc ♦ ! +-assoc ⟩
               (a + a) + (b + b) ≡⟨ += 2*-spec 2*-spec ⟩
               2# * a  + 2# * b  ≡⟨ ! *-+-distrˡ ⟩
               2# * (a + b)      ≡⟨ ! 2*-spec ⟩
               (a + b) + (a + b) ≡⟨ +-assoc ♦ += idp (! +-assoc) ⟩
               a + (b + a + b)   ∎))

      0−-+-distr : ∀ {x y} → 0−(x + y) ≡ 0− x − y
      0−-+-distr = 0−= +-comm ♦ 0−-+-distr′

  module From-Field-Ops (fld-ops : Field-Ops A) where
    open Field-Ops fld-ops

module Explicits where
  open Algebra.FunctionProperties.NP Π  {a}{a}{A} _≡_ public

  -- REPEATED from above but with explicit arguments
  module FromOp₂
           (_∙_ : Op₂ A){x x' y y'}(p : x ≡ x')(q : y ≡ y')
         where
    op= : x ∙ y ≡ x' ∙ y'
    op= = ap (_∙_ x) q ♦ ap (λ z → z ∙ y') p

  module FromComm
           (_∙_   : Op₂ A)
           (comm  : Commutative _∙_)
           (x y x' y' : A)
           (e : (y ∙ x) ≡ (y' ∙ x'))
         where
    open FromOp₂ _∙_

    comm= : x ∙ y ≡ x' ∙ y'
    comm= = comm _ _ ♦ e ♦ comm _ _

  module FromAssoc
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)

         where
    open FromOp₂ _∙_

    assocs : Associative _∙_ × Associative (flip _∙_)
    assocs = assoc , (λ _ _ _ → ! assoc _ _ _)

    module _ {c x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
      assoc= = ! assoc _ _ _ ♦ op= e idp ♦ assoc _ _ _

      !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
      !assoc= = assoc _ _ _ ♦ op= idp e ♦ ! assoc _ _ _

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
      inner= = assoc= (!assoc= e)

  module FromAssocComm
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)
           (comm  : Commutative _∙_)
         where
    open FromOp₂   _∙_       renaming (op= to ∙=)
    open FromAssoc _∙_ assoc public
    open FromComm  _∙_ comm  public

    module _ x y z where
      assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
      assoc-comm = assoc= (comm _ _)

      !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
      !assoc-comm = !assoc= (comm _ _)

    interchange : Interchange _∙_ _∙_
    interchange _ _ _ _ = assoc= (!assoc= (comm _ _))

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
      outer= = ∙= (comm _ _) (comm _ _) ♦ assoc= (!assoc= e) ♦ ∙= (comm _ _) (comm _ _)

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj _ _ fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Function.NP using (flip; Π; Πⁱ; Op₁; Op₂; nest)
open import Data.Nat.Base using (ℕ; _≤_; _∸_; z≤n; s≤s)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
import Data.Nat.Properties.Simple as ℕ°
open import Data.Integer.NP
  using    (ℤ; +_; -[1+_]; _⊖_; -_)
  renaming ( _+_ to _+ℤ_; _-_ to _−ℤ_
           ; suc to sucℤ; pred to predℤ
           )
open import Data.Product.NP using (_×_; _,_; fst; snd)
open import Relation.Nullary using (¬_)
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
import Algebra.FunctionProperties.NP
open import Algebra.Raw
open ≡-Reasoning
open import HoTT using (module Equivalences)
open Equivalences

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

module Implicits where
  open Algebra.FunctionProperties.NP Πⁱ {a}{a}{A} _≡_ public

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict

  module From-Magma (magma : Magma A) where

    open Magma magma

    module From-Comm
             (comm  : Commutative _∙_)
             {x y x' y' : A}
             (e : (y ∙ x) ≡ (y' ∙ x'))
           where
      comm= : x ∙ y ≡ x' ∙ y'
      comm= = comm ♦ e ♦ comm

    module From-Assoc
             (assoc : Associative _∙_)
           where

      assocs : Associative _∙_ × Associative (flip _∙_)
      assocs = assoc , ! assoc

      module _ {c x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
        assoc= = ! assoc ♦ ∙= e idp ♦ assoc

        !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
        !assoc= = assoc ♦ ∙= idp e ♦ ! assoc

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
        inner= = assoc= (!assoc= e)

    module From-Assoc-Comm
             (assoc : Associative _∙_)
             (comm  : Commutative _∙_)
           where
      open From-Assoc assoc public
      open From-Comm  comm  public

      module _ {x y z} where
        assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
        assoc-comm = assoc= comm

        !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
        !assoc-comm = !assoc= comm

      interchange : Interchange _∙_ _∙_
      interchange = assoc= (!assoc= comm)

      on-sides : ∀ {x x' y y' z z' t t'}
                 → x ∙ z ≡ x' ∙ z'
                 → y ∙ t ≡ y' ∙ t'
                 → (x ∙ y) ∙ (z ∙ t) ≡ (x' ∙ y') ∙ (z' ∙ t')
      on-sides p q = interchange ♦ ∙= p q ♦ interchange

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
        outer= = ∙= comm comm ♦ assoc= (!assoc= e) ♦ ∙= comm comm

  module From-Op₂ (op : Op₂ A) = From-Magma ⟨ op ⟩

  module From-Monoid-Ops (mon-ops : Monoid-Ops A) where
    open Monoid-Ops mon-ops
    open From-Op₂ _∙_ public

    module From-LeftIdentity (idl : LeftIdentity ε _∙_) where
      module _ {x y} where
        is-ε-left : x ≡ ε → x ∙ y ≡ y
        is-ε-left e = ap (λ z → z ∙ _) e ♦ idl

      ε^⁺ : ∀ n → ε ^⁺ n ≡ ε
      ε^⁺ 0      = idp
      ε^⁺ (1+ n) = idl ♦ ε^⁺ n

    module From-RightIdentity (idr : RightIdentity ε _∙_) where
      module _ {x y} where
        is-ε-right : y ≡ ε → x ∙ y ≡ x
        is-ε-right e = ap (λ z → _ ∙ z) e ♦ idr

      module _ {b} where
        ^⁺-^¹⁺ : ∀ n → b ^⁺ (1+ n) ≡ b ^¹⁺ n
        ^⁺-^¹⁺ 0 = idr
        ^⁺-^¹⁺ (1+ n) = ∙= idp (^⁺-^¹⁺ n)

        ^⁺0-ε : b ^⁺ 0 ≡ ε
        ^⁺0-ε = idp

        ^⁺1-id : b ^⁺ 1 ≡ b
        ^⁺1-id = idr

        ^⁺2-∙ : b ^⁺ 2 ≡ b ∙ b
        ^⁺2-∙ = ^⁺-^¹⁺ 1

        ^⁺3-∙ : b ^⁺ 3 ≡ b ∙ (b ∙ b)
        ^⁺3-∙ = ^⁺-^¹⁺ 2

        ^⁺4-∙ : b ^⁺ 4 ≡ b ∙ (b ∙ (b ∙ b))
        ^⁺4-∙ = ^⁺-^¹⁺ 3

    module From-Identities (identities : Identity ε _∙_) where
      comm-ε : ∀ {x} → x ∙ ε ≡ ε ∙ x
      comm-ε = snd identities ♦ ! fst identities

      open From-LeftIdentity  (fst identities) public
      open From-RightIdentity (snd identities) public

    module From-Assoc-RightIdentity
             (assoc : Associative _∙_)
             (idr   : RightIdentity ε _∙_)
             where
      open From-RightIdentity idr

      module _ {c x y}(e : x ∙ y ≡ ε) where
        elim-assoc= : (c ∙ x) ∙ y ≡ c
        elim-assoc= = assoc ♦ ∙= idp e ♦ idr

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-inner= = ! assoc ♦ ∙= (elim-assoc= e) idp

    module From-Assoc-LeftIdentity
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             where
      open From-LeftIdentity idl

      -- Together with ^⁺0-ε, ^⁺-+ shows that (b ^⁺_) is a
      -- monoid homomorphism from (ℕ,+,0) to (M,∙,ε)
      -- therefore also a group homomorphism
      ^⁺-+ : ∀ m {n b} → b ^⁺ (m +ℕ n) ≡ b ^⁺ m ∙ b ^⁺ n
      ^⁺-+ 0      = ! idl
      ^⁺-+ (1+ m) = ap (_∙_ _) (^⁺-+ m) ♦ ! assoc

      -- Derived from ^⁺-+ in Algebra.Group
      ^⁺-* : ∀ m {n b} → b ^⁺(m *ℕ n) ≡ (b ^⁺ n)^⁺ m
      ^⁺-* 0 = idp
      ^⁺-* (1+ m) {n} {b}
        = b ^⁺ (n +ℕ m *ℕ n)     ≡⟨ ^⁺-+ n ⟩
          b ^⁺ n ∙ b ^⁺(m *ℕ n)  ≡⟨ ap (_∙_ (b ^⁺ n)) (^⁺-* m) ⟩
          b ^⁺ n ∙ (b ^⁺ n)^⁺ m  ∎

      module _ {c x y} (e : x ∙ y ≡ ε) where
        elim-!assoc= : x ∙ (y ∙ c) ≡ c
        elim-!assoc= = ! assoc ♦ ∙= e idp ♦ idl

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-!inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-!inner= = assoc ♦ ap (_∙_ c) (elim-!assoc= e)

  module From-Group-Ops (grp-ops : Group-Ops A) where
    open Group-Ops grp-ops
    open From-Monoid-Ops mon-ops public

    module From-Assoc-LeftIdentity-LeftInverse
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             (inverseˡ : LeftInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-LeftIdentity idl
      open From-Assoc-LeftIdentity assoc idl

      ⁻¹-inverseʳ : RightInverse ε _⁻¹ _∙_
      ⁻¹-inverseʳ {x}
         = x ∙ x ⁻¹                      ≡⟨ ! idl ⟩
           ε ∙ (x ∙ x ⁻¹)                ≡⟨ ∙= (! inverseˡ) idp ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹) ∙ (x ∙ x ⁻¹) ≡⟨ elim-!inner= inverseˡ ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹)              ≡⟨ inverseˡ ⟩
           ε                             ∎

      cancels-∙-left : LeftCancel _∙_
      cancels-∙-left {c} {x} {y} e
        = x              ≡⟨ ! idl ⟩
          ε ∙ x          ≡⟨ ∙= (! inverseˡ) idp ⟩
          c ⁻¹ ∙ c ∙ x   ≡⟨ !assoc= e ⟩
          c ⁻¹ ∙ c ∙ y   ≡⟨ ∙= inverseˡ idp ⟩
          ε ∙ y          ≡⟨ idl ⟩
          y              ∎

      module _ {x y} where
        unique-ε-right : x ∙ y ≡ x → y ≡ ε
        unique-ε-right eq
          = y               ≡⟨ ! is-ε-left inverseˡ ⟩
            x ⁻¹ ∙  x ∙ y   ≡⟨ assoc ⟩
            x ⁻¹ ∙ (x ∙ y)  ≡⟨ ∙= idp eq ⟩
            x ⁻¹ ∙ x        ≡⟨ inverseˡ ⟩
            ε               ∎

      ε^⁻ : ∀ n → ε ^⁻ n ≡ ε
      ε^⁻ n = ⁻¹= (ε^⁺ n) ♦ unique-ε-right ⁻¹-inverseʳ

      ε^ : ∀ i → ε ^ i ≡ ε
      ε^ -[1+ n ] = ε^⁻(1+ n)
      ε^ (+ n)    = ε^⁺ n

      module _ {x y} where
        -- _⁻¹ is a group homomorphism, see Algebra.Group._ᵒᵖ
        ⁻¹-hom′ : (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
        ⁻¹-hom′ = cancels-∙-left {x ∙ y}
           ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ ⁻¹-inverseʳ ⟩
            ε                       ≡⟨ ! ⁻¹-inverseʳ ⟩
            x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! idl) ⟩
            x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! ⁻¹-inverseʳ) idp) ⟩
            x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
            x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
            (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

        ⁻¹-∙-distr′ : (x ∙ y)⁻¹ ≡ y ⁻¹ / x
        ⁻¹-∙-distr′ = ⁻¹-hom′

      ⁻¹-hom′= : ∀ {x y z t} → x ∙ y ≡ z ∙ t → y ⁻¹ ∙ x ⁻¹ ≡ t ⁻¹ ∙ z ⁻¹
      ⁻¹-hom′= e = ! ⁻¹-hom′ ♦ ap _⁻¹ e ♦ ⁻¹-hom′

      elim-∙-left-⁻¹∙ : ∀ {c x y} → (c ∙ x)⁻¹ ∙ (c ∙ y) ≡ x ⁻¹ ∙ y
      elim-∙-left-⁻¹∙ {c} {x} {y}
        = (c ∙ x)⁻¹   ∙ (c ∙ y)  ≡⟨ ∙= ⁻¹-hom′ idp ⟩
          x ⁻¹ ∙ c ⁻¹ ∙ (c ∙ y)  ≡⟨ elim-!inner= inverseˡ ⟩
          x ⁻¹ ∙ y               ∎

      elim-∙-right-/ : ∀ {c x y} → (x ∙ c) / (y ∙ c) ≡ x / y
      elim-∙-right-/ {c} {x} {y}
        = x ∙ c ∙ (y ∙ c)⁻¹  ≡⟨ ap (_∙_ _) ⁻¹-hom′  ⟩
          x ∙ c ∙ (c ⁻¹ / y) ≡⟨ elim-!inner= ⁻¹-inverseʳ ⟩
          x / y              ∎

    module From-Assoc-RightIdentity-RightInverse
             (assoc : Associative _∙_)
             (idr : RightIdentity ε _∙_)
             (inverseʳ : RightInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-Assoc-RightIdentity assoc idr

      cancels-∙-right : RightCancel _∙_
      cancels-∙-right {c} {x} {y} e
        = x              ≡⟨ ! idr ⟩
          x ∙ ε          ≡⟨ ∙= idp (! inverseʳ) ⟩
          x ∙ (c ∙ c ⁻¹) ≡⟨ assoc= e ⟩
          y ∙ (c ∙ c ⁻¹) ≡⟨ ∙= idp inverseʳ ⟩
          y ∙ ε          ≡⟨ idr ⟩
          y              ∎

      inverseˡ : LeftInverse ε _⁻¹ _∙_
      inverseˡ {x}
        = x ⁻¹ ∙ x                      ≡⟨ ! idr ⟩
          (x ⁻¹ ∙ x) ∙ ε                ≡⟨ ∙= idp (! inverseʳ) ⟩
          (x ⁻¹ ∙ x) ∙ (x ⁻¹ ∙ x ⁻¹ ⁻¹) ≡⟨ elim-inner= inverseʳ ⟩
          (x ⁻¹ ∙ x ⁻¹ ⁻¹)              ≡⟨ inverseʳ ⟩
          ε                             ∎

      ⁻¹-involutive : Involutive _⁻¹
      ⁻¹-involutive {x}
        = cancels-∙-right
          (x ⁻¹ ⁻¹ ∙ x ⁻¹ ≡⟨ inverseˡ ⟩
           ε              ≡⟨ ! inverseʳ ⟩
           x ∙ x ⁻¹       ∎)

      module _ {x y} where
        /-∙ : (x / y) ∙ y ≡ x
        /-∙ = elim-assoc= inverseˡ

        ∙-/ : (x ∙ y) / y ≡ x
        ∙-/ = elim-assoc= inverseʳ

      module _ {x y} where
        unique-ε-left : x ∙ y ≡ y → x ≡ ε
        unique-ε-left eq
          = x            ≡⟨ ! ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            y / y        ≡⟨ inverseʳ ⟩
            ε            ∎

        x/y≡ε→x≡y : x / y ≡ ε → x ≡ y
        x/y≡ε→x≡y x/y≡ε = cancels-∙-right (x/y≡ε ♦ ! inverseʳ)

        x/y≢ε : x ≢ y → x / y ≢ ε
        x/y≢ε x≢y x/y≡ε = x≢y (x/y≡ε→x≡y x/y≡ε)

      ε⁻¹≡ε : ε ⁻¹ ≡ ε
      ε⁻¹≡ε = unique-ε-left inverseˡ

    module From-Assoc-Identities-RightInverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv-r : RightInverse ε _⁻¹ _∙_)
             where
      private
        idl = fst identities
        idr = snd identities

      inverseʳ : RightInverse ε _⁻¹ _∙_
      inverseʳ = inv-r

      open From-Assoc assoc
      open From-Identities identities using (comm-ε)
      open From-LeftIdentity        idl
      open From-RightIdentity       idr
      open From-Assoc-LeftIdentity  assoc idl
      open From-Assoc-RightIdentity assoc idr
      open From-Assoc-RightIdentity-RightInverse assoc idr inverseʳ public
      open From-Assoc-LeftIdentity-LeftInverse assoc idl inverseˡ public
        hiding (⁻¹-inverseʳ)

      module _ {x y} where
        ∙-/′ : y ∙ (x /′ y) ≡ x
        ∙-/′ = elim-!assoc= inverseʳ

        /′-∙ : (y ∙ x) /′ y ≡ x
        /′-∙ = elim-!assoc= inverseˡ

        /-/′ : x / (x /′ y) ≡ y
        /-/′ =
          x ∙ (y ⁻¹ ∙ x) ⁻¹    ≡⟨ ∙= idp ⁻¹-hom′ ⟩
          x ∙ (x ⁻¹ ∙ y ⁻¹ ⁻¹) ≡⟨ elim-!assoc= inverseʳ ⟩
          y ⁻¹ ⁻¹              ≡⟨ ⁻¹-involutive ⟩
          y                    ∎

        /′-/ : x /′ (x / y) ≡ y
        /′-/ =
          (x / y)⁻¹ ∙ x        ≡⟨ ∙= ⁻¹-hom′ idp ⟩
          y ⁻¹ ⁻¹ ∙ x ⁻¹ ∙ x   ≡⟨ elim-assoc= inverseˡ ⟩
          y ⁻¹ ⁻¹              ≡⟨ ⁻¹-involutive ⟩
          y                    ∎

      ∙-is-equiv : ∀ {k} → Is-equiv (_∙_ k)
      ∙-is-equiv {k} = is-equiv (_∙_ (k ⁻¹))
                                (λ _ → ! assoc ♦ ∙= inverseʳ idp ♦ idl)
                                (λ _ → ! assoc ♦ ∙= inverseˡ idp ♦ idl)

      flip-∙-is-equiv : ∀ {k} → Is-equiv (flip _∙_ k)
      flip-∙-is-equiv {k} = is-equiv (flip _∙_ (k ⁻¹))
                                     (λ _ → assoc ♦ ∙= idp inverseˡ ♦ idr)
                                     (λ _ → assoc ♦ ∙= idp inverseʳ ♦ idr)

      module _ {x y} where
        unique-⁻¹ : x ∙ y ≡ ε → x ≡ y ⁻¹
        unique-⁻¹ eq
          = x            ≡⟨ ! ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            ε / y        ≡⟨ idl ⟩
            y ⁻¹         ∎

      ⁻¹-inj : ∀ {x y} → x ⁻¹ ≡ y ⁻¹ → x ≡ y
      ⁻¹-inj {x} {y} e
         = ! (y              ≡⟨ ! idr ⟩
              y ∙ ε          ≡⟨ ∙= idp (ε        ≡⟨ ! inverseˡ  ⟩
                                        x ⁻¹ ∙ x ≡⟨ ∙= e idp ⟩
                                        y ⁻¹ ∙ x ∎) ⟩
              y ∙ (y ⁻¹ ∙ x) ≡⟨ ∙-/′ ⟩
              x ∎)

      module _ {b} where
        ^⁺-1+ : ∀ n → b ^⁺(1+ n) ≡ b ^⁺ n ∙ b
        ^⁺-1+ 0 = comm-ε
        ^⁺-1+ (1+ n) = ap (_∙_ b) (^⁺-1+ n) ♦ ! assoc

        ^⁺-∸ : ∀ {m n} → n ≤ m → b ^⁺(m ∸ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁺-∸ z≤n = ! is-ε-right ε⁻¹≡ε
        ^⁺-∸ (s≤s {n} {m} n≤m) =
           b ^⁺(m ∸ n)                     ≡⟨ ^⁺-∸ n≤m ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖ : ∀ m n → b ^(m ⊖ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^-⊖ m      0      = ! is-ε-right ε⁻¹≡ε
        ^-⊖ 0      (1+ n) = ! idl
        ^-⊖ (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖ m n ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖' : ∀ m n → b ^(m ⊖ n) ≡ b ^⁻ n ∙ b ^⁺ m
        ^-⊖' m      0      = ! is-ε-left ε⁻¹≡ε
        ^-⊖' 0      (1+ n) = ! idr
        ^-⊖' (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖' m n ⟩
           (b ^⁻ n ∙ b ^⁺ m)               ≡⟨ ! elim-inner= inverseˡ ⟩
           (b ^⁻ n ∙ b ⁻¹) ∙ (b ∙ b ^⁺ m)  ≡⟨ ∙= (! ⁻¹-hom′) idp ⟩
           (b ∙ b ^⁺ n)⁻¹ ∙ (b ∙ b ^⁺ m)   ∎

        ^⁺-comm : ∀ m n → b ^⁺ m ∙ b ^⁺ n ≡ b ^⁺ n ∙ b ^⁺ m
        ^⁺-comm 0      n = ! comm-ε
        ^⁺-comm (1+ m) n =
          b ∙ bᵐ ∙ bⁿ   ≡⟨ !assoc= (^⁺-comm m n) ⟩
          b ∙ bⁿ ∙ bᵐ   ≡⟨ ∙= (^⁺-1+ n) idp ⟩
          bⁿ ∙ b ∙ bᵐ   ≡⟨ assoc ⟩
          bⁿ ∙ (b ∙ bᵐ) ∎
          where
            bⁿ = b ^⁺ n
            bᵐ = b ^⁺ m

        ^⁺-^⁻-comm : ∀ m n → b ^⁺ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁺ m
        ^⁺-^⁻-comm m n = ! ^-⊖ m n ♦ ^-⊖' m n

        ^⁻-^⁺-comm : ∀ m n → b ^⁻ n ∙ b ^⁺ m ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁻-^⁺-comm m n = ! ^-⊖' m n ♦ ^-⊖ m n

        ^⁻-comm : ∀ m n → b ^⁻ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁻ m
        ^⁻-comm m n = ⁻¹-hom′= (^⁺-comm n m)

        ^⁻-1+ : ∀ n → b ^⁻(1+ n) ≡ b ⁻¹ ∙ b ^⁻ n
        ^⁻-1+ n = ap _⁻¹ (^⁺-1+ n) ♦ ⁻¹-hom′

        ^⁻′-spec : ∀ n → b ^⁻′ n ≡ b ^⁻ n
        ^⁻′-spec 0 = ! ε⁻¹≡ε
        ^⁻′-spec (1+ n) = ap (_∙_ (b ⁻¹)) (^⁻′-spec n)
                        ♦ ! ⁻¹-hom′
                        ♦ ap _⁻¹ (! ^⁺-1+ n)

        ^⁻′1-id : b ^⁻′ 1 ≡ b ⁻¹
        ^⁻′1-id = idr

        ^⁻1-id : b ^⁻ 1 ≡ b ⁻¹
        ^⁻1-id = ! ^⁻′-spec 1 ♦ ^⁻′1-id

        ^⁻′2-∙ : b ^⁻′ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻′2-∙ = ap (_∙_ _) ^⁻′1-id

        ^⁻2-∙ : b ^⁻ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻2-∙ = ! ^⁻′-spec 2 ♦ ^⁻′2-∙

        -- ^-+ is a group homomorphism defined in Algebra.Group
        -- Some properties can be derived from it.
        ^-+ : ∀ i j → b ^(i +ℤ j) ≡ b ^ i ∙ b ^ j
        ^-+ -[1+ m ] -[1+ n ] = ap _⁻¹
                                 (ap (λ z → b ^⁺(1+ z)) (ℕ°.+-comm (1+ m) n)
                              ♦ ^⁺-+ (1+ n) {1+ m}) ♦ ⁻¹-hom′
        ^-+ -[1+ m ]   (+ n)  = ^-⊖' n (1+ m)
        ^-+   (+ m)  -[1+ n ] = ^-⊖ m (1+ n)
        ^-+   (+ m)    (+ n)  = ^⁺-+ m

        -- GroupHomomorphism.f-pres-inv
        ^-- : ∀ i → b ^(- i) ≡ (b ^ i)⁻¹
        ^-- -[1+ n ] = ! ⁻¹-involutive
        ^-- (+ 0)    = ! ε⁻¹≡ε
        ^-- (+ 1+ n) = idp

        -- GroupHomomorphism.f-−-/
        ^-− : ∀ i j → b ^(i −ℤ j) ≡ b ^ i / b ^ j
        ^-− i j = ^-+ i (- j) ♦ ∙= idp (^-- j)

        ^-suc : ∀ i → b ^(sucℤ i) ≡ b ∙ b ^ i
        ^-suc i = ^-+ (+ 1) i ♦ ∙= idr idp

        ^-pred : ∀ i → b ^(predℤ i) ≡ b ⁻¹ ∙ b ^ i
        ^-pred i = ^-+ (- + 1) i ♦ ap (λ z → z ⁻¹ ∙ b ^ i) idr

        ^-comm : ∀ i j → b ^ i ∙ b ^ j ≡ b ^ j ∙ b ^ i
        ^-comm -[1+ m ] -[1+ n ] = ^⁻-comm (1+ m) (1+ n)
        ^-comm -[1+ m ]   (+ n)  = ! ^⁺-^⁻-comm n (1+ m)
        ^-comm   (+ m)  -[1+ n ] = ^⁺-^⁻-comm m (1+ n)
        ^-comm   (+ m)    (+ n)  = ^⁺-comm m n

      {-
      ^-* : ∀ i j → b ^(i *ℤ j) ≡ (b ^ j)^ i
      ^-* i j = {!!}
      -}

    module From-Assoc-Identities-Inverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv : Inverse ε _⁻¹ _∙_)
             where
      open From-Assoc-Identities-RightInverse assoc identities (snd inv) public

  module From-Ring-Ops (rng-ops : Ring-Ops A) where
    open Ring-Ops rng-ops

    module DistributesOverʳ
             (*-comm : Commutative _*_)
             (*-+-distrˡ : _*_ DistributesOverˡ _+_)
             where
      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = *-comm ♦ *-+-distrˡ ♦ += *-comm *-comm

    module DistributesOverˡ
             (*-comm : Commutative _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = *-comm ♦ *-+-distrʳ ♦ += *-comm *-comm

    module From-+Group-1*Identity-DistributesOverʳ
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     ; ε⁻¹≡ε to 0−0≡0
                     ; ⁻¹-hom′ to 0−-hom′
                     )

      -0≡0 : -0# ≡ 0#
      -0≡0 = 0−0≡0

      0*-zero : LeftZero 0# _*_
      0*-zero {x} = cancels-+-left
        (x + 0# * x      ≡⟨ += (! 1*-identity) idp ⟩
         1# * x + 0# * x ≡⟨ ! *-+-distrʳ ⟩
         (1# + 0#) * x   ≡⟨ *= +0-identity idp ⟩
         1# * x          ≡⟨ 1*-identity ⟩
         x               ≡⟨ ! +0-identity ⟩
         x + 0#          ∎)

      2*-spec : ∀ {n} → 2* n ≡ 2# * n
      2*-spec = ! += 1*-identity 1*-identity ♦ ! *-+-distrʳ

      0−-*-distr : ∀ {x y} → 0−(x * y) ≡ (0− x) * y
      0−-*-distr = cancels-+-right (0−-inverseˡ ♦ ! 0*-zero ♦ *= (! 0−-inverseˡ) idp ♦ *-+-distrʳ)

      -1*-neg : ∀ {x} → -1# * x ≡ 0− x
      -1*-neg = ! 0−-*-distr ♦ 0−= 1*-identity

      2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
      2*-*-distr = ! *-+-distrʳ

    module From-+Group-*Identity-DistributesOver
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*1-identity : RightIdentity 1# _*_)
             (*-+-distrs : _*_ DistributesOver _+_)
             where
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = fst *-+-distrs

      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = snd *-+-distrs

      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( ⁻¹-involutive to 0−-involutive
                     ; cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     )

      open From-+Group-1*Identity-DistributesOverʳ
             +-assoc 0+-identity +0-identity 0−-inverseʳ
             1*-identity *-+-distrʳ
             public

      *0-zero : RightZero 0# _*_
      *0-zero {x} = cancels-+-right
        (x * 0# + x      ≡⟨ += idp (! *1-identity) ⟩
         x * 0# + x * 1# ≡⟨ ! *-+-distrˡ ⟩
         x * (0# + 1#)   ≡⟨ *= idp 0+-identity ⟩
         x * 1#          ≡⟨ *1-identity ⟩
         x               ≡⟨ ! 0+-identity ⟩
         0# + x          ∎)

      0−-*-distrʳ : ∀ {x y} → 0−(x * y) ≡ x * (0− y)
      0−-*-distrʳ = cancels-+-right (0−-inverseˡ ♦ (! *0-zero ♦ *= idp (! 0−-inverseˡ)) ♦ *-+-distrˡ)

      *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
      *-−-distr = *-+-distrˡ ♦ += idp (! 0−-*-distrʳ)

      ²-0−-distr : ∀ {x} → (0− x)² ≡ x ²
      ²-0−-distr = ! 0−-*-distr ♦ 0−=(! 0−-*-distrʳ) ♦ 0−-involutive

      +-comm : Commutative _+_
      +-comm {a} {b} =
          cancels-+-right
            (cancels-+-left
              (a + (a + b + b)   ≡⟨ += idp +-assoc ♦ ! +-assoc ⟩
               (a + a) + (b + b) ≡⟨ += 2*-spec 2*-spec ⟩
               2# * a  + 2# * b  ≡⟨ ! *-+-distrˡ ⟩
               2# * (a + b)      ≡⟨ ! 2*-spec ⟩
               (a + b) + (a + b) ≡⟨ +-assoc ♦ += idp (! +-assoc) ⟩
               a + (b + a + b)   ∎))

      0−-+-distr : ∀ {x y} → 0−(x + y) ≡ 0− x − y
      0−-+-distr = 0−= +-comm ♦ 0−-+-distr′

  module From-Field-Ops (fld-ops : Field-Ops A) where
    open Field-Ops fld-ops

module Explicits where
  open Algebra.FunctionProperties.NP Π  {a}{a}{A} _≡_ public

  -- REPEATED from above but with explicit arguments
  module FromOp₂
           (_∙_ : Op₂ A){x x' y y'}(p : x ≡ x')(q : y ≡ y')
         where
    op= : x ∙ y ≡ x' ∙ y'
    op= = ap (_∙_ x) q ♦ ap (λ z → z ∙ y') p

  module FromComm
           (_∙_   : Op₂ A)
           (comm  : Commutative _∙_)
           (x y x' y' : A)
           (e : (y ∙ x) ≡ (y' ∙ x'))
         where
    open FromOp₂ _∙_

    comm= : x ∙ y ≡ x' ∙ y'
    comm= = comm _ _ ♦ e ♦ comm _ _

  module FromAssoc
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)

         where
    open FromOp₂ _∙_

    assocs : Associative _∙_ × Associative (flip _∙_)
    assocs = assoc , (λ _ _ _ → ! assoc _ _ _)

    module _ {c x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
      assoc= = ! assoc _ _ _ ♦ op= e idp ♦ assoc _ _ _

      !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
      !assoc= = assoc _ _ _ ♦ op= idp e ♦ ! assoc _ _ _

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
      inner= = assoc= (!assoc= e)

  module FromAssocComm
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)
           (comm  : Commutative _∙_)
         where
    open FromOp₂   _∙_       renaming (op= to ∙=)
    open FromAssoc _∙_ assoc public
    open FromComm  _∙_ comm  public

    module _ x y z where
      assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
      assoc-comm = assoc= (comm _ _)

      !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
      !assoc-comm = !assoc= (comm _ _)

    interchange : Interchange _∙_ _∙_
    interchange _ _ _ _ = assoc= (!assoc= (comm _ _))

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
      outer= = ∙= (comm _ _) (comm _ _) ♦ assoc= (!assoc= e) ♦ ∙= (comm _ _) (comm _ _)

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj _ _ fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict
-- -}
-- -}
-- -}
-- -}


README: -vcomp,-composable

README: -vcomp,-composable

module README where

open import composition-sem-sec-reduction

open import one-time-semantic-security

open import flat-funs
open import forkable

open import program-distance
open import diff

open import flipbased
open import flipbased-implem
open import flipbased-tree

open import bit-guessing-game

open import circuit

module README where

open import composition-sem-sec-reduction

open import one-time-semantic-security

open import flat-funs
open import composable
open import vcomp
open import forkable

open import program-distance
open import diff

open import flipbased
open import flipbased-implem
open import flipbased-tree

open import bit-guessing-game

open import circuit


Inline trivial let bindings.

Inline trivial let bindings.

These bindings used to be more complicated, but with the recent changes,
we can just inline them.

Old-commit-hash: 1ab984cf29bc5dd53e7f1d6a9b36bc69fd00c2c5

import Parametric.Syntax.Type as Type
import Base.Syntax.Context as Context

module Parametric.Change.Term
    {Base : Set}
    (Constant : Context.Context (Type.Type Base) → Type.Type Base → Set {- of constants -})
    (Δbase : Base → Base)
  where

-- Terms that operate on changes

open Type Base
open Context Type

open import Parametric.Change.Type Δbase
open import Parametric.Syntax.Term Constant

open import Data.Product

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply :
  (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
  (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff :
  (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
  (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply :
  (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
  (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

import Parametric.Syntax.Type as Type
import Base.Syntax.Context as Context

module Parametric.Change.Term
    {Base : Set}
    (Constant : Context.Context (Type.Type Base) → Type.Type Base → Set {- of constants -})
    (Δbase : Base → Base)
  where

-- Terms that operate on changes

open Type Base
open Context Type

open import Parametric.Change.Type Δbase
open import Parametric.Syntax.Term Constant

open import Data.Product

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply :
  let
    Δtype = ΔType
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff :
  let
    Δtype = ΔType
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply :
  let
    Δtype = ΔType
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})


Added test for the conversion rules of subtraction.

------------------------------------------------------------------------------
-- Subtraction using the rec combinator
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOT.LTC-PCF.Data.Nat.SubtractionRecCombinator where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Base.Properties
open import LTC-PCF.Data.Nat.Properties hiding ( ∸-x0 ; ∸-0x ; ∸-0S ; ∸-SS )
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.Equations
open import LTC-PCF.Data.Nat.Type

-- We add 3 to the fixities of the standard library.
infixl 9 _∸_

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

-- Subtraction
_∸_ : D → D → D
m ∸ n = rec n m (lam (λ _ → lam pred₁))

-- Conversion rules (from the Agda standard library)

∸-x0 : ∀ n → n ∸ zero ≡ n
∸-x0 n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S nzero =
  rec (succ₁ zero) zero (lam (λ _ → lam pred₁))
    ≡⟨ rec-S zero zero (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · zero · (zero ∸ zero)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) zero) ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ predCong (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) zero (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) zero (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ predCong (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0x : ∀ {n} → N n → zero ∸ n ≡ zero
∸-0x nzero      = ∸-x0 zero
∸-0x (nsucc Nn) = ∸-0S Nn

∸-SS : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
∸-SS {m} _ nzero =
  rec (succ₁ zero) (succ₁ m) (lam (λ _ → lam pred₁))
    ≡⟨ rec-S zero (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · zero · (succ₁ m ∸ zero)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) zero) ⟩
  lam pred₁ · (succ₁ m ∸ zero)
    ≡⟨ beta pred₁ (succ₁ m ∸ zero) ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ predCong (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym (∸-x0 m) ⟩
  m ∸ zero ∎

∸-SS nzero (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ zero) (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) (succ₁ zero) (lam (λ _ → lam pred₁))  ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (succ₁ zero ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ zero ∸ succ₁ n) ⟩
  pred₁ (succ₁ zero ∸ succ₁ n)
    ≡⟨ predCong (∸-SS nzero Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ predCong (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym (∸-0S Nn) ⟩
  zero ∸ succ₁ n ∎

∸-SS (nsucc {m} Nm) (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ (succ₁ m)) (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) (succ₁ (succ₁ m)) (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ (succ₁ m) ∸ succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ predCong (∸-SS (nsucc Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym (beta pred₁ (succ₁ m ∸ n)) ⟩
  lam pred₁ · (succ₁ m ∸ n)
    ≡⟨ ·-leftCong (sym (beta (λ _ → lam pred₁) n)) ⟩
  (lam (λ _ → lam pred₁)) · n · (succ₁ m ∸ n)
    ≡⟨ sym (rec-S n (succ₁ m) (lam (λ _ → lam pred₁))) ⟩
  rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
    ≡⟨ refl ⟩
  succ₁ m ∸ succ₁ n ∎

------------------------------------------------------------------------------
-- Conversion rules from the Agda standard library without totality
-- hypotheses.

-- We could not prove this property.
-- ∸-0S₁ : ∀ n → zero ∸ succ₁ n ≡ zero
-- ∸-0S₁ n =
--   rec (succ₁ n) zero (lam (λ _ → lam pred₁))
--     ≡⟨ rec-S n zero (lam (λ _ → lam pred₁)) ⟩
--   lam (λ _ → lam pred₁) · n · (zero ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (zero ∸ n)
--     ≡⟨ beta pred₁ (zero ∸ n) ⟩
--   pred₁ (zero ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   zero ∎

-- We could not prove this property.
-- ∸-SS₁ : ∀ m n → succ₁ m ∸ succ₁ n ≡ m ∸ n
-- ∸-SS₁ m n =
--   rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
--   ≡⟨ rec-S n (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (succ₁ m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (succ₁ m ∸ n)
--     ≡⟨ beta pred₁ (succ₁ m ∸ n) ⟩
--   pred₁ (succ₁ m ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   m ∸ n ∎

------------------------------------------------------------------------------
-- Coq conversion rules

-- Fixpoint minus (n m:nat) : nat :=
--   match n, m with
--   | O, _ => n
--   | S k, O => S k
--   | S k, S l => k - l
--   end

∸-x0-coq : ∀ n → n ∸ zero ≡ n
∸-x0-coq n = rec zero n _ ≡⟨ rec-0 n ⟩
             n            ∎

∸-S0-coq : ∀ n → succ₁ n ∸ zero ≡ succ₁ n
∸-S0-coq n =
  rec zero (succ₁ n) (lam (λ _ → lam pred₁))
    ≡⟨ rec-0 (succ₁ n) ⟩
  succ₁ n ∎

-- We could not prove this property.
-- ∸-SS-coq : ∀ m n → succ₁ m ∸ succ₁ n ≡ m ∸ n
-- ∸-SS-coq m n =
--   rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
--   ≡⟨ rec-S n (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (succ₁ m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (succ₁ m ∸ n)
--     ≡⟨ beta pred₁ (succ₁ m ∸ n) ⟩
--   pred₁ (succ₁ m ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   m ∸ n ∎

------------------------------------------------------------------------------
-- Isabelle conversion rules (from Nat.thy)

-- primrec minus_nat where
--   diff_0 [code]: "m - 0 = (m :: nat)"
-- | diff_Suc: "m - Suc n = (case m - n of 0 => 0 | Suc k => k)"

∸-x0-isabelle : ∀ n → n ∸ zero ≡ n
∸-x0-isabelle n = rec zero n _ ≡⟨ rec-0 n ⟩
                  n            ∎

-- We could not prove this property.
-- ∸-xS-isabelle : ∀ m n → m ∸ succ₁ n ≡
--                         if (iszero₁ (m ∸ n)) then zero else pred₁ (m ∸ n)
-- ∸-xS-isabelle m n =
--   rec (succ₁ n) m (lam (λ _ → lam pred₁))
--     ≡⟨ rec-S n m (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (m ∸ n)
--     ≡⟨ beta pred₁ (m ∸ n) ⟩
--   pred₁ (m ∸ n)
--   ≡⟨ {!!} ⟩
--   if (iszero₁ (m ∸ n)) then zero else pred₁ (m ∸ n) ∎

------------------------------------------------------------------------------
-- Peter conversion rules

-- The analogous situation for subtraction is that  given

-- rec-0 : ∀ a {f} → rec zero a f ≡ a
-- rec-S : ∀ n a f → rec (succ₁ n) a f ≡ f · n · (rec n a f)

-- and

-- _∸_ : D → D → D
-- m ∸ n = rec n m (lam (λ _ → lam pred₁))

-- you get the equations obtained by the special case (instantiate a and
-- f according to the def of subtraction)! This has nothing to do a
-- priori with Agda's standard library.

∸-x0-peter : ∀ n → n ∸ zero ≡ n
∸-x0-peter n = rec zero n _ ≡⟨ rec-0 n ⟩
               n            ∎

∸-xS-peter : ∀ m n → m ∸ succ₁ n ≡ pred₁ (m ∸ n)
∸-xS-peter m n =
  rec (succ₁ n) m (lam (λ _ → lam pred₁))
    ≡⟨ rec-S n m (lam (λ _ → lam pred₁)) ⟩
  lam (λ x → lam pred₁) · n · (m ∸ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
  lam pred₁ · (m ∸ n)
    ≡⟨ beta pred₁ (m ∸ n) ⟩
  pred₁ (m ∸ n) ∎


Conat-coind and Conat-coind-wrong are not equivalents.

------------------------------------------------------------------------------
-- Co-inductive natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module GreatestFixedPoints.Conat where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Conat is a greatest fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The co-natural numbers are the greatest fixed-point of NatF.
postulate
  Conat : D → Set

  -- Conat is a post-fixed point of NatF, i.e.
  --
  -- Conat ≤ NatF Conat.
  Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  -- The higher-order version.
  Conat-unf-ho : ∀ {n} → Conat n → NatF Conat n

  -- Conat is the greatest post-fixed point of NatF, i.e
  --
  -- ∀ P. P ≤ NatF P ⇒ P ≤ Conat.
  Conat-coind : ∀ (A : D → Set) →
                (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
                ∀ {n} → A n → Conat n

  -- The higher-order version.
  Conat-coind-ho : ∀ (A : D → Set) →
                   (∀ {n} → A n → NatF A n) →
                   ∀ {n} → A n → Conat n

  Conat-coind-wrong : ∀ (A : D → Set) {n} →
                      -- A is post-fixed point of ConatF.
                      (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
                      -- Conat is greater than A.
                      A n → Conat n

------------------------------------------------------------------------------
-- Conat-unf and Conat-unf-ho are equivalents

Conat-unf' : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-unf' = Conat-unf-ho

Conat-unf-ho' : ∀ {n} → Conat n → NatF Conat n
Conat-unf-ho' = Conat-unf

------------------------------------------------------------------------------
-- Conat-coind and Conat-coind-ho are equivalents

Conat-coind' : ∀ (A : D → Set) →
               (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
               ∀ {n} → A n → Conat n
Conat-coind' = Conat-coind-ho

Conat-coind-ho' : ∀ (A : D → Set) →
                  (∀ {n} → A n → NatF A n) →
                  ∀ {n} → A n → Conat n
Conat-coind-ho' = Conat-coind

------------------------------------------------------------------------------
-- From Conat-coind/Conat-coind-wrong to Conat-coind-wrong/Conat-coind

Conat-coind'' : ∀ (A : D → Set) →
               (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
               ∀ {n} → A n → Conat n
Conat-coind'' A h An = Conat-coind-wrong A h An

-- 22 December 2013: We cannot prove Conat-coind-wrong'' using
-- Conat-coind.
Conat-coind-wrong'' : ∀ (A : D → Set) {n} →
                      (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
                      A n → Conat n
Conat-coind-wrong'' A h An = Conat-coind A {!!} An