Working on polymorphic lists.

Working on polymorphic lists.

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

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --universal-quantified-propositional-functions #-}
{-# 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

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

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --universal-quantified-propositional-functions #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Polymorphism.List where

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

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

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

postulate foo : ∀ x → x ≡ x
{-# ATP prove foo #-}


adding cases for new IT rules

adding cases for new IT rules

open import Nat
open import Prelude
open import List
open import core
open import contexts

module preservation where
  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             Δ ⊢ d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation TAConst (Step _ _ _) = TAConst
  preservation (TAAp wt x wt₁) (Step x₁ (ITCast x₂ x₃ x₄) x₅) = TAAp wt x wt₁
  preservation (TAAp wt x₁ wt₁) (Step x₂ (ITLam x₃) x₄) = TAAp wt x₁ wt₁
  preservation (TAAp x x₁ x₂) (Step x₃ (ITNEHole x₄) x₅) = TAAp x x₁ x₂
  preservation (TAAp x x₁ x₂) (Step x₃ ITEHole x₅) = TAAp x x₁ x₂
  preservation (TACast wt x) (Step x₁ (ITCast x₂ x₃ x₄) x₅) = TACast wt x
  preservation (TACast wt x₁) (Step x₂ (ITLam x₃) x₄) = TACast wt x₁
  preservation (TACast x x₁) (Step x₂ (ITNEHole x₃) x₄) = TACast x x₁
  preservation (TACast x x₁) (Step x₂ ITEHole x₄) = TACast x x₁
  preservation (TAEHole x x₁) (Step x₂ x₃ x₄) = TAEHole x x₁
  preservation (TALam wt) (Step x₁ (ITCast x₂ x₃ x₄) x₅) = TALam wt
  preservation (TALam wt) (Step x₂ (ITLam x₃) x₄) = TALam wt
  preservation (TALam x₁) (Step x₂ (ITNEHole x₃) x₄) = TALam x₁
  preservation (TALam x₁) (Step x₂ ITEHole x₄) = TALam x₁
  preservation (TANEHole x wt x₁) (Step x₂ (ITCast x₃ x₄ x₅) x₆) = TANEHole x wt x₁
  preservation (TANEHole x x₁ x₂) (Step x₃ (ITNEHole x₄) x₅) = TANEHole x x₁ x₂
  preservation (TANEHole x x₁ x₂) (Step x₃ ITEHole x₅) = TANEHole x x₁ x₂
  preservation (TANEHole x₁ wt x₂) (Step x₃ (ITLam x₄) x₅) = TANEHole x₁ wt x₂
  preservation (TAVar x₁) step = abort (somenotnone (! x₁))

open import Nat
open import Prelude
open import List
open import core
open import contexts

module preservation where
  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             Δ ⊢ d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation TAConst (Step _ _ _) = TAConst
  preservation (TAVar x₁) step = abort (somenotnone (! x₁))
  preservation (TALam wt) (Step x₂ (ITLam x₃) x₄) = TALam wt
  preservation (TALam wt) (Step x₁ (ITCast x₂ x₃ x₄) x₅) = TALam wt
  preservation (TAAp wt x₁ wt₁) (Step x₂ (ITLam x₃) x₄) = TAAp wt x₁ wt₁
  preservation (TAAp wt x wt₁) (Step x₁ (ITCast x₂ x₃ x₄) x₅) = TAAp wt x wt₁
  preservation (TAEHole x x₁) (Step x₂ x₃ x₄) = TAEHole x x₁
  preservation (TANEHole x₁ wt x₂) (Step x₃ (ITLam x₄) x₅) = TANEHole x₁ wt x₂
  preservation (TANEHole x wt x₁) (Step x₂ (ITCast x₃ x₄ x₅) x₆) = TANEHole x wt x₁
  preservation (TACast wt x₁) (Step x₂ (ITLam x₃) x₄) = TACast wt x₁
  preservation (TACast wt x) (Step x₁ (ITCast x₂ x₃ x₄) x₅) = TACast wt x


adder: use mapAccum

adder: use mapAccum

{-# OPTIONS --without-K #-}
open import Type
open import Data.Nat.NP
open import Data.Bool using (if_then_else_)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module adder where

module FunAdder
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU
    open FunOps funOps renaming (_∘_ to _`∘_)

    --iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ `Vec B n

    msb-adder : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
    msb-adder = <tt⁏ <0₂> , zip > ⁏ mapAccum full-adder ⁏ snd

    -- TODO reverses all over the places... switch to lsb first?
    -- lsb
    adder : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
    adder = < reverse × reverse > ⁏ msb-adder ⁏ reverse

    open import Data.Digit

    ℕ▹`Bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    ℕ▹`Bits ℓ n₀ = constBits (V.reverse (L▹V (L.map F▹𝟚 (proj₁ (toDigits 2 n₀)))))
      where open import Data.List as L
            open import Data.Product
            open import Data.Two
            L▹V : ∀ {n} → List 𝟚 → Vec 𝟚 n
            L▹V {zero} xs = []
            L▹V {suc n} [] = V.replicate 0₂
            L▹V {suc n} (x ∷ xs) = x ∷ L▹V xs
            F▹𝟚 : Fin 2 → 𝟚
            F▹𝟚 zero    = 0₂
            F▹𝟚 (suc _) = 1₂

{-
open import IO
import IO.Primitive
-}
open import Data.One
open import Data.Two
open import Data.Product
--open import Coinduction
open import FunUniverse.Agda
--open import Data.Nat.Show
open FunAdder agdaFunOps
open FunOps agdaFunOps
import FunUniverse.Cost as Cost
module TimeCost = FunOps Cost.timeOps
{-
putBit : 𝟚 → IO 𝟙
putBit 1₂ = putStr "1"
putBit 0₂ = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
-}
arg1   = ℕ▹`Bits 8 0x0b _
arg2   = ℕ▹`Bits 8 0x1f _
result = adder (arg1 , arg2)
adder-cost : ℕ → ℕ
adder-cost n = FunAdder.adder Cost.timeOps {n}
{-
mainIO : IO 𝟙
mainIO = ♯ putBits arg1 >>
      ♯ (♯ putStr " + " >>
      ♯ (♯ putBits arg2 >>
      ♯ (♯ putStr " = " >>
      ♯ (♯ putBits result >>
      ♯ (♯ putStr " cost:" >>
         ♯ putStr (show (adder-cost 8)))))))
main : IO.Primitive.IO 𝟙
main = IO.run mainIO
-}

{-# OPTIONS --without-K #-}
open import Type
open import Data.Nat.NP
open import Data.Bool using (if_then_else_)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module adder where

module FunAdder
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU
    open FunOps funOps renaming (_∘_ to _`∘_)

    --iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ `Vec B n

    iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ S `× `Vec B n
    iter {zero}  F = second <[]>
    iter {suc n} F = second uncons
                   ⁏ assoc-first F ⁏ around (iter F)
                   ⁏ second <∷>

    msb-adder : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
    msb-adder = <tt⁏ <0b> , zip > ⁏ iter full-adder ⁏ snd

    -- TODO reverses all over the places... switch to lsb first?
    -- lsb
    adder : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
    adder = < reverse × reverse > ⁏ msb-adder ⁏ reverse

    open import Data.Digit

    ℕ▹`Bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    ℕ▹`Bits ℓ n₀ = constBits (V.reverse (L▹V (L.map F▹𝟚 (proj₁ (toDigits 2 n₀)))))
      where open import Data.List as L
            open import Data.Product
            open import Data.Two
            L▹V : ∀ {n} → List 𝟚 → Vec 𝟚 n
            L▹V {zero} xs = []
            L▹V {suc n} [] = V.replicate 0₂
            L▹V {suc n} (x ∷ xs) = x ∷ L▹V xs
            F▹𝟚 : Fin 2 → 𝟚
            F▹𝟚 zero    = 0₂
            F▹𝟚 (suc _) = 1₂

{-
open import IO
import IO.Primitive
-}
open import Data.One
open import Data.Two
open import Data.Product
--open import Coinduction
open import FunUniverse.Agda
--open import Data.Nat.Show
open FunAdder agdaFunOps
open FunOps agdaFunOps
import FunUniverse.Cost as Cost
module TimeCost = FunOps Cost.timeOps
{-
putBit : 𝟚 → IO 𝟙
putBit 1₂ = putStr "1"
putBit 0₂ = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
-}
arg1   = ℕ▹`Bits 8 0x0b _
arg2   = ℕ▹`Bits 8 0x1f _
result = adder (arg1 , arg2)
adder-cost : ℕ → ℕ
adder-cost n = FunAdder.adder Cost.timeOps {n}
{-
mainIO : IO 𝟙
mainIO = ♯ putBits arg1 >>
      ♯ (♯ putStr " + " >>
      ♯ (♯ putBits arg2 >>
      ♯ (♯ putStr " = " >>
      ♯ (♯ putBits result >>
      ♯ (♯ putStr " cost:" >>
         ♯ putStr (show (adder-cost 8)))))))
main : IO.Primitive.IO 𝟙
main = IO.run mainIO
-}


Added x<x∸y→⊥.

Added x<x∸y→⊥.

Ignore-this: 126888dcec026c41373c92b862bf82d3

darcs-hash:20110215034929-3bd4e-70d149030e75804cc1ac587620afa976fa5a1806.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Data.Nat.Inequalities.PropertiesATP where

open import LTC.Base
open import LTC.Base.Properties using ( x≡y→Sx≡Sy )

open import Common.Function using ( _$_ )

open import LTC.Data.Nat
  using ( _+_ ; _∸_ ; ∸-SS
        ; N ; sN ; zN  -- The LTC natural numbers type
        )
open import LTC.Data.Nat.Inequalities
  using ( <-00 ; <-0S ; <-S0 ; <-SS
        ; GE ; GT ; LE ; LT ; NGT ; NLE ; NLT
        ; LT₂
        )
open import LTC.Data.Nat.Inequalities.Properties public
open import LTC.Data.Nat.PropertiesATP
  using ( +-N ; ∸-N
        ; +-comm
        ; +-rightIdentity
        ; ∸-0x
        )

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

x≥0 : ∀ {n} → N n → GE n zero
x≥0 zN          = <-0S zero
x≥0 (sN {n} Nn) = <-0S $ succ n

0≤x : ∀ {n} → N n → LE zero n
0≤x Nn = x≥0 Nn

0≯x : ∀ {n} → N n → NGT zero n
0≯x zN          = <-00
0≯x (sN {n} Nn) = <-S0 n

x≰x : ∀ {n} → N n → NLT n n
x≰x zN          = <-00
x≰x (sN {n} Nn) = trans (<-SS n n) (x≰x Nn)

S≰0 : ∀ {n} → N n → NLE (succ n) zero
S≰0 zN          = x≰x (sN zN)
S≰0 (sN {n} Nn) = trans (<-SS (succ n) zero) (<-S0 n)

x<Sx : ∀ {n} → N n → LT n (succ n)
x<Sx zN          = <-0S zero
x<Sx (sN {n} Nn) = trans (<-SS n (succ n)) (x<Sx Nn)

postulate
  x<y→Sx<Sy : ∀ {m n} → LT m n → LT (succ m) (succ n)
{-# ATP prove x<y→Sx<Sy #-}

postulate
  Sx<Sy→x<y : ∀ {m n} → LT (succ m) (succ n) → LT m n
{-# ATP prove Sx<Sy→x<y #-}

x≤x : ∀ {n} → N n → LE n n
x≤x zN          = <-0S zero
x≤x (sN {n} Nn) = trans (<-SS n (succ n)) (x≤x Nn)

x≤y→Sx≤Sy : ∀ {m n} → LE m n → LE (succ m) (succ n)
x≤y→Sx≤Sy {m} {n} m≤n = trans (<-SS m (succ n)) m≤n

postulate
  Sx≤Sy→x≤y : ∀ {m n} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≰y→Sx≰Sy : ∀ m n → NLE m n → NLE (succ m) (succ n)
x≰y→Sx≰Sy m n m≰n = trans (<-SS m (succ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → GT m n → LT n m
x>y→y<x zN          Nn          0>n   = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→y<x (sN {m} Nm) zN          _     = <-0S m
x>y→y<x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS n m) (x>y→y<x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → GE m n → NLT m n
x≥y→x≮y zN          zN          _     = x≰x zN
x≥y→x≮y zN          (sN Nn)     0≥Sn  = ⊥-elim $ 0≥S→⊥ Nn 0≥Sn
x≥y→x≮y (sN {m} Nm) zN          _     = <-S0 m
x≥y→x≮y (sN {m} Nm) (sN {n} Nn) Sm≥Sn =
  trans (<-SS m n) (x≥y→x≮y Nm Nn (trans (sym $ <-SS n (succ m)) Sm≥Sn))

x>y→x≰y : ∀ {m n} → N m → N n → GT m n → NLE m n
x>y→x≰y zN          Nn          0>m   = ⊥-elim $ 0>x→⊥ Nn 0>m
x>y→x≰y (sN Nm)     zN          _     = S≰0 Nm
x>y→x≰y (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

-- TODO: To move to LTC.Data.Nat.Inequalities.Properties.
postulate
  x>y→x≤y→⊥ : ∀ {m n} → N m → N n → GT m n → LE m n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

x>y∨x≤y : ∀ {m n} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ <-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m>n → inj₁ (trans (<-SS n m) m>n))
  , (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
  ] (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → LT m n ∨ GE m n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x≤y∨x≰y : ∀ {m n} → N m → N n → LE m n ∨ NLE m n
x≤y∨x≰y zN Nn = inj₁ (0≤x Nn)
x≤y∨x≰y (sN Nm) zN = inj₂ (S≰0 Nm)
x≤y∨x≰y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
  , (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
  ] (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} {Nm : N m} {Nn : N n} → m ≡ n → LE m n
x≡y→x≤y {Nm = Nm} refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x≤y zN (sN {n} Nn)          _     = <-0S $ succ n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<y→Sx≤y : ∀ {m n} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→Sx≤y zN          (sN Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = trans (<-SS (succ m) (succ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim $ S≤0→⊥ Nm Sm≤0
Sx≤y→x<y zN          (sN {n} Nn) _      = <-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

<-trans : ∀ {m n o} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN          _           0<0   _     = ⊥-elim $ 0<0→⊥ 0<0
<-trans zN          (sN Nn)     zN          _     Sn<0  = ⊥-elim $ S<0→⊥ Sn<0
<-trans zN          (sN Nn)     (sN {o} No) _     _     = <-0S o
<-trans (sN Nm)     Nn          zN          _     n<0   = ⊥-elim $ x<0→⊥ Nn n<0
<-trans (sN Nm)     zN          (sN No)     Sm<0  _     = ⊥-elim $ S<0→⊥ Sm<0
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy $ <-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So)

≤-trans : ∀ {m n o} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim $ S≤0→⊥ Nm Sm≤0
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim $ S≤0→⊥ Nn Sn≤0
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf $ x≤x+y Nm Nn
  where
    postulate prf : LE m (m + n) →  -- IH.
                    LE (succ m) (succ m + n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf #-}

x<x+Sy : ∀ {m n} → N m → N n → LT m (m + succ n)
x<x+Sy {n = n} zN Nn = prf0
  where
    postulate prf0 : LT zero (zero + succ n)
    {-# ATP prove prf0 #-}
x<x+Sy {n = n} (sN {m} Nm) Nn = prfS (x<x+Sy Nm Nn)
  where
    postulate prfS : LT m (m + succ n) → LT (succ m) (succ m + succ n)
    {-# ATP prove prfS #-}

k+x<k+y→x<y : ∀ {m n k} → N m → N n → N k → LT (k + m) (k + n) → LT m n
k+x<k+y→x<y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LT m n
    {-# ATP prove prf0 #-}
k+x<k+y→x<y {m} {n} Nm Nn (sN {k} Nk) h = k+x<k+y→x<y Nm Nn Nk prfS
  where
    postulate prfS : LT (k + m) (k + n)
    {-# ATP prove prfS #-}

postulate x+k<y+k→x<y : ∀ {m n k} → N m → N n → N k →
                        LT (m + k) (n + k) → LT m n
{-# ATP prove x+k<y+k→x<y k+x<k+y→x<y +-comm #-}

x≤y→k+x≤k+y : ∀ {m n k} → N m → N n → N k → LE m n → LE (k + m) (k + n)
x≤y→k+x≤k+y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LE (zero + m) (zero + n)
    {-# ATP prove prf0 #-}
x≤y→k+x≤k+y {m} {n} Nm Nn (sN {k} Nk) h = prfS (x≤y→k+x≤k+y Nm Nn Nk h)
  where
    postulate prfS : LE (k + m) (k + n) → LE (succ k + m) (succ k + n)
    {-# ATP prove prfS #-}

postulate x≤y→x+k≤y+k : ∀ {m n k} → N m → N n → N k → LE m n →
                        LE (m + k) (n + k)
{-# ATP prove x≤y→x+k≤y+k x≤y→k+x≤k+y +-comm #-}

x<y→Sx∸y≡0 : ∀ {m n} → N m → N n → LT m n → succ m ∸ n ≡ zero
x<y→Sx∸y≡0 Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→Sx∸y≡0 zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : succ zero ∸ succ n ≡ zero
    {-# ATP prove prf0S ∸-0x #-}
x<y→Sx∸y≡0 (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→Sx∸y≡0 Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : succ m ∸ n ≡ zero → succ (succ m) ∸ succ n ≡ zero
    {-# ATP prove prfSS #-}

postulate x≤y→x-y≡0 : ∀ {m n} → N m → N n → LE m n → (m ∸ n) ≡ zero
{-# ATP prove x≤y→x-y≡0 x<y→Sx∸y≡0 #-}

x<y→0<x∸y : ∀ {m n} → N m → N n → LT m n → LT zero (n ∸ m)
x<y→0<x∸y Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→0<x∸y zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : LT zero (succ n ∸ zero)
    {-# ATP prove prf0S #-}

x<y→0<x∸y (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→0<x∸y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : LT zero (n ∸ m) → LT zero (succ n ∸ succ m)
    {-# ATP prove prfSS #-}

0<x∸y→0<Sx∸y : ∀ {m n} → N m → N n → LT zero (m ∸ n) → LT zero (succ m ∸ n)
0<x∸y→0<Sx∸y {m} Nm zN h = prfx0
  where
    postulate prfx0 : LT zero (succ m ∸ zero)
    {-# ATP prove prfx0 #-}

0<x∸y→0<Sx∸y zN (sN {n} Nn) h = ⊥-elim (x<0→⊥ zN h')
  where
    postulate h' : LT zero zero
    {-# ATP prove h' #-}

0<x∸y→0<Sx∸y (sN {m} Nm) (sN {n} Nn) h = prfSS (0<x∸y→0<Sx∸y Nm Nn 0<m-n)
  where
    postulate 0<m-n : LT zero (m ∸ n)
    {-# ATP prove 0<m-n #-}

    postulate prfSS : LT zero (succ m ∸ n) → LT zero (succ (succ m) ∸ succ n)
    {-# ATP prove prfSS <-trans #-}

x∸y<Sx : ∀ {m n} → N m → N n → LT (m ∸ n) (succ m)
x∸y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m ∸ zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x∸y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero ∸ succ n) (succ zero)
    {-# ATP prove prf #-}

x∸y<Sx (sN {m} Nm) (sN {n} Nn) = prf $ x∸y<Sx Nm Nn
  where
    postulate prf : LT (m ∸ n) (succ m) →  -- IH.
                    LT (succ m ∸ succ n) (succ (succ m))
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf <-trans ∸-N x<Sx #-}  -- Use the hint sN.

postulate
  Sx∸Sy<Sx : ∀ {m n} → N m → N n → LT (succ m ∸ succ n) (succ m)
{-# ATP prove Sx∸Sy<Sx x∸y<Sx #-}

x<x∸y→⊥ : ∀ {m n} → N m → N n → ¬ (LT m (m ∸ n))
x<x∸y→⊥ {m} Nm zN m<m∸0 = prf
  where
    postulate prf : ⊥
    {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ zN (sN Nn) 0<0∸Sn = prf
 where
   postulate prf : ⊥
   {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ (sN Nm) (sN Nn) Sm<Sm∸Sn = prf
  where
    postulate prf : ⊥
    {-# ATP prove prf ∸-N x<y→y<x→⊥ x∸y<Sx #-}

x>y→x∸y+y≡x : ∀ {m n} → N m → N n → GT m n → (m ∸ n) + n ≡ m
x>y→x∸y+y≡x zN          Nn 0>n  = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→x∸y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m ∸ zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x∸y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf $ x>y→x∸y+y≡x Nm Nn m>n
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m ∸ n) + n ≡ m →  -- IH.
                    (succ m ∸ succ n) + succ n ≡ succ m
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n ∸ zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y∸x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim $ S≤0→⊥ Nm Sm≤0

x≤y→y∸x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf $ x≤y→y∸x+x≡y Nm Nn m≤n
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                    (succ n ∸ succ m) + succ m ≡ succ n
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x<y→x<Sy : ∀ {m n} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = <-0S $ succ n
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (<-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim $ x<0→⊥ Nm (trans (sym $ <-SS m zero) Sm<S0)
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (<-SS m n) m<n))
  , (λ m≡n → inj₂ (x≡y→Sx≡Sy m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym $ <-SS m (succ n)) Sm<SSn)

postulate
  x<y→y≡z→x<z : ∀ {m n o} → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : ∀ {m n o} → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

x≥y→y>0→x∸y<x : ∀ {m n} → N m → N n → GE m n → GT n zero → LT (m ∸ n) m
x≥y→y>0→x∸y<x Nm          zN          _     0>0  = ⊥-elim $ x>x→⊥ zN 0>0
x≥y→y>0→x∸y<x zN          (sN Nn)     0≥Sn  _    = ⊥-elim $ S≤0→⊥ Nn 0≥Sn
x≥y→y>0→x∸y<x (sN {m} Nm) (sN {n} Nn) Sm≥Sn Sn>0 = prf
  where
    postulate prf : LT (succ m ∸ succ n) (succ m)
    {-# ATP prove prf x∸y<Sx #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → LE n o → LT m o
x<y→y≤z→x<z Nm Nn No m<n n≤o =
  [ (λ n<o → <-trans Nm Nn No m<n n<o)
  , (λ n≡o → x<y→y≡z→x<z m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)

x≤y+x∸y : ∀ {m n} → N m → N n → LE m (n + (m ∸ n))
x≤y+x∸y {n = n} zN Nn = prf0
  where postulate prf0 : LE zero (n + (zero ∸ n))
        {-# ATP prove prf0 0≤x +-N  #-}
x≤y+x∸y (sN {m} Nm) zN = prfx0
  where postulate prfx0 : LE (succ m) (zero + (succ m ∸ zero))
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x∸y (sN {m} Nm) (sN {n} Nn) = prfSS (x≤y+x∸y Nm Nn)
  where postulate prfSS : LE m (n + (m ∸ n)) →  -- IH.
                          LE (succ m) (succ n + (succ m ∸ succ n))
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  xy<00→⊥ : ∀ {m n} → N m → N n → ¬ (LT₂ m n zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy<00→⊥ x<0→⊥ #-}

postulate
  Sxy₁<0y₂→⊥ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove Sxy₁<0y₂→⊥ x<0→⊥ #-}  -- Use the hint sN.

postulate
  0Sx<00→⊥ : ∀ {m} → N m → ¬ (LT₂ zero (succ m) zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove 0Sx<00→⊥ x<0→⊥ #-}  -- Use the hint sN.

postulate
  x₁y<x₂0→x₁<x₂ : ∀ {m₁ n m₂} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove x₁y<x₂0→x₁<x₂ x<0→⊥ #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ x<0→⊥ #-}

[Sx∸Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
[Sx∸Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}  -- Use the hint sN.

[Sx,Sy∸Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
[Sx,Sy∸Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}  -- Use the hint sN.

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Data.Nat.Inequalities.PropertiesATP where

open import LTC.Base
open import LTC.Base.Properties using ( x≡y→Sx≡Sy )

open import Common.Function using ( _$_ )

open import LTC.Data.Nat
  using ( _+_ ; _∸_ ; ∸-SS
        ; N ; sN ; zN  -- The LTC natural numbers type
        )
open import LTC.Data.Nat.Inequalities
  using ( <-00 ; <-0S ; <-S0 ; <-SS
        ; GE ; GT ; LE ; LT ; NGT ; NLE ; NLT
        ; LT₂
        )
open import LTC.Data.Nat.Inequalities.Properties public
open import LTC.Data.Nat.PropertiesATP
  using ( +-N ; ∸-N
        ; +-comm
        ; +-rightIdentity
        ; ∸-0x
        )

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

x≥0 : ∀ {n} → N n → GE n zero
x≥0 zN          = <-0S zero
x≥0 (sN {n} Nn) = <-0S $ succ n

0≤x : ∀ {n} → N n → LE zero n
0≤x Nn = x≥0 Nn

0≯x : ∀ {n} → N n → NGT zero n
0≯x zN          = <-00
0≯x (sN {n} Nn) = <-S0 n

x≰x : ∀ {n} → N n → NLT n n
x≰x zN          = <-00
x≰x (sN {n} Nn) = trans (<-SS n n) (x≰x Nn)

S≰0 : ∀ {n} → N n → NLE (succ n) zero
S≰0 zN          = x≰x (sN zN)
S≰0 (sN {n} Nn) = trans (<-SS (succ n) zero) (<-S0 n)

x<Sx : ∀ {n} → N n → LT n (succ n)
x<Sx zN          = <-0S zero
x<Sx (sN {n} Nn) = trans (<-SS n (succ n)) (x<Sx Nn)

postulate
  x<y→Sx<Sy : ∀ {m n} → LT m n → LT (succ m) (succ n)
{-# ATP prove x<y→Sx<Sy #-}

postulate
  Sx<Sy→x<y : ∀ {m n} → LT (succ m) (succ n) → LT m n
{-# ATP prove Sx<Sy→x<y #-}

x≤x : ∀ {n} → N n → LE n n
x≤x zN          = <-0S zero
x≤x (sN {n} Nn) = trans (<-SS n (succ n)) (x≤x Nn)

x≤y→Sx≤Sy : ∀ {m n} → LE m n → LE (succ m) (succ n)
x≤y→Sx≤Sy {m} {n} m≤n = trans (<-SS m (succ n)) m≤n

postulate
  Sx≤Sy→x≤y : ∀ {m n} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≰y→Sx≰Sy : ∀ m n → NLE m n → NLE (succ m) (succ n)
x≰y→Sx≰Sy m n m≰n = trans (<-SS m (succ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → GT m n → LT n m
x>y→y<x zN          Nn          0>n   = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→y<x (sN {m} Nm) zN          _     = <-0S m
x>y→y<x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS n m) (x>y→y<x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → GE m n → NLT m n
x≥y→x≮y zN          zN          _     = x≰x zN
x≥y→x≮y zN          (sN Nn)     0≥Sn  = ⊥-elim $ 0≥S→⊥ Nn 0≥Sn
x≥y→x≮y (sN {m} Nm) zN          _     = <-S0 m
x≥y→x≮y (sN {m} Nm) (sN {n} Nn) Sm≥Sn =
  trans (<-SS m n) (x≥y→x≮y Nm Nn (trans (sym $ <-SS n (succ m)) Sm≥Sn))

x>y→x≰y : ∀ {m n} → N m → N n → GT m n → NLE m n
x>y→x≰y zN          Nn          0>m   = ⊥-elim $ 0>x→⊥ Nn 0>m
x>y→x≰y (sN Nm)     zN          _     = S≰0 Nm
x>y→x≰y (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

-- TODO: To move to LTC.Data.Nat.Inequalities.Properties.
postulate
  x>y→x≤y→⊥ : ∀ {m n} → N m → N n → GT m n → LE m n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

x>y∨x≤y : ∀ {m n} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ <-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m>n → inj₁ (trans (<-SS n m) m>n))
  , (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
  ] (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → LT m n ∨ GE m n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x≤y∨x≰y : ∀ {m n} → N m → N n → LE m n ∨ NLE m n
x≤y∨x≰y zN Nn = inj₁ (0≤x Nn)
x≤y∨x≰y (sN Nm) zN = inj₂ (S≰0 Nm)
x≤y∨x≰y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
  , (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
  ] (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} {Nm : N m} {Nn : N n} → m ≡ n → LE m n
x≡y→x≤y {Nm = Nm} refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x≤y zN (sN {n} Nn)          _     = <-0S $ succ n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<y→Sx≤y : ∀ {m n} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→Sx≤y zN          (sN Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = trans (<-SS (succ m) (succ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim $ S≤0→⊥ Nm Sm≤0
Sx≤y→x<y zN          (sN {n} Nn) _      = <-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

<-trans : ∀ {m n o} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN          _           0<0   _     = ⊥-elim $ 0<0→⊥ 0<0
<-trans zN          (sN Nn)     zN          _     Sn<0  = ⊥-elim $ S<0→⊥ Sn<0
<-trans zN          (sN Nn)     (sN {o} No) _     _     = <-0S o
<-trans (sN Nm)     Nn          zN          _     n<0   = ⊥-elim $ x<0→⊥ Nn n<0
<-trans (sN Nm)     zN          (sN No)     Sm<0  _     = ⊥-elim $ S<0→⊥ Sm<0
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy $ <-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So)

≤-trans : ∀ {m n o} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim $ S≤0→⊥ Nm Sm≤0
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim $ S≤0→⊥ Nn Sn≤0
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf $ x≤x+y Nm Nn
  where
    postulate prf : LE m (m + n) →  -- IH.
                    LE (succ m) (succ m + n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf #-}

x<x+Sy : ∀ {m n} → N m → N n → LT m (m + succ n)
x<x+Sy {n = n} zN Nn = prf0
  where
    postulate prf0 : LT zero (zero + succ n)
    {-# ATP prove prf0 #-}
x<x+Sy {n = n} (sN {m} Nm) Nn = prfS (x<x+Sy Nm Nn)
  where
    postulate prfS : LT m (m + succ n) → LT (succ m) (succ m + succ n)
    {-# ATP prove prfS #-}

k+x<k+y→x<y : ∀ {m n k} → N m → N n → N k → LT (k + m) (k + n) → LT m n
k+x<k+y→x<y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LT m n
    {-# ATP prove prf0 #-}
k+x<k+y→x<y {m} {n} Nm Nn (sN {k} Nk) h = k+x<k+y→x<y Nm Nn Nk prfS
  where
    postulate prfS : LT (k + m) (k + n)
    {-# ATP prove prfS #-}

postulate x+k<y+k→x<y : ∀ {m n k} → N m → N n → N k →
                        LT (m + k) (n + k) → LT m n
{-# ATP prove x+k<y+k→x<y k+x<k+y→x<y +-comm #-}

x≤y→k+x≤k+y : ∀ {m n k} → N m → N n → N k → LE m n → LE (k + m) (k + n)
x≤y→k+x≤k+y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LE (zero + m) (zero + n)
    {-# ATP prove prf0 #-}
x≤y→k+x≤k+y {m} {n} Nm Nn (sN {k} Nk) h = prfS (x≤y→k+x≤k+y Nm Nn Nk h)
  where
    postulate prfS : LE (k + m) (k + n) → LE (succ k + m) (succ k + n)
    {-# ATP prove prfS #-}

postulate x≤y→x+k≤y+k : ∀ {m n k} → N m → N n → N k → LE m n →
                        LE (m + k) (n + k)
{-# ATP prove x≤y→x+k≤y+k x≤y→k+x≤k+y +-comm #-}

x<y→Sx∸y≡0 : ∀ {m n} → N m → N n → LT m n → succ m ∸ n ≡ zero
x<y→Sx∸y≡0 Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→Sx∸y≡0 zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : succ zero ∸ succ n ≡ zero
    {-# ATP prove prf0S ∸-0x #-}
x<y→Sx∸y≡0 (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→Sx∸y≡0 Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : succ m ∸ n ≡ zero → succ (succ m) ∸ succ n ≡ zero
    {-# ATP prove prfSS #-}

postulate x≤y→x-y≡0 : ∀ {m n} → N m → N n → LE m n → (m ∸ n) ≡ zero
{-# ATP prove x≤y→x-y≡0 x<y→Sx∸y≡0 #-}

x<y→0<x∸y : ∀ {m n} → N m → N n → LT m n → LT zero (n ∸ m)
x<y→0<x∸y Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→0<x∸y zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : LT zero (succ n ∸ zero)
    {-# ATP prove prf0S #-}

x<y→0<x∸y (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→0<x∸y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : LT zero (n ∸ m) → LT zero (succ n ∸ succ m)
    {-# ATP prove prfSS #-}

0<x∸y→0<Sx∸y : ∀ {m n} → N m → N n → LT zero (m ∸ n) → LT zero (succ m ∸ n)
0<x∸y→0<Sx∸y {m} Nm zN h = prfx0
  where
    postulate prfx0 : LT zero (succ m ∸ zero)
    {-# ATP prove prfx0 #-}

0<x∸y→0<Sx∸y zN (sN {n} Nn) h = ⊥-elim (x<0→⊥ zN h')
  where
    postulate h' : LT zero zero
    {-# ATP prove h' #-}

0<x∸y→0<Sx∸y (sN {m} Nm) (sN {n} Nn) h = prfSS (0<x∸y→0<Sx∸y Nm Nn 0<m-n)
  where
    postulate 0<m-n : LT zero (m ∸ n)
    {-# ATP prove 0<m-n #-}

    postulate prfSS : LT zero (succ m ∸ n) → LT zero (succ (succ m) ∸ succ n)
    {-# ATP prove prfSS <-trans #-}

x∸y<Sx : ∀ {m n} → N m → N n → LT (m ∸ n) (succ m)
x∸y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m ∸ zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x∸y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero ∸ succ n) (succ zero)
    {-# ATP prove prf #-}

x∸y<Sx (sN {m} Nm) (sN {n} Nn) = prf $ x∸y<Sx Nm Nn
  where
    postulate prf : LT (m ∸ n) (succ m) →  -- IH.
                    LT (succ m ∸ succ n) (succ (succ m))
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf <-trans ∸-N x<Sx #-}  -- Use the hint sN.

postulate
  Sx∸Sy<Sx : ∀ {m n} → N m → N n → LT (succ m ∸ succ n) (succ m)
{-# ATP prove Sx∸Sy<Sx x∸y<Sx #-}

x>y→x∸y+y≡x : ∀ {m n} → N m → N n → GT m n → (m ∸ n) + n ≡ m
x>y→x∸y+y≡x zN          Nn 0>n  = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→x∸y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m ∸ zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x∸y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf $ x>y→x∸y+y≡x Nm Nn m>n
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m ∸ n) + n ≡ m →  -- IH.
                    (succ m ∸ succ n) + succ n ≡ succ m
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n ∸ zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y∸x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim $ S≤0→⊥ Nm Sm≤0

x≤y→y∸x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf $ x≤y→y∸x+x≡y Nm Nn m≤n
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                    (succ n ∸ succ m) + succ m ≡ succ n
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x<y→x<Sy : ∀ {m n} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = <-0S $ succ n
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (<-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim $ x<0→⊥ Nm (trans (sym $ <-SS m zero) Sm<S0)
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (<-SS m n) m<n))
  , (λ m≡n → inj₂ (x≡y→Sx≡Sy m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym $ <-SS m (succ n)) Sm<SSn)

postulate
  x<y→y≡z→x<z : ∀ {m n o} → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : ∀ {m n o} → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

x≥y→y>0→x∸y<x : ∀ {m n} → N m → N n → GE m n → GT n zero → LT (m ∸ n) m
x≥y→y>0→x∸y<x Nm          zN          _     0>0  = ⊥-elim $ x>x→⊥ zN 0>0
x≥y→y>0→x∸y<x zN          (sN Nn)     0≥Sn  _    = ⊥-elim $ S≤0→⊥ Nn 0≥Sn
x≥y→y>0→x∸y<x (sN {m} Nm) (sN {n} Nn) Sm≥Sn Sn>0 = prf
  where
    postulate prf : LT (succ m ∸ succ n) (succ m)
    {-# ATP prove prf x∸y<Sx #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → LE n o → LT m o
x<y→y≤z→x<z Nm Nn No m<n n≤o =
  [ (λ n<o → <-trans Nm Nn No m<n n<o)
  , (λ n≡o → x<y→y≡z→x<z m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)

x≤y+x∸y : ∀ {m n} → N m → N n → LE m (n + (m ∸ n))
x≤y+x∸y {n = n} zN Nn = prf0
  where postulate prf0 : LE zero (n + (zero ∸ n))
        {-# ATP prove prf0 0≤x +-N  #-}
x≤y+x∸y (sN {m} Nm) zN = prfx0
  where postulate prfx0 : LE (succ m) (zero + (succ m ∸ zero))
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x∸y (sN {m} Nm) (sN {n} Nn) = prfSS (x≤y+x∸y Nm Nn)
  where postulate prfSS : LE m (n + (m ∸ n)) →  -- IH.
                          LE (succ m) (succ n + (succ m ∸ succ n))
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  xy<00→⊥ : ∀ {m n} → N m → N n → ¬ (LT₂ m n zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy<00→⊥ x<0→⊥ #-}

postulate
  Sxy₁<0y₂→⊥ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove Sxy₁<0y₂→⊥ x<0→⊥ #-}  -- Use the hint sN.

postulate
  0Sx<00→⊥ : ∀ {m} → N m → ¬ (LT₂ zero (succ m) zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove 0Sx<00→⊥ x<0→⊥ #-}  -- Use the hint sN.

postulate
  x₁y<x₂0→x₁<x₂ : ∀ {m₁ n m₂} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove x₁y<x₂0→x₁<x₂ x<0→⊥ #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ x<0→⊥ #-}

[Sx∸Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
[Sx∸Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}  -- Use the hint sN.

[Sx,Sy∸Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
[Sx,Sy∸Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}  -- Use the hint sN.


Fixed typo.

Fixed typo.

------------------------------------------------------------------------------
-- ABP lemma 2
------------------------------------------------------------------------------

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

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2I 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.Loop
open import FOTC.Base.PropertiesI
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the ABP lemma 2

module Helper where

  helper : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
           Bit b →
           Fair os₀' →
           ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
           ∀ ft₁ os₁'' → F*T ft₁ → Fair os₁'' → os₁' ≡ ft₁ ++ os₁'' →
           ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₀''
           ∧ Fair os₁''
           ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
  helper {b} {i'} {is'} {os₀'} {os₁'} {as'} {bs'} {cs'} {ds'} {js'}
         Bb Fos₀' (ds'ABP' , as'ABP , bs'ABP' , cs'ABP' , js'ABP')
         .(T ∷ []) os₁'' f*tnil Fos₁'' os₁'-eq =
         os₀' , os₁'' , as'' , bs'' , cs'' , ds''
         , Fos₀' , Fos₁''
         , as''-eq , bs''-eq ,  cs''-eq , refl , js'-eq

    where
    os₁'-eq-helper : os₁' ≡ T ∷ os₁''
    os₁'-eq-helper =
      os₁'                 ≡⟨ os₁'-eq ⟩
      (true ∷ []) ++ os₁'' ≡⟨ ++-∷ true [] os₁'' ⟩
      true ∷ [] ++ os₁''   ≡⟨ ∷-rightCong (++-leftIdentity os₁'') ⟩
      true ∷ os₁''         ∎

    ds'' : D
    ds'' = corrupt os₁'' · cs'

    ds'-eq : ds' ≡ ok b ∷ ds''
    ds'-eq =
      ds' ≡⟨ ds'ABP' ⟩
      corrupt os₁' · (b ∷ cs')
        ≡⟨ ·-leftCong (corruptCong os₁'-eq-helper) ⟩
      corrupt (T ∷ os₁'') · (b ∷ cs')
        ≡⟨ corrupt-T os₁'' b cs' ⟩
      ok b ∷ corrupt os₁'' · cs'
        ≡⟨ refl ⟩
      ok b ∷ ds'' ∎

    as'' : D
    as'' = as'

    as''-eq : as'' ≡ send (not b) · is' · ds''
    as''-eq =
      as''                         ≡⟨ as'ABP ⟩
      await b i' is' ds'           ≡⟨ awaitCong₄ ds'-eq ⟩
      await b i' is' (ok b ∷ ds'') ≡⟨ await-ok≡ b b i' is' ds'' refl ⟩
      send (not b) · is' · ds''    ∎

    bs'' : D
    bs'' = bs'

    bs''-eq : bs'' ≡ corrupt os₀' · as'
    bs''-eq = bs'ABP'

    cs'' : D
    cs'' = cs'

    cs''-eq : cs'' ≡ ack (not b) · bs'
    cs''-eq = cs'ABP'

    js'-eq : js' ≡ out (not b) · bs''
    js'-eq = js'ABP'

  helper {b} {i'} {is'} {os₀'} {os₁'} {as'} {bs'} {cs'} {ds'} {js'}
         Bb Fos₀' (ds'ABP' , as'ABP , bs'ABP' , cs'ABP' , js'ABP')
         .(F ∷ ft₁) os₁'' (f*tcons {ft₁} FTft₁) Fos₁'' os₁'-eq
         = helper Bb (tail-Fair Fos₀') ABP'IH ft₁ os₁'' FTft₁ Fos₁'' refl

    where
    os₀^ : D
    os₀^ = tail₁ os₀'

    os₁^ : D
    os₁^ = ft₁ ++ os₁''

    os₁'-eq-helper : os₁' ≡ F ∷ os₁^
    os₁'-eq-helper = os₁'               ≡⟨ os₁'-eq ⟩
                     (F ∷ ft₁) ++ os₁'' ≡⟨ ++-∷ _ _ _ ⟩
                     F ∷ ft₁ ++ os₁''   ≡⟨ refl ⟩
                     F ∷ os₁^           ∎

    ds^ : D
    ds^ = corrupt os₁^ · cs'

    ds'-eq : ds' ≡ error ∷ ds^
    ds'-eq =
      ds'
        ≡⟨ ds'ABP' ⟩
      corrupt os₁' · (b ∷ cs')
        ≡⟨ ·-leftCong (corruptCong os₁'-eq-helper) ⟩
      corrupt (F ∷ os₁^) · (b ∷ cs')
        ≡⟨ corrupt-F _ _ _ ⟩
      error ∷ corrupt os₁^ · cs'
        ≡⟨ refl ⟩
      error ∷ ds^ ∎

    as^ : D
    as^ = await b i' is' ds^

    as'-eq : as' ≡ < i' , b > ∷ as^
    as'-eq = as'                             ≡⟨ as'ABP ⟩
             await b i' is' ds'              ≡⟨ awaitCong₄ ds'-eq ⟩
             await b i' is' (error ∷ ds^)    ≡⟨ await-error _ _ _ _ ⟩
             < i' , b > ∷ await b i' is' ds^ ≡⟨ refl ⟩
             < i' , b > ∷ as^                ∎

    bs^ : D
    bs^ = corrupt os₀^ · as^

    bs'-eq-helper₁ : os₀' ≡ T ∷ tail₁ os₀' → bs' ≡ ok < i' , b > ∷ bs^
    bs'-eq-helper₁ h =
      bs'
        ≡⟨ bs'ABP' ⟩
      corrupt os₀' · as'
        ≡⟨ subst₂ (λ t t' → corrupt os₀' · as' ≡ corrupt t · t')
                  h
                  as'-eq
                  refl
        ⟩
      corrupt (T ∷ tail₁ os₀') · (< i' , b > ∷ as^)
        ≡⟨ corrupt-T _ _ _ ⟩
      ok < i' , b > ∷ corrupt (tail₁ os₀') · as^
        ≡⟨ refl ⟩
      ok < i' , b > ∷ bs^ ∎

    bs'-eq-helper₂ : os₀' ≡ F ∷ tail₁ os₀' → bs' ≡ error ∷ bs^
    bs'-eq-helper₂ h =
      bs'
        ≡⟨ bs'ABP' ⟩
      corrupt os₀' · as'
        ≡⟨ subst₂ (λ t t' → corrupt os₀' · as' ≡ corrupt t · t')
                  h
                  as'-eq
                  refl
        ⟩
      corrupt (F ∷ tail₁ os₀') · (< i' , b > ∷ as^)
        ≡⟨ corrupt-F _ _ _ ⟩
      error ∷ corrupt (tail₁ os₀') · as^
        ≡⟨ refl ⟩
      error ∷ bs^ ∎

    bs'-eq : bs' ≡ ok < i' , b > ∷ bs^ ∨ bs' ≡ error ∷ bs^
    bs'-eq = case (λ h → inj₁ (bs'-eq-helper₁ h))
                  (λ h → inj₂ (bs'-eq-helper₂ h))
                  (head-tail-Fair Fos₀')

    cs^ : D
    cs^ = ack (not b) · bs^

    cs'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs^ → cs' ≡ b ∷ cs^
    cs'-eq-helper₁ h =
      cs'
      ≡⟨ cs'ABP' ⟩
      ack (not b) · bs'
        ≡⟨ ·-rightCong h ⟩
      ack (not b) · (ok < i' , b > ∷ bs^)
        ≡⟨ ack-ok≢ _ _ _ _ (not-x≢x Bb) ⟩
      not (not b) ∷ ack (not b) · bs^
        ≡⟨ ∷-leftCong (not-involutive Bb) ⟩
      b ∷ ack (not b) · bs^
        ≡⟨ refl ⟩
      b ∷ cs^ ∎

    cs'-eq-helper₂ : bs' ≡ error ∷ bs^ → cs' ≡ b ∷ cs^
    cs'-eq-helper₂ h =
      cs'                             ≡⟨ cs'ABP' ⟩
      ack (not b) · bs'               ≡⟨ ·-rightCong h ⟩
      ack (not b) · (error ∷ bs^)     ≡⟨ ack-error _ _ ⟩
      not (not b) ∷ ack (not b) · bs^ ≡⟨ ∷-leftCong (not-involutive Bb) ⟩
      b ∷ ack (not b) · bs^           ≡⟨ refl ⟩
      b ∷ cs^                         ∎

    cs'-eq : cs' ≡ b ∷ cs^
    cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

    js'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs^ → js' ≡ out (not b) · bs^
    js'-eq-helper₁ h  =
      js'
        ≡⟨ js'ABP' ⟩
      out (not b) · bs'
        ≡⟨ ·-rightCong h ⟩
      out (not b) · (ok < i' , b > ∷ bs^)
        ≡⟨ out-ok≢ (not b) b i' bs^ (not-x≢x Bb) ⟩
      out (not b) · bs^ ∎

    js'-eq-helper₂ : bs' ≡ error ∷ bs^ → js' ≡ out (not b) · bs^
    js'-eq-helper₂ h  =
      js'                         ≡⟨ js'ABP' ⟩
      out (not b) · bs'           ≡⟨ ·-rightCong h ⟩
      out (not b) · (error ∷ bs^) ≡⟨ out-error (not b) bs^ ⟩
      out (not b) · bs^           ∎

    js'-eq : js' ≡ out (not b) · bs^
    js'-eq = case js'-eq-helper₁ js'-eq-helper₂ bs'-eq

    ds^-eq : ds^ ≡ corrupt os₁^ · (b ∷ cs^)
    ds^-eq = ·-rightCong cs'-eq

    ABP'IH : ABP' b i' is' os₀^ os₁^ as^ bs^ cs^ ds^ js'
    ABP'IH = ds^-eq , refl , refl , refl , js'-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈
-- Fair, and hence by unfolding Fair we conclude that there are ft₁ :
-- F*T and os₁'' : Fair, such that os₁' = ft₁ ++ os₁''.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma₂ : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₀' →
         Fair os₁' →
         ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
         ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
         Fair os₀''
         ∧ Fair os₁''
         ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
lemma₂ Bb Fos₀' Fos₁' abp' with Fair-unf Fos₁'
... | ft , os₀'' , FTft , h , Fos₀'' =
  helper Bb Fos₀' abp' ft os₀'' FTft Fos₀'' h

------------------------------------------------------------------------------
-- ABP lemma 2
------------------------------------------------------------------------------

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

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2I 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.Loop
open import FOTC.Base.PropertiesI
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the ABP lemma 2

module Helper where

  helper : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
           Bit b →
           Fair os₀' →
           ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
           ∀ ft₁ os₁'' → F*T ft₁ → Fair os₁'' → os₁' ≡ ft₁ ++ os₁'' →
           ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₀''
           ∧ Fair os₁''
           ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
  helper {b} {i'} {is'} {os₀'} {os₁'} {as'} {bs'} {cs'} {ds'} {js'}
         Bb Fos₀' (ds'ABP' , as'ABP , bs'ABP' , cs'ABP' , js'ABP')
         .(T ∷ []) os₁'' f*tnil Fos₁'' os₁'-eq =
         os₀' , os₁'' , as'' , bs'' , cs'' , ds''
         , Fos₀' , Fos₁''
         , as''-eq , bs''-eq ,  cs''-eq , refl , js'-eq

    where
    os'₁-eq-helper : os₁' ≡ T ∷ os₁''
    os'₁-eq-helper =
      os₁'                 ≡⟨ os₁'-eq ⟩
      (true ∷ []) ++ os₁'' ≡⟨ ++-∷ true [] os₁'' ⟩
      true ∷ [] ++ os₁''   ≡⟨ ∷-rightCong (++-leftIdentity os₁'') ⟩
      true ∷ os₁''         ∎

    ds'' : D
    ds'' = corrupt os₁'' · cs'

    ds'-eq : ds' ≡ ok b ∷ ds''
    ds'-eq =
      ds' ≡⟨ ds'ABP' ⟩
      corrupt os₁' · (b ∷ cs')
        ≡⟨ ·-leftCong (corruptCong os'₁-eq-helper) ⟩
      corrupt (T ∷ os₁'') · (b ∷ cs')
        ≡⟨ corrupt-T os₁'' b cs' ⟩
      ok b ∷ corrupt os₁'' · cs'
        ≡⟨ refl ⟩
      ok b ∷ ds'' ∎

    as'' : D
    as'' = as'

    as''-eq : as'' ≡ send (not b) · is' · ds''
    as''-eq =
      as''                         ≡⟨ as'ABP ⟩
      await b i' is' ds'           ≡⟨ awaitCong₄ ds'-eq ⟩
      await b i' is' (ok b ∷ ds'') ≡⟨ await-ok≡ b b i' is' ds'' refl ⟩
      send (not b) · is' · ds''    ∎

    bs'' : D
    bs'' = bs'

    bs''-eq : bs'' ≡ corrupt os₀' · as'
    bs''-eq = bs'ABP'

    cs'' : D
    cs'' = cs'

    cs''-eq : cs'' ≡ ack (not b) · bs'
    cs''-eq = cs'ABP'

    js'-eq : js' ≡ out (not b) · bs''
    js'-eq = js'ABP'

  helper {b} {i'} {is'} {os₀'} {os₁'} {as'} {bs'} {cs'} {ds'} {js'}
         Bb Fos₀' (ds'ABP' , as'ABP , bs'ABP' , cs'ABP' , js'ABP')
         .(F ∷ ft₁) os₁'' (f*tcons {ft₁} FTft₁) Fos₁'' os₁'-eq
         = helper Bb (tail-Fair Fos₀') ABP'IH ft₁ os₁'' FTft₁ Fos₁'' refl

    where
    os₀^ : D
    os₀^ = tail₁ os₀'

    os₁^ : D
    os₁^ = ft₁ ++ os₁''

    os₁'-eq-helper : os₁' ≡ F ∷ os₁^
    os₁'-eq-helper = os₁'               ≡⟨ os₁'-eq ⟩
                     (F ∷ ft₁) ++ os₁'' ≡⟨ ++-∷ _ _ _ ⟩
                     F ∷ ft₁ ++ os₁''   ≡⟨ refl ⟩
                     F ∷ os₁^           ∎

    ds^ : D
    ds^ = corrupt os₁^ · cs'

    ds'-eq : ds' ≡ error ∷ ds^
    ds'-eq =
      ds'
        ≡⟨ ds'ABP' ⟩
      corrupt os₁' · (b ∷ cs')
        ≡⟨ ·-leftCong (corruptCong os₁'-eq-helper) ⟩
      corrupt (F ∷ os₁^) · (b ∷ cs')
        ≡⟨ corrupt-F _ _ _ ⟩
      error ∷ corrupt os₁^ · cs'
        ≡⟨ refl ⟩
      error ∷ ds^ ∎

    as^ : D
    as^ = await b i' is' ds^

    as'-eq : as' ≡ < i' , b > ∷ as^
    as'-eq = as'                             ≡⟨ as'ABP ⟩
             await b i' is' ds'              ≡⟨ awaitCong₄ ds'-eq ⟩
             await b i' is' (error ∷ ds^)    ≡⟨ await-error _ _ _ _ ⟩
             < i' , b > ∷ await b i' is' ds^ ≡⟨ refl ⟩
             < i' , b > ∷ as^                ∎

    bs^ : D
    bs^ = corrupt os₀^ · as^

    bs'-eq-helper₁ : os₀' ≡ T ∷ tail₁ os₀' → bs' ≡ ok < i' , b > ∷ bs^
    bs'-eq-helper₁ h =
      bs'
        ≡⟨ bs'ABP' ⟩
      corrupt os₀' · as'
        ≡⟨ subst₂ (λ t t' → corrupt os₀' · as' ≡ corrupt t · t')
                  h
                  as'-eq
                  refl
        ⟩
      corrupt (T ∷ tail₁ os₀') · (< i' , b > ∷ as^)
        ≡⟨ corrupt-T _ _ _ ⟩
      ok < i' , b > ∷ corrupt (tail₁ os₀') · as^
        ≡⟨ refl ⟩
      ok < i' , b > ∷ bs^ ∎

    bs'-eq-helper₂ : os₀' ≡ F ∷ tail₁ os₀' → bs' ≡ error ∷ bs^
    bs'-eq-helper₂ h =
      bs'
        ≡⟨ bs'ABP' ⟩
      corrupt os₀' · as'
        ≡⟨ subst₂ (λ t t' → corrupt os₀' · as' ≡ corrupt t · t')
                  h
                  as'-eq
                  refl
        ⟩
      corrupt (F ∷ tail₁ os₀') · (< i' , b > ∷ as^)
        ≡⟨ corrupt-F _ _ _ ⟩
      error ∷ corrupt (tail₁ os₀') · as^
        ≡⟨ refl ⟩
      error ∷ bs^ ∎

    bs'-eq : bs' ≡ ok < i' , b > ∷ bs^ ∨ bs' ≡ error ∷ bs^
    bs'-eq = case (λ h → inj₁ (bs'-eq-helper₁ h))
                  (λ h → inj₂ (bs'-eq-helper₂ h))
                  (head-tail-Fair Fos₀')

    cs^ : D
    cs^ = ack (not b) · bs^

    cs'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs^ → cs' ≡ b ∷ cs^
    cs'-eq-helper₁ h =
      cs'
      ≡⟨ cs'ABP' ⟩
      ack (not b) · bs'
        ≡⟨ ·-rightCong h ⟩
      ack (not b) · (ok < i' , b > ∷ bs^)
        ≡⟨ ack-ok≢ _ _ _ _ (not-x≢x Bb) ⟩
      not (not b) ∷ ack (not b) · bs^
        ≡⟨ ∷-leftCong (not-involutive Bb) ⟩
      b ∷ ack (not b) · bs^
        ≡⟨ refl ⟩
      b ∷ cs^ ∎

    cs'-eq-helper₂ : bs' ≡ error ∷ bs^ → cs' ≡ b ∷ cs^
    cs'-eq-helper₂ h =
      cs'                             ≡⟨ cs'ABP' ⟩
      ack (not b) · bs'               ≡⟨ ·-rightCong h ⟩
      ack (not b) · (error ∷ bs^)     ≡⟨ ack-error _ _ ⟩
      not (not b) ∷ ack (not b) · bs^ ≡⟨ ∷-leftCong (not-involutive Bb) ⟩
      b ∷ ack (not b) · bs^           ≡⟨ refl ⟩
      b ∷ cs^                         ∎

    cs'-eq : cs' ≡ b ∷ cs^
    cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

    js'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs^ → js' ≡ out (not b) · bs^
    js'-eq-helper₁ h  =
      js'
        ≡⟨ js'ABP' ⟩
      out (not b) · bs'
        ≡⟨ ·-rightCong h ⟩
      out (not b) · (ok < i' , b > ∷ bs^)
        ≡⟨ out-ok≢ (not b) b i' bs^ (not-x≢x Bb) ⟩
      out (not b) · bs^ ∎

    js'-eq-helper₂ : bs' ≡ error ∷ bs^ → js' ≡ out (not b) · bs^
    js'-eq-helper₂ h  =
      js'                         ≡⟨ js'ABP' ⟩
      out (not b) · bs'           ≡⟨ ·-rightCong h ⟩
      out (not b) · (error ∷ bs^) ≡⟨ out-error (not b) bs^ ⟩
      out (not b) · bs^           ∎

    js'-eq : js' ≡ out (not b) · bs^
    js'-eq = case js'-eq-helper₁ js'-eq-helper₂ bs'-eq

    ds^-eq : ds^ ≡ corrupt os₁^ · (b ∷ cs^)
    ds^-eq = ·-rightCong cs'-eq

    ABP'IH : ABP' b i' is' os₀^ os₁^ as^ bs^ cs^ ds^ js'
    ABP'IH = ds^-eq , refl , refl , refl , js'-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈
-- Fair, and hence by unfolding Fair we conclude that there are ft₁ :
-- F*T and os₁'' : Fair, such that os₁' = ft₁ ++ os₁''.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma₂ : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₀' →
         Fair os₁' →
         ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
         ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
         Fair os₀''
         ∧ Fair os₁''
         ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
lemma₂ Bb Fos₀' Fos₁' abp' with Fair-unf Fos₁'
... | ft , os₀'' , FTft , h , Fos₀'' =
  helper Bb Fos₀' abp' ft os₀'' FTft Fos₀'' h


Uncomment

Uncomment

{-
Demonstrating the technique of using type-changing functions
to pattern match against types with higher-order arguments
like Σ and Π.

The technique was originally explored to compare higher-order
small arguments that occur in Φ types in
TacticsMatchingFunctionCalls.agda

This file shows that the technique scales to large higher-order
functions , in a closed universe with a predicative hierarchy
of levels that supports elimType.

-}

open import Data.Empty
open import Data.Unit
open import Data.Bool
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Fin.Props
open import Data.Product
open import Data.String
open import Function
open import Relation.Binary.PropositionalEquality hiding ( inspect )
open Deprecated-inspect
module HierMatchExt where

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

plusrident : (n : ℕ) → n + 0 ≡ n
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

record Universe : Set₁ where
  field
    Codes : Set
    Meaning : Codes → Set

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

data Even : ℕ → Set where
  ezero : Even 0
  esuc : {n : ℕ} → Even n → Even (2 + n)

data Odd : ℕ → Set where
  ozero : Odd 1
  osuc : {n : ℕ} → Odd n → Odd (2 + n)

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

data TypeForm (U : Universe) : Set
⟦_/_⟧ : (U : Universe) → TypeForm U → Set

data TypeForm U where
  `⊥ `⊤ `Bool `ℕ `Type : TypeForm U
  `Fin `Even `Odd : (n : ℕ) → TypeForm U
  `Π `Σ : (A : TypeForm U)
    (B : ⟦ U / A ⟧ → TypeForm U)
    → TypeForm U
  `Id : (A : TypeForm U) (x y : ⟦ U / A ⟧) → TypeForm U
  `⟦_⟧ : (A : Universe.Codes U) → TypeForm U

⟦ U / `⊥ ⟧ = ⊥
⟦ U / `⊤ ⟧ = ⊤
⟦ U / `Bool ⟧ = Bool
⟦ U / `ℕ ⟧ = ℕ
⟦ U / `Fin n ⟧ = Fin n
⟦ U / `Even n ⟧ = Even n
⟦ U / `Odd n ⟧ = Odd n
⟦ U / `Π A B ⟧ = (a : ⟦ U / A ⟧) → ⟦ U / B a ⟧
⟦ U / `Σ A B ⟧ = Σ ⟦ U / A ⟧ (λ a → ⟦ U / B a ⟧)
⟦ U / `Id A x y ⟧ = _≡_ {A = ⟦ U / A ⟧} x y
⟦ U / `Type ⟧ = Universe.Codes U
⟦ U / `⟦ A ⟧ ⟧ = Universe.Meaning U A

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

_`→_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `→ B = `Π A (λ _ → B)

_`×_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `× B = `Σ A (λ _ → B)

Level : (ℓ : ℕ) → Universe
Level zero = record { Codes = ⊥ ; Meaning = λ() }
Level (suc ℓ) = record { Codes = TypeForm (Level ℓ)
                       ; Meaning = ⟦_/_⟧ (Level ℓ) }

Type : ℕ → Set
Type ℓ = TypeForm (Level ℓ)

⟦_∣_⟧ : (ℓ : ℕ) → Type ℓ → Set
⟦ ℓ ∣ A ⟧ = ⟦ Level ℓ / A ⟧

`Dynamic : (ℓ : ℕ) → Type (suc ℓ)
`Dynamic ℓ = `Σ `Type `⟦_⟧

`Tactic : (ℓ : ℕ) → Type (suc ℓ)
`Tactic ℓ = `Dynamic ℓ `→ `Dynamic ℓ

Tactic : (ℓ : ℕ) → Set
Tactic ℓ = ⟦ suc ℓ ∣ `Tactic ℓ ⟧

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

rm-plus0-Fin : (ℓ : ℕ) → Tactic (suc ℓ)
rm-plus0-Fin ℓ (`⟦ `Σ `ℕ B ⟧ , (n , b))
  with inspect (B n)
... | `Fin m with-≡ p =
  `Π `ℕ (λ x → `Id `Type (B x) (`Fin (x + 0)))
  `→
  `Σ `ℕ `Fin
  ,
  λ f → n , subst Fin
    (plusrident n)
    (subst (λ A → ⟦ ℓ ∣ A ⟧) (f n) b)
... | Bn with-≡ p = (`⟦ `Σ `ℕ B ⟧ , (n , subst (λ x → ⟦ ℓ ∣ B x ⟧) refl b))
rm-plus0-Fin ℓ x = x

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

eg-rm-plus0-Fin : (ℓ : ℕ) →
  ⟦ suc ℓ ∣ `⟦ `Σ `ℕ (λ n → `Fin (n + zero)) ⟧
        `→ `⟦ `Σ `ℕ (λ n → `Fin n) ⟧ ⟧
eg-rm-plus0-Fin ℓ (n , i) = proj₂
  (rm-plus0-Fin ℓ (`⟦ `Σ `ℕ (λ n → `Fin (n + zero)) ⟧ , (n , i)))
  (λ _ → refl)

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

{-
Demonstrating the technique of using type-changing functions
to pattern match against types with higher-order arguments
like Σ and Π.

The technique was originally explored to compare higher-order
small arguments that occur in Φ types in
TacticsMatchingFunctionCalls.agda

This file shows that the technique scales to large higher-order
functions , in a closed universe with a predicative hierarchy
of levels that supports elimType.

-}

open import Data.Empty
open import Data.Unit
open import Data.Bool
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Fin.Props
open import Data.Product
open import Data.String
open import Function
open import Relation.Binary.PropositionalEquality hiding ( inspect )
open Deprecated-inspect
module HierMatchExt where

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

plusrident : (n : ℕ) → n + 0 ≡ n
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

record Universe : Set₁ where
  field
    Codes : Set
    Meaning : Codes → Set

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

data Even : ℕ → Set where
  ezero : Even 0
  esuc : {n : ℕ} → Even n → Even (2 + n)

data Odd : ℕ → Set where
  ozero : Odd 1
  osuc : {n : ℕ} → Odd n → Odd (2 + n)

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

data TypeForm (U : Universe) : Set
⟦_/_⟧ : (U : Universe) → TypeForm U → Set

data TypeForm U where
  `⊥ `⊤ `Bool `ℕ `Type : TypeForm U
  `Fin `Even `Odd : (n : ℕ) → TypeForm U
  `Π `Σ : (A : TypeForm U)
    (B : ⟦ U / A ⟧ → TypeForm U)
    → TypeForm U
  `Id : (A : TypeForm U) (x y : ⟦ U / A ⟧) → TypeForm U
  `⟦_⟧ : (A : Universe.Codes U) → TypeForm U

⟦ U / `⊥ ⟧ = ⊥
⟦ U / `⊤ ⟧ = ⊤
⟦ U / `Bool ⟧ = Bool
⟦ U / `ℕ ⟧ = ℕ
⟦ U / `Fin n ⟧ = Fin n
⟦ U / `Even n ⟧ = Even n
⟦ U / `Odd n ⟧ = Odd n
⟦ U / `Π A B ⟧ = (a : ⟦ U / A ⟧) → ⟦ U / B a ⟧
⟦ U / `Σ A B ⟧ = Σ ⟦ U / A ⟧ (λ a → ⟦ U / B a ⟧)
⟦ U / `Id A x y ⟧ = _≡_ {A = ⟦ U / A ⟧} x y
⟦ U / `Type ⟧ = Universe.Codes U
⟦ U / `⟦ A ⟧ ⟧ = Universe.Meaning U A

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

_`→_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `→ B = `Π A (λ _ → B)

_`×_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `× B = `Σ A (λ _ → B)

Level : (ℓ : ℕ) → Universe
Level zero = record { Codes = ⊥ ; Meaning = λ() }
Level (suc ℓ) = record { Codes = TypeForm (Level ℓ)
                       ; Meaning = ⟦_/_⟧ (Level ℓ) }

Type : ℕ → Set
Type ℓ = TypeForm (Level ℓ)

⟦_∣_⟧ : (ℓ : ℕ) → Type ℓ → Set
⟦ ℓ ∣ A ⟧ = ⟦ Level ℓ / A ⟧

`Dynamic : (ℓ : ℕ) → Type (suc ℓ)
`Dynamic ℓ = `Σ `Type `⟦_⟧

`Tactic : (ℓ : ℕ) → Type (suc ℓ)
`Tactic ℓ = `Dynamic ℓ `→ `Dynamic ℓ

Tactic : (ℓ : ℕ) → Set
Tactic ℓ = ⟦ suc ℓ ∣ `Tactic ℓ ⟧

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

rm-plus0-Fin : (ℓ : ℕ) → Tactic (suc ℓ)
rm-plus0-Fin ℓ (`⟦ `Σ `ℕ B ⟧ , (n , b))
  with inspect (B n)
... | `Fin m with-≡ p =
  `Π `ℕ (λ x → `Id `Type (B x) (`Fin (x + 0)))
  `→
  `Σ `ℕ `Fin
  ,
  λ f → n , subst Fin
    (plusrident n)
    (subst (λ A → ⟦ ℓ ∣ A ⟧) (f n) b)
... | Bn with-≡ p = (`⟦ `Σ `ℕ B ⟧ , (n , subst (λ x → ⟦ ℓ ∣ B x ⟧) refl b))
rm-plus0-Fin ℓ x = x

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

-- eg-rm-plus0-Fin : (ℓ : ℕ) →
--   ⟦ suc ℓ ∣ `⟦ `Σ `ℕ (λ n → `Fin (n + zero)) ⟧
--         `→ `⟦ `Σ `ℕ (λ n → `Fin n) ⟧ ⟧
-- eg-rm-plus0-Fin ℓ (n , i) = proj₂
--   (rm-plus0-Fin ℓ (`⟦ `Σ `ℕ (λ n → `Fin (n + zero)) ⟧ , (n , i)))
--   (λ _ → refl)

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


flat-funs: more polishing work

flat-funs: more polishing work

module flat-funs where

open import Data.Unit using (⊤)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_; _⊔_)
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
import Data.Vec.NP as V
import Level as L
import Function as F
import Data.Product as ×
open V using (Vec; []; _∷_; _++_)
open × using (_×_; _,_; proj₁; proj₂; uncurry)

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

open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    El       : T → Set
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    -- Functions
    id    : ∀ {A} → A `→ A
    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
    const : ∀ {_A B} → El B → _A `→ B

    -- Products
    <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
    fst   : ∀ {A B} → A `× B `→ A
    snd   : ∀ {A B} → A `× B `→ B

    -- Unit
    tt : ∀ {_A} → _A `→ `⊤

    -- Vectors
    nil    : ∀ {_A B} → _A `→ `Vec B 0
    cons   : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  _∘_ : ∀ {A B C} → (B `→ C) → (A `→ B) → (A `→ C)
  f ∘ g = g >>> f

  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = < fst >>> f , snd >>> g >

  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  swap : ∀ {A B} → (A `× B) `→ (B `× A)
  swap = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = f *** id

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = id *** f

  assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc = < fst >>> fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd >>> snd >

  <_`zip`_> : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  < f `zip` g > = < < fst × fst > >>> f ,
                    < snd × snd > >>> g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons >>> fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons >>> snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons >>> < f × g > >>> cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > >>> cons

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                >>> assoc′
                >>> first f
                >>> foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons >>> foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                >>> assoc
                >>> second (foldr f)
                >>> f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons >>> swap >>> foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map {zero}  f = nil
  map {suc n} f = < f ∷ map f >

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                  >>> < f `zip` (zipWith f) >
                  >>> cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = < id , nil > >>> cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd >>> singleton
  snoc {suc n} = first uncons >>> assoc >>> second snoc >>> cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons >>> swap >>> first reverse >>> snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
               >>> assoc
               >>> second append
               >>> cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , id >
  splitAt (suc m) = uncons
                >>> second (splitAt m)
                >>> assoc′
                >>> first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail >>> drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) >>> < folda n f × folda n f > >>> f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail >>> last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons >>> second concat >>> append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k >>> second (group n k) >>> cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f >>> concat

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = uncons >>> < f × ⊛ fs > >>> cons

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < id , replicate > >>> cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz >>> f , tabulate (fs >>> f) > >>> cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst >>> elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail >>> lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate id

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

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

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U F.id -→-

module FunTypes = FlatFuns fun♭Funs

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

module BitsFunTypes = FlatFuns bitsFun♭Funs

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

module FinFunTypes = FlatFuns finFun♭Funs

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk F.id (λ f g x → g (f x)) F.const ×.<_,_> proj₁ proj₂
             _ (F.const []) (uncurry _∷_) V.uncons

module FunOps = FlatFunsOps fun♭Ops

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id _>>>_ const <_,_> (λ {A} → V.take A)
                    (λ {A} → V.drop A) (const []) (const []) id id
  where
  open FlatFuns bitsFun♭Funs
  open FlatFunsOps fun♭Ops using (id; _>>>_; const)
  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > x = f x ++ g x

module BitsFunOps = FlatFunsOps bitsFun♭Ops

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) → S.El A₀ × T.El A₁ })
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe (λ A → S.El A × T.El _)
                            (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T
  = mk (S.id , T.id) (×.zip S._>>>_ T._>>>_) < S.const × T.const >
       (×.zip S.<_,_> T.<_,_>) (S.fst , T.fst) (S.snd , T.snd)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.cons) (S.uncons , T.uncons)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤
  = mk (S.id , T.id) (×.zip S._>>>_ T._>>>_) < S.const × T.const >
       (×.zip S.<_,_> T.<_,_>) (S.fst , T.fst) (S.snd , T.snd)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.id) (S.uncons , T.id)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

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

module ConstFunTypes A = FlatFuns (constFuns A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ (F.const 0) _⊔_ 0 0 0 0 0 0

module TimeOps = FlatFunsOps timeOps

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ const _+_ 0 0 0 0 0 0
  where open FlatFuns (constFuns ℕ)
        const : ∀ {_A B} → El B → _A `→ B
        const {_} {_} x = x

module SpaceOps = FlatFunsOps spaceOps

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps

module Time×SpaceOps = FlatFunsOps time×spaceOps

module flat-funs where

open import Data.Unit using (⊤)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_; _⊔_)
import Data.Vec as V
open V using (Vec; []; _∷_; _++_)
import Level as L
import Function as F
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
import Data.Product as ×
open × using (_×_; _,_; proj₁; proj₂; uncurry)

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

open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    El      : T → Set
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    -- Functions
    id : ∀ {A} → A `→ A
    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
    const : ∀ {_A B} → El B → _A `→ B

    -- Products
    <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

    -- Unit
    tt : ∀ {_A} → _A `→ `⊤

    -- Vectors
    nil : ∀ {_A B} → _A `→ `Vec B 0
    cons : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = < fst >>> f , snd >>> g >

  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  swap : ∀ {A B} → (A `× B) `→ (B `× A)
  swap = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = f *** id

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = id *** f

  assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc = < fst >>> fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd >>> snd >

  `×-zip : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  `×-zip f g = < < fst >>> fst , snd >>> fst > >>> f ,
                 < fst >>> snd , snd >>> snd > >>> g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons >>> fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons >>> snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons >>> < f × g > >>> cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > >>> cons

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                >>> assoc′
                >>> first f
                >>> foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons >>> foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                >>> assoc
                >>> second (foldr f)
                >>> f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons >>> swap >>> foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map {zero}  f = nil
  map {suc n} f = < f ∷ map f >

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                  >>> `×-zip f (zipWith f)
                  >>> cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = < id , nil > >>> cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd >>> singleton
  snoc {suc n} = first uncons >>> assoc >>> second snoc >>> cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons >>> swap >>> first reverse >>> snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
               >>> assoc
               >>> second append
               >>> cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , id >
  splitAt (suc m) = uncons
                >>> second (splitAt m)
                >>> assoc′
                >>> first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail >>> drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) >>> < folda n f × folda n f > >>> f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail >>> last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons >>> second concat >>> append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k >>> second (group n k) >>> cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f >>> concat

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = uncons >>> < f × ⊛ fs > >>> cons

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < id , replicate > >>> cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz >>> f , tabulate (fs >>> f) > >>> cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst >>> elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail >>> lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate id

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

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

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U F.id -→-

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

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

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk F.id (λ f g x → g (f x)) F.const ×.<_,_> proj₁ proj₂
             _ (F.const []) (uncurry _∷_) uncons
  where
  uncons : ∀ {n A} → Vec A (1 + n) → (A × Vec A n)
  uncons (x ∷ xs) = x , xs

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id _>>>_ const <_,_> (λ {A} → V.take A)
                    (λ {A} → V.drop A) (const []) (const []) id id
  where
  open FlatFuns bitsFun♭Funs
  open FlatFunsOps fun♭Ops using (id; _>>>_; const)
  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > x = f x ++ g x

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) → S.El A₀ × T.El A₁ })
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe (λ A → S.El A × T.El _)
                            (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T
  = mk (S.id , T.id) (×.zip S._>>>_ T._>>>_) < S.const × T.const >
       (×.zip S.<_,_> T.<_,_>) (S.fst , T.fst) (S.snd , T.snd)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.cons) (S.uncons , T.uncons)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤
  = mk (S.id , T.id) (×.zip S._>>>_ T._>>>_) < S.const × T.const >
       (×.zip S.<_,_> T.<_,_>) (S.fst , T.fst) (S.snd , T.snd)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.id) (S.uncons , T.id)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

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

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ (F.const 0) _⊔_ 0 0 0 0 0 0

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ const _+_ 0 0 0 0 0 0
  where open FlatFuns (constFuns ℕ)
        const : ∀ {_A B} → El B → _A `→ B
        const {_} {_} x = x

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps


Two.Equality: export subst and ⇒≡

Two.Equality: export subst and ⇒≡

{-# OPTIONS --without-K #-}
open import Data.Two hiding (_≟_; decSetoid)
open import Type
open import Relation.Binary.NP
open import Relation.Nullary
open import Function
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Data.Two.Equality where

module ✓-== where

    _≈_ : (x y : 𝟚) → ★₀
    x ≈ y = ✓ (x == y)

    subst : ∀ {ℓ} → Substitutive _≈_ ℓ
    subst _ {0₂} {0₂} _ = id
    subst _ {1₂} {1₂} _ = id
    subst _ {0₂} {1₂} ()
    subst _ {1₂} {0₂} ()

    ⇒≡ : _≈_ ⇒ _≡_
    ⇒≡ = substitutive⇒≡ subst

    decSetoid : DecSetoid _ _
    decSetoid = record { Carrier = 𝟚; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }
      where
        refl : Reflexive _≈_
        refl {0₂} = _
        refl {1₂} = _

        sym : Symmetric _≈_
        sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

        trans : Transitive _≈_
        trans {x} {y} {z} x≈y y≈z = subst (_≈_ x) {y} {z} y≈z x≈y

        _≟_ : Decidable _≈_
        0₂ ≟ 0₂ = yes _
        1₂ ≟ 1₂ = yes _
        0₂ ≟ 1₂ = no (λ())
        1₂ ≟ 0₂ = no (λ())

        isEquivalence : IsEquivalence _≈_
        isEquivalence = record { refl  = λ {x} → refl {x}
                               ; sym   = λ {x} {y} → sym {x} {y}
                               ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

        isDecEquivalence : IsDecEquivalence _≈_
        isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

    open DecSetoid decSetoid public hiding (_≈_)

module ==-≡1₂ where

    _≈_ : (x y : 𝟚) → ★₀
    x ≈ y = (x == y) ≡ 1₂

    subst : ∀ {ℓ} → Substitutive _≈_ ℓ
    subst _ {0₂} {0₂} _ = id
    subst _ {1₂} {1₂} _ = id
    subst _ {0₂} {1₂} ()
    subst _ {1₂} {0₂} ()

    ⇒≡ : _≈_ ⇒ _≡_
    ⇒≡ = substitutive⇒≡ subst

    decSetoid : DecSetoid _ _
    decSetoid = record { Carrier = 𝟚; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }
      where
        refl : Reflexive _≈_
        refl {0₂} = ≡.refl
        refl {1₂} = ≡.refl

        sym : Symmetric _≈_
        sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

        trans : Transitive _≈_
        trans {x} x≈y y≈z = subst (_≈_ x) y≈z x≈y

        _≟_ : Decidable _≈_
        0₂ ≟ 0₂ = yes ≡.refl
        1₂ ≟ 1₂ = yes ≡.refl
        0₂ ≟ 1₂ = no (λ())
        1₂ ≟ 0₂ = no (λ())

        isEquivalence : IsEquivalence _≈_
        isEquivalence = record { refl  = λ {x} → refl {x}
                               ; sym   = λ {x} {y} → sym {x} {y}
                               ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

        isDecEquivalence : IsDecEquivalence _≈_
        isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

    open DecSetoid decSetoid public hiding (_≈_)

neg-xor : ∀ b₀ b₁ → b₀ == b₁ ≡ not (b₀ xor b₁)
neg-xor 0₂ b = ≡.refl
neg-xor 1₂ b = ≡.sym (not-involutive b)

comm : ∀ b₀ b₁ → b₀ == b₁ ≡ b₁ == b₀
comm 0₂ 0₂ = ≡.refl
comm 0₂ 1₂ = ≡.refl
comm 1₂ 0₂ = ≡.refl
comm 1₂ 1₂ = ≡.refl

{-# OPTIONS --without-K #-}
open import Data.Two hiding (_≟_; decSetoid)
open import Type
open import Relation.Binary
open import Relation.Nullary
open import Function
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Data.Two.Equality where

module ✓-== where

    decSetoid : DecSetoid _ _
    decSetoid = record { Carrier = 𝟚; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }
      where
        _≈_ : (x y : 𝟚) → ★₀
        x ≈ y = ✓ (x == y)

        refl : Reflexive _≈_
        refl {0₂} = _
        refl {1₂} = _

        subst : ∀ {ℓ} → Substitutive _≈_ ℓ
        subst _ {0₂} {0₂} _ = id
        subst _ {1₂} {1₂} _ = id
        subst _ {0₂} {1₂} ()
        subst _ {1₂} {0₂} ()

        sym : Symmetric _≈_
        sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

        trans : Transitive _≈_
        trans {x} {y} {z} x≈y y≈z = subst (_≈_ x) {y} {z} y≈z x≈y

        _≟_ : Decidable _≈_
        0₂ ≟ 0₂ = yes _
        1₂ ≟ 1₂ = yes _
        0₂ ≟ 1₂ = no (λ())
        1₂ ≟ 0₂ = no (λ())

        isEquivalence : IsEquivalence _≈_
        isEquivalence = record { refl  = λ {x} → refl {x}
                               ; sym   = λ {x} {y} → sym {x} {y}
                               ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

        isDecEquivalence : IsDecEquivalence _≈_
        isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

    open DecSetoid decSetoid public hiding (_≈_; _≟_)

module ==-≡1₂ where

    decSetoid : DecSetoid _ _
    decSetoid = record { Carrier = 𝟚; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }
      where
        _≈_ : (x y : 𝟚) → ★₀
        x ≈ y = (x == y) ≡ 1₂

        refl : Reflexive _≈_
        refl {0₂} = ≡.refl
        refl {1₂} = ≡.refl

        subst : ∀ {ℓ} → Substitutive _≈_ ℓ
        subst _ {0₂} {0₂} _ = id
        subst _ {1₂} {1₂} _ = id
        subst _ {0₂} {1₂} ()
        subst _ {1₂} {0₂} ()

        sym : Symmetric _≈_
        sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

        trans : Transitive _≈_
        trans {x} x≈y y≈z = subst (_≈_ x) y≈z x≈y

        _≟_ : Decidable _≈_
        0₂ ≟ 0₂ = yes ≡.refl
        1₂ ≟ 1₂ = yes ≡.refl
        0₂ ≟ 1₂ = no (λ())
        1₂ ≟ 0₂ = no (λ())

        isEquivalence : IsEquivalence _≈_
        isEquivalence = record { refl  = λ {x} → refl {x}
                               ; sym   = λ {x} {y} → sym {x} {y}
                               ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

        isDecEquivalence : IsDecEquivalence _≈_
        isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

    open DecSetoid decSetoid public

neg-xor : ∀ b₀ b₁ → b₀ == b₁ ≡ not (b₀ xor b₁)
neg-xor 0₂ b = ≡.refl
neg-xor 1₂ b = ≡.sym (not-involutive b)

comm : ∀ b₀ b₁ → b₀ == b₁ ≡ b₁ == b₀
comm 0₂ 0₂ = ≡.refl
comm 0₂ 1₂ = ≡.refl
comm 1₂ 0₂ = ≡.refl
comm 1₂ 1₂ = ≡.refl