[ Agda ] Fixed issue 1264

[ Agda ] Fixed issue 1264

------------------------------------------------------------------------------
-- The ABP using the Agda standard library
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.ABP-SL where

open import Coinduction
open import Data.Bool
open import Data.Product
open import Data.Stream
open import Relation.Nullary

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

Bit : Set
Bit = Bool

-- Data type used to model the fair unreliable transmission channel.
data Err (A : Set) : Set where
  ok    : (x : A) → Err A
  error : Err A

-- The mutual sender functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
sendA  : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bool)
awaitA : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bit)

sendA b (i ∷ is) ds = (i , b) ∷ ♯ awaitA b (i ∷ is) ds

awaitA b (i ∷ is) (ok b' ∷ ds) with b ≟ b'
... | yes p = sendA (not b) (♭ is) (♭ ds)
... | no ¬p = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))
awaitA b (i ∷ is) (error ∷ ds) = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))

-- The receiver functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
ackA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream Bit
ackA b (ok (_ , b') ∷ bs) with b ≟ b'
... | yes p = b ∷ ♯ (ackA (not b) (♭ bs))
... | no ¬p = not b ∷ ♯ (ackA b (♭ bs))
ackA b (error ∷ bs) = not b ∷ ♯ (ackA b (♭ bs))

{-# NO_TERMINATION_CHECK #-}
outA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream A
outA b (ok (i , b') ∷ bs) with b ≟ b'
... | yes p = i ∷ ♯ (outA (not b) (♭ bs))
... | no ¬p = outA b (♭ bs)
outA b (error ∷ bs) = outA b (♭ bs)

-- Model the fair unreliable tranmission channel.
corruptA : {A : Set} → Stream Bit → Stream A → Stream (Err A)
corruptA (true ∷ os)  (_ ∷ xs) = error ∷ ♯ (corruptA (♭ os) (♭ xs))
corruptA (false ∷ os) (x ∷ xs) = ok x ∷ ♯ (corruptA (♭ os) (♭ xs))

-- The ABP transfer function.
{-# NO_TERMINATION_CHECK #-}
abpTransA : {A : Set} → Bit → Stream Bit → Stream Bit → Stream A → Stream A
abpTransA {A} b os₁ os₂ is = outA b bs
  where
  as : Stream (A × Bit)
  bs : Stream (Err (A × Bit))
  cs : Stream Bit
  ds : Stream (Err Bit)

  as = sendA b is ds
  bs = corruptA os₁ as
  cs = ackA b bs
  ds = corruptA os₂ cs

------------------------------------------------------------------------------
-- The ABP using the Agda standard library
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.ABP-SL where

open import Coinduction
open import Data.Bool
open import Data.Product
open import Data.Stream
open import Relation.Nullary

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

Bit : Set
Bit = Bool

-- Data type used to model the fair unreliable transmission channel.
data Err (A : Set) : Set where
  ok    : (x : A) → Err A
  error : Err A

-- The mutual sender functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
sendA  : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bool)
awaitA : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bit)

sendA b (i ∷ is) ds = (i , b) ∷ ♯ awaitA b (i ∷ is) ds

awaitA b (i ∷ is) (ok b' ∷ ds) with b ≟ b'
... | yes p = sendA (not b) (♭ is) (♭ ds)
... | no ¬p = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))
awaitA b (i ∷ is) (error ∷ ds) = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))

-- The receiver functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
ackA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream Bit
ackA b (ok (_ , b') ∷ bs) with b ≟ b'
... | yes p = b ∷ ♯ (ackA (not b) (♭ bs))
... | no ¬p = not b ∷ ♯ (ackA b (♭ bs))
ackA b (error ∷ bs) = not b ∷ ♯ (ackA b (♭ bs))

{-# NO_TERMINATION_CHECK #-}
outA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream A
outA b (ok (i , b') ∷ bs) with b ≟ b'
... | yes p = i ∷ ♯ (outA (not b) (♭ bs))
... | no ¬p = outA b (♭ bs)
outA b (error ∷ bs) = outA b (♭ bs)

-- Model the fair unreliable tranmission channel.
--
-- 29 August 2014 Requires the non-termination flag when using
-- --without-K after the release of Agda 2.4.2. See issue 1264.
{-# NO_TERMINATION_CHECK #-}
corruptA : {A : Set} → Stream Bit → Stream A → Stream (Err A)
corruptA (true ∷ os)  (_ ∷ xs) = error ∷ ♯ (corruptA (♭ os) (♭ xs))
corruptA (false ∷ os) (x ∷ xs) = ok x ∷ ♯ (corruptA (♭ os) (♭ xs))

-- The ABP transfer function.
{-# NO_TERMINATION_CHECK #-}
abpTransA : {A : Set} → Bit → Stream Bit → Stream Bit → Stream A → Stream A
abpTransA {A} b os₁ os₂ is = outA b bs
  where
  as : Stream (A × Bit)
  bs : Stream (Err (A × Bit))
  cs : Stream Bit
  ds : Stream (Err Bit)

  as = sendA b is ds
  bs = corruptA os₁ as
  cs = ackA b bs
  ds = corruptA os₂ cs


Fixed indentation.

Fixed indentation.

------------------------------------------------------------------------------
-- Arithmetic properties
------------------------------------------------------------------------------

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

-- References:
--
-- M. J. Beeson. Proving programs and programming proofs. In Ruth
-- Barcan Marcus, George J. W. Dorn, and Paul Weingartner,
-- editors. Logic, Methodology and Philosophy of Science VII (1983),
-- volume 114 of Studies in Logic and the Foundations of
-- Mathematics. North-Holland Publishing Company, 1988, pages 51–82.

module FOTC.Data.Nat.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Data.Nat
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityI

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

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong refl = refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong refl = refl

∸-leftCong : ∀ {m n o} → m ≡ n → m ∸ o ≡ n ∸ o
∸-leftCong refl = refl

∸-rightCong : ∀ {m n o} → n ≡ o → m ∸ n ≡ m ∸ o
∸-rightCong refl = refl

*-leftCong : ∀ {m n o} → m ≡ n → m * o ≡ n * o
*-leftCong refl = refl

*-rightCong : ∀ {m n o} → n ≡ o → m * n ≡ m * o
*-rightCong refl = refl

------------------------------------------------------------------------------
-- Some proofs are based on the proofs in the standard library.

Sx≢x : ∀ {n} → N n → succ₁ n ≢ n
Sx≢x nzero h      = ⊥-elim (0≢S (sym h))
Sx≢x (nsucc Nn) h = ⊥-elim (Sx≢x Nn (succInjective h))

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity = +-0x

+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity nzero          = +-leftIdentity zero
+-rightIdentity (nsucc {n} Nn) =
  trans (+-Sx n zero) (succCong (+-rightIdentity Nn))

pred-N : ∀ {n} → N n → N (pred₁ n)
pred-N nzero          = subst N (sym pred-0) nzero
pred-N (nsucc {n} Nn) = subst N (sym (pred-S n)) Nn

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} nzero          Nn = subst N (sym (+-leftIdentity n)) Nn
+-N {n = n} (nsucc {m} Nm) Nn = subst N (sym (+-Sx m n)) (nsucc (+-N Nm Nn))

∸-N : ∀ {m n} → N m → N n → N (m ∸ n)
∸-N {m} Nm nzero          = subst N (sym (∸-x0 m)) Nm
∸-N {m} Nm (nsucc {n} Nn) = subst N (sym (∸-xS m n)) (pred-N (∸-N Nm Nn))

+-assoc : ∀ {m} → N m → ∀ n o → m + n + o ≡ m + (n + o)
+-assoc nzero n o =
  zero + n + o   ≡⟨ +-leftCong (+-leftIdentity n) ⟩
  n + o          ≡⟨ sym (+-leftIdentity (n + o)) ⟩
  zero + (n + o) ∎

+-assoc (nsucc {m} Nm) n o =
  succ₁ m + n + o     ≡⟨ +-leftCong (+-Sx m n) ⟩
  succ₁ (m + n) + o   ≡⟨ +-Sx (m + n) o ⟩
  succ₁ (m + n + o)   ≡⟨ succCong (+-assoc Nm n o) ⟩
  succ₁ (m + (n + o)) ≡⟨ sym (+-Sx m (n + o)) ⟩
  succ₁ m + (n + o)   ∎

x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] nzero n =
  zero + succ₁ n   ≡⟨ +-leftIdentity (succ₁ n) ⟩
  succ₁ n          ≡⟨ succCong (sym (+-leftIdentity n)) ⟩
  succ₁ (zero + n) ∎

x+Sy≡S[x+y] (nsucc {m} Nm) n =
  succ₁ m + succ₁ n     ≡⟨ +-Sx m (succ₁ n) ⟩
  succ₁ (m + succ₁ n)   ≡⟨ succCong (x+Sy≡S[x+y] Nm n) ⟩
  succ₁ (succ₁ (m + n)) ≡⟨ succCong (sym (+-Sx m n)) ⟩
  succ₁ (succ₁ m + n)   ∎

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} nzero Nn =
  zero + n ≡⟨ +-leftIdentity n ⟩
  n        ≡⟨ sym (+-rightIdentity Nn) ⟩
  n + zero ∎

+-comm {n = n} (nsucc {m} Nm) Nn =
  succ₁ m + n   ≡⟨ +-Sx m n ⟩
  succ₁ (m + n) ≡⟨ succCong (+-comm Nm Nn) ⟩
  succ₁ (n + m) ≡⟨ sym (x+Sy≡S[x+y] Nn m) ⟩
  n + succ₁ m   ∎

private
  0∸S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
  0∸S nzero =
    zero ∸ [1]          ≡⟨ ∸-xS zero zero ⟩
    pred₁ (zero ∸ zero) ≡⟨ predCong (∸-x0 zero) ⟩
    pred₁ zero          ≡⟨ pred-0 ⟩
    zero                ∎

  0∸S (nsucc {n} Nn) =
    zero ∸ succ₁ (succ₁ n)   ≡⟨ ∸-xS zero (succ₁ n) ⟩
    pred₁ (zero ∸ (succ₁ n)) ≡⟨ predCong (0∸S Nn) ⟩
    pred₁ zero               ≡⟨ pred-0 ⟩
    zero                     ∎

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

S∸S : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
S∸S {m} _ nzero =
  succ₁ m ∸ [1]
    ≡⟨ ∸-xS (succ₁ m) zero ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ predCong (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym (∸-x0 m) ⟩
  m ∸ zero ∎

S∸S nzero (nsucc {n} Nn) =
  [1] ∸ succ₁ (succ₁ n)
    ≡⟨ ∸-xS [1] (succ₁ n) ⟩
  pred₁ ([1] ∸ succ₁ n)
    ≡⟨ predCong (S∸S nzero Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ predCong (0∸x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym (0∸S Nn) ⟩
  zero ∸ succ₁ n ∎

S∸S (nsucc {m} Nm) (nsucc {n} Nn) =
  succ₁ (succ₁ m) ∸ succ₁ (succ₁ n)
    ≡⟨ ∸-xS (succ₁ (succ₁ m)) (succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ predCong (S∸S (nsucc Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym (∸-xS (succ₁ m) n) ⟩
  succ₁ m ∸ succ₁ n ∎

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

Sx∸x≡1 : ∀ {n} → N n → succ₁ n ∸ n ≡ [1]
Sx∸x≡1 nzero      = ∸-x0 [1]
Sx∸x≡1 (nsucc Nn) = trans (S∸S (nsucc Nn) Nn) (Sx∸x≡1 Nn)

[x+Sy]∸y≡Sx : ∀ {m n} → N m → N n → m + succ₁ n ∸ n ≡ succ₁ m
[x+Sy]∸y≡Sx {n = n} nzero Nn =
  zero + succ₁ n ∸ n ≡⟨ ∸-leftCong (+-leftIdentity (succ₁ n)) ⟩
  succ₁ n ∸ n        ≡⟨ Sx∸x≡1 Nn ⟩
  [1]                ∎

[x+Sy]∸y≡Sx (nsucc {m} Nm) nzero =
  succ₁ m + [1] ∸ zero     ≡⟨ ∸-leftCong (+-Sx m [1]) ⟩
  succ₁ (m + [1]) ∸ zero   ≡⟨ ∸-x0 (succ₁ (m + [1])) ⟩
  succ₁ (m + [1])          ≡⟨ succCong (+-comm Nm 1-N) ⟩
  succ₁ ([1] + m)          ≡⟨ succCong (+-Sx zero m) ⟩
  succ₁ (succ₁ (zero + m)) ≡⟨ succCong (succCong (+-leftIdentity m)) ⟩
  succ₁ (succ₁ m)          ∎

[x+Sy]∸y≡Sx (nsucc {m} Nm) (nsucc {n} Nn) =
  succ₁ m + succ₁ (succ₁ n) ∸ succ₁ n
    ≡⟨ ∸-leftCong (+-Sx m (succ₁ (succ₁ n))) ⟩
  succ₁ (m + succ₁ (succ₁ n)) ∸ succ₁ n
    ≡⟨ S∸S (+-N Nm (nsucc (nsucc Nn))) Nn ⟩
  m + succ₁ (succ₁ n) ∸ n
    ≡⟨ ∸-leftCong (x+Sy≡S[x+y] Nm (succ₁ n)) ⟩
  succ₁ (m + succ₁ n) ∸ n
    ≡⟨ ∸-leftCong (sym (+-Sx m (succ₁ n))) ⟩
  succ₁ m + succ₁ n ∸ n
    ≡⟨ [x+Sy]∸y≡Sx (nsucc Nm) Nn ⟩
  succ₁ (succ₁ m) ∎

[x+y]∸[x+z]≡y∸z : ∀ {m n o} → N m → N n → N o → (m + n) ∸ (m + o) ≡ n ∸ o
[x+y]∸[x+z]≡y∸z {n = n} {o} nzero _ _ =
  (zero + n) ∸ (zero + o) ≡⟨ ∸-leftCong (+-leftIdentity n) ⟩
    n ∸ (zero + o)        ≡⟨ ∸-rightCong (+-leftIdentity o) ⟩
    n ∸ o                 ∎

[x+y]∸[x+z]≡y∸z {n = n} {o} (nsucc {m} Nm) Nn No =
  (succ₁ m + n) ∸ (succ₁ m + o) ≡⟨ ∸-leftCong (+-Sx m n) ⟩
  succ₁ (m + n) ∸ (succ₁ m + o) ≡⟨ ∸-rightCong (+-Sx m o) ⟩
  succ₁ (m + n) ∸ succ₁ (m + o) ≡⟨ S∸S (+-N Nm Nn) (+-N Nm No) ⟩
  (m + n) ∸ (m + o)             ≡⟨ [x+y]∸[x+z]≡y∸z Nm Nn No ⟩
  n ∸ o                         ∎

*-leftZero : ∀ n → zero * n ≡ zero
*-leftZero = *-0x

*-rightZero : ∀ {n} → N n → n * zero ≡ zero
*-rightZero nzero          = *-leftZero zero
*-rightZero (nsucc {n} Nn) =
  trans (*-Sx n zero)
        (trans (+-leftIdentity (n * zero)) (*-rightZero Nn))

*-N : ∀ {m n} → N m → N n → N (m * n)
*-N {n = n} nzero          Nn = subst N (sym (*-leftZero n)) nzero
*-N {n = n} (nsucc {m} Nm) Nn = subst N (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

*-leftIdentity : ∀ {n} → N n → [1] * n ≡ n
*-leftIdentity {n} Nn =
  [1] * n      ≡⟨ *-Sx zero n ⟩
  n + zero * n ≡⟨ +-rightCong (*-leftZero n) ⟩
  n + zero     ≡⟨ +-rightIdentity Nn ⟩
  n            ∎

x*Sy≡x+xy : ∀ {m n} → N m → N n → m * succ₁ n ≡ m + m * n
x*Sy≡x+xy {n = n} nzero Nn = sym
  (
    zero + zero * n ≡⟨ +-rightCong (*-leftZero n) ⟩
    zero + zero     ≡⟨ +-leftIdentity zero ⟩
    zero            ≡⟨ sym (*-leftZero (succ₁ n)) ⟩
    zero * succ₁ n  ∎
  )

x*Sy≡x+xy {n = n} (nsucc {m} Nm) Nn =
  succ₁ m * succ₁ n
    ≡⟨ *-Sx m (succ₁ n) ⟩
  succ₁ n + m * succ₁ n
    ≡⟨ +-rightCong (x*Sy≡x+xy Nm Nn) ⟩
  succ₁ n + (m + m * n)
    ≡⟨ +-Sx n (m + m * n) ⟩
  succ₁ (n + (m + m * n))
    ≡⟨ succCong (sym (+-assoc Nn m (m * n))) ⟩
  succ₁ (n + m + m * n)
    ≡⟨ succCong (+-leftCong (+-comm Nn Nm)) ⟩
  succ₁ (m + n + m * n)
    ≡⟨ subst (λ t → succ₁ (m + n + m * n) ≡ succ₁ t)
             (+-assoc Nm n (m * n))
               refl
    ⟩
  succ₁ (m + (n + m * n))
    ≡⟨ sym (+-Sx m (n + m * n)) ⟩
  succ₁ m + (n + m * n)
    ≡⟨ +-rightCong (sym (*-Sx m n)) ⟩
  succ₁ m + succ₁ m * n ∎

*-comm : ∀ {m n} → N m → N n → m * n ≡ n * m
*-comm {n = n} nzero Nn          = trans (*-leftZero n) (sym (*-rightZero Nn))
*-comm {n = n} (nsucc {m} Nm) Nn =
  succ₁ m * n ≡⟨ *-Sx m n ⟩
  n + m * n   ≡⟨ subst (λ t → n + m * n ≡ n + t) (*-comm Nm Nn) refl ⟩
  n + n * m   ≡⟨ sym (x*Sy≡x+xy Nn Nm) ⟩
  n * succ₁ m ∎

*-rightIdentity : ∀ {n} → N n → n * [1] ≡ n
*-rightIdentity {n} Nn = trans (*-comm Nn (nsucc nzero)) (*-leftIdentity Nn)

*∸-leftDistributive : ∀ {m n o} → N m → N n → N o → (m ∸ n) * o ≡ m * o ∸ n * o
*∸-leftDistributive {m} {o = o} _ nzero _ =
  (m ∸ zero) * o   ≡⟨ *-leftCong (∸-x0 m) ⟩
  m * o            ≡⟨ sym (∸-x0 (m * o)) ⟩
  m * o ∸ zero     ≡⟨ ∸-rightCong (sym (*-leftZero o)) ⟩
  m * o ∸ zero * o ∎

*∸-leftDistributive {o = o} nzero (nsucc {n} Nn) No =
  (zero ∸ succ₁ n) * o   ≡⟨ *-leftCong (0∸S Nn) ⟩
  zero * o               ≡⟨ *-leftZero o ⟩
  zero                   ≡⟨ sym (0∸x (*-N (nsucc Nn) No)) ⟩
  zero ∸ succ₁ n * o     ≡⟨ ∸-leftCong (sym (*-leftZero o)) ⟩
  zero * o ∸ succ₁ n * o ∎

*∸-leftDistributive (nsucc {m} Nm) (nsucc {n} Nn) nzero =
  (succ₁ m ∸ succ₁ n) * zero
    ≡⟨ *-comm (∸-N (nsucc Nm) (nsucc Nn)) nzero ⟩
  zero * (succ₁ m ∸ succ₁ n)
    ≡⟨ *-leftZero (succ₁ m ∸ succ₁ n) ⟩
  zero
    ≡⟨ sym (0∸x (*-N (nsucc Nn) nzero)) ⟩
  zero ∸ succ₁ n * zero
    ≡⟨ ∸-leftCong (sym (*-leftZero (succ₁ m))) ⟩
  zero * succ₁ m ∸ succ₁ n * zero
    ≡⟨ ∸-leftCong (*-comm nzero (nsucc Nm)) ⟩
  succ₁ m * zero ∸ succ₁ n * zero ∎

*∸-leftDistributive (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) =
  (succ₁ m ∸ succ₁ n) * succ₁ o
    ≡⟨ *-leftCong (S∸S Nm Nn) ⟩
  (m ∸ n) * succ₁ o
     ≡⟨ *∸-leftDistributive Nm Nn (nsucc No) ⟩
  m * succ₁ o ∸ n * succ₁ o
    ≡⟨ sym ([x+y]∸[x+z]≡y∸z (nsucc No) (*-N Nm (nsucc No)) (*-N Nn (nsucc No))) ⟩
  (succ₁ o + m * succ₁ o) ∸ (succ₁ o + n * succ₁ o)
    ≡⟨ ∸-leftCong (sym (*-Sx m (succ₁ o))) ⟩
  (succ₁ m * succ₁ o) ∸ (succ₁ o + n * succ₁ o)
    ≡⟨ ∸-rightCong (sym (*-Sx n (succ₁ o))) ⟩
  (succ₁ m * succ₁ o) ∸ (succ₁ n * succ₁ o) ∎

*+-leftDistributive : ∀ {m n o} → N m → N n → N o → (m + n) * o ≡ m * o + n * o
*+-leftDistributive {m} {n} Nm Nn nzero =
  (m + n) * zero
    ≡⟨ *-comm (+-N Nm Nn) nzero ⟩
  zero * (m + n)
    ≡⟨ *-leftZero (m + n) ⟩
  zero
    ≡⟨ sym (*-leftZero m) ⟩
  zero * m
    ≡⟨ *-comm nzero Nm ⟩
  m * zero
    ≡⟨ sym (+-rightIdentity (*-N Nm nzero)) ⟩
  m * zero + zero
    ≡⟨ +-rightCong (trans (sym (*-leftZero n)) (*-comm nzero Nn)) ⟩
  m * zero + n * zero ∎

*+-leftDistributive {n = n} nzero Nn (nsucc {o} No) =
  (zero + n) * succ₁ o         ≡⟨ *-leftCong (+-leftIdentity n) ⟩
  n * succ₁ o                  ≡⟨ sym (+-leftIdentity (n * succ₁ o)) ⟩
  zero + n * succ₁ o           ≡⟨ +-leftCong (sym (*-leftZero (succ₁ o))) ⟩
  zero * succ₁ o + n * succ₁ o ∎

*+-leftDistributive (nsucc {m} Nm) nzero (nsucc {o} No) =
  (succ₁ m + zero) * succ₁ o
    ≡⟨ *-leftCong (+-rightIdentity (nsucc Nm)) ⟩
  succ₁ m * succ₁ o
    ≡⟨ sym (+-rightIdentity (*-N (nsucc Nm) (nsucc No))) ⟩
  succ₁ m * succ₁ o + zero
    ≡⟨ +-rightCong (sym (*-leftZero (succ₁ o))) ⟩
  succ₁ m * succ₁ o + zero * succ₁ o ∎

*+-leftDistributive (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) =
  (succ₁ m + succ₁ n) * succ₁ o
    ≡⟨ *-leftCong (+-Sx m (succ₁ n)) ⟩
  succ₁ (m + succ₁ n) * succ₁ o
    ≡⟨ *-Sx (m + succ₁ n) (succ₁ o) ⟩
  succ₁ o + (m + succ₁ n) * succ₁ o
    ≡⟨ +-rightCong (*+-leftDistributive Nm (nsucc Nn) (nsucc No)) ⟩
  succ₁ o + (m * succ₁ o + succ₁ n * succ₁ o)
    ≡⟨ sym (+-assoc (nsucc No) (m * succ₁ o) (succ₁ n * succ₁ o)) ⟩
  succ₁ o + m * succ₁ o + succ₁ n * succ₁ o
    ≡⟨ +-leftCong (sym (*-Sx m (succ₁ o))) ⟩
  succ₁ m * succ₁ o + succ₁ n * succ₁ o ∎

xy≡0→x≡0∨y≡0 : ∀ {m n} → N m → N n → m * n ≡ zero → m ≡ zero ∨ n ≡ zero
xy≡0→x≡0∨y≡0 nzero          _              _      = inj₁ refl
xy≡0→x≡0∨y≡0 (nsucc Nm)     nzero          _      = inj₂ refl
xy≡0→x≡0∨y≡0 (nsucc {m} Nm) (nsucc {n} Nn) SmSn≡0 = ⊥-elim (0≢S prf)
  where
  prf : zero ≡ succ₁ (n + m * succ₁ n)
  prf = zero                    ≡⟨ sym SmSn≡0 ⟩
        succ₁ m * succ₁ n       ≡⟨ *-Sx m (succ₁ n) ⟩
        succ₁ n + m * succ₁ n   ≡⟨ +-Sx n (m * succ₁ n) ⟩
        succ₁ (n + m * succ₁ n) ∎

xy≡1→x≡1 : ∀ {m n} → N m → N n → m * n ≡ [1] → m ≡ [1]
xy≡1→x≡1 {n = n} nzero Nn h = ⊥-elim (0≢S (trans (sym (*-leftZero n)) h))
xy≡1→x≡1 (nsucc nzero) Nn h = refl
xy≡1→x≡1 (nsucc (nsucc {m} Nm)) nzero h =
  ⊥-elim (0≢S (trans (sym (*-rightZero (nsucc (nsucc Nm)))) h))
xy≡1→x≡1 (nsucc (nsucc {m} Nm)) (nsucc {n} Nn) h = ⊥-elim (0≢S prf₂)
  where
  prf₁ : [1] ≡ succ₁ (succ₁ (m + n * succ₁ (succ₁ m)))
  prf₁ = [1]
           ≡⟨ sym h ⟩
         succ₁ (succ₁ m) * succ₁ n
           ≡⟨ *-comm (nsucc (nsucc Nm)) (nsucc Nn) ⟩
         succ₁ n * succ₁ (succ₁ m)
           ≡⟨ *-Sx n (succ₁ (succ₁ m)) ⟩
         succ₁ (succ₁ m) + n * succ₁ (succ₁ m)
           ≡⟨ +-Sx (succ₁ m) (n * succ₁ (succ₁ m)) ⟩
         succ₁ (succ₁ m + n * succ₁ (succ₁ m))
           ≡⟨ succCong (+-Sx m (n * succ₁ (succ₁ m))) ⟩
         succ₁ (succ₁ (m + n * succ₁ (succ₁ m))) ∎

  prf₂ : zero ≡ succ₁ (m + n * succ₁ (succ₁ m))
  prf₂ = succInjective prf₁

xy≡1→y≡1 : ∀ {m n} → N m → N n → m * n ≡ [1] → n ≡ [1]
xy≡1→y≡1 Nm Nn h = xy≡1→x≡1 Nn Nm (trans (*-comm Nn Nm) h)

-- Feferman's axiom as presented by (Beeson 1986, p. 74).
succOnto : ∀ {n} → N n → n ≢ zero → succ₁ (pred₁ n) ≡ n
succOnto nzero          h = ⊥-elim (h refl)
succOnto (nsucc {n} Nn) h = succCong (pred-S n)


Added doc.

Added doc.

Ignore-this: 80d926b9e4dbcac1a79e75c92af756e4

darcs-hash:20100910030406-3bd4e-315bf9d30a56b926e882dc4e4bf2d9510b894407.gz

module Test.Fail.Add where

infix  4 _≡_
infixl 6 _+_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set
  _+_    : D → D → D
  +-0x   : (d : D) → zero + d     ≡ d
  +-Sx   : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

-- The ATPs should not prove this postulate.
postulate
  +-comm : (d e : D) → d + e ≡ e + d
-- Equinox 5.0alpha (2010-03-29) no-success due to timeout.
-- E 1.2 no-success due to timeout.
-- TODO: Metis 2.2 (release 20100825) success (SZS status CounterSatisfiable).
{-# ATP prove +-comm #-}

module Test.Fail.Add where

infix  4 _≡_
infixl 6 _+_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set
  _+_    : D → D → D
  +-0x   : (d : D) → zero + d     ≡ d
  +-Sx   : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

-- The ATPs cannot prove this postulate from the axioms.
postulate
  +-comm : (d e : D) → d + e ≡ e + d
{-# ATP prove +-comm #-}


FFI.JS.Type: more types and some notes

FFI.JS.Type: more types and some notes

module FFI.JS.Type where

open import FFI.JS using (JSValue; String)

-- https://javascriptweblog.wordpress.com/2011/08/08/fixing-the-javascript-typeof-operator/

-- typeof [1,2,3] === 'object'
-- typeof null    === 'object'

-- typeof NaN === "number" :)

-- Maybe there should be a JSONType with: array object number string bool null

data JSType : Set where
  array object number string bool null undefined function : JSType
{-# COMPILED_JS JSType function (x,v) { return require("libagda").readProp(v)(x)(); } #-}
{-# COMPILED_JS array     "array"  #-}
{-# COMPILED_JS object    "object" #-}
{-# COMPILED_JS number    "number" #-}
{-# COMPILED_JS string    "string" #-}
{-# COMPILED_JS bool      "bool"   #-}
{-# COMPILED_JS null      "null"   #-}
{-# COMPILED_JS undefined "undefined" #-}
{-# COMPILED_JS function  "function"  #-}

postulate typeof : JSValue → JSType
{-# COMPILED_JS typeof function(x) { return typeof(x); } #-}

postulate showJSType : JSType → String
{-# COMPILED_JS showJSType String #-}

-- TODO dyn check?
postulate castJSType : String → JSType
{-# COMPILED_JS castJSType String #-}

module FFI.JS.Type where

open import FFI.JS using (JSValue; String)

data JSType : Set where
  array object number string bool null : JSType
{-# COMPILED_JS JSType function (x,v) { return require("libagda").readProp(v)(x)(); } #-}
{-# COMPILED_JS array  "array"  #-}
{-# COMPILED_JS object "object" #-}
{-# COMPILED_JS number "number" #-}
{-# COMPILED_JS string "string" #-}
{-# COMPILED_JS bool   "bool"   #-}
{-# COMPILED_JS null   "null"   #-}

postulate typeof : JSValue → JSType
{-# COMPILED_JS typeof function(x) { return typeof(x); } #-}

postulate showJSType : JSType → String
{-# COMPILED_JS showJSType String #-}

-- TODO dyn check?
postulate castJSType : String → JSType
{-# COMPILED_JS castJSType String #-}


Typo.

Typo.

Ignore-this: 7a1ad958638531dfb96e1595d378bb26

darcs-hash:20120601191753-3bd4e-9b05ece3a07b7f4c240900179c8f58d8a48a3749.gz

------------------------------------------------------------------------------
-- Testing the function FOL.Translation.Terms.termToFOLTerm: Con term
------------------------------------------------------------------------------

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

module Test.Succeed.FOL.TermToFOLTerm.ConTerm where

-- We add 3 to the fixities of the standard library.
infixl 9 _+_
infix  7 _≡_

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

data M : Set where
  zero :     M
  succ : M → M

data _≡_ (m : M) : M → Set where
  refl : m ≡ m

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

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

+-Sx : ∀ m n → succ m + n ≡ succ (m + n)
+-Sx m n = refl
{-# ATP hint +-Sx #-}

postulate
  +-rightIdentity : ∀ n → n + zero ≡ n
  x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero     n = sym (+-rightIdentity n)
+-comm (succ m) n = prf (+-comm m n)
  where
  postulate prf : m + n ≡ n + m →  -- IH.
                  succ m + n ≡ n + succ m
  {-# ATP prove prf x+Sy≡S[x+y] #-}

------------------------------------------------------------------------------
-- Testing the function FOL.Translation.Terms.termToFOLTerm : Con term
------------------------------------------------------------------------------

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

module Test.Succeed.FOL.TermToFOLTerm.ConTerm where

-- We add 3 to the fixities of the standard library.
infixl 9 _+_
infix  7 _≡_

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

data M : Set where
  zero :     M
  succ : M → M

data _≡_ (m : M) : M → Set where
  refl : m ≡ m

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

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

+-Sx : ∀ m n → succ m + n ≡ succ (m + n)
+-Sx m n = refl
{-# ATP hint +-Sx #-}

postulate
  +-rightIdentity : ∀ n → n + zero ≡ n
  x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero     n = sym (+-rightIdentity n)
+-comm (succ m) n = prf (+-comm m n)
  where
  postulate prf : m + n ≡ n + m →  -- IH.
                  succ m + n ≡ n + succ m
  {-# ATP prove prf x+Sy≡S[x+y] #-}


Cosmetic changes.

Cosmetic changes.

Ignore-this: 80903b2cf7fe900d44f42d86dbdcea46

darcs-hash:20101201234212-3bd4e-27546a12f5c2b6f6c478b64bb34f66a05030b62b.gz

------------------------------------------------------------------------------
-- Equality reasoning on the universe of discourse.
------------------------------------------------------------------------------

module Common.Relation.Binary.EqReasoning where

open import Common.Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Common.Relation.Binary.PropositionalEquality.Properties
  using ( trans )
open import Common.Universe using ( D )

-- We add 3 to the fixities of the standard library.
infix 7 _≃_
infix  4 begin_
infixr 5 _≡⟨_⟩_
infix  5 _∎

------------------------------------------------------------------------------
-- Adapted from the standard library (Relation.Binary.PreorderReasoning).
private
  data _≃_ (x y : D) : Set where
    prf : x ≡ y → x ≃ y

begin_ : {x y : D} → x ≃ y → x ≡ y
begin prf x≡y = x≡y

_≡⟨_⟩_ : (x : D){y z : D} → x ≡ y → y ≃ z → x ≃ z
_ ≡⟨ x≡y ⟩ prf y≡z = prf (trans x≡y y≡z)

_∎ : (x : D) → x ≃ x
_∎ _ = prf refl

------------------------------------------------------------------------------
-- Equality reasoning on the universe of discourse.
------------------------------------------------------------------------------

module Common.Relation.Binary.EqReasoning where

open import Common.Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Common.Relation.Binary.PropositionalEquality.Properties
  using ( trans )
open import Common.Universe using ( D )

infix 7 _≃_

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

private
  data _≃_ (x y : D) : Set where
    prf : x ≡ y → x ≃ y

-- Adapted from the Ulf's thesis.
-- infix  5 chain>_
-- infixl 5 _===_by_
-- infix  4 _qed

-- chain>_ : (x : D) → x ≃ x
-- chain> x = prf (refl {x})

-- _===_by_ : {x y : D} → x ≃ y → (z : D) → y ≡ z → x ≃ z
-- prf p === z by q = prf (trans {_} {_} {_} p q)

-- _qed : {x y : D} → x ≃ y → x ≡ y
-- prf p qed = p

-- Adapted from the standard library (Relation.Binary.PreorderReasoning).

-- We add 3 to the fixities of the standard library.
infix  4 begin_
infixr 5 _≡⟨_⟩_
infix  5 _∎

begin_ : {x y : D} → x ≃ y → x ≡ y
begin prf x≡y = x≡y

_≡⟨_⟩_ : (x : D){y z : D} → x ≡ y → y ≃ z → x ≃ z
_ ≡⟨ x≡y ⟩ prf y≡z = prf (trans x≡y y≡z)

_∎ : (x : D) → x ≃ x
_∎ _ = prf refl


Cleaning.

Cleaning.

------------------------------------------------------------------------------
-- Equivalence: N as the least fixed-point and N using Agda's data constructor
------------------------------------------------------------------------------

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

module LeastFixedPoints.N where

open import FOTC.Base hiding ( pred-0 ; pred-S )
open import FOTC.Base.PropertiesI hiding ( predCong )

------------------------------------------------------------------------------
-- Auxiliary definitions and properties

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

------------------------------------------------------------------------------
module LFP where

  -- N is a least fixed-point of a functor

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

  -- The natural numbers are the least fixed-point of NatF.
  postulate
    N : D → Set

    -- N is a pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the introduction rules.
    N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ N n') → N n

    -- The higher-order version.
    N-in-ho : ∀ {n} → NatF N n → N n

    -- N is the least pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the elimination rule of an inductively
    -- defined predicate.
    N-least-pre-fixed :
      (A : D → Set) →
      (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ A n') → A n) →
      ∀ {n} → N n → A n

    -- Higher-order version.
    N-least-pre-fixed-ho :
      (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n

  ----------------------------------------------------------------------------
  -- From/to N-in/N-in-ho.

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

  N-in-ho₁ : ∀ {n} → NatF N n → N n
  N-in-ho₁ = N-in₁

  ----------------------------------------------------------------------------
  -- From/to N-least-pre-fixed/N-least-pre-fixed-ho

  N-least-pre-fixed' :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed' = N-least-pre-fixed-ho

  N-least-pre-fixed-ho' :
    (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n
  N-least-pre-fixed-ho' = N-least-pre-fixed

  ----------------------------------------------------------------------------
  -- The data constructors of N.
  nzero : N zero
  nzero = N-in (inj₁ refl)

  nsucc : ∀ {n} → N n → N (succ · n)
  nsucc Nn = N-in (inj₂ (_ , refl , Nn))

  ----------------------------------------------------------------------------
  -- Because N is the least pre-fixed point of NatF (i.e. N-in and
  -- N-ind), we can proof that N is also a post-fixed point of NatF.

  -- N is a post-fixed point of NatF.
  N-post-fixed : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ N n')
  N-post-fixed = N-least-pre-fixed A h
    where
    A : D → Set
    A m = m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ N m')

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ A m') → A m
    h (inj₁ m≡0)              = inj₁ m≡0
    h (inj₂ (m' , prf , Am')) = inj₂ (m' , prf , helper Am')
      where
      helper : A m' → N m'
      helper (inj₁ prf')                = subst N (sym prf') nzero
      helper (inj₂ (m'' , prf' , Am'')) = subst N (sym prf') (nsucc Am'')

  ----------------------------------------------------------------------------
  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step using N-least-pre-fixed.

  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h Nn = ∧-proj₂ (N-least-pre-fixed B h' Nn)
    where
    B : D → Set
    B n = N n ∧ A n

    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ B m') → B m
    h' (inj₁ m≡0) = subst B (sym m≡0) (nzero , A0)
    h' (inj₂ (m' , prf , Nm' , Am')) =
      (subst N (sym prf) (nsucc Nm')) , subst A (sym prf) (h Nm' Am')

  ----------------------------------------------------------------------------
  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step using N-least-pre-fixed

  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h = N-least-pre-fixed A h'
    where
    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ A m') → A m
    h' (inj₁ m≡0)              = subst A (sym m≡0) A0
    h' (inj₂ (m' , prf , Am')) = subst A (sym prf) (h Am')

  ----------------------------------------------------------------------------
  -- Example: We will use N-least-pre-fixed as the induction
  -- principle on N.

  postulate
    _+_  : D → D → D
    +-0x : ∀ d → zero + d         ≡ d
    +-Sx : ∀ d e → (succ · d) + e ≡ succ · (d + e)

  +-leftIdentity : ∀ n → zero + n ≡ n
  +-leftIdentity n = +-0x n

  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {n = n} Nm Nn = N-least-pre-fixed A h Nm
    where
    A : D → Set
    A i = N (i + n)

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ A m') → A m
    h (inj₁ m≡0) = subst N (cong (flip _+_ n) (sym m≡0)) A0
      where
      A0 : A zero
      A0 = subst N (sym (+-leftIdentity n)) Nn
    h (inj₂ (m' , prf , Am')) =
      subst N (cong (flip _+_ n) (sym prf)) (is Am')
      where
      is : ∀ {i} → A i → A (succ · i)
      is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

  ----------------------------------------------------------------------------
  -- Example: A proof using N-post-fixed.

  postulate
    pred-0 : pred · zero             ≡ zero
    pred-S : ∀ n → pred · (succ · n) ≡ n

  predCong : ∀ {m n} → m ≡ n → pred · m ≡ pred · n
  predCong refl = refl

  pred-N : ∀ {n} → N n → N (pred · n)
  pred-N {n} Nn = case h₁ h₂ (N-post-fixed Nn)
    where
    h₁ : n ≡ zero → N (pred · n)
    h₁ n≡0 = subst N (sym (trans (predCong n≡0) pred-0)) nzero

    h₂ : ∃[ n' ] n ≡ succ · n' ∧ N n' → N (pred · n)
    h₂ (n' , prf , Nn') = subst N (sym (trans (predCong prf) (pred-S n'))) Nn'

  ----------------------------------------------------------------------------
  -- From/to N as a least fixed-point to/from N as data type.

  data N' : D → Set where
    nzero' : N' zero
    nsucc' : ∀ {n} → N' n → N' (succ · n)

  N'→N : ∀ {n} → N' n → N n
  N'→N nzero'      = nzero
  N'→N (nsucc' Nn) = nsucc (N'→N Nn)

  -- Using N-ind₁.
  N→N' : ∀ {n} → N n → N' n
  N→N' = N-ind₁ N' nzero' (λ _ → nsucc')

  -- Using N-ind₂.
  N→N'₁ : ∀ {n} → N n → N' n
  N→N'₁ = N-ind₂ N' nzero' nsucc'

------------------------------------------------------------------------------
module Data where

  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ · n)

  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step.
  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h nzero      = A0
  N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step.
  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h nzero      = A0
  N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

  ----------------------------------------------------------------------------
  -- N-in.

  N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ N n') → N n
  N-in {n} h = case prf₁ prf₂ h
    where
    prf₁ : n ≡ zero → N n
    prf₁ n≡0 = subst N (sym n≡0) nzero

    prf₂ : ∃[ n' ] n ≡ succ · n' ∧ N n' → N n
    prf₂ (n' , prf , Nn') = subst N (sym prf) (nsucc Nn')

  ----------------------------------------------------------------------------
  -- From N-ind₂ to N-least-pre-fixed.

  N-least-pre-fixed₂ :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed₂ A h = N-ind₂ A h₁ h₂
    where
    h₁ :  A zero
    h₁ = h (inj₁ refl)

    h₂ : ∀ {m} → A m → A (succ · m)
    h₂ {m} Am = h (inj₂ (m , refl , Am))

------------------------------------------------------------------------------
-- Equivalence: N as the least fixed-point and N using Agda's data constructor
------------------------------------------------------------------------------

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

module LeastFixedPoints.N where

open import FOTC.Base hiding ( pred-0 ; pred-S )
open import FOTC.Base.PropertiesI hiding ( predCong )

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions and properties

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

------------------------------------------------------------------------------
module LFP where

  -- N is a least fixed-point of a functor

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

  -- The natural numbers are the least fixed-point of NatF.
  postulate
    N : D → Set

    -- N is a pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the introduction rules.
    N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ N n') → N n

    -- The higher-order version.
    N-in-ho : ∀ {n} → NatF N n → N n

    -- N is the least pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the elimination rule of an inductively
    -- defined predicate.
    N-least-pre-fixed :
      (A : D → Set) →
      (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ A n') → A n) →
      ∀ {n} → N n → A n

    -- Higher-order version.
    N-least-pre-fixed-ho :
      (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n

  ----------------------------------------------------------------------------
  -- From/to N-in/N-in-ho.

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

  N-in-ho₁ : ∀ {n} → NatF N n → N n
  N-in-ho₁ = N-in₁

  ----------------------------------------------------------------------------
  -- From/to N-least-pre-fixed/N-least-pre-fixed-ho

  N-least-pre-fixed' :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed' = N-least-pre-fixed-ho

  N-least-pre-fixed-ho' :
    (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n
  N-least-pre-fixed-ho' = N-least-pre-fixed

  ----------------------------------------------------------------------------
  -- The data constructors of N.
  nzero : N zero
  nzero = N-in (inj₁ refl)

  nsucc : ∀ {n} → N n → N (succ · n)
  nsucc Nn = N-in (inj₂ (_ , refl , Nn))

  ----------------------------------------------------------------------------
  -- Because N is the least pre-fixed point of NatF (i.e. N-in and
  -- N-ind), we can proof that N is also a post-fixed point of NatF.

  -- N is a post-fixed point of NatF.
  N-post-fixed : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ N n')
  N-post-fixed = N-least-pre-fixed A h
    where
    A : D → Set
    A m = m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ N m')

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ A m') → A m
    h (inj₁ m≡0)              = inj₁ m≡0
    h (inj₂ (m' , prf , Am')) = inj₂ (m' , prf , helper Am')
      where
      helper : A m' → N m'
      helper (inj₁ prf')                = subst N (sym prf') nzero
      helper (inj₂ (m'' , prf' , Am'')) = subst N (sym prf') (nsucc Am'')

  ----------------------------------------------------------------------------
  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step using N-least-pre-fixed.

  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h Nn = ∧-proj₂ (N-least-pre-fixed B h' Nn)
    where
    B : D → Set
    B n = N n ∧ A n

    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ B m') → B m
    h' (inj₁ m≡0) = subst B (sym m≡0) (nzero , A0)
    h' (inj₂ (m' , prf , Nm' , Am')) =
      (subst N (sym prf) (nsucc Nm')) , subst A (sym prf) (h Nm' Am')

  ----------------------------------------------------------------------------
  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step using N-least-pre-fixed

  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h = N-least-pre-fixed A h'
    where
    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ A m') → A m
    h' (inj₁ m≡0)              = subst A (sym m≡0) A0
    h' (inj₂ (m' , prf , Am')) = subst A (sym prf) (h Am')

  ----------------------------------------------------------------------------
  -- Example: We will use N-least-pre-fixed as the induction
  -- principle on N.

  postulate
    _+_  : D → D → D
    +-0x : ∀ d → zero + d         ≡ d
    +-Sx : ∀ d e → (succ · d) + e ≡ succ · (d + e)

  +-leftIdentity : ∀ n → zero + n ≡ n
  +-leftIdentity n = +-0x n

  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {n = n} Nm Nn = N-least-pre-fixed A h Nm
    where
    A : D → Set
    A i = N (i + n)

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ · m' ∧ A m') → A m
    h (inj₁ m≡0) = subst N (cong (flip _+_ n) (sym m≡0)) A0
      where
      A0 : A zero
      A0 = subst N (sym (+-leftIdentity n)) Nn
    h (inj₂ (m' , prf , Am')) =
      subst N (cong (flip _+_ n) (sym prf)) (is Am')
      where
      is : ∀ {i} → A i → A (succ · i)
      is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

  ----------------------------------------------------------------------------
  -- Example: A proof using N-post-fixed.

  postulate
    pred-0 : pred · zero             ≡ zero
    pred-S : ∀ n → pred · (succ · n) ≡ n

  predCong : ∀ {m n} → m ≡ n → pred · m ≡ pred · n
  predCong refl = refl

  pred-N : ∀ {n} → N n → N (pred · n)
  pred-N {n} Nn = case h₁ h₂ (N-post-fixed Nn)
    where
    h₁ : n ≡ zero → N (pred · n)
    h₁ n≡0 = subst N (sym (trans (predCong n≡0) pred-0)) nzero

    h₂ : ∃[ n' ] n ≡ succ · n' ∧ N n' → N (pred · n)
    h₂ (n' , prf , Nn') = subst N (sym (trans (predCong prf) (pred-S n'))) Nn'

  ----------------------------------------------------------------------------
  -- From/to N as a least fixed-point to/from N as data type.

  data N' : D → Set where
    nzero' : N' zero
    nsucc' : ∀ {n} → N' n → N' (succ · n)

  N'→N : ∀ {n} → N' n → N n
  N'→N nzero'      = nzero
  N'→N (nsucc' Nn) = nsucc (N'→N Nn)

  -- Using N-ind₁.
  N→N' : ∀ {n} → N n → N' n
  N→N' = N-ind₁ N' nzero' (λ _ → nsucc')

  -- Using N-ind₂.
  N→N'₁ : ∀ {n} → N n → N' n
  N→N'₁ = N-ind₂ N' nzero' nsucc'

------------------------------------------------------------------------------
module Data where

  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ · n)

  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step.
  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h nzero      = A0
  N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step.
  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ · n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h nzero      = A0
  N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

  ----------------------------------------------------------------------------
  -- N-in.

  N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ N n') → N n
  N-in {n} h = case prf₁ prf₂ h
    where
    prf₁ : n ≡ zero → N n
    prf₁ n≡0 = subst N (sym n≡0) nzero

    prf₂ : ∃[ n' ] n ≡ succ · n' ∧ N n' → N n
    prf₂ (n' , prf , Nn') = subst N (sym prf) (nsucc Nn')

  ----------------------------------------------------------------------------
  -- From N-ind₂ to N-least-pre-fixed.

  N-least-pre-fixed₂ :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ · n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed₂ A h = N-ind₂ A h₁ h₂
    where
    h₁ :  A zero
    h₁ = h (inj₁ refl)

    h₂ : ∀ {m} → A m → A (succ · m)
    h₂ {m} Am = h (inj₂ (m , refl , Am))

------------------------------------------------------------------------------
-- References
--
-- Ésik, Z. (2009). Fixed Point Theory. In: Handbook of Weighted
-- Automata. Ed. by Droste, M., Kuich, W. and Vogler, H. Monographs in
-- Theoretical Computer Science. An EATCS Series. Springer. Chap. 2.


Cosmetic changes.

Cosmetic changes.

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

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

module FOTC.Data.List.PropertiesATP where

open import FOTC.Base
open FOTC.Base.BList
open import FOTC.Data.Conat
open import FOTC.Data.List
open import FOTC.Data.Nat.Type

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

++-List : ∀ {xs ys} → List xs → List ys → List (xs ++ ys)
++-List {ys = ys} lnil Lys = prf
  where postulate prf : List ([] ++ ys)
        {-# ATP prove prf #-}

++-List {ys = ys} (lcons x {xs} Lxs) Lys = prf (++-List Lxs Lys)
  where postulate prf : List (xs ++ ys) → List ((x ∷ xs) ++ ys)
        {-# ATP prove prf #-}

map-List : ∀ f {xs} → List xs → List (map f xs)
map-List f lnil = prf
  where postulate prf : List (map f [])
        {-# ATP prove prf #-}
map-List f (lcons x {xs} Lxs) = prf (map-List f Lxs)
  where postulate prf : List (map f xs) → List (map f (x ∷ xs))
        {-# ATP prove prf #-}

rev-List : ∀ {xs ys} → List xs → List ys → List (rev xs ys)
rev-List {ys = ys} lnil Lys = prf
  where postulate prf : List (rev [] ys)
        {-# ATP prove prf #-}
rev-List {ys = ys} (lcons x {xs} Lxs) Lys = prf (rev-List Lxs (lcons x Lys))
  where postulate prf : List (rev xs (x ∷ ys)) → List (rev (x ∷ xs) ys)
        {-# ATP prove prf #-}

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

-- Length properties

length-replicate : ∀ x {n} → N n → length (replicate n x) ≡ n
length-replicate x nzero = prf
  where postulate prf : length (replicate zero x) ≡ zero
        {-# ATP prove prf #-}
length-replicate x (nsucc {n} Nn) = prf (length-replicate x Nn)
  where postulate prf : length (replicate n x) ≡ n →
                        length (replicate (succ₁ n) x) ≡ succ₁ n
        {-# ATP prove prf #-}

postulate lg-xs≡∞→lg-x∷xs≡∞ : ∀ x xs → length xs ≡ ∞ → length (x ∷ xs) ≡ ∞
{-# ATP prove lg-xs≡∞→lg-x∷xs≡∞ #-}

-- Append properties

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

++-rightIdentity : ∀ {xs} → List xs → xs ++ [] ≡ xs
++-rightIdentity lnil = prf
  where postulate prf : [] ++ [] ≡ []
        {-# ATP prove prf #-}

++-rightIdentity (lcons x {xs} Lxs) = prf (++-rightIdentity Lxs)
  where postulate prf : xs ++ [] ≡ xs → (x ∷ xs) ++ [] ≡ x ∷ xs
        {-# ATP prove prf #-}

++-assoc : ∀ {xs} → List xs → ∀ ys zs → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
++-assoc .{[]} lnil ys zs = prf
  where postulate prf : ([] ++ ys) ++ zs ≡ [] ++ ys ++ zs
        {-# ATP prove prf #-}

++-assoc .{x ∷ xs} (lcons x {xs} Lxs) ys zs = prf (++-assoc Lxs ys zs)
  where postulate prf : (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs →
                        ((x ∷ xs) ++ ys) ++ zs ≡ (x ∷ xs) ++ ys ++ zs
        {-# ATP prove prf #-}

-- Map properties

map-++-commute : ∀ f {xs} → List xs → ∀ ys →
                 map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-commute f lnil ys = prf
  where postulate prf : map f ([] ++ ys) ≡ map f [] ++ map f ys
        {-# ATP prove prf #-}

map-++-commute f (lcons x {xs} Lxs) ys = prf (map-++-commute f Lxs ys)
  where postulate prf : map f (xs ++ ys) ≡ map f xs ++ map f ys →
                        map f ((x ∷ xs) ++ ys) ≡ map f (x ∷ xs) ++ map f ys
        {-# ATP prove prf #-}

-- Reverse properties

postulate reverse-[x]≡[x] : ∀ x → reverse (x ∷ []) ≡ x ∷ []
{-# ATP prove reverse-[x]≡[x] #-}

rev-++-commute : ∀ {xs} → List xs → ∀ ys → rev xs ys ≡ rev xs [] ++ ys
rev-++-commute lnil ys = prf
  where postulate prf : rev [] ys ≡ rev [] [] ++ ys
        {-# ATP prove prf #-}
rev-++-commute (lcons x {xs} Lxs) ys =
  prf (rev-++-commute Lxs (x ∷ ys)) (rev-++-commute Lxs (x ∷ []))
  where postulate prf : rev xs (x ∷ ys) ≡ rev xs [] ++ x ∷ ys →
                        rev xs (x ∷ []) ≡ rev xs [] ++ x ∷ [] →
                        rev (x ∷ xs) ys ≡ rev (x ∷ xs) [] ++ ys
        {-# ATP prove prf ++-assoc rev-List #-}

reverse-++-commute : ∀ {xs ys} → List xs → List ys →
                     reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-commute {ys = ys} lnil Lys = prf
  where postulate prf : reverse ([] ++ ys) ≡ reverse ys ++ reverse []
        {-# ATP prove prf ++-rightIdentity reverse-List #-}

reverse-++-commute (lcons x {xs} Lxs) lnil = prf
  where
  postulate prf : reverse ((x ∷ xs) ++ []) ≡ reverse [] ++ reverse (x ∷ xs)
  {-# ATP prove prf ++-rightIdentity #-}

reverse-++-commute (lcons x {xs} Lxs) (lcons y {ys} Lys) =
  prf (reverse-++-commute Lxs (lcons y Lys))
  where
  postulate prf : reverse (xs ++ y ∷ ys) ≡ reverse (y ∷ ys) ++
                                           reverse xs →
                  reverse ((x ∷ xs) ++ y ∷ ys) ≡ reverse (y ∷ ys) ++
                                                 reverse (x ∷ xs)
  {-# ATP prove prf reverse-List ++-List rev-++-commute ++-assoc #-}

reverse-∷ : ∀ x {ys} → List ys →
            reverse (x ∷ ys) ≡ reverse ys ++ (x ∷ [])
reverse-∷ x lnil = prf
  where postulate prf : reverse (x ∷ []) ≡ reverse [] ++ x ∷ []
        {-# ATP prove prf #-}

reverse-∷ x (lcons y {ys} Lys) = prf
  where postulate prf : reverse (x ∷ y ∷ ys) ≡ reverse (y ∷ ys) ++ x ∷ []
        {-# ATP prove prf reverse-[x]≡[x] reverse-++-commute #-}

reverse-involutive : ∀ {xs} → List xs → reverse (reverse xs) ≡ xs
reverse-involutive lnil = prf
  where postulate prf : reverse (reverse []) ≡ []
        {-# ATP prove prf #-}

reverse-involutive (lcons x {xs} Lxs) = prf (reverse-involutive Lxs)
  where
  postulate prf : reverse (reverse xs) ≡ xs →
                  reverse (reverse (x ∷ xs)) ≡ x ∷ xs
  {-# ATP prove prf rev-List reverse-++-commute ++-List ++-rightIdentity #-}


Finish script rules.

Finish script rules.

Script doesn't have length except with macron and breve marks.

module Language.Greek.Script where

open import Relation.Nullary using (¬_)

data Vowel : Set where
  α ε η ι ο υ ω : Vowel

data Consonant : Set where
  β γ δ ζ θ κ λ′ μ ν ξ π ρ σ τ φ χ ψ : Consonant

data Letter : Set where
  vowel : Vowel → Letter
  consonant : Consonant → Letter

data LengthMark : Set where
  breve macron : LengthMark

data VowelLengthMark : Vowel → LengthMark → Set where
  either-α : ∀ {l} → VowelLengthMark α l
  either-ι : ∀ {l} → VowelLengthMark ι l
  either-υ : ∀ {l} → VowelLengthMark υ l

data Case : Set where
  upper lower : Case

data LetterCase : Letter → Case → Set where
  any-case : ∀ {l c} → LetterCase l c

data VowelIotaSubscript : Vowel → Set where
  ᾳ : VowelIotaSubscript α
  ῃ : VowelIotaSubscript η
  ῳ : VowelIotaSubscript ω

data VowelDiaeresis : Vowel → Set where
  diaeresis : ∀ {v} → VowelDiaeresis v

data Accent : Set where
  acute grave circumflex : Accent

data VowelAccent : Vowel → Accent → Set where
  vowelAcute : ∀ {v} → VowelAccent v acute
  vowelGrave : ∀ {v} → VowelAccent v grave
  vowelCircumflex-α : VowelAccent α circumflex
  vowelCircumflex-η : VowelAccent η circumflex
  vowelCircumflex-ι : VowelAccent ι circumflex
  vowelCircumflex-υ : VowelAccent υ circumflex
  vowelCircumflex-ω : VowelAccent ω circumflex

data Breathing : Set where
  smooth rough : Breathing

data LetterBreathing : Letter → Breathing → Set where
  vowelBreathing : ∀ {v b} → LetterBreathing v b
  rhoBreathing : ∀ {b} → LetterBreathing (consonant ρ) b

data Final : Letter → Set where
  ς : Final (consonant σ)

-- proofs about iota subscript

ε-no-subscript : ¬ VowelIotaSubscript ε
ε-no-subscript ()

ι-no-subscript : ¬ VowelIotaSubscript ι
ι-no-subscript ()

ο-no-subscript : ¬ VowelIotaSubscript ο
ο-no-subscript ()

υ-no-subscript : ¬ VowelIotaSubscript υ
υ-no-subscript ()

module Language.Greek.Script where

open import Relation.Nullary using (¬_)

data Vowel : Set where
  α ε η ι ο υ ω : Vowel

data Consonant : Set where
  β γ δ ζ θ κ λ′ μ ν ξ π ρ σ τ φ χ ψ : Consonant

data Letter : Set where
  vowel : Vowel → Letter
  consonant : Consonant → Letter

data Length : Set where
  short long : Length

data VowelLength : Vowel → Length → Set where
  either-α : ∀ {l} → VowelLength α l
  either-ι : ∀ {l} → VowelLength ι l
  either-υ : ∀ {l} → VowelLength υ l
  short-ε : VowelLength ε short
  short-ο : VowelLength ο short
  long-η : VowelLength η long
  long-ω : VowelLength ω long

data Case : Set where
  upper lower : Case

data LetterCase : Letter → Case → Set where
  any-case : ∀ {l c} → LetterCase l c

data IotaSubscript : Vowel → Set where
  α_ι : IotaSubscript α
  η_ι : IotaSubscript η
  ω_ι : IotaSubscript ω

-- proofs about length

ε-not-long : ¬ VowelLength ε long
ε-not-long ()

ο-not-long : ¬ VowelLength ο long
ο-not-long ()

η-not-short : ¬ VowelLength η short
η-not-short ()

ω-not-short : ¬ VowelLength ω short
ω-not-short ()

-- proofs about iota subscript

ε-no-subscript : ¬ IotaSubscript ε
ε-no-subscript ()

ι-no-subscript : ¬ IotaSubscript ι
ι-no-subscript ()

ο-no-subscript : ¬ IotaSubscript ο
ο-no-subscript ()

υ-no-subscript : ¬ IotaSubscript υ
υ-no-subscript ()


Upgrade flat-funs-implem

Upgrade flat-funs-implem

module flat-funs-implem where

open import Data.Unit using (⊤)
open import Data.Fin using (Fin)
open import Data.Nat.NP using (ℕ)
open import Data.Bool using (if_then_else_)
import Data.Vec.NP as V
import Function as F
import Data.Product as ×
open F using (const; _∘′_)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_; _,_; proj₁; proj₂; uncurry)

open import Data.Bits using (_→ᵇ_; 0b; 1b)

open import data-universe
open import flat-funs

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

module FunTypes = FlatFuns fun♭Funs

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

module BitsFunTypes = FlatFuns bitsFun♭Funs

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

module FinFunTypes = FlatFuns finFun♭Funs

funLin : LinRewiring fun♭Funs
funLin = mk F.id _∘′_
            (λ f → ×.map f F.id)
            ×.swap (λ {((x , y) , z) → x , (y , z) }) (λ x → _ , x) proj₂
            (λ f g → ×.map f g) (λ f → ×.map F.id f)
            (F.const []) _ (uncurry _∷_) V.uncons

funRewiring : Rewiring fun♭Funs
funRewiring = mk funLin _ (λ x → x , x) (F.const []) ×.<_,_> proj₁ proj₂

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk funRewiring (F.const 0b) (F.const 1b) (λ { (b , x , y) → if b then x else y })
             (λ { f g (b , x) → (if b then f else g) x })

module FunOps = FlatFunsOps fun♭Ops

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk rewiring (const [ 0b ]) (const [ 1b ]) cond forkᵇ
  where
  open BitsFunTypes
  open FunOps using (id; _∘_)
  fstᵇ : ∀ {A B} → A `× B `→ A
  fstᵇ {A} = V.take A
  sndᵇ : ∀ {B} A → A `× B `→ B
  sndᵇ A = V.drop A
  <_,_>ᵇ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  <_,_>ᵇ f g x = f x ++ g x
  forkᵇ : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  forkᵇ f g (b ∷ xs) = (if b then f else g) xs
  open Defaults bitsFun♭Funs
  open DefaultsGroup2 id _∘_ (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)
  open DefaultCond forkᵇ fstᵇ (λ {x} → sndᵇ x)

  lin : LinRewiring bitsFun♭Funs
  lin = mk id _∘_ first (λ {x} → swap {x}) (λ {x} → assoc {x}) id id
           <_×_> (λ {x} → second {x}) id id id id

  rewiring : Rewiring bitsFun♭Funs
  rewiring = mk lin (const []) dup (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)

bitsFunRewiring : Rewiring bitsFun♭Funs
bitsFunRewiring = FlatFunsOps.rewiring bitsFun♭Ops

bitsFunLin : LinRewiring bitsFun♭Funs
bitsFunLin = Rewiring.linRewiring bitsFunRewiring

module BitsFunOps = FlatFunsOps bitsFun♭Ops

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

module ConstFunTypes A = FlatFuns (constFuns A)

⊤-FunOps : FlatFunsOps (constFuns ⊤)
⊤-FunOps = _

module flat-funs-implem where

open import Data.Unit using (⊤)
open import Data.Fin using (Fin)
open import Data.Nat.NP using (ℕ)
open import Data.Bool using (if_then_else_)
import Data.Vec.NP as V
import Function as F
import Data.Product as ×
open F using (const; _∘′_)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_; _,_; proj₁; proj₂; uncurry)

open import Data.Bits using (_→ᵇ_; 0b; 1b)

open import data-universe
open import flat-funs

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

module FunTypes = FlatFuns fun♭Funs

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

module BitsFunTypes = FlatFuns bitsFun♭Funs

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

module FinFunTypes = FlatFuns finFun♭Funs

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk F.id _∘′_
             (F.const 0b) (F.const 1b) (λ { (b , x , y) → if b then x else y })
             (λ { f g (b , x) → (if b then f else g) x }) _
             ×.<_,_> proj₁ proj₂ (λ x → x , x) (λ f → ×.map f F.id)
             ×.swap (λ {((x , y) , z) → x , (y , z) }) (λ x → _ , x) proj₂
             (λ f g → ×.map f g) (λ f → ×.map F.id f)
             (F.const []) (uncurry _∷_) V.uncons

module FunOps = FlatFunsOps fun♭Ops

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id _∘_
                 (const [ 0b ]) (const [ 1b ]) cond forkᵇ (const [])
                 <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x) dup first
                 (λ {x} → swap {x}) (λ {x} → assoc {x}) id id
                 <_×_> (λ {x} → second {x}) (const []) id id
  where
  open BitsFunTypes
  open FunOps using (id; _∘_)
  fstᵇ : ∀ {A B} → A `× B `→ A
  fstᵇ {A} = V.take A
  sndᵇ : ∀ {B} A → A `× B `→ B
  sndᵇ A = V.drop A
  <_,_>ᵇ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  <_,_>ᵇ f g x = f x ++ g x
  forkᵇ : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  forkᵇ f g (b ∷ xs) = (if b then f else g) xs
  open Defaults bitsFun♭Funs
  open DefaultsGroup2 id _∘_ (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)
  open DefaultCond forkᵇ fstᵇ (λ {x} → sndᵇ x)

module BitsFunOps = FlatFunsOps bitsFun♭Ops

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

module ConstFunTypes A = FlatFuns (constFuns A)


Removed unnecessary import.

Removed unnecessary import.

Ignore-this: 26a6cc88934801a8cf0d09f6f5d6bef

darcs-hash:20111208203353-3bd4e-576bb8e2e9180af6a7f4e5fbe64f7112429b79c3.gz

-- Tested on 08 December 2011.

module BottomBottom where

open import Common.Universe
open import Common.Data.Empty

postulate bot₁ bot₂ : ⊥
{-# ATP prove bot₁ bot₂ #-}
{-# ATP prove bot₂ bot₁ #-}

-- $ agda2atp -i src -i notes/papers/FoSSaCS-2012/ notes/papers/FoSSaCS-2012/BottomBottom.agda
-- Proving the conjecture in /tmp/BottomBottom.bot1_8.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/BottomBottom.bot1_8.tptp
-- Proving the conjecture in /tmp/BottomBottom.bot2_8.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/BottomBottom.bot2_8.tptp

-- Tested on 08 December 2011.

module BottomBottom where

open import Common.Universe
open import Common.Data.Empty
import Common.Relation.Binary.PropositionalEquality
open module Eq =
  Common.Relation.Binary.PropositionalEquality.Inductive

postulate
  bot₁ : ⊥
  bot₂ : ⊥
{-# ATP prove bot₁ bot₂ #-}
{-# ATP prove bot₂ bot₁ #-}

-- $ agda2atp -isrc -inotes/papers/FoSSaCS-2012/  notes/papers/FoSSaCS-2012/BottomBottom.agda
-- Proving the conjecture in /tmp/BottomBottom.bot1_12.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/BottomBottom.bot1_12.tptp
-- Proving the conjecture in /tmp/BottomBottom.bot2_13.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/BottomBottom.bot2_13.tptp


Added examples of polimorphic lists.

Added examples of polimorphic lists.

------------------------------------------------------------------------------
-- Testing polymorphic lists
------------------------------------------------------------------------------

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

module FOT.FOTC.Polymorphism.List where

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

------------------------------------------------------------------------------
-- Heterogeneous lists
data List : D → Set where
  lnil  :                      List []
  lcons : ∀ x {xs} → List xs → List (x ∷ xs)

xs : D
xs = [0] ∷ true ∷ [1] ∷ false ∷ []

xs-List : List xs
xs-List = lcons [0] (lcons true (lcons [1] (lcons false lnil)))

-- Lists of total natural numbers
data ListN : D → Set where
  lnnil  :                             ListN []
  lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

ys : D
ys = [0] ∷ [1] ∷ [2] ∷ []

ys-ListN : ListN ys
ys-ListN =
  lncons nzero (lncons (nsucc nzero) (lncons (nsucc (nsucc nzero)) lnnil))

-- Lists of total Booleans
data ListB : D → Set where
  lbnil  :                                ListB []
  lbcons : ∀ {b bs} → Bool b → ListB bs → ListB (b ∷ bs)

zs : D
zs = true ∷ false ∷ true ∷ []

zs-ListB : ListB zs
zs-ListB = lbcons btrue (lbcons bfalse (lbcons btrue lbnil))

-- Polymorphic lists.
-- NB. The data type list is in *Set₁*.
data ListP (A : D → Set) : D → Set₁ where
  lnil  :                               ListP A []
  lcons : ∀ {x xs} → A x → ListP A xs → ListP A (x ∷ xs)

List₁ : D → Set₁
List₁ = ListP (λ d → d ≡ d)

xs-List₁ : List₁ xs
xs-List₁ = lcons refl (lcons refl (lcons refl (lcons refl lnil)))

ListN₁ : D → Set₁
ListN₁ = ListP N

ys-ListN₁ : ListN₁ ys
ys-ListN₁ = lcons nzero (lcons (nsucc nzero) (lcons (nsucc (nsucc nzero)) lnil))

ListB₁ : D → Set₁
ListB₁ = ListP Bool

zs-ListB₁ : ListB₁ zs
zs-ListB₁ = lcons btrue (lcons bfalse (lcons btrue lnil))

------------------------------------------------------------------------------
-- Testing polymorphic lists
------------------------------------------------------------------------------

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

module FOT.FOTC.Polymorphism.List where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Bool.Type
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Heterogeneous lists
data List : D → Set where
  lnil  :                      List []
  lcons : ∀ x {xs} → List xs → List (x ∷ xs)

-- Lists of total natural numbers
data ListN : D → Set where
  lnnil  :                             ListN []
  lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

-- Lists of total Booleans
data ListB : D → Set where
  lbnil  :                                ListB []
  lbcons : ∀ {b bs} → Bool b → ListB bs → ListB (b ∷ bs)

-- Polymorphic lists.
-- NB. The data type list is in *Set₁*.
data ListP (A : D → Set) : D → Set₁ where
  lnil  :                               ListP A []
  lcons : ∀ {x xs} → A x → ListP A xs → ListP A (x ∷ xs)

List₁ : D → Set₁
List₁ = ListP (λ d → d ≡ d)

ListN₁ : D → Set₁
ListN₁ = ListP N

ListB₁ : D → Set₁
ListB₁ = ListP Bool


Simplified some proofs.

Simplified some proofs.

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

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

module FOTC.Data.List.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning
open import Common.Function

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

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

∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
∷-leftCong refl = refl

∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
∷-rightCong refl = refl

++-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

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

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

reverseCong : ∀ {xs ys} → xs ≡ ys → reverse xs ≡ reverse ys
reverseCong 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

-- Length properties

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

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

lg-xs<lg-[]→⊥ : ∀ {xs} → List xs → ¬ (LT (length xs) (length []))
lg-xs<lg-[]→⊥ lnil lg-[]<lg-[] = ⊥-elim (0<0→⊥ helper)
  where
  helper : zero < zero ≡ true
  helper =
    zero < zero
      ≡⟨ subst₂ (λ t₁ t₂ → zero < zero ≡ t₁ < t₂)
                (sym length-[])
                (sym length-[])
                refl
      ⟩
    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 ≡ true
  helper =
    succ₁ (length xs) < zero
      ≡⟨ subst₂ (λ t₁ t₂ → succ₁ (length xs) < zero ≡ t₁ < t₂)
                (sym (length-∷ x xs))
                (sym length-[])
                refl
      ⟩
    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               = ++-[] []
++-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 (++-[] 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-++-commute : ∀ f {xs} → List xs → ∀ ys →
                 map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-commute f lnil ys =
  map f ([] ++ ys)
    ≡⟨ subst (λ t → map f ([] ++ ys) ≡ map f t) (++-[] ys) refl ⟩
  map f ys
    ≡⟨ sym (++-leftIdentity (map f ys)) ⟩
  [] ++ map f ys
     ≡⟨ subst (λ t → [] ++ map f ys ≡ t ++ map f ys) (sym (map-[] f)) refl
     ⟩
  map f [] ++ map f ys ∎

map-++-commute f (lcons x {xs} Lxs) ys =
  map f ((x ∷ xs) ++ ys)
    ≡⟨ subst (λ t → map f ((x ∷ xs) ++ ys) ≡ map f t) (++-∷ x xs ys) refl ⟩
  map f (x ∷ xs ++ ys)
    ≡⟨ map-∷ f x (xs ++ ys) ⟩
  f · x ∷ map f (xs ++ ys)
    ≡⟨ subst (λ t → f · x ∷ map f (xs ++ ys) ≡ f · x ∷ t)
             (map-++-commute f Lxs ys)
             refl
    ⟩
  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
     ≡⟨ subst (λ t → (f · x ∷ map f xs) ++ map f ys ≡ t ++ map f ys)
              (sym (map-∷ f x xs))
              refl
     ⟩
  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-++-commute : ∀ {xs} → List xs → ∀ ys → rev xs ys ≡ rev xs [] ++ ys
rev-++-commute lnil ys =
  rev [] ys       ≡⟨ rev-[] ys ⟩
  ys              ≡⟨ sym $ ++-leftIdentity ys ⟩
  [] ++ ys        ≡⟨ ++-leftCong (sym $ rev-[] []) ⟩
  rev [] [] ++ ys ∎

rev-++-commute (lcons x {xs} Lxs) ys =
  rev (x ∷ xs) ys
    ≡⟨ rev-∷ x xs ys ⟩
  rev xs (x ∷ ys)
    ≡⟨ rev-++-commute 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-++-commute Lxs (x ∷ [])) ⟩
  rev xs (x ∷ []) ++ ys
    ≡⟨ ++-leftCong (sym $ rev-∷ x xs []) ⟩
  rev (x ∷ xs) [] ++ ys ∎

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

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

reverse-++-commute (lcons x {xs} Lxs) (lcons y {ys} Lys) =
  reverse ((x ∷ xs) ++ y ∷ ys)
    ≡⟨ refl ⟩
  rev ((x ∷ xs) ++ y ∷ ys) []
    ≡⟨ revLeftCong (++-∷ x xs (y ∷ ys)) ⟩
  rev (x ∷ (xs ++ y ∷ ys)) []
    ≡⟨ rev-∷ x (xs ++ y ∷ ys) [] ⟩
  rev (xs ++ y ∷ ys) (x ∷ [])
    ≡⟨ rev-++-commute (++-List Lxs (lcons y Lys)) (x ∷ []) ⟩
  rev (xs ++ y ∷ ys) [] ++ (x ∷ [])
    ≡⟨ refl ⟩
  reverse (xs ++ y ∷ ys) ++ (x ∷ [])
    ≡⟨ ++-leftCong (reverse-++-commute 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-++-commute 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-++-commute (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) ∎

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

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

module FOTC.Data.List.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning
open import Common.Function

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

------------------------------------------------------------------------------
-- 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

-- Length properties

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

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

lg-xs<lg-[]→⊥ : ∀ {xs} → List xs → ¬ (LT (length xs) (length []))
lg-xs<lg-[]→⊥ lnil lg-[]<lg-[] = ⊥-elim (0<0→⊥ helper)
  where
  helper : zero < zero ≡ true
  helper =
    zero < zero
      ≡⟨ subst₂ (λ t₁ t₂ → zero < zero ≡ t₁ < t₂)
                (sym length-[])
                (sym length-[])
                refl
      ⟩
    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 ≡ true
  helper =
    succ₁ (length xs) < zero
      ≡⟨ subst₂ (λ t₁ t₂ → succ₁ (length xs) < zero ≡ t₁ < t₂)
                (sym (length-∷ x xs))
                (sym length-[])
                refl
      ⟩
    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               = ++-[] []
++-rightIdentity (lcons x {xs} Lxs) =
  (x ∷ xs) ++ []
     ≡⟨ ++-∷ x xs [] ⟩
  x ∷ (xs ++ [])
    ≡⟨ subst (λ t → x ∷ (xs ++ []) ≡ x ∷ t) (++-rightIdentity Lxs) refl ⟩
  x ∷ xs ∎

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

++-assoc (lcons x {xs} Lxs) ys zs =
  ((x ∷ xs) ++ ys) ++ zs
    ≡⟨ subst (λ t → ((x ∷ xs) ++ ys) ++ zs ≡ t ++ zs) (++-∷ x xs ys) refl ⟩
  (x ∷ (xs ++ ys)) ++ zs
     ≡⟨ ++-∷ x (xs ++ ys) zs ⟩
  x ∷ ((xs ++ ys) ++ zs)
    ≡⟨ subst (λ t → x ∷ ((xs ++ ys) ++ zs) ≡ x ∷ t)
             (++-assoc Lxs ys zs)
             refl
    ⟩
  x ∷ (xs ++ ys ++ zs)
    ≡⟨ sym (++-∷ x xs (ys ++ zs)) ⟩
  (x ∷ xs) ++ ys ++ zs ∎

-- Map properties

map-++-commute : ∀ f {xs} → List xs → ∀ ys →
                 map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-commute f lnil ys =
  map f ([] ++ ys)
    ≡⟨ subst (λ t → map f ([] ++ ys) ≡ map f t) (++-[] ys) refl ⟩
  map f ys
    ≡⟨ sym (++-leftIdentity (map f ys)) ⟩
  [] ++ map f ys
     ≡⟨ subst (λ t → [] ++ map f ys ≡ t ++ map f ys) (sym (map-[] f)) refl
     ⟩
  map f [] ++ map f ys ∎

map-++-commute f (lcons x {xs} Lxs) ys =
  map f ((x ∷ xs) ++ ys)
    ≡⟨ subst (λ t → map f ((x ∷ xs) ++ ys) ≡ map f t) (++-∷ x xs ys) refl ⟩
  map f (x ∷ xs ++ ys)
    ≡⟨ map-∷ f x (xs ++ ys) ⟩
  f · x ∷ map f (xs ++ ys)
    ≡⟨ subst (λ t → f · x ∷ map f (xs ++ ys) ≡ f · x ∷ t)
             (map-++-commute f Lxs ys)
             refl
    ⟩
  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
     ≡⟨ subst (λ t → (f · x ∷ map f xs) ++ map f ys ≡ t ++ map f ys)
              (sym (map-∷ f x xs))
              refl
     ⟩
  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-++-commute : ∀ {xs} → List xs → ∀ ys → rev xs ys ≡ rev xs [] ++ ys
rev-++-commute lnil ys =
  rev [] ys       ≡⟨ rev-[] ys ⟩
  ys              ≡⟨ sym $ ++-leftIdentity ys ⟩
  [] ++ ys        ≡⟨ subst (λ t → [] ++ ys ≡ t ++ ys) (sym $ rev-[] []) refl ⟩
  rev [] [] ++ ys ∎

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

reverse-++-commute : ∀ {xs ys} → List xs → List ys →
                     reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-commute {ys = ys} lnil Lys =
  reverse ([] ++ ys)
    ≡⟨ subst (λ t → reverse ([] ++ ys) ≡ reverse t) (++-[] ys) refl ⟩
  reverse ys
    ≡⟨ sym (++-rightIdentity (reverse-List Lys)) ⟩
  reverse ys ++ []
    ≡⟨ subst (λ t → reverse ys ++ [] ≡ reverse ys ++ t) (sym (rev-[] [])) refl ⟩
    reverse ys ++ reverse [] ∎

reverse-++-commute (lcons x {xs} Lxs) lnil =
  reverse ((x ∷ xs) ++ [])
    ≡⟨ subst (λ t → reverse ((x ∷ xs) ++ []) ≡ reverse t)
             (++-rightIdentity (lcons x Lxs))
             refl
    ⟩
  reverse (x ∷ xs)
    ≡⟨ sym (++-[] (reverse (x ∷ xs))) ⟩
  [] ++ reverse (x ∷ xs)
     ≡⟨ subst (λ t → [] ++ reverse (x ∷ xs) ≡ t ++ reverse (x ∷ xs))
              (sym (rev-[] []))
              refl
     ⟩
  reverse [] ++ reverse (x ∷ xs) ∎

reverse-++-commute (lcons x {xs} Lxs) (lcons y {ys} Lys) =
  reverse ((x ∷ xs) ++ y ∷ ys)
    ≡⟨ refl ⟩
  rev ((x ∷ xs) ++ y ∷ ys) []
    ≡⟨ subst (λ t → rev ((x ∷ xs) ++ y ∷ ys) [] ≡ rev t [])
             (++-∷ x xs (y ∷ ys))
             refl
    ⟩
  rev (x ∷ (xs ++ y ∷ ys)) []
    ≡⟨ rev-∷ x (xs ++ y ∷ ys) [] ⟩
  rev (xs ++ y ∷ ys) (x ∷ [])
    ≡⟨ rev-++-commute (++-List Lxs (lcons y Lys)) (x ∷ []) ⟩
  rev (xs ++ y ∷ ys) [] ++ (x ∷ [])
    ≡⟨ subst (λ t → rev (xs ++ y ∷ ys) [] ++ (x ∷ []) ≡ t ++ (x ∷ []))
             refl
             refl
    ⟩
  reverse (xs ++ y ∷ ys) ++ (x ∷ [])
    ≡⟨ subst (λ t → reverse (xs ++ y ∷ ys) ++ (x ∷ []) ≡ t ++ (x ∷ []))
             (reverse-++-commute Lxs (lcons y Lys))
             refl
    ⟩
  (reverse (y ∷ ys) ++ reverse xs) ++ x ∷ []
    ≡⟨ ++-assoc (reverse-List (lcons y Lys)) (reverse xs) (x ∷ []) ⟩
  reverse (y ∷ ys) ++ reverse xs ++ x ∷ []
    ≡⟨ subst (λ t → reverse (y ∷ ys) ++ reverse xs ++ x ∷ [] ≡
                    reverse (y ∷ ys) ++ t ++ x ∷ [])
             refl
             refl
    ⟩
  reverse (y ∷ ys) ++ rev xs [] ++ x ∷ []
    ≡⟨ subst (λ t → reverse (y ∷ ys) ++ rev xs [] ++ x ∷ [] ≡
                    reverse (y ∷ ys) ++ t)
             (sym $ rev-++-commute Lxs (x ∷ []))
             refl
    ⟩
  reverse (y ∷ ys) ++ rev xs (x ∷ [])
    ≡⟨ subst (λ t → reverse (y ∷ ys) ++ rev xs (x ∷ []) ≡
                    reverse (y ∷ ys) ++ t)
             (sym $ rev-∷ x xs [])
             refl
    ⟩
  reverse (y ∷ ys) ++ rev (x ∷ xs) []
    ≡⟨ subst (λ t → reverse (y ∷ ys) ++ rev (x ∷ xs) [] ≡
                    reverse (y ∷ ys) ++ t)
             refl
             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 ∷ []
    ≡⟨ subst (λ p → [] ++ x ∷ [] ≡ p ++ x ∷ []) (sym (rev-[] [])) refl ⟩
  rev [] [] ++ x ∷ [] ∎

reverse-∷ x (lcons y {ys} Lys) = sym
  ( reverse (y ∷ ys) ++ x ∷ []
      ≡⟨ subst (λ p → reverse (y ∷ ys) ++ x ∷ [] ≡ reverse (y ∷ ys) ++ p)
               (sym (reverse-[x]≡[x] x))
               refl
      ⟩
    (reverse (y ∷ ys) ++ reverse (x ∷ []))
      ≡⟨ sym (reverse-++-commute (lcons x lnil) (lcons y Lys)) ⟩
    reverse ((x ∷ []) ++ (y ∷ ys))
      ≡⟨ subst (λ p → reverse ((x ∷ []) ++ (y ∷ ys)) ≡ reverse p)
               (++-∷ x [] (y ∷ ys))
               refl
      ⟩
    reverse (x ∷ ([] ++ (y ∷ ys)))
      ≡⟨ subst (λ p → reverse (x ∷ ([] ++ (y ∷ ys))) ≡ reverse (x ∷ p))
               (++-leftIdentity (y ∷ ys))
               refl
      ⟩
    reverse (x ∷ y ∷ ys) ∎
  )