------------------------------------------------------------------------------
-- Properties related with lists
------------------------------------------------------------------------------

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

module FOTC.Data.List.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Base.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.List
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Congruence properties

++-leftCong : ∀ {xs ys zs} → xs ≡ ys → xs ++ zs ≡ ys ++ zs
++-leftCong refl = refl

++-rightCong : ∀ {xs ys zs} → ys ≡ zs → xs ++ ys ≡ xs ++ zs
++-rightCong refl = refl

mapCong₂ : ∀ {f xs ys} → xs ≡ ys → map f xs ≡ map f ys
mapCong₂ refl = refl

revCong₁ : ∀ {xs ys zs} → xs ≡ ys → rev xs zs ≡ rev ys zs
revCong₁ refl = refl

revCong₂ : ∀ {xs ys zs} → ys ≡ zs → rev xs ys ≡ rev xs zs
revCong₂ refl = refl

reverseCong : ∀ {xs ys} → xs ≡ ys → reverse xs ≡ reverse ys
reverseCong refl = refl

reverse'Cong : ∀ {xs ys} → xs ≡ ys → reverse' xs ≡ reverse' ys
reverse'Cong refl = refl

lengthCong : ∀ {xs ys} → xs ≡ ys → length xs ≡ length ys
lengthCong refl = refl

------------------------------------------------------------------------------
-- Totality properties

lengthList-N : ∀ {xs} → List xs → N (length xs)
lengthList-N lnil               = subst N (sym length-[]) nzero
lengthList-N (lcons x {xs} Lxs) =
  subst N (sym (length-∷ x xs)) (nsucc (lengthList-N Lxs))

++-List : ∀ {xs ys} → List xs → List ys → List (xs ++ ys)
++-List {ys = ys} lnil               Lys = subst List (sym (++-[] ys)) Lys
++-List {ys = ys} (lcons x {xs} Lxs) Lys =
  subst List (sym (++-∷ x xs ys)) (lcons x (++-List Lxs Lys))

map-List : ∀ f {xs} → List xs → List (map f xs)
map-List f lnil               = subst List (sym (map-[] f)) lnil
map-List f (lcons x {xs} Lxs) =
  subst List (sym (map-∷ f x xs)) (lcons (f · x) (map-List f Lxs))

rev-List : ∀ {xs ys} → List xs → List ys → List (rev xs ys)
rev-List {ys = ys} lnil               Lys = subst List (sym (rev-[] ys)) Lys
rev-List {ys = ys} (lcons x {xs} Lxs) Lys =
  subst List (sym (rev-∷ x xs ys)) (rev-List Lxs (lcons x Lys))

reverse-List : ∀ {xs} → List xs → List (reverse xs)
reverse-List Lxs = rev-List Lxs lnil

reverse'-List : ∀ {xs} → List xs → List (reverse' xs)
reverse'-List lnil = subst List (sym reverse'-[]) lnil
reverse'-List (lcons x {xs} Lxs) =
  subst List (sym (reverse'-∷ x xs)) (++-List (reverse'-List Lxs) (lcons x lnil))

-- Length properties

lg-x<lg-x∷xs : ∀ x {xs} → List xs → length xs < length (x ∷ xs)
lg-x<lg-x∷xs x lnil =
  lt (length []) (length (x ∷ []))
    ≡⟨ subst₂ (λ t t' → lt (length []) (length (x ∷ [])) ≡ lt t t')
              length-[]
              (length-∷ x [])
              refl
    ⟩
  lt zero (succ₁ (length []))
    ≡⟨ lt-0S (length []) ⟩
  true ∎

lg-x<lg-x∷xs x (lcons y {xs} Lxs) =
  lt (length (y ∷ xs)) (length (x ∷ y ∷ xs))
    ≡⟨ subst₂ (λ t t' → lt (length (y ∷ xs)) (length (x ∷ y ∷ xs)) ≡ lt t t')
              (length-∷ y xs)
              (length-∷ x (y ∷ xs))
              refl
    ⟩
  lt (succ₁ (length xs)) (succ₁ (length (y ∷ xs)))
    ≡⟨ lt-SS (length xs) (length (y ∷ xs)) ⟩
  lt (length xs) (length (y ∷ xs))
    ≡⟨ lg-x<lg-x∷xs y Lxs ⟩
  true ∎

lg-xs<lg-[]→⊥ : ∀ {xs} → List xs → ¬ (length xs < length [])
lg-xs<lg-[]→⊥ lnil lg-[]<lg-[] = ⊥-elim (0<0→⊥ helper)
  where
  helper : zero < zero
  helper =
    lt zero zero
      ≡⟨ subst₂ (λ t t' → lt zero zero ≡ lt t t')
                (sym length-[])
                (sym length-[])
                refl
      ⟩
    lt (length []) (length [])
      ≡⟨ lg-[]<lg-[] ⟩
    true ∎

lg-xs<lg-[]→⊥ (lcons x {xs} Lxs) lg-x∷xs<lg-[] = ⊥-elim (S<0→⊥ helper)
  where
  helper : succ₁ (length xs) < zero
  helper =
    lt (succ₁ (length xs)) zero
      ≡⟨ subst₂ (λ t t' → lt (succ₁ (length xs)) zero ≡ lt t t')
                (sym (length-∷ x xs))
                (sym length-[])
                refl
      ⟩
    lt (length (x ∷ xs)) (length [])
      ≡⟨ lg-x∷xs<lg-[] ⟩
    true ∎

lg-xs≡∞→lg-x∷xs≡∞ : ∀ x xs → length xs ≡ ∞ → length (x ∷ xs) ≡ ∞
lg-xs≡∞→lg-x∷xs≡∞ x xs h =
  length (x ∷ xs)   ≡⟨ length-∷ x xs ⟩
  succ₁ (length xs) ≡⟨ succCong h ⟩
  succ₁ ∞           ≡⟨ sym ∞-eq ⟩
  ∞                 ∎

-- Append properties

++-leftIdentity : ∀ xs → [] ++ xs ≡ xs
++-leftIdentity = ++-[]

++-rightIdentity : ∀ {xs} → List xs → xs ++ [] ≡ xs
++-rightIdentity lnil               = ++-leftIdentity []
++-rightIdentity (lcons x {xs} Lxs) =
  (x ∷ xs) ++ [] ≡⟨ ++-∷ x xs [] ⟩
  x ∷ (xs ++ []) ≡⟨ ∷-rightCong (++-rightIdentity Lxs) ⟩
  x ∷ xs         ∎

++-assoc : ∀ {xs} → List xs → ∀ ys zs → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
++-assoc lnil ys zs =
  ([] ++ ys) ++ zs ≡⟨ ++-leftCong (++-leftIdentity ys) ⟩
  ys ++ zs         ≡⟨ sym (++-leftIdentity (ys ++ zs)) ⟩
  [] ++ ys ++ zs   ∎

++-assoc (lcons x {xs} Lxs) ys zs =
  ((x ∷ xs) ++ ys) ++ zs ≡⟨ ++-leftCong (++-∷ x xs ys) ⟩
  (x ∷ (xs ++ ys)) ++ zs ≡⟨ ++-∷ x (xs ++ ys) zs ⟩
  x ∷ ((xs ++ ys) ++ zs) ≡⟨ ∷-rightCong (++-assoc Lxs ys zs) ⟩
  x ∷ (xs ++ ys ++ zs)   ≡⟨ sym (++-∷ x xs (ys ++ zs)) ⟩
  (x ∷ xs) ++ ys ++ zs   ∎

-- Map properties

map-++ : ∀ f {xs} → List xs → ∀ ys → map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++ f lnil ys =
  map f ([] ++ ys)     ≡⟨ mapCong₂ (++-leftIdentity ys) ⟩
  map f ys             ≡⟨ sym (++-leftIdentity (map f ys)) ⟩
  [] ++ map f ys       ≡⟨ ++-leftCong (sym (map-[] f)) ⟩
  map f [] ++ map f ys ∎

map-++ f (lcons x {xs} Lxs) ys =
  map f ((x ∷ xs) ++ ys)         ≡⟨ mapCong₂ (++-∷ x xs ys) ⟩
  map f (x ∷ xs ++ ys)           ≡⟨ map-∷ f x (xs ++ ys) ⟩
  f · x ∷ map f (xs ++ ys)       ≡⟨ ∷-rightCong (map-++ f Lxs ys) ⟩
  f · x ∷ (map f xs ++ map f ys) ≡⟨ sym (++-∷ (f · x) (map f xs) (map f ys)) ⟩
  (f · x ∷ map f xs) ++ map f ys ≡⟨ ++-leftCong (sym (map-∷ f x xs)) ⟩
  map f (x ∷ xs) ++ map f ys     ∎

map≡[] : ∀ {f xs} → List xs → map f xs ≡ [] → xs ≡ []
map≡[] lnil                   h = refl
map≡[] {f} (lcons x {xs} Lxs) h = ⊥-elim ([]≢cons (trans (sym h) (map-∷ f x xs)))

-- Reverse properties

reverse-[x]≡[x] : ∀ x → reverse (x ∷ []) ≡ x ∷ []
reverse-[x]≡[x] x =
  rev (x ∷ []) [] ≡⟨ rev-∷ x [] [] ⟩
  rev [] (x ∷ []) ≡⟨ rev-[] (x ∷ []) ⟩
  x ∷ []          ∎

rev-++ : ∀ {xs} → List xs → ∀ ys → rev xs ys ≡ rev xs [] ++ ys
rev-++ lnil ys =
  rev [] ys       ≡⟨ rev-[] ys ⟩
  ys              ≡⟨ sym (++-leftIdentity ys) ⟩
  [] ++ ys        ≡⟨ ++-leftCong (sym (rev-[] [])) ⟩
  rev [] [] ++ ys ∎

rev-++ (lcons x {xs} Lxs) ys =
  rev (x ∷ xs) ys
    ≡⟨ rev-∷ x xs ys ⟩
  rev xs (x ∷ ys)
    ≡⟨ rev-++ Lxs (x ∷ ys) ⟩
  rev xs [] ++ x ∷ ys
    ≡⟨ subst (λ t → rev xs [] ++ x ∷ ys ≡ rev xs [] ++ t)
             (sym (
               (x ∷ []) ++ ys  ≡⟨ ++-∷ x [] ys ⟩
                x ∷ ([] ++ ys) ≡⟨ ∷-rightCong (++-leftIdentity ys) ⟩
                x ∷ ys         ∎
               )
             )
             refl
    ⟩
  rev xs [] ++ (x ∷ []) ++ ys
    ≡⟨ sym (++-assoc (rev-List Lxs lnil) (x ∷ []) ys) ⟩
  (rev xs [] ++ (x ∷ [])) ++ ys
    ≡⟨ ++-leftCong (sym (rev-++ Lxs (x ∷ []))) ⟩
  rev xs (x ∷ []) ++ ys
    ≡⟨ ++-leftCong (sym (rev-∷ x xs [])) ⟩
  rev (x ∷ xs) [] ++ ys ∎

reverse-++ : ∀ {xs ys} → List xs → List ys →
             reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++ {ys = ys} lnil Lys =
  reverse ([] ++ ys)       ≡⟨ reverseCong (++-leftIdentity ys) ⟩
  reverse ys               ≡⟨ sym (++-rightIdentity (reverse-List Lys)) ⟩
  reverse ys ++ []         ≡⟨ ++-rightCong (sym (rev-[] [])) ⟩
  reverse ys ++ reverse [] ∎

reverse-++ (lcons x {xs} Lxs) lnil =
  reverse ((x ∷ xs) ++ [])
    ≡⟨ reverseCong (++-rightIdentity (lcons x Lxs)) ⟩
  reverse (x ∷ xs)
    ≡⟨ sym (++-leftIdentity (reverse (x ∷ xs))) ⟩
  [] ++ reverse (x ∷ xs)
     ≡⟨ ++-leftCong (sym (rev-[] [])) ⟩
  reverse [] ++ reverse (x ∷ xs) ∎

reverse-++ (lcons x {xs} Lxs) (lcons y {ys} Lys) =
  reverse ((x ∷ xs) ++ y ∷ ys)
    ≡⟨ refl ⟩
  rev ((x ∷ xs) ++ y ∷ ys) []
    ≡⟨ revCong₁ (++-∷ x xs (y ∷ ys)) ⟩
  rev (x ∷ (xs ++ y ∷ ys)) []
    ≡⟨ rev-∷ x (xs ++ y ∷ ys) [] ⟩
  rev (xs ++ y ∷ ys) (x ∷ [])
    ≡⟨ rev-++ (++-List Lxs (lcons y Lys)) (x ∷ []) ⟩
  rev (xs ++ y ∷ ys) [] ++ (x ∷ [])
    ≡⟨ refl ⟩
  reverse (xs ++ y ∷ ys) ++ (x ∷ [])
    ≡⟨ ++-leftCong (reverse-++ Lxs (lcons y Lys)) ⟩
  (reverse (y ∷ ys) ++ reverse xs) ++ x ∷ []
    ≡⟨ ++-assoc (reverse-List (lcons y Lys)) (reverse xs) (x ∷ []) ⟩
  reverse (y ∷ ys) ++ reverse xs ++ x ∷ []
    ≡⟨ refl ⟩
  reverse (y ∷ ys) ++ rev xs [] ++ x ∷ []
    ≡⟨ ++-rightCong (sym (rev-++ Lxs (x ∷ []))) ⟩
  reverse (y ∷ ys) ++ rev xs (x ∷ [])
    ≡⟨ ++-rightCong (sym (rev-∷ x xs [])) ⟩
  reverse (y ∷ ys) ++ rev (x ∷ xs) []
    ≡⟨ refl ⟩
  reverse (y ∷ ys) ++ reverse (x ∷ xs) ∎

reverse-∷ : ∀ x {ys} → List ys →
            reverse (x ∷ ys) ≡ reverse ys ++ (x ∷ [])
reverse-∷ x lnil =
  rev (x ∷ []) []     ≡⟨ rev-∷ x [] [] ⟩
  rev [] (x ∷ [])     ≡⟨ rev-[] (x ∷ []) ⟩
  x ∷ []              ≡⟨ sym (++-leftIdentity (x ∷ [])) ⟩
  [] ++ x ∷ []        ≡⟨ ++-leftCong (sym (rev-[] [])) ⟩
  rev [] [] ++ x ∷ [] ∎

reverse-∷ x (lcons y {ys} Lys) = sym prf
  where
  prf : reverse (y ∷ ys) ++ x ∷ [] ≡ reverse (x ∷ y ∷ ys)
  prf =
    reverse (y ∷ ys) ++ x ∷ []
      ≡⟨ ++-rightCong (sym (reverse-[x]≡[x] x)) ⟩
    (reverse (y ∷ ys) ++ reverse (x ∷ []))
      ≡⟨ sym (reverse-++ (lcons x lnil) (lcons y Lys)) ⟩
    reverse ((x ∷ []) ++ (y ∷ ys))
      ≡⟨ reverseCong (++-∷ x [] (y ∷ ys)) ⟩
    reverse (x ∷ ([] ++ (y ∷ ys)))
      ≡⟨ reverseCong (∷-rightCong (++-leftIdentity (y ∷ ys))) ⟩
    reverse (x ∷ y ∷ ys) ∎

reverse'-involutive-helper : ∀ x {ys} → List ys →
                             reverse' (ys ++ x ∷ []) ≡ x ∷ reverse' ys
reverse'-involutive-helper x lnil =
  reverse' ([] ++ x ∷ []) ≡⟨ reverse'Cong (++-[] (x ∷ [])) ⟩
  reverse' (x ∷ [])       ≡⟨ reverse'-∷ x [] ⟩
  reverse' [] ++ x ∷ []   ≡⟨ ++-leftCong reverse'-[] ⟩
  [] ++ x ∷ []            ≡⟨ ++-[] (x ∷ []) ⟩
  x ∷ []                  ≡⟨ ∷-rightCong (sym reverse'-[]) ⟩
  x ∷ reverse' []         ∎

reverse'-involutive-helper x (lcons y {ys} Lys) =
  reverse' ((y ∷ ys) ++ x ∷ [])
    ≡⟨ reverse'Cong (++-∷ y ys (x ∷ [])) ⟩
  reverse' (y ∷ ys ++ x ∷ [])
    ≡⟨ reverse'-∷ y (ys ++ x ∷ []) ⟩
  reverse' (ys ++ x ∷ []) ++ y ∷ []
    ≡⟨ ++-leftCong (reverse'-involutive-helper x Lys) ⟩
  (x ∷ reverse' ys) ++ (y ∷ [])
    ≡⟨ ++-∷ x (reverse' ys) (y ∷ []) ⟩
  x ∷ (reverse' ys ++ y ∷ [])
    ≡⟨ ∷-rightCong (sym (reverse'-∷ y ys)) ⟩
  x ∷ reverse' (y ∷ ys) ∎

-- Adapted from (Bird and Wadler, 1988 §5.4.2).
reverse'-involutive : ∀ {xs} → List xs → reverse' (reverse' xs) ≡ xs
reverse'-involutive lnil =
  reverse' (reverse' []) ≡⟨ reverse'Cong reverse'-[] ⟩
  reverse' []            ≡⟨ reverse'-[] ⟩
  []                     ∎

reverse'-involutive (lcons x {xs} Lxs) =
  reverse' (reverse' (x ∷ xs))
    ≡⟨ reverse'Cong (reverse'-∷ x xs) ⟩
  reverse' (reverse' xs ++ (x ∷ []))
    ≡⟨ reverse'-involutive-helper x (reverse'-List Lxs) ⟩
  x ∷ reverse' (reverse' xs)
    ≡⟨ ∷-rightCong (reverse'-involutive Lxs) ⟩
  x ∷ xs ∎

------------------------------------------------------------------------------
-- References

-- Bird, R. and Wadler, P. (1988). Introduction to Functional
-- Programming. Prentice Hall International.


-- Andreas, 2016-07-29, issue #717
-- reported by LarryTheLiquid on 2012-10-28

data Foo (A : Set) : Set where
  foo : Foo A

data Bar : Set where
  bar baz : Foo {!Bar!} → Bar  -- previously, this IP got duplicated internally

fun : (x : Bar) → Foo Bar
fun (bar y) = {!y!} -- WAS: goal is "Set" (incorrect, should be "Foo Bar")
fun (baz z) = {!z!} -- goal is "Foo Bar" (correct)

-- Works now, after fix for #1720!


{-
    T R U N C A T I O N   L E V E L S
                 I N
H O M O T O P Y   T Y P E   T H E O R Y

======= ELECTRONIC APPENDIX =======

           NICOLAI KRAUS

           February 2015
-}

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

module INDEX where

-- Chapter 2
open import Preliminaries
-- Parts of Chapter 2 are in a separate file:
open import Pointed

{- Chapter 3,4,5,6 are joint work with
   Martin Escardo,
   Thierry Coquand,
   Thorsten Altenkirch -}

-- Chapter 3
open import Truncation_Level_Criteria

-- Chapter 4
open import Anonymous_Existence_CollSplit
open import Anonymous_Existence_Populatedness
open import Anonymous_Existence_Comparison

-- Chapter 5
open import Weakly_Constant_Functions

-- Chapter 6
open import Judgmental_Computation

{- Chapter 7 (joint work with Christian Sattler)
   has two parts. First, we construct homotopically
   complicated types; this development is distributed
   beween two files. Then, we discuss connectedness,
   which turns out to be very hard to formalise;
   we use in total five files to structure that
   discussion, see below. -}

{- First, we have an auxiliary file which makes precise
   that the 'universe of n-types' behaves like an actual
   universe. We formalise operations for it; this is
   very useful as it allows a more 'principled' development. -}
open import UniverseOfNTypes
{- Now: Sections 1-4 of Chapter 7, where 1,2 are "hidden".
   They are special cases of the more general theorem that
   we prove in 7.4; the special cases are written out only
   for pedagogical reasons and are thus omitted in this
   formalisation. -}
open import HHHUU-ComplicatedTypes

{- Note that Chapter 7.5 is not formalised, even though it
   could have been; we omit it because it is only an
   alternative to the above formalisation, and actually
   leads to a weaker result than the one in
   'HHHUU-ComplicatedTypes'.

   Chapter 7.6 is very hard to formalise (mostly done by
   Christian Sattler). Caveat: The order of the statements
   in the formalisation is different from the order in
   the thesis (it sometimes is more convenient to define
   multiple notions in the same module because they share
   argument to avoid replication of code, without them
   belonging together logically).

   First, we show (in a separate file) that the non-dependent
   universal property and the dependent universal
   property are equivalent.

   Contains: Definition 7.6.2, Lemma 7.6.6 -}
open import Trunc.Universal

-- Definition 7.6.4, Lemma 7.6.7, Corollary 7.6.8
open import Trunc.Basics

-- Lemma 7.6.9, Lemma 7.6.10
-- (actually even a stronger version of Lemma 7.6.10)
open import Trunc.TypeConstructors

{- main part of connectedness:
   (link to 7.6.1,)
   Definition 7.6.13, Definition 7.6.11,
   Lemma 7.6.14, Lemma 7.6.12, Lemma 7.6.15
   and
   Theorem 7.7.1 -}
open import Trunc.Connection

-- Remark 7.6.16
open import Trunc.ConnectednessAlt

{- The main result of Chapter 8 is, unfortunately,
   meta-theoretical. It is plausible that in an
   implementation of a type theory with 'two levels'
   (one semi-internal 'strict' equality and the
   ordinary identity type), the complete Chapter 8
   could be formalised; but at the moment, this is
   merely speculation. -}

-- Chapter 9.2: Semi-Simplicial Types

-- Proposition 9.2.1 (Δ₊ implemented with judgmental categorical laws)
open import Deltaplus


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Monoid.MorphismProperties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Function using (_∘_; id)
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Functions.Embedding
open import Cubical.Data.Sigma

open import Cubical.Algebra
open import Cubical.Algebra.Properties
open import Cubical.Algebra.Monoid.Morphism

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Pointed

open import Cubical.Algebra.Semigroup.Properties using (isPropIsSemigroup)

open import Cubical.Relation.Binary.Reasoning.Equality

open Iso

private
  variable
    ℓ ℓ′ ℓ′′ : Level
    L : Monoid ℓ
    M : Monoid ℓ′
    N : Monoid ℓ′′

isPropIsMonoidHom : ∀ (M : Monoid ℓ) (N : Monoid ℓ′) f → isProp (IsMonoidHom M N f)
isPropIsMonoidHom M N f (ismonoidhom aOp aId) (ismonoidhom bOp bId) =
  cong₂ ismonoidhom
    (isPropHomomorphic₂ (Monoid.is-set N) f (Monoid._•_ M) (Monoid._•_ N) aOp bOp)
    (isPropHomomorphic₀ (Monoid.is-set N) f (Monoid.ε   M) (Monoid.ε   N) aId bId)

isSetMonoidHom : isSet (M ⟶ᴴ N)
isSetMonoidHom {M = M} {N = N} = isOfHLevelRespectEquiv 2 equiv
                                  (isSetΣ (isSetΠ λ _ → is-set N)
                                          (λ f → isProp→isSet (isPropIsMonoidHom M N f)))
  where
    open Monoid
    equiv : (Σ[ g ∈ (⟨ M ⟩ → ⟨ N ⟩) ] IsMonoidHom M N g) ≃ MonoidHom M N
    equiv = isoToEquiv (iso (λ (g , m) → monoidhom g m) (λ (monoidhom g m) → g , m) (λ _ → refl) λ _ → refl)

isMonoidHomComp : {f : ⟨ L ⟩ → ⟨ M ⟩} {g : ⟨ M ⟩ → ⟨ N ⟩}
                  → IsMonoidHom L M f → IsMonoidHom M N g → IsMonoidHom L N (g ∘ f)
isMonoidHomComp {g = g} (ismonoidhom fOp fId) (ismonoidhom gOp gId) =
  ismonoidhom (λ _ _ → cong g (fOp _ _) ∙ gOp _ _) (cong g fId ∙ gId)

private
  isMonoidHomComp′ : (f : L ⟶ᴴ M) (g : M ⟶ᴴ N)
                      → IsMonoidHom L N (MonoidHom.fun g ∘ MonoidHom.fun f)
  isMonoidHomComp′ (monoidhom f (ismonoidhom fOp fId)) (monoidhom g (ismonoidhom gOp gId)) =
    ismonoidhom (λ _ _ → cong g (fOp _ _) ∙ gOp _ _) (cong g fId ∙ gId)

compMonoidHom : (L ⟶ᴴ M) → (M ⟶ᴴ N) → (L ⟶ᴴ N)
compMonoidHom f g = monoidhom _ (isMonoidHomComp′ f g)

compMonoidEquiv : L ≃ᴴ M → M ≃ᴴ N → L ≃ᴴ N
compMonoidEquiv f g = monoidequiv (compEquiv f.eq g.eq) (isMonoidHomComp′ f.hom g.hom)
  where
    module f = MonoidEquiv f
    module g = MonoidEquiv g

isMonoidHomId : (M : Monoid ℓ) → IsMonoidHom M M id
isMonoidHomId M = record
  { preservesOp = λ _ _ → refl
  ; preservesId = refl
  }

idMonoidHom : (M : Monoid ℓ) → (M ⟶ᴴ M)
idMonoidHom M = record
  { fun   = id
  ; isHom = isMonoidHomId M
  }

idMonoidEquiv : (M : Monoid ℓ) → M ≃ᴴ M
idMonoidEquiv M = record
  { eq    = idEquiv ⟨ M ⟩
  ; isHom = isMonoidHomId M
  }

-- Isomorphism inversion
isMonoidHomInv : (eqv : M ≃ᴴ N) → IsMonoidHom N M (invEq (MonoidEquiv.eq eqv))
isMonoidHomInv {M = M} {N = N} (monoidequiv eq (ismonoidhom hOp hId)) = ismonoidhom
  (λ x y → isInj-f (
    f (f⁻¹ (x N.• y))       ≡⟨ retEq eq _ ⟩
    x N.• y                 ≡˘⟨ cong₂ N._•_ (retEq eq x) (retEq eq y) ⟩
    f (f⁻¹ x) N.• f (f⁻¹ y) ≡˘⟨ hOp (f⁻¹ x) (f⁻¹ y) ⟩
    f (f⁻¹ x M.• f⁻¹ y)     ∎))
  (isInj-f (
    f (f⁻¹ N.ε) ≡⟨ retEq eq _ ⟩
    N.ε         ≡˘⟨ hId ⟩
    f M.ε       ∎))
    where
      module M = Monoid M
      module N = Monoid N
      f = equivFun eq
      f⁻¹ = invEq eq
      isInj-f : {x y : ⟨ M ⟩} → f x ≡ f y → x ≡ y
      isInj-f {x} {y} = invEq (_ , isEquiv→isEmbedding (eq .snd) x y)

invMonoidHom : M ≃ᴴ N → (N ⟶ᴴ M)
invMonoidHom eq = record { isHom = isMonoidHomInv eq }

invMonoidEquiv : M ≃ᴴ N → N ≃ᴴ M
invMonoidEquiv eq = record
  { eq    = invEquiv (MonoidEquiv.eq eq)
  ; isHom = isMonoidHomInv eq
  }

monoidHomEq : {f g : M ⟶ᴴ N} → MonoidHom.fun f ≡ MonoidHom.fun g → f ≡ g
monoidHomEq {M = M} {N = N} {monoidhom f fm} {monoidhom g gm} p i =
  monoidhom (p i) (p-hom i)
  where
    p-hom : PathP (λ i → IsMonoidHom M N (p i)) fm gm
    p-hom = toPathP (isPropIsMonoidHom M N _ _ _)

monoidEquivEq : {f g : M ≃ᴴ N} → MonoidEquiv.eq f ≡ MonoidEquiv.eq g → f ≡ g
monoidEquivEq {M = M} {N = N} {monoidequiv f fm} {monoidequiv g gm} p i =
  monoidequiv (p i) (p-hom i)
  where
    p-hom : PathP (λ i → IsMonoidHom M N (p i .fst)) fm gm
    p-hom = toPathP (isPropIsMonoidHom M N _ _ _)

module MonoidΣTheory {ℓ} where

  RawMonoidStructure : Type ℓ → Type ℓ
  RawMonoidStructure X = (X → X → X) × X

  RawMonoidEquivStr = AutoEquivStr RawMonoidStructure

  rawMonoidUnivalentStr : UnivalentStr _ RawMonoidEquivStr
  rawMonoidUnivalentStr = autoUnivalentStr RawMonoidStructure

  MonoidAxioms : (M : Type ℓ) → RawMonoidStructure M → Type ℓ
  MonoidAxioms M (_•_ , ε) = IsSemigroup M _•_ × Identity ε _•_

  MonoidStructure : Type ℓ → Type ℓ
  MonoidStructure = AxiomsStructure RawMonoidStructure MonoidAxioms

  MonoidΣ : Type (ℓ-suc ℓ)
  MonoidΣ = TypeWithStr ℓ MonoidStructure

  isPropMonoidAxioms : (M : Type ℓ) (s : RawMonoidStructure M) → isProp (MonoidAxioms M s)
  isPropMonoidAxioms M (_•_ , ε) = isPropΣ isPropIsSemigroup
                                    λ isSemiM → isPropIdentity (IsSemigroup.is-set isSemiM) _•_ ε

  MonoidEquivStr : StrEquiv MonoidStructure ℓ
  MonoidEquivStr = AxiomsEquivStr RawMonoidEquivStr MonoidAxioms

  MonoidAxiomsIsoIsMonoid : {M : Type ℓ} (s : RawMonoidStructure M) →
                            Iso (MonoidAxioms M s) (IsMonoid M (s .fst) (s .snd))
  fun (MonoidAxiomsIsoIsMonoid s) (x , y)        = ismonoid x y
  inv (MonoidAxiomsIsoIsMonoid s) (ismonoid x y) = (x , y)
  rightInv (MonoidAxiomsIsoIsMonoid s) _         = refl
  leftInv (MonoidAxiomsIsoIsMonoid s) _          = refl

  MonoidAxioms≡IsMonoid : {M : Type ℓ} (s : RawMonoidStructure M) →
                          MonoidAxioms M s ≡ IsMonoid M (s .fst) (s .snd)
  MonoidAxioms≡IsMonoid s = isoToPath (MonoidAxiomsIsoIsMonoid s)

  Monoid→MonoidΣ : Monoid ℓ → MonoidΣ
  Monoid→MonoidΣ (mkmonoid M _•_ ε isMonoidM) =
    M , (_•_ , ε) , MonoidAxiomsIsoIsMonoid (_•_ , ε) .inv isMonoidM

  MonoidΣ→Monoid : MonoidΣ → Monoid ℓ
  MonoidΣ→Monoid (M , (_•_ , ε) , isMonoidM) =
    mkmonoid M _•_ ε (MonoidAxiomsIsoIsMonoid (_•_ , ε) .fun isMonoidM)

  MonoidIsoMonoidΣ : Iso (Monoid ℓ) MonoidΣ
  MonoidIsoMonoidΣ =
    iso Monoid→MonoidΣ MonoidΣ→Monoid (λ _ → refl) (λ _ → refl)

  monoidUnivalentStr : UnivalentStr MonoidStructure MonoidEquivStr
  monoidUnivalentStr = axiomsUnivalentStr _ isPropMonoidAxioms rawMonoidUnivalentStr

  MonoidΣPath : (M N : MonoidΣ) → (M ≃[ MonoidEquivStr ] N) ≃ (M ≡ N)
  MonoidΣPath = SIP monoidUnivalentStr

  MonoidEquivΣ : (M N : Monoid ℓ) → Type ℓ
  MonoidEquivΣ M N = Monoid→MonoidΣ M ≃[ MonoidEquivStr ] Monoid→MonoidΣ N

  MonoidIsoΣPath : {M N : Monoid ℓ} → Iso (MonoidEquiv M N) (MonoidEquivΣ M N)
  fun MonoidIsoΣPath (monoidequiv eq (ismonoidhom hOp hId)) = (eq , hOp , hId)
  inv MonoidIsoΣPath (eq , hOp , hId)                       = monoidequiv eq (ismonoidhom hOp hId)
  rightInv MonoidIsoΣPath _                                 = refl
  leftInv MonoidIsoΣPath _                                  = refl

  MonoidPath : (M N : Monoid ℓ) → (MonoidEquiv M N) ≃ (M ≡ N)
  MonoidPath M N =
    MonoidEquiv M N                       ≃⟨ isoToEquiv MonoidIsoΣPath ⟩
    MonoidEquivΣ M N                      ≃⟨ MonoidΣPath _ _ ⟩
    Monoid→MonoidΣ M ≡ Monoid→MonoidΣ N   ≃⟨ isoToEquiv (invIso (congIso MonoidIsoMonoidΣ)) ⟩
    M ≡ N                                 ■

  RawMonoidΣ : Type (ℓ-suc ℓ)
  RawMonoidΣ = TypeWithStr ℓ RawMonoidStructure

  Monoid→RawMonoidΣ : Monoid ℓ → RawMonoidΣ
  Monoid→RawMonoidΣ (mkmonoid A _•_ ε _) = A , _•_ , ε

  InducedMonoid : (M : Monoid ℓ) (N : RawMonoidΣ) (e : M .Monoid.Carrier ≃ N .fst) →
                  RawMonoidEquivStr (Monoid→RawMonoidΣ M) N e → Monoid ℓ
  InducedMonoid M N e r =
    MonoidΣ→Monoid (inducedStructure rawMonoidUnivalentStr (Monoid→MonoidΣ M) N (e , r))

  InducedMonoidPath : (M : Monoid ℓ) (N : RawMonoidΣ) (e : M .Monoid.Carrier ≃ N .fst)
                      (E : RawMonoidEquivStr (Monoid→RawMonoidΣ M) N e) →
                      M ≡ InducedMonoid M N e E
  InducedMonoidPath M N e E =
    MonoidPath M (InducedMonoid M N e E) .fst (monoidequiv e (ismonoidhom (E .fst) (E .snd)))

-- We now extract the important results from the above module

open MonoidΣTheory public using (InducedMonoid; InducedMonoidPath)

isPropIsMonoid : {M : Type ℓ} {_•_ : Op₂ M} {ε : M} → isProp (IsMonoid M _•_ ε)
isPropIsMonoid {_•_ = _•_} {ε} =
  subst isProp (MonoidΣTheory.MonoidAxioms≡IsMonoid (_•_ , ε))
        (MonoidΣTheory.isPropMonoidAxioms _ (_•_ , ε))

MonoidPath : (M ≃ᴴ N) ≃ (M ≡ N)
MonoidPath {M = M} {N} = MonoidΣTheory.MonoidPath M N

open Monoid

uaMonoid : M ≃ᴴ N → M ≡ N
uaMonoid = equivFun MonoidPath

carac-uaMonoid : {M N : Monoid ℓ} (f : M ≃ᴴ N) → cong Carrier (uaMonoid f) ≡ ua (MonoidEquiv.eq f)
carac-uaMonoid (monoidequiv f m) =
  (refl ∙∙ ua f ∙∙ refl)  ≡˘⟨ rUnit (ua f) ⟩
  ua f                    ∎

Monoid≡ : (M N : Monoid ℓ) → (
  Σ[ p ∈ ⟨ M ⟩ ≡ ⟨ N ⟩ ]
  Σ[ q ∈ PathP (λ i → p i → p i → p i) (_•_ M) (_•_ N) ]
  Σ[ r ∈ PathP (λ i → p i) (ε M) (ε N) ]
  PathP (λ i → IsMonoid (p i) (q i) (r i)) (isMonoid M) (isMonoid N))
  ≃ (M ≡ N)
Monoid≡ M N = isoToEquiv (iso
  (λ (p , q , r , s) i → mkmonoid (p i) (q i) (r i) (s i))
  (λ p → cong Carrier p , cong _•_ p , cong ε p , cong isMonoid p)
  (λ _ → refl) (λ _ → refl))

caracMonoid≡ : {M N : Monoid ℓ} (p q : M ≡ N) → cong Carrier p ≡ cong Carrier q → p ≡ q
caracMonoid≡ {M = M} {N} p q t = cong (fst (Monoid≡ M N)) (Σ≡Prop (λ _ →
    isPropΣ
    (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set N) _ _) λ _ → isPropΣ
    (isOfHLevelPathP' 1 (is-set N) _ _) λ _ →
    isOfHLevelPathP 1 isPropIsMonoid _ _)
  t)

uaMonoidId : (M : Monoid ℓ) → uaMonoid (idMonoidEquiv M) ≡ refl
uaMonoidId M = caracMonoid≡ _ _ (carac-uaMonoid (idMonoidEquiv M) ∙ uaIdEquiv)

uaCompMonoidEquiv : {L M N : Monoid ℓ} (f : L ≃ᴴ M) (g : M ≃ᴴ N)
                    → uaMonoid (compMonoidEquiv f g) ≡ uaMonoid f ∙ uaMonoid g
uaCompMonoidEquiv f g = caracMonoid≡ _ _ (
  cong Carrier (uaMonoid (compMonoidEquiv f g))
    ≡⟨ carac-uaMonoid (compMonoidEquiv f g) ⟩
  ua (eq (compMonoidEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  ua (eq f) ∙ ua (eq g)
    ≡˘⟨ cong (_∙ ua (eq g)) (carac-uaMonoid f) ⟩
  cong Carrier (uaMonoid f) ∙ ua (eq g)
    ≡˘⟨ cong (cong Carrier (uaMonoid f) ∙_) (carac-uaMonoid g) ⟩
  cong Carrier (uaMonoid f) ∙ cong Carrier (uaMonoid g)
    ≡˘⟨ cong-∙ Carrier (uaMonoid f) (uaMonoid g) ⟩
  cong Carrier (uaMonoid f ∙ uaMonoid g) ∎)
  where open MonoidEquiv


module TLP02 where

open import Data.Bool
open import Data.Nat
open import Data.String
open import Relation.Binary.PropositionalEquality
  as PropEq using (_≡_; refl)

-- ----- Star型の定義 -----
data Star : Set where
  NIL : Star
  TRU : Star
  N   : ℕ → Star
  S   : String → Star
  C   : Star → Star → Star

-- ----- 組込関数の定義 -----
postulate
  CONS : Star → Star → Star
  CAR : Star → Star
  CDR : Star → Star
  ATOM : Star → Star
  IF : Star → Star → Star → Star
  EQUAL : Star → Star → Star
  SIZE : Star → Star
  LT : Star → Star → Star

-- ----- Starから≡に -----
postulate
  ~ : Star → Star
  equal-eq : {x y : Star} → (EQUAL x y) ≡ TRU →  x ≡ y
  ifAP : {q x y : Star} → (IF q (EQUAL x y) TRU) ≡ TRU → (q ≡ TRU → x ≡ y)
  ifEP : {q x y : Star} → (IF q TRU (EQUAL x y)) ≡ TRU → ((~ q) ≡ TRU → x ≡ y)
-- ----- 公理 -----
  equal-same : (x : Star) → (EQUAL (EQUAL x x) TRU) ≡ TRU
  equal-swap : (x y : Star) → (EQUAL (EQUAL x y) (EQUAL y x)) ≡ TRU
  equal-if : (x y : Star) → (IF (EQUAL x y) (EQUAL x y) TRU) ≡ TRU
  atom/cons : (x y : Star) → (EQUAL (ATOM (CONS x y)) NIL) ≡ TRU
  car/cons : (x y : Star) → (EQUAL (CAR (CONS x y)) x) ≡ TRU
  cdr/cons : (x y : Star) → (EQUAL (CDR (CONS x y)) y) ≡ TRU
  cons/car+cdr : (x : Star)
    → (IF (ATOM x) TRU (EQUAL (CONS (CAR x) (CDR x)) x)) ≡ TRU
  if-true : (x y : Star) → (EQUAL (IF TRU x y) x) ≡ TRU
  if-false : (x y : Star) → (EQUAL (IF NIL x y) y) ≡ TRU
  if-same : (x y : Star) → (EQUAL (IF x y y) y) ≡ TRU
  if-nest-A : (x y z : Star) → (IF x (EQUAL (IF x y z) y) TRU) ≡ TRU
  if-nest-E : (x y z : Star) → (IF x TRU (EQUAL (IF x y z) z)) ≡ TRU
  size/car : (x : Star)
    → (IF (ATOM x) TRU (EQUAL (LT (SIZE (CAR x)) (SIZE x)) TRU)) ≡ TRU
  size/cdr : (x : Star)
    → (IF (ATOM x) TRU (EQUAL (LT (SIZE (CDR x)) (SIZE x)) TRU)) ≡ TRU

-- ----- 練習 -----
hoge2 : (ATOM (CONS TRU TRU)) ≡ NIL
hoge2 = equal-eq (atom/cons TRU TRU)

hoge2' : (ATOM (CONS TRU TRU)) ≡ NIL
hoge2'
  rewrite (equal-eq (atom/cons TRU TRU))
    = refl
-- -----

{--
-- ----- 停止性で引っかかる -----
memb?' : Star → Star
memb?' xs =
  (IF (ATOM xs)
       NIL
       (IF (EQUAL (CAR xs) (S "?"))
           TRU
           (memb?' (CDR xs))))
--}
-- ----- memb?の停止性 -----
postulate
  premise : (xs : Star) → (~ (ATOM xs)) ≡ TRU
measure-memb? : (xs : Star)
  → (IF (ATOM xs)
        TRU
        (IF (EQUAL (CAR xs) (S "?"))
            TRU
            (LT (SIZE (CDR xs)) (SIZE xs))))
    ≡ TRU
measure-memb? xs
  rewrite (ifEP (size/cdr xs) (premise xs))
        | (equal-eq (if-same (EQUAL (CAR xs) (S "?")) TRU))
        | (equal-eq (if-same (ATOM xs) TRU)) = refl

-- ----- memb?の定義 -----
postulate
  memb? : Star → Star
  def-memb? : (xs : Star) →
    memb? xs ≡
      (IF (ATOM xs)
          NIL
          (IF (EQUAL (CAR xs) (S "?"))
              TRU
              (memb? (CDR xs))))
-- ----- rembの定義 -----
postulate
  remb : Star → Star
  def-remb : (xs : Star) →
    remb xs ≡
      (IF (ATOM xs)
          (S "'()")
          (IF (EQUAL (CAR xs) (S "?"))
              (remb (CDR xs))
              (CONS (CAR xs)
                 (remb (CDR xs)))))
-- ----- 帰納的な証明 -----
postulate
  premise2 : (xs : Star) → (ATOM xs) ≡ TRU
  premise3 : (xs : Star) → ~ (ATOM xs) ≡ TRU
  atomt : (ATOM (S "'()")) ≡ TRU
memb?/remb : (xs : Star)
  → (IF (ATOM xs)
        (EQUAL (memb? (remb xs)) NIL)
        (IF (EQUAL (memb? (remb (CDR xs))) NIL)
            (EQUAL (memb? (remb xs)) NIL)
            TRU))
    ≡ IF (ATOM xs) TRU (IF (EQUAL (memb? (remb (CDR xs))) NIL) TRU TRU)
memb?/remb xs
  rewrite (def-remb xs)
        | (ifAP (if-nest-A (ATOM xs) (S "'()") ((IF (EQUAL (CAR xs) (S "?"))
              (remb (CDR xs))
              (CONS (CAR xs)
                 (remb (CDR xs)))))) (premise2 xs))
        | (def-memb? ((S "'()")))
        | (atomt)
        | (equal-eq (if-true NIL ((IF (EQUAL (CAR (S "'()")) (S "?"))
                        TRU
                        (memb? (CDR (S "'()")))))))
        | (equal-eq (equal-same NIL))
        | (def-remb xs)
          -- ----- ここで証明ステップが一気に進んだ
        | (ifEP (if-nest-E (ATOM xs) (S "'()") (IF (EQUAL (CAR xs) (S "?"))
              (remb (CDR xs))
              (CONS (CAR xs)
                 (remb (CDR xs))))) (premise3 xs)) = refl

memb?/remb2 : (xs : Star)
  → IF (ATOM xs) TRU (IF (EQUAL (memb? (remb (CDR xs))) NIL) TRU TRU)
    ≡ TRU
memb?/remb2 xs
  rewrite (equal-eq (if-same (EQUAL (memb? (remb (CDR xs))) NIL) TRU))
        | (equal-eq (if-same (ATOM xs) TRU)) = refl


{-# OPTIONS --copatterns --sized-types --experimental-irrelevance #-}
-- {-# OPTIONS --show-implicit --show-irrelevant #-}
-- {-# OPTIONS -v tc.polarity:10 -v tc.pos:15 -v tc.size.solve:100 #-}

module SizedCoinductiveRecords where

open import Common.Size

{- THIS WOULD BE A BETTER TYPING FOR sizeSuc, but it requires builtin Size<
sizeSuc : (i : Size) → Size< (↑ (↑ i))
sizeSuc i = ↑ i
-}

-- -- Subtyping for Size<
-- Andreas, 2015-03-15: Functions returning sizes are now illegal:
-- emb< : {i : Size} → Size< i → Size
-- emb< {i} j = j

-- Use Size< hypotheses

data Empty : {i : Size} → Set where
  empty : {i : Size} → Empty {i} → Empty {↑ i}

subEmpty : {i : Size}{j : Size< i} → Empty {j} → Empty {i}
subEmpty x = x

-- SHOULD FAIL:
-- fail : {i : Size}{j : Size< i} → Empty {i} → Empty {j}
-- fail x = x

-- -- Covariance for Size<
-- Andreas, 2015-03-15: Functions returning sizes are now illegal:
-- co : {i : Size}{j : Size< i} → Size< j → Size< i
-- co k = k

-- Contravariance for bounded quantification

Bounded : Size → Set
Bounded i = (j : Size< i) → Empty {j}

contra : {i : Size}{j : Size< i} → Bounded i → Bounded j
contra k = k

-- sized naturals

data Nat {i : Size} : Set where
  zero : Nat
  suc  : {j : Size< i} → Nat {j} → Nat

-- polarity of successor

data Bool : Set where
  true false : Bool

-- a natural number

one : Nat
one = suc {i = ∞} zero

mySuc : {i : Size} → Nat {i} → Nat {↑ i}
mySuc x = suc x

pred : {i : Size} → Nat {↑ i} → Nat {i}
pred zero = zero
pred (suc n) = n

shift : {i : Size} → (Nat → Nat {↑ i}) → Nat → Nat {i}
shift f n = pred (f (suc n))

{- Does not type check
loop : {i : Size} → Nat {i} → (Nat → Nat {i}) → Set
loop (suc n) f = loop n (shift f)
loop zero      = Nat
-}

data ⊥ : Set where
record ⊤ : Set where

mono : {i : Size}{j : Size< i} → Nat {j} → Nat {i}
mono n = n

id : {i : Size} → Nat {i} → Nat {i}
id (zero) = zero
id (suc n) = suc (id n)

monus : {i : Size} → Nat {i} → Nat → Nat {i}
monus x zero = x
monus zero y = zero
monus (suc x) (suc y) = monus x y

div : {i : Size} → Nat {i} → Nat → Nat {i}
div zero    y = zero
div (suc x) y = suc (div (monus x y) y)

-- postulate _∪_ : {i : Size} → Size< i → Size< i → Size< i

{-
max : {i : Size} → Nat {i} → Nat {i} → Nat {i}
max zero n = n
max m zero = m
max {i} (suc {j = j} m) (suc {j = k} n) = suc {j = j ∪ k} (max {j ∪ k} m n)
-}

-- omega inst

{- DOES NOT MAKE SENSE:
omegaBad' : (F : Size → Set) (i : Size) (j : Size< i)
            (f : (k : Size< (↑ j)) → F k) → F j
omegaBad' F i j f = f j
-}

-- fix

A : Size → Set
A i = Nat {i} → Nat

{-# TERMINATING #-}
fix : (f : (i : Size) → ((j : Size< i) → A j) → A i) → (i : Size) → A i
fix f i zero        = zero
fix f i (suc {j} n) = f i (λ j → fix f j) (suc n)

-- forever : {i : Size} → ({j : Size< i} → Nat {i} → Nat {j}) → Nat {i} → ⊥
-- forever {i} f n = forever f (f {{!!}} n)

-- sized streams

module STREAM where

  record Stream (A : Set) {i : Size} : Set where
    coinductive
    constructor _∷_
    field
      head : A
      tail : {j : Size< i} → Stream A {j}
  open Stream

  map : {A B : Set}(f : A → B){i : Size} → Stream A {i} → Stream B {i}
  head (map f s) = f (head s)
  tail (map f s) = map f (tail s)

  -- stream antitone

  anti : {A : Set}{i : Size}{j : Size< i} → Stream A {i} → Stream A {j}
  anti s = s

  anti' : {A : Set}{i : Size}{j : Size< i} → (Stream A {j} → A) → (Stream A {i} → A)
  anti' f = f

-- Spanning tree

data List (A : Set) {i : Size} : Set where
  []  : List A
  _∷_ : {j : Size< i}(x : A)(xs : List A {j}) → List A

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

module Graph (I : Set)(adj : I → List I) where

  record Span {i : Size} : Set where
    coinductive
    constructor span
    field
      root  : I
      nodes : {j : Size< i} → List (Span {j})
  open Span

  tree : {i : Size} → I → Span {i}
  root  (tree root) = root
  nodes (tree root) = map (tree) (adj root)


------------------------------------------------------------------------------
-- Conversion rules for the Collatz function
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Collatz.ConversionRulesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOT.FOTC.Program.Collatz.CollatzConditionals

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Program.Collatz.Data.Nat

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

private
  -- The steps

  -- Initially, the equation collatz-eq is used.

  collatz-s₁ : D → D
  collatz-s₁ n = if (iszero₁ n)
                   then 1'
                   else (if (iszero₁ (pred₁ n))
                           then 1'
                           else (if (even n)
                                   then collatz (div n 2')
                                   else collatz (3' * n + 1')))

  -- First if_then_else_ iszero₁ n = b.
  collatz-s₂ : D → D → D
  collatz-s₂ n b = if b
                     then 1'
                     else (if (iszero₁ (pred₁ n))
                             then 1'
                             else (if (even n)
                                     then collatz (div n 2')
                                     else collatz (3' * n + 1')))

  -- First if_then_else_ when if true ....
  collatz-s₃ : D → D
  collatz-s₃ n = 1'

  -- First if_then_else_ when if false ....
  collatz-s₄ : D → D
  collatz-s₄ n = if (iszero₁ (pred₁ n))
                   then 1'
                   else (if (even n)
                           then collatz (div n 2')
                           else collatz (3' * n + 1'))

  -- Second if_then_else_ iszero₁ (pred₁ n) = b.
  collatz-s₅ : D → D → D
  collatz-s₅ n b = if b
                     then 1'
                     else (if (even n)
                             then collatz (div n 2')
                             else collatz (3' * n + 1'))

  -- Second if_then_else_ when if true ....
  collatz-s₆ : D → D
  collatz-s₆ n = 1'

  -- Second if_then_else_ when if false ....
  collatz-s₇ : D → D
  collatz-s₇ n = if (even n) then collatz (div n 2') else collatz (3' * n + 1')

  -- Third if_then_else_ even n b.
  collatz-s₈ : D → D → D
  collatz-s₈ n b = if b then collatz (div n 2') else collatz (3' * n + 1')

  -- Third if_then_else_ when if true ....
  collatz-s₉ : D → D
  collatz-s₉ n = collatz (div n 2')

  -- Third if_then_else_ when if false ....
  collatz-s₁₀ : D → D
  collatz-s₁₀ n = collatz (3' * n + 1')

  ----------------------------------------------------------------------------
  -- The execution steps

  proof₀₋₁ : ∀ n → collatz n ≡ collatz-s₁ n
  proof₀₋₁ n = collatz-eq n

  proof₁₋₂ : ∀ {n b} → iszero₁ n ≡ b → collatz-s₁ n ≡ collatz-s₂ n b
  proof₁₋₂ {n} {b} h = subst (λ x → collatz-s₂ n x ≡ collatz-s₂ n b)
                             (sym h)
                             refl

  proof₂₋₃ : ∀ n → collatz-s₂ n true ≡ collatz-s₃ n
  proof₂₋₃ n = if-true (collatz-s₃ n)

  proof₂₋₄ : ∀ n → collatz-s₂ n false ≡ collatz-s₄ n
  proof₂₋₄ n = if-false (collatz-s₄ n)

  proof₄₋₅ : ∀ {n b} → iszero₁ (pred₁ n) ≡ b → collatz-s₄ n ≡ collatz-s₅ n b
  proof₄₋₅ {n} {b} h = subst (λ x → collatz-s₅ n x ≡ collatz-s₅ n b)
                             (sym h)
                             refl

  proof₅₋₆ : ∀ n → collatz-s₅ n true ≡ collatz-s₆ n
  proof₅₋₆ n = if-true (collatz-s₆ n)

  proof₅₋₇ : ∀ n → collatz-s₅ n false ≡ collatz-s₇ n
  proof₅₋₇ n = if-false (collatz-s₇ n)

  proof₇₋₈ : ∀ {n b} → even n ≡ b → collatz-s₇ n ≡ collatz-s₈ n b
  proof₇₋₈ {n} {b} h = subst (λ x → collatz-s₈ n x ≡ collatz-s₈ n b)
                             (sym h)
                             refl

  proof₈₋₉ : ∀ n → collatz-s₈ n true ≡ collatz-s₉ n
  proof₈₋₉ n = if-true (collatz-s₉ n)

  proof₈₋₁₀ : ∀ n → collatz-s₈ n false ≡ collatz-s₁₀ n
  proof₈₋₁₀ n = if-false (collatz-s₁₀ n)

------------------------------------------------------------------------------
-- Conversion rules for the Collatz function

collatz-0 : collatz zero ≡ 1'
collatz-0 =
  collatz    zero      ≡⟨ proof₀₋₁ zero ⟩
  collatz-s₁ zero      ≡⟨ proof₁₋₂ iszero-0 ⟩
  collatz-s₂ zero true ≡⟨ proof₂₋₃ zero ⟩
  1'                  ∎

collatz-1 : collatz 1' ≡ 1'
collatz-1 =
  collatz 1'
    ≡⟨ proof₀₋₁ 1' ⟩
  collatz-s₁ 1'
    ≡⟨ proof₁₋₂ (iszero-S zero) ⟩
  collatz-s₂ 1' false
    ≡⟨ proof₂₋₄ 1'  ⟩
  collatz-s₄ 1'
    ≡⟨ proof₄₋₅ (subst (λ x → iszero₁ x ≡ true) (sym (pred-S zero)) iszero-0) ⟩
  collatz-s₅ 1' true
    ≡⟨ proof₅₋₆ 1' ⟩
  1' ∎

collatz-even : ∀ {n} → Even (succ₁ (succ₁ n)) →
               collatz (succ₁ (succ₁ n)) ≡ collatz (div (succ₁ (succ₁ n)) 2')
collatz-even {n} h =
  collatz (succ₁ (succ₁ n))
    ≡⟨ proof₀₋₁ (succ₁ (succ₁ n)) ⟩
  collatz-s₁ (succ₁ (succ₁ n))
    ≡⟨ proof₁₋₂ (iszero-S (succ₁ n)) ⟩
  collatz-s₂ (succ₁ (succ₁ n)) false
    ≡⟨ proof₂₋₄ (succ₁ (succ₁ n)) ⟩
  collatz-s₄ (succ₁ (succ₁ n))
    ≡⟨ proof₄₋₅ (subst (λ x → iszero₁ x ≡ false)
                       (sym (pred-S (succ₁ n)))
                       (iszero-S n))
    ⟩
  collatz-s₅ (succ₁ (succ₁ n)) false
    ≡⟨ proof₅₋₇ (succ₁ (succ₁ n)) ⟩
  collatz-s₇ (succ₁ (succ₁ n))
    ≡⟨ proof₇₋₈ h ⟩
  collatz-s₈ (succ₁ (succ₁ n)) true
    ≡⟨ proof₈₋₉ (succ₁ (succ₁ n)) ⟩
  collatz (div (succ₁ (succ₁ n)) 2') ∎

collatz-noteven : ∀ {n} → NotEven (succ₁ (succ₁ n)) →
                  collatz (succ₁ (succ₁ n)) ≡
                  collatz (3' * (succ₁ (succ₁ n)) + 1')
collatz-noteven {n} h =
  collatz (succ₁ (succ₁ n))
    ≡⟨ proof₀₋₁ (succ₁ (succ₁ n)) ⟩
  collatz-s₁ (succ₁ (succ₁ n))
    ≡⟨ proof₁₋₂ (iszero-S (succ₁ n)) ⟩
  collatz-s₂ (succ₁ (succ₁ n)) false
    ≡⟨ proof₂₋₄ (succ₁ (succ₁ n)) ⟩
  collatz-s₄ (succ₁ (succ₁ n))
    ≡⟨ proof₄₋₅ (subst (λ x → iszero₁ x ≡ false)
                       (sym (pred-S (succ₁ n)))
                       (iszero-S n))
    ⟩
  collatz-s₅ (succ₁ (succ₁ n)) false
    ≡⟨ proof₅₋₇ (succ₁ (succ₁ n)) ⟩
  collatz-s₇ (succ₁ (succ₁ n))
    ≡⟨ proof₇₋₈ h ⟩
  collatz-s₈ (succ₁ (succ₁ n)) false
    ≡⟨ proof₈₋₁₀ (succ₁ (succ₁ n)) ⟩
  collatz (3' * (succ₁ (succ₁ n)) + 1') ∎


------------------------------------------------------------------------
-- Equivalences with erased "proofs"
------------------------------------------------------------------------

-- This module contains some basic definitions with few dependencies.
-- See Equivalence.Erased for more definitions. The definitions below
-- are reexported from Equivalence.Erased.

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

open import Equality

module Equivalence.Erased.Basics
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open Derived-definitions-and-properties eq
open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (id; [_,_]) renaming (_∘_ to _⊚_)

open import Equivalence eq as Eq using (_≃_; Is-equivalence)
import Equivalence.Half-adjoint eq as HA
open import Erased.Basics
open import Preimage eq as Preimage using (_⁻¹_)

private
  variable
    a b c d ℓ : Level
    A B C     : Type a
    p x y     : A
    P Q       : A → Type p
    f g       : (x : A) → P x

------------------------------------------------------------------------
-- Is-equivalenceᴱ

-- Is-equivalence with erased proofs.

Is-equivalenceᴱ : {A : Type a} {B : Type b} → @0 (A → B) → Type (a ⊔ b)
Is-equivalenceᴱ {A = A} {B = B} f =
  ∃ λ (f⁻¹ : B → A) → Erased (HA.Proofs f f⁻¹)

------------------------------------------------------------------------
-- Some conversion lemmas

-- Conversions between Is-equivalence and Is-equivalenceᴱ.

Is-equivalence→Is-equivalenceᴱ :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} →
  Is-equivalence f → Is-equivalenceᴱ f
Is-equivalence→Is-equivalenceᴱ = Σ-map P.id [_]→

@0 Is-equivalenceᴱ→Is-equivalence :
  Is-equivalenceᴱ f → Is-equivalence f
Is-equivalenceᴱ→Is-equivalence = Σ-map P.id erased

-- See also Equivalence.Erased.Is-equivalence≃Is-equivalenceᴱ.

------------------------------------------------------------------------
-- _≃ᴱ_

private
 module Dummy where

  -- Equivalences with erased proofs.

  infix 4 _≃ᴱ_

  record _≃ᴱ_ (A : Type a) (B : Type b) : Type (a ⊔ b) where
    constructor ⟨_,_⟩
    field
      to             : A → B
      is-equivalence : Is-equivalenceᴱ to

open Dummy public using (_≃ᴱ_; ⟨_,_⟩) hiding (module _≃ᴱ_)

-- A variant of the constructor of _≃ᴱ_ with erased type arguments.

⟨_,_⟩₀ :
  {@0 A : Type a} {@0 B : Type b}
  (to : A → B) → Is-equivalenceᴱ to → A ≃ᴱ B
⟨ to , eq ⟩₀ = ⟨ to , eq ⟩

-- Note that the type arguments A and B are erased. This is not the
-- case for the record module Dummy._≃ᴱ_.

module _≃ᴱ_ {@0 A : Type a} {@0 B : Type b} (A≃B : A ≃ᴱ B) where

  -- The "left-to-right" direction of the equivalence.

  to : A → B
  to = let ⟨ to , _ ⟩ = A≃B in to

  -- The function to is an equivalence.

  is-equivalence : Is-equivalenceᴱ to
  is-equivalence = let ⟨ _ , eq ⟩ = A≃B in eq

  -- The "right-to-left" direction of the equivalence.

  from : B → A
  from = let from , _ = is-equivalence in from

  -- The underlying logical equivalence.

  logical-equivalence : A ⇔ B
  logical-equivalence = record
    { to   = to
    ; from = from
    }

  -- In an erased context one can construct a corresponding
  -- equivalence.

  @0 equivalence : A ≃ B
  equivalence =
    Eq.⟨ to , Is-equivalenceᴱ→Is-equivalence is-equivalence ⟩

  -- In an erased context the function from is a right inverse of to.

  @0 right-inverse-of : ∀ y → to (from y) ≡ y
  right-inverse-of = _≃_.right-inverse-of equivalence

  -- In an erased context the function from is a left inverse of to.

  @0 left-inverse-of : ∀ x → from (to x) ≡ x
  left-inverse-of = _≃_.left-inverse-of equivalence

  -- Two coherence properties.

  @0 left-right-lemma :
    ∀ x → cong to (left-inverse-of x) ≡ right-inverse-of (to x)
  left-right-lemma = _≃_.left-right-lemma equivalence

  @0 right-left-lemma :
    ∀ x → cong from (right-inverse-of x) ≡ left-inverse-of (from x)
  right-left-lemma = _≃_.right-left-lemma equivalence

private
  variable
    A≃B : A ≃ᴱ B

------------------------------------------------------------------------
-- More conversion lemmas

-- Equivalences are equivalent to pairs.

≃ᴱ-as-Σ : (A ≃ᴱ B) ≃ (∃ λ (f : A → B) → Is-equivalenceᴱ f)
≃ᴱ-as-Σ = Eq.↔⇒≃ (record
  { surjection = record
    { logical-equivalence = record
      { to   = λ { ⟨ f , is ⟩ → f , is }
      ; from = uncurry ⟨_,_⟩
      }
    ; right-inverse-of = refl
    }
  ; left-inverse-of = refl
  })

-- Conversions between _≃_ and _≃ᴱ_.

≃→≃ᴱ :
  {@0 A : Type a} {@0 B : Type b} →
  A ≃ B → A ≃ᴱ B
≃→≃ᴱ Eq.⟨ f , is-equiv ⟩ =
  ⟨ f , Is-equivalence→Is-equivalenceᴱ is-equiv ⟩

@0 ≃ᴱ→≃ : A ≃ᴱ B → A ≃ B
≃ᴱ→≃ = _≃ᴱ_.equivalence

-- Data corresponding to the erased proofs of an equivalence with
-- erased proofs.

record Erased-proofs {A : Type a} {B : Type b}
                     (to : A → B) (from : B → A) : Type (a ⊔ b) where
  field
    proofs : HA.Proofs to from

-- Extracts "erased proofs" from a regular equivalence.

[proofs] :
  {@0 A : Type a} {@0 B : Type b}
  (A≃B : A ≃ B) → Erased-proofs (_≃_.to A≃B) (_≃_.from A≃B)
[proofs] A≃B .Erased-proofs.proofs =
  let record { is-equivalence = is-equivalence } = A≃B in
  proj₂₀ is-equivalence

-- Converts two functions and some erased proofs to an equivalence
-- with erased proofs.
--
-- Note that Agda can in many cases infer "to" and "from" from the
-- first explicit argument, see (for instance) ↔→≃ᴱ below.

[≃]→≃ᴱ :
  {@0 A : Type a} {@0 B : Type b} {to : A → B} {from : B → A} →
  @0 Erased-proofs to from →
  A ≃ᴱ B
[≃]→≃ᴱ {to = to} {from = from} ep =
  ⟨ to , (from , [ ep .Erased-proofs.proofs ]) ⟩

-- A function with a quasi-inverse with erased proofs can be turned
-- into an equivalence with erased proofs.

↔→≃ᴱ :
  {@0 A : Type a} {@0 B : Type b}
  (f : A → B) (g : B → A) →
  @0 (∀ x → f (g x) ≡ x) →
  @0 (∀ x → g (f x) ≡ x) →
  A ≃ᴱ B
↔→≃ᴱ {A = A} {B = B} f g f∘g g∘f = [≃]→≃ᴱ ([proofs] A≃B′)
  where
  @0 A≃B′ : A ≃ B
  A≃B′ = Eq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { to   = f
        ; from = g
        }
      ; right-inverse-of = f∘g
      }
    ; left-inverse-of = g∘f
    })

-- A variant of ↔→≃ᴱ.

⇔→≃ᴱ :
  {@0 A : Type a} {@0 B : Type b} →
  @0 Is-proposition A → @0 Is-proposition B →
  (A → B) → (B → A) →
  A ≃ᴱ B
⇔→≃ᴱ A-prop B-prop to from =
  [≃]→≃ᴱ ([proofs] (Eq.⇔→≃ A-prop B-prop to from))

------------------------------------------------------------------------
-- Equivalences with erased proofs form an equivalence relation

-- Identity.

id : {@0 A : Type a} → A ≃ᴱ A
id = [≃]→≃ᴱ ([proofs] Eq.id)

-- Inverse.

inverse :
  {@0 A : Type a} {@0 B : Type b} →
  A ≃ᴱ B → B ≃ᴱ A
inverse A≃B = [≃]→≃ᴱ ([proofs] (Eq.inverse (≃ᴱ→≃ A≃B)))

-- Composition.

infixr 9 _∘_

_∘_ :
  {@0 A : Type a} {@0 B : Type b} {@0 C : Type c} →
  B ≃ᴱ C → A ≃ᴱ B → A ≃ᴱ C
f ∘ g = [≃]→≃ᴱ ([proofs] (≃ᴱ→≃ f Eq.∘ ≃ᴱ→≃ g))

------------------------------------------------------------------------
-- A preservation lemma

-- Is-equivalenceᴱ f is logically equivalent to Is-equivalenceᴱ g if f
-- and g are pointwise equal.
--
-- See also Equivalence.Erased.[]-cong₂-⊔.Is-equivalenceᴱ-cong.

Is-equivalenceᴱ-cong-⇔ :
  {@0 A : Type a} {@0 B : Type b} {@0 f g : A → B} →
  @0 (∀ x → f x ≡ g x) →
  Is-equivalenceᴱ f ⇔ Is-equivalenceᴱ g
Is-equivalenceᴱ-cong-⇔ {f = f} {g = g} f≡g =
  record { to = to f≡g; from = to (sym ⊚ f≡g) }
  where
  to :
    {@0 A : Type a} {@0 B : Type b} {@0 f g : A → B} →
    @0 (∀ x → f x ≡ g x) →
    Is-equivalenceᴱ f → Is-equivalenceᴱ g
  to f≡g f-eq@(f⁻¹ , _) =
    ( f⁻¹
    , [ erased $ proj₂ $
        Is-equivalence→Is-equivalenceᴱ $
        Eq.respects-extensional-equality f≡g $
        Is-equivalenceᴱ→Is-equivalence f-eq
      ]
    )

----------------------------------------------------------------------
-- The left-to-right and right-to-left components of an equivalence
-- with erased proofs can be replaced with extensionally equal
-- functions

-- The forward direction of an equivalence with erased proofs can be
-- replaced by an extensionally equal function.

with-other-function :
  {@0 A : Type a} {@0 B : Type b}
  (A≃B : A ≃ᴱ B) (f : A → B) →
  @0 (∀ x → _≃ᴱ_.to A≃B x ≡ f x) →
  A ≃ᴱ B
with-other-function ⟨ g , is-equivalence ⟩ f g≡f =
  ⟨ f
  , (let record { to = to } = Is-equivalenceᴱ-cong-⇔ g≡f in
     to is-equivalence)
  ⟩₀

_ : _≃ᴱ_.to (with-other-function A≃B f p) ≡ f
_ = refl _

_ : _≃ᴱ_.from (with-other-function A≃B f p) ≡ _≃ᴱ_.from A≃B
_ = refl _

-- The same applies to the other direction.

with-other-inverse :
  {@0 A : Type a} {@0 B : Type b}
  (A≃B : A ≃ᴱ B) (g : B → A) →
  @0 (∀ x → _≃ᴱ_.from A≃B x ≡ g x) →
  A ≃ᴱ B
with-other-inverse A≃B g ≡g =
  inverse $ with-other-function (inverse A≃B) g ≡g

_ : _≃ᴱ_.from (with-other-inverse A≃B g p) ≡ g
_ = refl _

_ : _≃ᴱ_.to (with-other-inverse A≃B f p) ≡ _≃ᴱ_.to A≃B
_ = refl _


-- 2010-09-29 Andreas, mail to Ulf

module ExistentialsProjections where

postulate
 .irrelevant : {A : Set} -> .A -> A

record Exists (A : Set) (P : A -> Set) : Set where
  constructor exists
  field
    .fwitness : A
    fcontent : P fwitness

.witness : forall {A P} -> (x : Exists A P) -> A
witness (exists a p) = irrelevant a

-- second projection out of existential is breaking abstraction, so should be forbidden

content : forall {A P} -> (x : Exists A P) -> P (witness x)
content (exists a p) = p  -- should not typecheck!!

{- We have p : P a != P (witness (exists a p)) = P (irrelevant a)
because a != irrelevant a.
-}


------------------------------------------------------------------------
-- Some corollaries
------------------------------------------------------------------------

module TotalParserCombinators.Derivative.Corollaries where

open import Data.List
open import Function.Base
open import Function.Inverse using (_↔_)
import Function.Related as Related
import Relation.Binary.PropositionalEquality as P

open Related using (SK-sym)

open import TotalParserCombinators.Derivative.Definition
open import TotalParserCombinators.Derivative.LeftInverse
open import TotalParserCombinators.Derivative.RightInverse
open import TotalParserCombinators.Derivative.SoundComplete
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics

-- D is correct.

correct : ∀ {Tok R xs x s} {t} {p : Parser Tok R xs} →
          x ∈ D t p · s ↔ x ∈ p · t ∷ s
correct {p = p} = record
  { to         = P.→-to-⟶ $ sound p
  ; from       = P.→-to-⟶ complete
  ; inverse-of = record
    { left-inverse-of  = complete∘sound p
    ; right-inverse-of = sound∘complete
    }
  }

-- D is monotone.

mono : ∀ {Tok R xs₁ xs₂ t}
         {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
       p₁ ≲ p₂ → D t p₁ ≲ D t p₂
mono p₁≲p₂ = complete ∘ p₁≲p₂ ∘ sound _

-- D preserves parser and language equivalence.

cong : ∀ {k Tok R xs₁ xs₂}
         {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
       p₁ ∼[ k ] p₂ → ∀ {t} → D t p₁ ∼[ k ] D t p₂
cong {p₁ = p₁} {p₂} p₁≈p₂ {t} {x} {s} =
  x ∈ D t p₁ · s  ↔⟨ correct ⟩
  x ∈ p₁ · t ∷ s  ∼⟨ p₁≈p₂ ⟩
  x ∈ p₂ · t ∷ s  ↔⟨ SK-sym correct ⟩
  x ∈ D t p₂ · s  ∎
  where open Related.EquationalReasoning


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

-- Multicategories but over an 'index' type, rather than forcing Fin n
module Categories.Multi.Category.Indexed where

open import Level
open import Data.Fin.Base using (Fin)
open import Data.Product using (Σ; uncurry; curry; _×_; _,_; proj₁; proj₂)
open import Data.Product.Properties
open import Data.Unit.Polymorphic using (⊤; tt)
open import Data.Vec.Functional
open import Function.Base using (const) renaming (_∘_ to _●_; id to id→)
open import Function.Equality using (_⟨$⟩_)
-- note how this is Function.Inverse instead of the one from Function.
open import Function.Inverse as Inv renaming (id to id↔; _∘_ to trans)
open import Relation.Binary.Core using (Rel)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

-- any point can be lifted to a function from ⊤
pointed : {s t : Level} {S : Set s} (x : S) → ⊤ {t} → S
pointed x _ = x

-- the standard library doesn't seem to have the 'right' version of these.
⊤×K↔K : {t k : Level} {K : Set k} → (⊤ {t} × K) ↔ K
⊤×K↔K = inverse proj₂ (tt ,_) (λ _ → refl) λ _ → refl

K×⊤↔K : {t k : Level} {K : Set k} → (K × ⊤ {t}) ↔ K
K×⊤↔K = inverse proj₁ (_, tt) (λ _ → refl) λ _ → refl

⊤×⊤↔⊤ : {t : Level} → (⊤ {t} × ⊤) ↔ ⊤
⊤×⊤↔⊤ = inverse proj₁ (λ x → x , x) (λ _ → refl) λ _ → refl

Σ-assoc : {a b c : Level} {I : Set a} {J : I → Set b} {K : Σ I J → Set c} →
  Σ (Σ I J) K ↔ Σ I (λ i → Σ (J i) (curry K i))
Σ-assoc {I = I} {J} {K} = inverse g f (λ _ → refl) λ _ → refl
  where
  f : Σ I (λ i → Σ (J i) (λ j → K (i , j))) → Σ (Σ I J) K
  f (i , j , k) = (i , j) , k
  g : Σ (Σ I J) K → Σ I (λ i → Σ (J i) (λ j → K (i , j)))
  g ((i , j) , k) = i , j , k

-- the ι level is for the 'index' (and to not steal 'i')

-- The important part is that in _∘_, there is no flattening of the
-- index set. But also _≈[_]_ builds in an explicit equivalence
-- that allows one to properly re-index things. The classical view
-- of MultiCategory sweeps all of that under the rug, which gives
-- Agda conniptions (and rightfully so). The advantage of doing it
-- this way makes it clear that the 3 laws are based on the underlying
-- 3 laws that hold for (dependent!) product.

-- The upshot is that this version of MultiCategory makes no finiteness
-- assumption whatsoever.  The index sets involved could be huge,
-- without any issues.

-- Note that this still isn't Symmetric Multicategory. The renaming that
-- happens on indices say nothing about the relation to the contents
-- of the other Hom set.
record MultiCategory {o ℓ e ı : Level} : Set (suc (o ⊔ ℓ ⊔ e ⊔ ı)) where
  infix  4 _≈[_]_
  infixr 9 _∘_

  field
    Obj : Set o
    Hom : {I : Set ı} → (I → Obj) → Obj → Set ℓ
    id : (o : Obj) → Hom {⊤} (pointed o) o
    _∘_ : {I : Set ı} {aₙ : I → Obj} {a : Obj} {J : I → Set ı}
          {v : (i : I) → J i → Obj} {b : I → Obj} →
          Hom {I} aₙ a → ((i : I) → Hom (v i) (b i)) → Hom {Σ I J} (uncurry v) a
    _≈[_]_ : {I J : Set ı} {aₙ : I → Obj} {a : Obj} →
          Hom {I} aₙ a → (σ : I ↔ J) → Hom {J} (aₙ ● ( Inverse.from σ ⟨$⟩_ )) a → Set e

    identityˡ : {K : Set ı} {aₖ : K → Obj} {a : Obj} {f : Hom aₖ a} →
              id a ∘ pointed f ≈[ ⊤×K↔K ]  f
    identityʳ : {K : Set ı} {aₖ : K → Obj} {a : Obj} {f : Hom aₖ a} →
              f ∘ (id ● aₖ) ≈[ K×⊤↔K ] f

    identity² : {a : Obj} → id a ∘ pointed (id a) ≈[ ⊤×⊤↔⊤ ] id a

    assoc : -- the 3 index sets
            {I : Set ı} {J : I → Set ı} {K : Σ I J → Set ı}
            -- the 3 sets of (indexed) objects
            {vh : I → Obj} {bh : Obj}
            {vg : (i : I) → J i → Obj} {bg : I → Obj}
            {vf : (h : Σ I J) → K h → Obj} {bf : Σ I J → Obj}
            -- the 3 Homs
            {h : Hom vh bh}
            {g : (i : I) → Hom (vg i) (bg i)}
            {f : (k : Σ I J) → Hom (vf k) (bf k)} →
            -- and their relation under composition
            (h ∘ g) ∘ f ≈[ Σ-assoc ] h ∘ (λ i → g i ∘ curry f i)

    -- we also need that _≈[_]_ is, in an appropriate sense, an equivalence relation, which in this case
    -- means that _≈[ id↔ ]_ is.  In other words, we don't care when transport is over 'something else'.
    refl≈ : {I : Set ı} {aₙ : I → Obj} {a : Obj} →
            {h : Hom {I} aₙ a} → h ≈[ id↔ ] h
    sym≈ : {I : Set ı} {aₙ : I → Obj} {a : Obj} →
           {g h : Hom {I} aₙ a} → g ≈[ id↔ ] h → h ≈[ id↔ ] g
    trans≈ : {I : Set ı} {aₙ : I → Obj} {a : Obj} →
           {f g h : Hom {I} aₙ a} → f ≈[ id↔ ] g → g ≈[ id↔ ] h → f ≈[ id↔ ] h

    -- we probably need ∘-resp-≈ too.


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

module Data.Empty where

open import Data.Empty.Base public


module non-regular where

open import Data.Nat
open import Data.Empty
open import Data.List
open import Data.Maybe hiding ( map )
open import Relation.Binary.PropositionalEquality hiding ( [_] )
open import logic
open import automaton
open import automaton-ex
open import finiteSetUtil
open import finiteSet
open import Relation.Nullary
open import regular-language
open import nat

open FiniteSet

inputnn :  List  In2 → Maybe (List In2)
inputnn [] = just []
inputnn  (i1 ∷ t) = just (i1 ∷ t)
inputnn  (i0 ∷ t) with inputnn t
... | nothing = nothing
... | just [] = nothing
... | just (i0 ∷ t1) = nothing   -- can't happen
... | just (i1 ∷ t1) = just t1   -- remove i1 from later part

inputnn1 :  List  In2 → Bool
inputnn1  s with inputnn  s
... | nothing = false
... | just [] = true
... | just _ = false

t1 = inputnn1 ( i0 ∷ i1 ∷ [] )
t2 = inputnn1 ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ [] )
t3 = inputnn1 ( i0 ∷ i0 ∷ i0 ∷ i1 ∷ i1 ∷ [] )

inputnn0 : ( n :  ℕ )  →  { Σ : Set  } → ( x y : Σ ) → List  Σ → List  Σ
inputnn0 zero {_} _ _ s = s
inputnn0 (suc n) x y s = x  ∷ ( inputnn0 n x y ( y  ∷ s ) )

t4 : inputnn1 ( inputnn0 5 i0 i1 [] ) ≡ true
t4 = refl

t5 : ( n : ℕ ) → Set
t5 n = inputnn1 ( inputnn0 n i0 i1 [] ) ≡ true

--
--  if there is an automaton with n states , which accespt inputnn1, it has a trasition function.
--  The function is determinted by inputs,
--

open RegularLanguage
open Automaton

open _∧_

data Trace { Q : Set } { Σ : Set  } (fa : Automaton Q  Σ ) : (is : List Σ) → Q → Set where
    tend  : {q : Q} → aend fa q ≡ true → Trace fa [] q
    tnext : (q : Q) → {i : Σ} { is : List Σ}
        → Trace fa is (δ fa q i) → Trace fa (i ∷ is) q

tr-len :  { Q : Set } { Σ : Set  }
    → (fa : Automaton Q  Σ )
    → (is : List Σ) → (q : Q) → Trace fa is q → suc (length is) ≡ length (trace fa q is )
tr-len {Q} {Σ} fa .[] q (tend x) = refl
tr-len {Q} {Σ} fa (i ∷ is) q (tnext .q t) = cong suc (tr-len {Q} {Σ} fa is (δ fa q i) t)

tr-accept→ : { Q : Set } { Σ : Set  }
    → (fa : Automaton Q  Σ )
    → (is : List Σ) → (q : Q) → Trace fa is q → accept fa q is ≡ true
tr-accept→ {Q} {Σ} fa [] q (tend x)  = x
tr-accept→ {Q} {Σ} fa (i ∷ is) q  (tnext _ tr) = tr-accept→ {Q} {Σ} fa is (δ fa q i) tr

tr-accept← : { Q : Set } { Σ : Set  }
    → (fa : Automaton Q  Σ )
    → (is : List Σ) → (q : Q)  → accept fa q is ≡ true → Trace fa is q
tr-accept← {Q} {Σ} fa [] q ac = tend ac
tr-accept← {Q} {Σ} fa (x ∷ []) q ac = tnext _ (tend ac )
tr-accept← {Q} {Σ} fa (x ∷ x1 ∷ is) q ac = tnext _ (tr-accept← fa (x1 ∷ is)  (δ fa q x)  ac)

tr→qs : { Q : Set } { Σ : Set  }
    → (fa : Automaton Q  Σ )
    → (is : List Σ) → (q : Q) → Trace fa is q → List Q
tr→qs fa [] q (tend x) = []
tr→qs fa (i ∷ is) q (tnext q tr) = q ∷ tr→qs fa is (δ fa q i) tr

tr→qs=is : { Q : Set } { Σ : Set  }
    → (fa : Automaton Q  Σ )
    → (is : List Σ) → (q : Q) → (tr : Trace fa is q ) → length is ≡  length (tr→qs fa is q tr)
tr→qs=is fa .[] q (tend x) = refl
tr→qs=is fa (i ∷ is) q (tnext .q tr) = cong suc (tr→qs=is fa is  (δ fa q i) tr)

open Data.Maybe

open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ )
open import Relation.Binary.Definitions
open import Data.Unit using (⊤ ; tt)
open import Data.Nat.Properties

data QDSEQ { Q : Set } { Σ : Set  } { fa : Automaton  Q  Σ} ( finq : FiniteSet Q) (qd : Q) (z1 :  List Σ) :
       {q : Q} {y2 : List Σ} → Trace fa (y2 ++ z1) q → Set where
   qd-nil :  (q : Q) → (tr : Trace fa z1 q) → equal? finq qd q ≡ true → QDSEQ finq qd z1 tr
   qd-next : {i : Σ} (y2 : List Σ) → (q : Q) → (tr : Trace fa (y2 ++ z1) (δ fa q i)) → equal? finq qd q ≡ false
       → QDSEQ finq qd z1 tr
       → QDSEQ finq qd z1 (tnext q tr)

record TA1 { Q : Set } { Σ : Set  } (fa : Automaton Q  Σ ) (finq : FiniteSet Q)  ( q qd : Q ) (is : List Σ)  : Set where
    field
       y z : List Σ
       yz=is : y ++ z ≡ is
       trace-z    : Trace fa z  qd
       trace-yz   : Trace fa (y ++ z)  q
       q=qd : QDSEQ finq qd z trace-yz

--
-- using accept ≡ true may simplify the pumping-lemma
-- QDSEQ is too complex, should we generate (lengty y ≡ 0 → equal ) ∧  ...
--
-- like this ...
-- record TA2 { Q : Set } { Σ : Set  } (fa : Automaton Q  Σ ) (finq : FiniteSet Q)  ( q qd : Q ) (is : List Σ)  : Set where
--     field
--        y z : List Σ
--        yz=is : y ++ z ≡ is
--        trace-z    : accpet fa z qd ≡ true
--        trace-yz   : accept fa (y ++ z)  q ≡ true
--        q=qd  : last (tr→qs fa q trace-yz) ≡ just qd
--        ¬q=qd : non-last (tr→qs fa q trace-yz) ≡ just qd

record TA { Q : Set } { Σ : Set  } (fa : Automaton Q  Σ )   ( q : Q ) (is : List Σ)  : Set where
    field
       x y z : List Σ
       xyz=is : x ++ y ++ z ≡ is
       trace-xyz  : Trace fa (x ++ y ++ z)  q
       trace-xyyz : Trace fa (x ++ y ++ y ++ z) q
       non-nil-y : ¬ (y ≡ [])

pumping-lemma : { Q : Set } { Σ : Set  } (fa : Automaton Q  Σ ) (finq : FiniteSet Q) (q qd : Q) (is : List Σ)
     → (tr : Trace fa is q )
     → dup-in-list finq qd (tr→qs fa is q tr) ≡ true
     → TA fa q is
pumping-lemma {Q} {Σ} fa finq q qd is tr dup = tra-phase1 q is tr dup where
   open TA
   tra-phase2 : (q : Q)  → (is : List Σ)  → (tr : Trace fa is  q )
       → phase2 finq qd (tr→qs fa is q tr) ≡ true → TA1 fa finq q qd is
   tra-phase2 q (i ∷ is) (tnext q tr) p with equal? finq qd q | inspect ( equal? finq qd) q
   ... | true | record { eq = eq } = record { y = [] ; z = i ∷ is ; yz=is = refl ; q=qd = qd-nil q (tnext q tr) eq
        ; trace-z  = subst (λ k → Trace fa (i ∷ is) k ) (sym (equal→refl finq eq)) (tnext q tr) ; trace-yz = tnext q tr }
   ... | false | record { eq = ne } = record { y = i ∷ TA1.y ta ; z = TA1.z ta ; yz=is = cong (i ∷_ ) (TA1.yz=is ta )
       ; q=qd = tra-08
       ; trace-z = TA1.trace-z ta ; trace-yz = tnext q ( TA1.trace-yz ta ) } where
            ta : TA1 fa finq (δ fa q i) qd is
            ta = tra-phase2 (δ fa q i) is tr p
            tra-07 : Trace fa (TA1.y ta ++ TA1.z ta) (δ fa q i)
            tra-07 = subst (λ k → Trace fa k (δ fa q i)) (sym (TA1.yz=is ta)) tr
            tra-08 : QDSEQ finq qd (TA1.z ta) (tnext q (TA1.trace-yz ta))
            tra-08 = qd-next (TA1.y ta) q (TA1.trace-yz (tra-phase2 (δ fa q i) is tr p))  ne (TA1.q=qd ta)
   tra-phase1 : (q : Q)  → (is : List Σ)  → (tr : Trace fa is  q ) → phase1 finq qd (tr→qs fa is q tr) ≡ true  → TA fa q is
   tra-phase1 q (i ∷ is) (tnext q tr) p with equal? finq qd q | inspect (equal? finq qd) q
   ... | true | record { eq = eq } = record { x = [] ; y = i ∷ TA1.y ta ;  z = TA1.z ta ; xyz=is =  cong (i ∷_ ) (TA1.yz=is ta)
           ; non-nil-y = λ ()
           ; trace-xyz  = tnext q (TA1.trace-yz ta)
           ; trace-xyyz = tnext q tra-05 } where
        ta : TA1 fa finq (δ fa q i ) qd is
        ta = tra-phase2 (δ fa q i ) is tr p
        y1 = TA1.y ta
        z1 = TA1.z ta
        tryz0 : Trace fa (y1 ++ z1) (δ fa qd i)
        tryz0 = subst₂ (λ j k → Trace fa k (δ fa j i) ) (sym (equal→refl finq eq)) (sym (TA1.yz=is ta)) tr
        tryz : Trace fa (i ∷ y1 ++ z1) qd
        tryz = tnext qd tryz0
        -- create Trace (y ++ y ++ z)
        tra-04 : (y2 : List Σ) → (q : Q) → (tr : Trace fa (y2 ++ z1) q)
               →  QDSEQ finq qd z1 {q} {y2} tr
               → Trace fa (y2 ++ (i ∷ y1) ++ z1) q
        tra-04 [] q tr (qd-nil q _ x₁) with equal? finq qd q | inspect (equal? finq qd) q
        ... | true | record { eq = eq } = subst (λ k → Trace fa (i ∷ y1 ++ z1) k) (equal→refl finq eq) tryz
        ... | false | record { eq = ne } = ⊥-elim ( ¬-bool  refl x₁ )
        tra-04 (y0 ∷ y2) q (tnext q tr) (qd-next _ _  _ x₁ qdseq) with equal? finq qd q | inspect (equal? finq qd) q
        ... | true | record { eq = eq } = ⊥-elim ( ¬-bool x₁ refl )
        ... | false | record { eq = ne } = tnext q (tra-04 y2 (δ fa q y0) tr qdseq )
        tra-05 : Trace fa (TA1.y ta ++ (i ∷ TA1.y ta) ++ TA1.z ta) (δ fa q i)
        tra-05 with equal→refl finq eq
        ... | refl = tra-04 y1  (δ fa qd i) (TA1.trace-yz ta) (TA1.q=qd ta)
   ... | false | _ = record { x = i ∷ x ta ; y = y ta ; z = z ta ; xyz=is = cong (i ∷_ ) (xyz=is ta)
           ; non-nil-y = non-nil-y ta
            ; trace-xyz = tnext q (trace-xyz ta ) ; trace-xyyz = tnext q (trace-xyyz ta )} where
        ta : TA fa (δ fa q i ) is
        ta = tra-phase1 (δ fa q i ) is tr p

open RegularLanguage
open import Data.Nat.Properties
open import nat

lemmaNN : (r : RegularLanguage In2 ) → ¬ ( (s : List In2)  → isRegular inputnn1  s r )
lemmaNN r Rg = tann {TA.x TAnn} (TA.non-nil-y TAnn ) {!!} (tr-accept→ (automaton r) _  (astart r) (TA.trace-xyz TAnn) )
       (tr-accept→ (automaton r) _  (astart r) (TA.trace-xyyz TAnn) ) where
    n : ℕ
    n = suc (finite (afin r))
    nn =  inputnn0 n i0 i1 []
    nn01  : (i : ℕ) → inputnn1 ( inputnn0 i i0 i1 [] ) ≡ true
    nn01 zero = refl
    nn01 (suc i) = {!!} where
      nn02 : (i : ℕ) → ( x : List In2) → inputnn ( inputnn0 i i0 i1 x ) ≡ inputnn x
      nn02 zero _ = refl
      nn02 (suc i) x with inputnn (inputnn0 (suc i) i0 i1 x)
      ... | nothing = {!!}
      ... | just []  = {!!}
      ... | just (i0 ∷ t1)   = {!!}
      ... | just (i1 ∷ t1)   = {!!}
    nn03 : accept (automaton r) (astart r) nn ≡ true
    nn03 = subst (λ k → k ≡ true ) (Rg nn ) (nn01 n)
    nn09 : (n m : ℕ) → n ≤ n + m
    nn09 zero m = z≤n
    nn09 (suc n) m = s≤s (nn09 n m)
    nn04 :  Trace (automaton r) nn (astart r)
    nn04 = tr-accept← (automaton r) nn (astart r) nn03
    nntrace = tr→qs (automaton r) nn (astart r) nn04
    nn07 : (n : ℕ) →  length (inputnn0 n i0 i1 []) ≡ n + n
    nn07 n = subst (λ k → length (inputnn0 n i0 i1 []) ≡ k) (+-comm (n + n) _ ) (nn08 n [] )where
       nn08 : (n : ℕ) → (s : List In2) → length (inputnn0 n i0 i1 s) ≡ n + n + length s
       nn08 zero s = refl
       nn08 (suc n) s = begin
         length (inputnn0 (suc n) i0 i1 s) ≡⟨ refl ⟩
         suc (length (inputnn0 n i0 i1 (i1 ∷ s))) ≡⟨ cong suc (nn08 n (i1 ∷ s)) ⟩
         suc (n + n + suc (length s)) ≡⟨ +-assoc (suc n) n _  ⟩
         suc n + (n + suc (length s)) ≡⟨ cong (λ k → suc n + k) (sym (+-assoc n  _ _))  ⟩
         suc n + ((n + 1) + length s) ≡⟨ cong (λ k → suc n + (k + length s)) (+-comm n _) ⟩
         suc n + (suc n + length s) ≡⟨ sym (+-assoc (suc n)  _ _) ⟩
         suc n + suc n + length s  ∎  where open ≡-Reasoning
    nn05 : length nntrace > finite (afin r)
    nn05 = begin
         suc (finite (afin r))  ≤⟨ nn09 _ _ ⟩
         n + n   ≡⟨ sym (nn07 n) ⟩
         length (inputnn0 n i0 i1 []) ≡⟨ tr→qs=is (automaton r) (inputnn0 n i0 i1 []) (astart r) nn04 ⟩
         length nntrace ∎  where open ≤-Reasoning
    nn06 : Dup-in-list ( afin r) (tr→qs (automaton r) nn (astart r) nn04)
    nn06 = dup-in-list>n (afin r) nntrace nn05
    TAnn : TA (automaton r) (astart r) nn
    TAnn = pumping-lemma (automaton r) (afin r) (astart r) (Dup-in-list.dup nn06) nn nn04 (Dup-in-list.is-dup nn06)
    count : In2 → List In2 → ℕ
    count _ [] = 0
    count i0 (i0 ∷ s) = suc (count i0 s)
    count i1 (i1 ∷ s) = suc (count i1 s)
    count x (_ ∷ s) = count x s
    nn11 : {x : In2} → (s t : List In2) → count x (s ++ t) ≡ count x s + count x t
    nn11 {x} [] t = refl
    nn11 {i0} (i0 ∷ s) t = cong suc ( nn11 s t )
    nn11 {i0} (i1 ∷ s) t = nn11 s t
    nn11 {i1} (i0 ∷ s) t = nn11 s t
    nn11 {i1} (i1 ∷ s) t = cong suc ( nn11 s t )
    nn10 : (s : List In2) → accept (automaton r) (astart r) s ≡ true → count i0 s ≡ count i1 s
    nn10 s p = nn101 s (subst (λ k → k ≡ true) (sym (Rg s)) p ) where
        nn101 : (s : List In2) → inputnn1 s ≡ true →  count i0 s ≡ count i1 s
        nn101 [] p = refl
        nn101 (x ∷ s) p = {!!}
    i1-i0? : List In2 → Bool
    i1-i0? [] = false
    i1-i0? (i1 ∷ []) = false
    i1-i0? (i0 ∷ []) = false
    i1-i0? (i1 ∷ i0 ∷ s) = true
    i1-i0? (_ ∷ s0 ∷ s1) = i1-i0? (s0 ∷ s1)
    nn20 : {s s0 s1 : List In2} → accept (automaton r) (astart r) s ≡ true → ¬ ( s ≡ s0 ++ i1 ∷ i0 ∷ s1 )
    nn20 {s} {s0} {s1} p np = {!!}
    mono-color : List In2 → Bool
    mono-color [] = true
    mono-color (i0 ∷ s) = mono-color0 s where
        mono-color0 : List In2 → Bool
        mono-color0 [] = true
        mono-color0 (i1 ∷ s) = false
        mono-color0 (i0 ∷ s) = mono-color0 s
    mono-color (i1 ∷ s) = mono-color1 s where
        mono-color1 : List In2 → Bool
        mono-color1 [] = true
        mono-color1 (i0 ∷ s) = false
        mono-color1 (i1 ∷ s) = mono-color1 s
    record Is10 (s : List In2) : Set where
       field
           s0 s1 : List In2
           is-10 :  s ≡ s0 ++ i1 ∷ i0 ∷ s1
    not-mono : { s : List In2 } → ¬ (mono-color s ≡ true)  → Is10 (s ++ s)
    not-mono = {!!}
    mono-count : { s : List In2 } → mono-color s ≡ true   → (length s ≡ count i0 s) ∨ ( length s ≡ count i1 s)
    mono-count = {!!}
    tann : {x y z : List In2} → ¬ y ≡ []
       → x ++ y ++ z ≡ nn
       → accept (automaton r) (astart r) (x ++ y ++ z) ≡ true → ¬ (accept (automaton r) (astart r) (x ++ y ++ y ++ z)  ≡ true )
    tann {x} {y} {z} ny eq axyz axyyz with mono-color y
    ... | true = {!!}
    ... | false = {!!}


-- Intuitionistic propositional calculus.
-- Gentzen-style formalisation of syntax.
-- Normal forms and neutrals.

module IPC.Syntax.GentzenNormalForm where

open import IPC.Syntax.Gentzen public

-- Derivations.

mutual
  -- Normal forms, or introductions.
  infix 3 _⊢ⁿᶠ_
  data _⊢ⁿᶠ_ (Γ : Cx Ty) : Ty → Set where
    neⁿᶠ   : ∀ {A}   → Γ ⊢ⁿᵉ A → Γ ⊢ⁿᶠ A
    lamⁿᶠ  : ∀ {A B} → Γ , A ⊢ⁿᶠ B → Γ ⊢ⁿᶠ A ▻ B
    pairⁿᶠ : ∀ {A B} → Γ ⊢ⁿᶠ A → Γ ⊢ⁿᶠ B → Γ ⊢ⁿᶠ A ∧ B
    unitⁿᶠ : Γ ⊢ⁿᶠ ⊤
    inlⁿᶠ  : ∀ {A B} → Γ ⊢ⁿᶠ A → Γ ⊢ⁿᶠ A ∨ B
    inrⁿᶠ  : ∀ {A B} → Γ ⊢ⁿᶠ B → Γ ⊢ⁿᶠ A ∨ B

  -- Neutrals, or eliminations.
  infix 3 _⊢ⁿᵉ_
  data _⊢ⁿᵉ_ (Γ : Cx Ty) : Ty → Set where
    varⁿᵉ  : ∀ {A}     → A ∈ Γ → Γ ⊢ⁿᵉ A
    appⁿᵉ  : ∀ {A B}   → Γ ⊢ⁿᵉ A ▻ B → Γ ⊢ⁿᶠ A → Γ ⊢ⁿᵉ B
    fstⁿᵉ  : ∀ {A B}   → Γ ⊢ⁿᵉ A ∧ B → Γ ⊢ⁿᵉ A
    sndⁿᵉ  : ∀ {A B}   → Γ ⊢ⁿᵉ A ∧ B → Γ ⊢ⁿᵉ B
    boomⁿᵉ : ∀ {C}     → Γ ⊢ⁿᵉ ⊥ → Γ ⊢ⁿᵉ C
    caseⁿᵉ : ∀ {A B C} → Γ ⊢ⁿᵉ A ∨ B → Γ , A ⊢ⁿᶠ C → Γ , B ⊢ⁿᶠ C → Γ ⊢ⁿᵉ C

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

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

-- Translation to simple terms.

mutual
  nf→tm : ∀ {A Γ} → Γ ⊢ⁿᶠ A → Γ ⊢ A
  nf→tm (neⁿᶠ t)     = ne→tm t
  nf→tm (lamⁿᶠ t)    = lam (nf→tm t)
  nf→tm (pairⁿᶠ t u) = pair (nf→tm t) (nf→tm u)
  nf→tm unitⁿᶠ       = unit
  nf→tm (inlⁿᶠ t)    = inl (nf→tm t)
  nf→tm (inrⁿᶠ t)    = inr (nf→tm t)

  ne→tm : ∀ {A Γ} → Γ ⊢ⁿᵉ A → Γ ⊢ A
  ne→tm (varⁿᵉ i)      = var i
  ne→tm (appⁿᵉ t u)    = app (ne→tm t) (nf→tm u)
  ne→tm (fstⁿᵉ t)      = fst (ne→tm t)
  ne→tm (sndⁿᵉ t)      = snd (ne→tm t)
  ne→tm (boomⁿᵉ t)     = boom (ne→tm t)
  ne→tm (caseⁿᵉ t u v) = case (ne→tm t) (nf→tm u) (nf→tm v)

nf→tm⋆ : ∀ {Ξ Γ} → Γ ⊢⋆ⁿᶠ Ξ → Γ ⊢⋆ Ξ
nf→tm⋆ {∅}     ∙        = ∙
nf→tm⋆ {Ξ , A} (ts , t) = nf→tm⋆ ts , nf→tm t

ne→tm⋆ : ∀ {Ξ Γ} → Γ ⊢⋆ⁿᵉ Ξ → Γ ⊢⋆ Ξ
ne→tm⋆ {∅}     ∙        = ∙
ne→tm⋆ {Ξ , A} (ts , t) = ne→tm⋆ ts , ne→tm t

-- Monotonicity with respect to context inclusion.

mutual
  mono⊢ⁿᶠ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢ⁿᶠ A → Γ′ ⊢ⁿᶠ A
  mono⊢ⁿᶠ η (neⁿᶠ t)     = neⁿᶠ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᶠ η (lamⁿᶠ t)    = lamⁿᶠ (mono⊢ⁿᶠ (keep η) t)
  mono⊢ⁿᶠ η (pairⁿᶠ t u) = pairⁿᶠ (mono⊢ⁿᶠ η t) (mono⊢ⁿᶠ η u)
  mono⊢ⁿᶠ η unitⁿᶠ       = unitⁿᶠ
  mono⊢ⁿᶠ η (inlⁿᶠ t)    = inlⁿᶠ (mono⊢ⁿᶠ η t)
  mono⊢ⁿᶠ η (inrⁿᶠ t)    = inrⁿᶠ (mono⊢ⁿᶠ η t)

  mono⊢ⁿᵉ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢ⁿᵉ A → Γ′ ⊢ⁿᵉ A
  mono⊢ⁿᵉ η (varⁿᵉ i)      = varⁿᵉ (mono∈ η i)
  mono⊢ⁿᵉ η (appⁿᵉ t u)    = appⁿᵉ (mono⊢ⁿᵉ η t) (mono⊢ⁿᶠ η u)
  mono⊢ⁿᵉ η (fstⁿᵉ t)      = fstⁿᵉ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᵉ η (sndⁿᵉ t)      = sndⁿᵉ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᵉ η (boomⁿᵉ t)     = boomⁿᵉ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᵉ η (caseⁿᵉ t u v) = caseⁿᵉ (mono⊢ⁿᵉ η t) (mono⊢ⁿᶠ (keep η) u) (mono⊢ⁿᶠ (keep η) v)

mono⊢⋆ⁿᶠ : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢⋆ⁿᶠ Ξ → Γ′ ⊢⋆ⁿᶠ Ξ
mono⊢⋆ⁿᶠ {∅}     η ∙        = ∙
mono⊢⋆ⁿᶠ {Ξ , A} η (ts , t) = mono⊢⋆ⁿᶠ η ts , mono⊢ⁿᶠ η t

mono⊢⋆ⁿᵉ : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢⋆ⁿᵉ Ξ → Γ′ ⊢⋆ⁿᵉ Ξ
mono⊢⋆ⁿᵉ {∅}     η ∙        = ∙
mono⊢⋆ⁿᵉ {Ξ , A} η (ts , t) = mono⊢⋆ⁿᵉ η ts , mono⊢ⁿᵉ η t

-- Reflexivity.

refl⊢⋆ⁿᵉ : ∀ {Γ} → Γ ⊢⋆ⁿᵉ Γ
refl⊢⋆ⁿᵉ {∅}     = ∙
refl⊢⋆ⁿᵉ {Γ , A} = mono⊢⋆ⁿᵉ weak⊆ refl⊢⋆ⁿᵉ , varⁿᵉ top


module json where

open import general-util

data json : Set where
  json-null : json
  json-raw : rope → json
  json-string : string → json
  json-nat : nat → json
  json-array : 𝕃 json → json
  json-object : 𝕃 (string × json) → json

json-escape-string : string → string
json-escape-string str = 𝕃char-to-string $ rec $ string-to-𝕃char str where
  rec : 𝕃 char → 𝕃 char
  rec [] = []
  rec ('\b' :: chars) = '\\' :: 'b' :: rec chars
  rec ('\f' :: chars) = '\\' :: 'f' :: rec chars
  rec ('\n' :: chars) = '\\' :: 'n' :: rec chars
  rec ('\r' :: chars) = '\\' :: 'r' :: rec chars
  rec ('\t' :: chars) = '\\' :: 't' :: rec chars
  rec ('"'  :: chars) = '\\' :: '"' :: rec chars
  rec ('\\' :: chars) = '\\' :: '\\' :: rec chars
  rec (char :: chars) = char :: rec chars

{-# TERMINATING #-}
json-to-rope : json → rope
json-to-rope json-null = [[ "null" ]]
json-to-rope (json-raw rope) = rope
json-to-rope (json-string string) = [[ "\"" ]] ⊹⊹ [[ json-escape-string string ]] ⊹⊹ [[ "\"" ]]
json-to-rope (json-nat nat) = [[ ℕ-to-string nat ]]
json-to-rope (json-array array) = [[ "[" ]] ⊹⊹ 𝕃-to-rope json-to-rope "," array ⊹⊹ [[ "]" ]]
json-to-rope (json-object t) = [[ "{" ]] ⊹⊹ 𝕃-to-rope (uncurry λ k v → [[ "\"" ]] ⊹⊹ [[ json-escape-string k ]] ⊹⊹ [[ "\":" ]] ⊹⊹ json-to-rope v)  "," t ⊹⊹ [[ "}" ]]

json-rope : rope → json
json-rope rope = json-raw ([[ "\"" ]] ⊹⊹ rope ⊹⊹ [[ "\"" ]])

json-raw-string : string → json
json-raw-string str = json-raw [[ str ]]

putJson : json → IO ⊤
putJson = putRopeLn ∘ json-to-rope


open import Data.Nat     using (ℕ) renaming (_+_ to _+ᵢ_; _≤?_ to _≤?ᵢ_)
open import Agda.Builtin.Float renaming (primFloatPlus to _+ᵣ_; primFloatLess to _≤?ᵣ_)
open import Data.Bool    using (Bool; true; false; not; _∧_)
open import Data.Sum     using (inj₁; inj₂; _⊎_)
open import Data.Product using (_×_; _,_; -,_; _-,-_; ∃; ∃-syntax; proj₂)
open import Data.String  using (String; _≟_)
open import Relation.Nullary           using (¬_; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Nullary.Negation  using (contradiction)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)

vname = String
int = ℕ
real = Float
bool = Bool

data val : Set where
  Iv : int  → val
  Rv : real → val

data aexp : Set where
  Ic   : int   → aexp
  Rc   : real  → aexp
  V    : vname → aexp
  Plus : aexp  → aexp → aexp

data bexp : Set where
  Bc   : Bool → bexp
  Not  : bexp → bexp
  And  : bexp → bexp → bexp
  Less : aexp → aexp → bexp

data com : Set where
  SKIP  : com
  _::=_ : String → aexp → com
  _::_  : com → com → com
  IF_THEN_ELSE_ : bexp → com → com → com
  WHILE_DO_     : bexp → com → com

data ty : Set where
  Ity : ty
  Rty : ty

tyenv = vname → ty
state = vname → val

_[_::=_] : state → vname → val → state
(s [ X ::= n ]) Y with Y ≟ X
... | yes _ = n
... | no  _ = s Y

data _⊢ₐ_∷_ : tyenv → aexp → ty → Set where
  taexpI : ∀{Γ i} → Γ ⊢ₐ Ic i ∷ Ity
  taexpR : ∀{Γ r} → Γ ⊢ₐ Rc r ∷ Rty
  taexpV : ∀{Γ x} → Γ ⊢ₐ V x ∷ Γ x
  taexpP : ∀{Γ a₁ a₂ τ}
      → Γ ⊢ₐ a₁ ∷ τ
      → Γ ⊢ₐ a₂ ∷ τ
      → Γ ⊢ₐ Plus a₁ a₂ ∷ τ

data _⊢₆_ : tyenv → bexp → Set where
  tbexpC : ∀{Γ v} → Γ ⊢₆ Bc v
  tbexpN : ∀{Γ b} → Γ ⊢₆ b
                   → Γ ⊢₆ Not b
  tbexpA : ∀{Γ b₁ b₂}
      → Γ ⊢₆ b₁
      → Γ ⊢₆ b₂
      → Γ ⊢₆ And b₁ b₂
  tbexpL : ∀{Γ a₁ a₂ τ}
      → Γ ⊢ₐ a₁ ∷ τ
      → Γ ⊢ₐ a₂ ∷ τ
      → Γ ⊢₆ Less a₁ a₂

data _⊢_ : tyenv → com → Set where
  TSkip : ∀{Γ} → Γ ⊢ SKIP
  TLoc : ∀{Γ a x} → Γ ⊢ₐ a ∷ Γ x
                 → Γ ⊢ (x ::= a)
  TSeq : ∀{Γ c₁ c₂}
       → Γ ⊢ c₁
       → Γ ⊢ c₂
       → Γ ⊢ (c₁ :: c₂)
  TIf : ∀{Γ b c₁ c₂}
      → Γ ⊢₆ b
      → Γ ⊢ c₁
      → Γ ⊢ c₂
      → Γ ⊢ (IF b THEN c₁ ELSE c₂)
  TWhile : ∀{Γ b c}
         → Γ ⊢₆ b
         → Γ ⊢ c
         → Γ ⊢ (WHILE b DO c)

type : val → ty
type (Iv i) = Ity
type (Rv r) = Rty

_⊢ₛ_ : tyenv → state → Set
Γ ⊢ₛ s = ∀ x → type (s x) ≡ Γ x

data taval : aexp → state → val → Set where
  tavalI : ∀{i s}
         → taval (Ic i) s (Iv i)
  tavalR : ∀{r s}
         → taval (Rc r) s (Rv r)
  tavalV : ∀{x s}
         → taval (V x) s (s x)
  tavalSI : ∀{s a₁ a₂ i₁ i₂}
          → taval a₁ s (Iv i₁)
          → taval a₂ s (Iv i₂)
          → taval (Plus a₁ a₂) s (Iv (i₁ +ᵢ i₂))
  tavalSR : ∀{s a₁ a₂ r₁ r₂}
          → taval a₁ s (Rv r₁)
          → taval a₂ s (Rv r₂)
          → taval (Plus a₁ a₂) s (Rv (r₁ +ᵣ r₂))

data tbval : bexp → state → bool → Set where
  tbvalC : ∀{s v}
         → tbval (Bc v) s v
  tbvalN : ∀{s b bv}
         → tbval b s bv
         → tbval (Not b) s (not bv)
  tbvalA : ∀{s b₁ b₂ bv₁ bv₂}
         → tbval b₁ s bv₁
         → tbval b₂ s bv₂
         → tbval (And b₁ b₂) s (bv₁ ∧ bv₂)
  tbvalLI : ∀{s a₁ a₂ i₁ i₂}
         → taval a₁ s (Iv i₁)
         → taval a₂ s (Iv i₂)
         → tbval (Less a₁ a₂) s (⌊ i₁ ≤?ᵢ i₂ ⌋)
  tbvalLR : ∀{s a₁ a₂ r₁ r₂}
         → taval a₁ s (Rv r₁)
         → taval a₂ s (Rv r₂)
         → tbval (Less a₁ a₂) s (r₁ ≤?ᵣ r₂)

data ⦅_,_⦆→⦅_,_⦆ : com → state → com → state → Set where
  Loc : ∀{x a s v}
      → taval a s v
      → ⦅ x ::= a , s ⦆→⦅ SKIP , s [ x ::= v ] ⦆
  Comp₁ : ∀{c s}
        → ⦅ SKIP :: c , s ⦆→⦅ c , s ⦆
  Comp₂ : ∀{c₁ c₁′ c₂ s s′}
        →  ⦅ c₁       , s ⦆→⦅ c₁′       , s′ ⦆
        →  ⦅ c₁ :: c₂ , s ⦆→⦅ c₁′ :: c₂ , s′ ⦆
  IfTrue  : ∀{b s c₁ c₂}
          → tbval b s true
          → ⦅ IF b THEN c₁ ELSE c₂ , s ⦆→⦅ c₁ , s ⦆
  IfFalse : ∀{b s c₁ c₂}
          → tbval b s false
          → ⦅ IF b THEN c₁ ELSE c₂ , s ⦆→⦅ c₂ , s ⦆
  While : ∀{b s c}
        → ⦅ WHILE b DO c , s ⦆→⦅ IF b THEN (c :: (WHILE b DO c)) ELSE SKIP , s ⦆

data  ⦅_,_⦆→*⦅_,_⦆ : com → state → com → state → Set where
  Ref : ∀{c s} → ⦅ c , s ⦆→*⦅ c , s ⦆
  Step : ∀{c c′ c² s s′ s²}
       → ⦅ c  , s  ⦆→⦅ c′ , s′ ⦆
       → ⦅ c′ , s′ ⦆→*⦅ c² , s² ⦆
       → ⦅ c  , s  ⦆→*⦅ c² , s² ⦆

trans : ∀{c c′ c² s s′ s²}
      → ⦅ c  , s  ⦆→*⦅ c′ , s′ ⦆
      → ⦅ c′ , s′ ⦆→*⦅ c² , s² ⦆
      → ⦅ c  , s  ⦆→*⦅ c² , s² ⦆
trans Ref b = b
trans (Step x a) b = Step x (trans a b)

preservation-aval : ∀{Γ a s τ v}
  → Γ ⊢ₐ a ∷ τ
  → Γ ⊢ₛ s
  → taval a s v
  → type v ≡ τ
preservation-aval taexpI b tavalI = refl
preservation-aval taexpR b tavalR = refl
preservation-aval taexpV b (tavalV {x}) = b x
preservation-aval (taexpP a a₁) b (tavalSI c c₁) = preservation-aval a₁ b c₁
preservation-aval (taexpP a a₁) b (tavalSR c c₁) = preservation-aval a₁ b c₁

extract-ity : ∀ v
  → type v ≡ Ity
  → ∃[ i ] (v ≡ Iv i)
extract-ity (Iv x) r = x , refl

extract-rty : ∀ v
  → type v ≡ Rty
  → ∃[ i ] (v ≡ Rv i)
extract-rty (Rv x) r = x , refl

progress-aval : ∀{Γ a s τ}
  → Γ ⊢ₐ a ∷ τ
  → Γ ⊢ₛ s
  → ∃[ v ] (taval a s v)
progress-aval taexpI b = -, tavalI
progress-aval taexpR b = -, tavalR
progress-aval taexpV b = -, tavalV
progress-aval {τ = Ity} (taexpP a₁ a₂) b with progress-aval a₁ b | progress-aval a₂ b
... | rv , r  | mv , m with extract-ity rv (preservation-aval a₁ b r)
                          | extract-ity mv (preservation-aval a₂ b m)
... | v1 , e1 | v2 , e2 rewrite e1 | e2 = -, tavalSI r m
progress-aval {τ = Rty} (taexpP a₁ a₂) b with progress-aval a₁ b | progress-aval a₂ b
... | rv , r  | mv , m with extract-rty rv (preservation-aval a₁ b r)
                          | extract-rty mv (preservation-aval a₂ b m)
... | v1 , e1 | v2 , e2 rewrite e1 | e2 = -, tavalSR r m

progress-bval : ∀{Γ b s}
  → Γ ⊢₆ b
  → Γ ⊢ₛ s
  → ∃[ v ] (tbval b s v)
progress-bval tbexpC x₁ = -, tbvalC
progress-bval (tbexpN x) x₁ = -, tbvalN (proj₂ (progress-bval x x₁))
progress-bval (tbexpA a b) x = -, tbvalA (proj₂ (progress-bval a x))
                                         (proj₂ (progress-bval b x))
progress-bval (tbexpL {τ = Ity} a₁ a₂) b with progress-aval a₁ b | progress-aval a₂ b
... | rv , r  | mv , m with extract-ity rv (preservation-aval a₁ b r)
                          | extract-ity mv (preservation-aval a₂ b m)
... | v1 , e1 | v2 , e2 rewrite e1 | e2 = -, tbvalLI r m
progress-bval (tbexpL {τ = Rty} a₁ a₂) b with progress-aval a₁ b | progress-aval a₂ b
... | rv , r  | mv , m with extract-rty rv (preservation-aval a₁ b r)
                          | extract-rty mv (preservation-aval a₂ b m)
... | v1 , e1 | v2 , e2 rewrite e1 | e2 = -, tbvalLR r m

preservation-com : ∀{Γ c s c′ s′}
  → ⦅ c , s ⦆→⦅ c′ , s′ ⦆
  → Γ ⊢ c
  → Γ ⊢ c′
preservation-com (Loc x₁) (TLoc x₂) = TSkip
preservation-com Comp₁ (TSeq b b₁) = b₁
preservation-com (Comp₂ a) (TSeq b b₁) = TSeq (preservation-com a b) b₁
preservation-com (IfTrue x) (TIf x₁ b b₁) = b
preservation-com (IfFalse x) (TIf x₁ b b₁) = b₁
preservation-com While (TWhile x b) = TIf x (TSeq b (TWhile x b)) TSkip

preservation-state : ∀{Γ c s c′ s′}
  → ⦅ c , s ⦆→⦅ c′ , s′ ⦆
  → Γ ⊢ c
  → Γ ⊢ₛ s
  → Γ ⊢ₛ s′
preservation-state (Loc {x₃} x₁) (TLoc x₂) r x₄ with x₄ ≟ x₃
... | no ¬p = r x₄
... | yes p with preservation-aval x₂ r x₁
... | z rewrite p = z
preservation-state Comp₁ (TSeq c c₁) r = r
preservation-state (Comp₂ d) (TSeq c c₁) r = preservation-state d c r
preservation-state (IfTrue x) (TIf x₁ c c₁) r = r
preservation-state (IfFalse x) (TIf x₁ c c₁) r = r
preservation-state While (TWhile x c) r = r

preservation : ∀{Γ c s c′ s′}
  → Γ ⊢  c
  → Γ ⊢ₛ s
  → ⦅ c , s ⦆→⦅ c′ , s′ ⦆
  → Γ ⊢ c′ × Γ ⊢ₛ s′
preservation a b c = preservation-com c a , preservation-state c a b

either-skip : ∀ c
            → c ≡ SKIP ⊎ ¬ c ≡ SKIP
either-skip SKIP = inj₁ refl
either-skip (x ::= x₁) = inj₂ (λ ())
either-skip (c :: c₁) = inj₂ (λ ())
either-skip (IF x THEN c ELSE c₁) = inj₂ (λ ())
either-skip (WHILE x DO c) = inj₂ (λ ())

progress : ∀{Γ c s}
  → Γ ⊢  c
  → Γ ⊢ₛ s
  → ¬ c ≡ SKIP
  → ∃[ c′ ] (∃[ s′ ] ( ⦅ c , s ⦆→⦅ c′ , s′ ⦆ ))
progress TSkip b c = contradiction refl c
progress {s = s} (TLoc x) b _ = SKIP , -, Loc (proj₂ (progress-aval x b))
progress {s = s} (TSeq {_}{c₁}{c₂} a a₁) b _ with either-skip c₁
... | inj₁  skip rewrite skip = c₂ , s , Comp₁
... | inj₂ ¬skip = let c₁′       , s′ ,       r = progress a b ¬skip
                    in c₁′ :: c₂ , s′ , Comp₂ r
progress (TIf x a a₁) b _ with progress-bval x b
... | false , tb = -, -, IfFalse tb
... | true  , tb = -, -, IfTrue tb
progress (TWhile x a) b _ = -, -, While

type-soundness : ∀{c s c′ s′ Γ}
  → ⦅ c , s ⦆→*⦅ c′ , s′ ⦆
  → Γ ⊢  c
  → Γ ⊢ₛ s
  → ¬ c′ ≡ SKIP
  → ∃[ c″ ] (∃[ s″ ] ( ⦅ c′ , s′ ⦆→⦅ c″ , s″ ⦆ ))
type-soundness Ref c d e =  progress c d e
type-soundness (Step x r) c d e with preservation c d x
... | ct , st = type-soundness r ct st e


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

module Fragment.Examples.CSemigroup.Arith.Atomic where

open import Fragment.Examples.CSemigroup.Arith.Base

-- Fully dynamic associativity

+-dyn-assoc₁ : ∀ {m n o} → (m + n) + o ≡ m + (n + o)
+-dyn-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-dyn-assoc₂ : ∀ {m n o p} → ((m + n) + o) + p ≡ m + (n + (o + p))
+-dyn-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-dyn-assoc₃ : ∀ {m n o p q} → (m + n) + o + (p + q) ≡ m + (n + o + p) + q
+-dyn-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-dyn-assoc₁ : ∀ {m n o} → (m * n) * o ≡ m * (n * o)
*-dyn-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-dyn-assoc₂ : ∀ {m n o p} → ((m * n) * o) * p ≡ m * (n * (o * p))
*-dyn-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-dyn-assoc₃ : ∀ {m n o p q} → (m * n) * o * (p * q) ≡ m * (n * o * p) * q
*-dyn-assoc₃ = fragment CSemigroupFrex *-csemigroup

-- Fully dynamic commutativity

+-dyn-comm₁ : ∀ {m n} → m + n ≡ n + m
+-dyn-comm₁ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm₂ : ∀ {m n o} → m + (n + o) ≡ (o + n) + m
+-dyn-comm₂ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm₃ : ∀ {m n o p} → (m + n) + (o + p) ≡ (p + o) + (n + m)
+-dyn-comm₃ = fragment CSemigroupFrex +-csemigroup

*-dyn-comm₁ : ∀ {m n} → m * n ≡ n * m
*-dyn-comm₁ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm₂ : ∀ {m n o} → m * (n * o) ≡ (o * n) * m
*-dyn-comm₂ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm₃ : ∀ {m n o p} → (m * n) * (o * p) ≡ (p * o) * (n * m)
*-dyn-comm₃ = fragment CSemigroupFrex *-csemigroup

-- Fully dynamic associavity and commutativity

+-dyn-comm-assoc₁ : ∀ {m n o} → (m + n) + o ≡ n + (m + o)
+-dyn-comm-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm-assoc₂ : ∀ {m n o p} → ((m + n) + o) + p ≡ p + (o + (n + m))
+-dyn-comm-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm-assoc₃ : ∀ {m n o p q} → (m + n) + o + (p + q) ≡ q + (p + o + n) + m
+-dyn-comm-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-dyn-comm-assoc₁ : ∀ {m n o} → (m * n) * o ≡ n * (m * o)
*-dyn-comm-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm-assoc₂ : ∀ {m n o p} → ((m * n) * o) * p ≡ p * (o * (n * m))
*-dyn-comm-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm-assoc₃ : ∀ {m n o p q} → (m * n) * o * (p * q) ≡ q * (p * o * n) * m
*-dyn-comm-assoc₃ = fragment CSemigroupFrex *-csemigroup

-- Partially static associativity

+-sta-assoc₁ : ∀ {m n} → (m + 2) + (3 + n) ≡ m + (5 + n)
+-sta-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-sta-assoc₂ : ∀ {m n o p} → (((m + n) + 5) + o) + p ≡ m + (n + (2 + (3 + (o + p))))
+-sta-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-sta-assoc₃ : ∀ {m n o p} → ((m + n) + 2) + (3 + (o + p)) ≡ m + ((n + 1) + (4 + o)) + p
+-sta-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-sta-assoc₁ : ∀ {m n} → (m * 2) * (3 * n) ≡ m * (6 * n)
*-sta-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-sta-assoc₂ : ∀ {m n o p} → (((m * n) * 6) * o) * p ≡ m * (n * (2 * (3 * (o * p))))
*-sta-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-sta-assoc₃ : ∀ {m n o p} → ((m * n) * 2) * (6 * (o * p)) ≡ m * ((n * 2) * (6 * o)) * p
*-sta-assoc₃ = fragment CSemigroupFrex *-csemigroup

-- Partially static commutativity

+-sta-comm₁ : ∀ {m} → m + 1 ≡ 1 + m
+-sta-comm₁ = fragment CSemigroupFrex +-csemigroup

+-sta-comm₂ : ∀ {m n} → m + (2 + n) ≡ (n + 2) + m
+-sta-comm₂ = fragment CSemigroupFrex +-csemigroup

+-sta-comm₃ : ∀ {m n o p} → (1 + (m + n)) + ((o + p) + 2) ≡ ((p + o) + 2) + (1 + (n + m))
+-sta-comm₃ = fragment CSemigroupFrex +-csemigroup

*-sta-comm₁ : ∀ {m} → m * 4 ≡ 4 * m
*-sta-comm₁ = fragment CSemigroupFrex *-csemigroup

*-sta-comm₂ : ∀ {m n} → m * (2 * n) ≡ (n * 2) * m
*-sta-comm₂ = fragment CSemigroupFrex *-csemigroup

*-sta-comm₃ : ∀ {m n o p} → (4 * (m * n)) * ((o * p) * 2) ≡ ((p * o) * 2) * (4 * (n * m))
*-sta-comm₃ = fragment CSemigroupFrex *-csemigroup

-- Partially static associavity and commutativity

+-sta-comm-assoc₁ : ∀ {m n o} → 1 + (m + n) + o + 4 ≡ 5 + n + (m + o)
+-sta-comm-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-sta-comm-assoc₂ : ∀ {m n o p} → 5 + ((m + n) + o) + p ≡ p + ((o + 1) + (n + m)) + 4
+-sta-comm-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-sta-comm-assoc₃ : ∀ {m n o p q} → (m + n + 1) + o + (p + q + 4) ≡ (2 + q) + (p + o + n) + (m + 3)
+-sta-comm-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-sta-comm-assoc₁ : ∀ {m n o} → 2 * (m * n) * o * 3 ≡ 6 * n * (m * o)
*-sta-comm-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-sta-comm-assoc₂ : ∀ {m n o p} → 6 * ((m * n) * o) * p ≡ p * ((o * 2) * (n * m)) * 3
*-sta-comm-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-sta-comm-assoc₃ : ∀ {m n o p q} → (m * n * 3) * o * (p * q * 4) ≡ (2 * q) * (p * o * n) * (m * 6)
*-sta-comm-assoc₃ = fragment CSemigroupFrex *-csemigroup


------------------------------------------------------------------------------
-- We only translate definition with one clause
------------------------------------------------------------------------------

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

module OnlyOneClause where

infixl 9 _+_
infix  7 _≡_

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

data _≡_ (n : ℕ) : ℕ → Set where
  refl : n ≡ n

_+_ : ℕ → ℕ → ℕ
zero   + n = n
succ m + n = succ (m + n)
{-# ATP definition _+_ #-}

postulate +-comm : ∀ m n → m + n ≡ n + m
{-# ATP prove +-comm #-}


{-# OPTIONS --experimental-irrelevance #-}
module ShapeIrrelevantParameterNoBecauseOfRecursion where

data ⊥ : Set where
record ⊤ : Set where

data Bool : Set where
  true false : Bool

True : Bool → Set
True false = ⊥
True true  = ⊤

data D ..(b : Bool) : Set where
  c : True b → D b  -- should fail

fromD : {b : Bool} → D b → True b
fromD (c p) = p

cast : .(a b : Bool) → D a → D b
cast _ _ x = x

bot : ⊥
bot = fromD (cast true false (c _))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Consequences of a monomorphism between ring-like structures
------------------------------------------------------------------------

-- See Data.Nat.Binary.Properties for examples of how this and similar
-- modules can be used to easily translate properties between types.

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

open import Algebra.Bundles
open import Algebra.Morphism.Structures
open import Relation.Binary.Core

module Algebra.Morphism.RingMonomorphism
  {a b ℓ₁ ℓ₂} {R₁ : RawRing a ℓ₁} {R₂ : RawRing b ℓ₂} {⟦_⟧}
  (isRingMonomorphism : IsRingMonomorphism R₁ R₂ ⟦_⟧)
  where

open IsRingMonomorphism isRingMonomorphism
open RawRing R₁ renaming (Carrier to A; _≈_ to _≈₁_)
open RawRing R₂ renaming
  ( Carrier to B; _≈_ to _≈₂_; _+_ to _⊕_
  ; _*_ to _⊛_; 1# to 1#₂; 0# to 0#₂; -_ to ⊝_)

open import Algebra.Definitions
open import Algebra.Structures
open import Data.Product
import Relation.Binary.Reasoning.Setoid as SetoidReasoning

------------------------------------------------------------------------
-- Re-export all properties of group and monoid monomorphisms

open import Algebra.Morphism.GroupMonomorphism
  +-isGroupMonomorphism renaming
  ( assoc to +-assoc
  ; comm to +-comm
  ; cong to +-cong
  ; idem to +-idem
  ; identity to +-identity; identityˡ to +-identityˡ; identityʳ to +-identityʳ
  ; cancel to +-cancel; cancelˡ to +-cancelˡ; cancelʳ to +-cancelʳ
  ; zero to +-zero; zeroˡ to +-zeroˡ; zeroʳ to +-zeroʳ
  ; isMagma to +-isMagma
  ; isSemigroup to +-isSemigroup
  ; isMonoid to +-isMonoid
  ; isSelectiveMagma to +-isSelectiveMagma
  ; isSemilattice to +-isSemilattice
  ; sel to +-sel
  ; isBand to +-isBand
  ; isCommutativeMonoid to +-isCommutativeMonoid
  ) public

open import Algebra.Morphism.MonoidMonomorphism
  *-isMonoidMonomorphism renaming
  ( assoc to *-assoc
  ; comm to *-comm
  ; cong to *-cong
  ; idem to *-idem
  ; identity to *-identity; identityˡ to *-identityˡ; identityʳ to *-identityʳ
  ; cancel to *-cancel; cancelˡ to *-cancelˡ; cancelʳ to *-cancelʳ
  ; zero to *-zero; zeroˡ to *-zeroˡ; zeroʳ to *-zeroʳ
  ; isMagma to *-isMagma
  ; isSemigroup to *-isSemigroup
  ; isMonoid to *-isMonoid
  ; isSelectiveMagma to *-isSelectiveMagma
  ; isSemilattice to *-isSemilattice
  ; sel to *-sel
  ; isBand to *-isBand
  ; isCommutativeMonoid to *-isCommutativeMonoid
  ) public

------------------------------------------------------------------------
-- Properties

module _ (+-isGroup : IsGroup  _≈₂_ _⊕_ 0#₂ ⊝_)
         (*-isMagma : IsMagma _≈₂_ _⊛_) where

  open IsGroup +-isGroup hiding (setoid; refl)
  open IsMagma *-isMagma renaming (∙-cong to ◦-cong)
  open SetoidReasoning setoid

  distribˡ : _DistributesOverˡ_ _≈₂_ _⊛_ _⊕_ → _DistributesOverˡ_ _≈₁_ _*_ _+_
  distribˡ distribˡ x y z = injective (begin
    ⟦ x * (y + z) ⟧               ≈⟨ *-homo x (y + z) ⟩
    ⟦ x ⟧ ⊛ ⟦ y + z ⟧             ≈⟨ ◦-cong refl (+-homo y z) ⟩
    ⟦ x ⟧ ⊛ (⟦ y ⟧ ⊕ ⟦ z ⟧)       ≈⟨ distribˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩
    ⟦ x ⟧ ⊛ ⟦ y ⟧ ⊕ ⟦ x ⟧ ⊛ ⟦ z ⟧ ≈˘⟨ ∙-cong (*-homo x y) (*-homo x z) ⟩
    ⟦ x * y ⟧ ⊕ ⟦ x * z ⟧         ≈˘⟨ +-homo (x * y) (x * z) ⟩
    ⟦ x * y + x * z ⟧ ∎)

  distribʳ : _DistributesOverʳ_ _≈₂_ _⊛_ _⊕_ → _DistributesOverʳ_ _≈₁_ _*_ _+_
  distribʳ distribˡ x y z = injective (begin
    ⟦ (y + z) * x ⟧               ≈⟨ *-homo (y + z) x ⟩
    ⟦ y + z ⟧ ⊛ ⟦ x ⟧             ≈⟨ ◦-cong (+-homo y z) refl ⟩
    (⟦ y ⟧ ⊕ ⟦ z ⟧) ⊛ ⟦ x ⟧       ≈⟨ distribˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩
    ⟦ y ⟧ ⊛ ⟦ x ⟧ ⊕ ⟦ z ⟧ ⊛ ⟦ x ⟧ ≈˘⟨ ∙-cong (*-homo y x) (*-homo z x) ⟩
    ⟦ y * x ⟧ ⊕ ⟦ z * x ⟧         ≈˘⟨ +-homo (y * x) (z * x) ⟩
    ⟦ y * x + z * x ⟧ ∎)

  distrib : _DistributesOver_ _≈₂_ _⊛_ _⊕_ → _DistributesOver_ _≈₁_ _*_ _+_
  distrib distrib = distribˡ (proj₁ distrib) , distribʳ (proj₂ distrib)

  zeroˡ : LeftZero _≈₂_ 0#₂ _⊛_ → LeftZero _≈₁_ 0# _*_
  zeroˡ zeroˡ x = injective (begin
    ⟦ 0# * x ⟧     ≈⟨ *-homo 0# x ⟩
    ⟦ 0# ⟧ ⊛ ⟦ x ⟧ ≈⟨ ◦-cong 0#-homo refl ⟩
    0#₂ ⊛ ⟦ x ⟧    ≈⟨ zeroˡ ⟦ x ⟧ ⟩
    0#₂            ≈˘⟨ 0#-homo ⟩
    ⟦ 0# ⟧         ∎)

  zeroʳ : RightZero _≈₂_ 0#₂ _⊛_ → RightZero _≈₁_ 0# _*_
  zeroʳ zeroʳ x = injective (begin
    ⟦ x * 0# ⟧     ≈⟨ *-homo x 0# ⟩
    ⟦ x ⟧ ⊛ ⟦ 0# ⟧ ≈⟨ ◦-cong refl 0#-homo ⟩
    ⟦ x ⟧ ⊛ 0#₂    ≈⟨ zeroʳ ⟦ x ⟧ ⟩
    0#₂            ≈˘⟨ 0#-homo ⟩
    ⟦ 0# ⟧         ∎)

  zero : Zero _≈₂_ 0#₂ _⊛_ → Zero _≈₁_ 0# _*_
  zero zero = zeroˡ (proj₁ zero) , zeroʳ (proj₂ zero)

isRing : IsRing _≈₂_ _⊕_ _⊛_ ⊝_ 0#₂ 1#₂ → IsRing _≈₁_ _+_ _*_ -_ 0# 1#
isRing isRing = record
  { +-isAbelianGroup = isAbelianGroup R.+-isAbelianGroup
  ; *-isMonoid       = *-isMonoid R.*-isMonoid
  ; distrib          = distrib R.+-isGroup R.*-isMagma R.distrib
  ; zero             = zero R.+-isGroup R.*-isMagma R.zero
  } where module R = IsRing isRing


{-# OPTIONS --cubical #-}
module _ where
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Bool

data S¹ : Set where
  base : S¹
  loop : base ≡ base

-- We cannot allow this definition as
--   decideEq (loop i)  base ↦ false
-- but
--   decideEq (loop i0) base ↦ true

decideEq : ∀ (x y : S¹) → Bool
decideEq base     base     = true
decideEq (loop i) (loop j) = true
decideEq x        y        = false